merge
[ghc.git] / rts / Interpreter.c
1 /* -----------------------------------------------------------------------------
2 * Bytecode interpreter
3 *
4 * Copyright (c) The GHC Team, 1994-2002.
5 * ---------------------------------------------------------------------------*/
6
7 #include "PosixSource.h"
8 #include "Rts.h"
9 #include "RtsAPI.h"
10 #include "rts/Bytecodes.h"
11
12 // internal headers
13 #include "sm/Storage.h"
14 #include "sm/Sanity.h"
15 #include "RtsUtils.h"
16 #include "Schedule.h"
17 #include "Updates.h"
18 #include "Prelude.h"
19 #include "Stable.h"
20 #include "Printer.h"
21 #include "Disassembler.h"
22 #include "Interpreter.h"
23 #include "ThreadPaused.h"
24 #include "Threads.h"
25
26 #include <string.h> /* for memcpy */
27 #ifdef HAVE_ERRNO_H
28 #include <errno.h>
29 #endif
30
31 // When building the RTS in the non-dyn way on Windows, we don't
32 // want declspec(__dllimport__) on the front of function prototypes
33 // from libffi.
34 #if defined(mingw32_HOST_OS) && !defined(__PIC__)
35 # define LIBFFI_NOT_DLL
36 #endif
37
38 #include "ffi.h"
39
40 /* --------------------------------------------------------------------------
41 * The bytecode interpreter
42 * ------------------------------------------------------------------------*/
43
44 /* Gather stats about entry, opcode, opcode-pair frequencies. For
45 tuning the interpreter. */
46
47 /* #define INTERP_STATS */
48
49
50 /* Sp points to the lowest live word on the stack. */
51
52 #define BCO_NEXT instrs[bciPtr++]
53 #define BCO_NEXT_32 (bciPtr += 2)
54 #define BCO_READ_NEXT_32 (BCO_NEXT_32, (((StgWord) instrs[bciPtr-2]) << 16) \
55 + ( (StgWord) instrs[bciPtr-1]))
56 #define BCO_NEXT_64 (bciPtr += 4)
57 #define BCO_READ_NEXT_64 (BCO_NEXT_64, (((StgWord) instrs[bciPtr-4]) << 48) \
58 + (((StgWord) instrs[bciPtr-3]) << 32) \
59 + (((StgWord) instrs[bciPtr-2]) << 16) \
60 + ( (StgWord) instrs[bciPtr-1]))
61 #if WORD_SIZE_IN_BITS == 32
62 #define BCO_NEXT_WORD BCO_NEXT_32
63 #define BCO_READ_NEXT_WORD BCO_READ_NEXT_32
64 #elif WORD_SIZE_IN_BITS == 64
65 #define BCO_NEXT_WORD BCO_NEXT_64
66 #define BCO_READ_NEXT_WORD BCO_READ_NEXT_64
67 #else
68 #error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64
69 #endif
70 #define BCO_GET_LARGE_ARG ((bci & bci_FLAG_LARGE_ARGS) ? BCO_READ_NEXT_WORD : BCO_NEXT)
71
72 #define BCO_PTR(n) (W_)ptrs[n]
73 #define BCO_LIT(n) literals[n]
74
75 #define LOAD_STACK_POINTERS \
76 Sp = cap->r.rCurrentTSO->stackobj->sp; \
77 /* We don't change this ... */ \
78 SpLim = tso_SpLim(cap->r.rCurrentTSO);
79
80 #define SAVE_STACK_POINTERS \
81 ASSERT(Sp > SpLim); \
82 cap->r.rCurrentTSO->stackobj->sp = Sp
83
84 #define RETURN_TO_SCHEDULER(todo,retcode) \
85 SAVE_STACK_POINTERS; \
86 cap->r.rCurrentTSO->what_next = (todo); \
87 threadPaused(cap,cap->r.rCurrentTSO); \
88 cap->r.rRet = (retcode); \
89 return cap;
90
91 #define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode) \
92 SAVE_STACK_POINTERS; \
93 cap->r.rCurrentTSO->what_next = (todo); \
94 cap->r.rRet = (retcode); \
95 return cap;
96
97
98 STATIC_INLINE StgPtr
99 allocate_NONUPD (Capability *cap, int n_words)
100 {
101 return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
102 }
103
104 int rts_stop_next_breakpoint = 0;
105 int rts_stop_on_exception = 0;
106
107 #ifdef INTERP_STATS
108
109 /* Hacky stats, for tuning the interpreter ... */
110 int it_unknown_entries[N_CLOSURE_TYPES];
111 int it_total_unknown_entries;
112 int it_total_entries;
113
114 int it_retto_BCO;
115 int it_retto_UPDATE;
116 int it_retto_other;
117
118 int it_slides;
119 int it_insns;
120 int it_BCO_entries;
121
122 int it_ofreq[27];
123 int it_oofreq[27][27];
124 int it_lastopc;
125
126
127 #define INTERP_TICK(n) (n)++
128
129 void interp_startup ( void )
130 {
131 int i, j;
132 it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
133 it_total_entries = it_total_unknown_entries = 0;
134 for (i = 0; i < N_CLOSURE_TYPES; i++)
135 it_unknown_entries[i] = 0;
136 it_slides = it_insns = it_BCO_entries = 0;
137 for (i = 0; i < 27; i++) it_ofreq[i] = 0;
138 for (i = 0; i < 27; i++)
139 for (j = 0; j < 27; j++)
140 it_oofreq[i][j] = 0;
141 it_lastopc = 0;
142 }
143
144 void interp_shutdown ( void )
145 {
146 int i, j, k, o_max, i_max, j_max;
147 debugBelch("%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
148 it_retto_BCO + it_retto_UPDATE + it_retto_other,
149 it_retto_BCO, it_retto_UPDATE, it_retto_other );
150 debugBelch("%d total entries, %d unknown entries \n",
151 it_total_entries, it_total_unknown_entries);
152 for (i = 0; i < N_CLOSURE_TYPES; i++) {
153 if (it_unknown_entries[i] == 0) continue;
154 debugBelch(" type %2d: unknown entries (%4.1f%%) == %d\n",
155 i, 100.0 * ((double)it_unknown_entries[i]) /
156 ((double)it_total_unknown_entries),
157 it_unknown_entries[i]);
158 }
159 debugBelch("%d insns, %d slides, %d BCO_entries\n",
160 it_insns, it_slides, it_BCO_entries);
161 for (i = 0; i < 27; i++)
162 debugBelch("opcode %2d got %d\n", i, it_ofreq[i] );
163
164 for (k = 1; k < 20; k++) {
165 o_max = 0;
166 i_max = j_max = 0;
167 for (i = 0; i < 27; i++) {
168 for (j = 0; j < 27; j++) {
169 if (it_oofreq[i][j] > o_max) {
170 o_max = it_oofreq[i][j];
171 i_max = i; j_max = j;
172 }
173 }
174 }
175
176 debugBelch("%d: count (%4.1f%%) %6d is %d then %d\n",
177 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
178 i_max, j_max );
179 it_oofreq[i_max][j_max] = 0;
180
181 }
182 }
183
184 #else // !INTERP_STATS
185
186 #define INTERP_TICK(n) /* nothing */
187
188 #endif
189
190 static StgWord app_ptrs_itbl[] = {
191 (W_)&stg_ap_p_info,
192 (W_)&stg_ap_pp_info,
193 (W_)&stg_ap_ppp_info,
194 (W_)&stg_ap_pppp_info,
195 (W_)&stg_ap_ppppp_info,
196 (W_)&stg_ap_pppppp_info,
197 };
198
199 HsStablePtr rts_breakpoint_io_action; // points to the IO action which is executed on a breakpoint
200 // it is set in main/GHC.hs:runStmt
201
202 Capability *
203 interpretBCO (Capability* cap)
204 {
205 // Use of register here is primarily to make it clear to compilers
206 // that these entities are non-aliasable.
207 register StgPtr Sp; // local state -- stack pointer
208 register StgPtr SpLim; // local state -- stack lim pointer
209 register StgClosure *tagged_obj = 0, *obj;
210 nat n, m;
211
212 LOAD_STACK_POINTERS;
213
214 cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
215 // goes to zero we must return to the scheduler.
216
217 // ------------------------------------------------------------------------
218 // Case 1:
219 //
220 // We have a closure to evaluate. Stack looks like:
221 //
222 // | XXXX_info |
223 // +---------------+
224 // Sp | -------------------> closure
225 // +---------------+
226 //
227 if (Sp[0] == (W_)&stg_enter_info) {
228 Sp++;
229 goto eval;
230 }
231
232 // ------------------------------------------------------------------------
233 // Case 2:
234 //
235 // We have a BCO application to perform. Stack looks like:
236 //
237 // | .... |
238 // +---------------+
239 // | arg1 |
240 // +---------------+
241 // | BCO |
242 // +---------------+
243 // Sp | RET_BCO |
244 // +---------------+
245 //
246 else if (Sp[0] == (W_)&stg_apply_interp_info) {
247 obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
248 Sp += 2;
249 goto run_BCO_fun;
250 }
251
252 // ------------------------------------------------------------------------
253 // Case 3:
254 //
255 // We have an unboxed value to return. See comment before
256 // do_return_unboxed, below.
257 //
258 else {
259 goto do_return_unboxed;
260 }
261
262 // Evaluate the object on top of the stack.
263 eval:
264 tagged_obj = (StgClosure*)Sp[0]; Sp++;
265
266 eval_obj:
267 obj = UNTAG_CLOSURE(tagged_obj);
268 INTERP_TICK(it_total_evals);
269
270 IF_DEBUG(interpreter,
271 debugBelch(
272 "\n---------------------------------------------------------------\n");
273 debugBelch("Evaluating: "); printObj(obj);
274 debugBelch("Sp = %p\n", Sp);
275 debugBelch("\n" );
276
277 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
278 debugBelch("\n\n");
279 );
280
281 // IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
282 IF_DEBUG(sanity,checkStackFrame(Sp));
283
284 switch ( get_itbl(obj)->type ) {
285
286 case IND:
287 case IND_PERM:
288 case IND_STATIC:
289 {
290 tagged_obj = ((StgInd*)obj)->indirectee;
291 goto eval_obj;
292 }
293
294 case CONSTR:
295 case CONSTR_1_0:
296 case CONSTR_0_1:
297 case CONSTR_2_0:
298 case CONSTR_1_1:
299 case CONSTR_0_2:
300 case CONSTR_STATIC:
301 case CONSTR_NOCAF_STATIC:
302 case FUN:
303 case FUN_1_0:
304 case FUN_0_1:
305 case FUN_2_0:
306 case FUN_1_1:
307 case FUN_0_2:
308 case FUN_STATIC:
309 case PAP:
310 // already in WHNF
311 break;
312
313 case BCO:
314 {
315 ASSERT(((StgBCO *)obj)->arity > 0);
316 break;
317 }
318
319 case AP: /* Copied from stg_AP_entry. */
320 {
321 nat i, words;
322 StgAP *ap;
323
324 ap = (StgAP*)obj;
325 words = ap->n_args;
326
327 // Stack check
328 if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
329 Sp -= 2;
330 Sp[1] = (W_)tagged_obj;
331 Sp[0] = (W_)&stg_enter_info;
332 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
333 }
334
335 /* Ok; we're safe. Party on. Push an update frame. */
336 Sp -= sizeofW(StgUpdateFrame);
337 {
338 StgUpdateFrame *__frame;
339 __frame = (StgUpdateFrame *)Sp;
340 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
341 __frame->updatee = (StgClosure *)(ap);
342 }
343
344 /* Reload the stack */
345 Sp -= words;
346 for (i=0; i < words; i++) {
347 Sp[i] = (W_)ap->payload[i];
348 }
349
350 obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
351 ASSERT(get_itbl(obj)->type == BCO);
352 goto run_BCO_fun;
353 }
354
355 default:
356 #ifdef INTERP_STATS
357 {
358 int j;
359
360 j = get_itbl(obj)->type;
361 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
362 it_unknown_entries[j]++;
363 it_total_unknown_entries++;
364 }
365 #endif
366 {
367 // Can't handle this object; yield to scheduler
368 IF_DEBUG(interpreter,
369 debugBelch("evaluating unknown closure -- yielding to sched\n");
370 printObj(obj);
371 );
372 Sp -= 2;
373 Sp[1] = (W_)tagged_obj;
374 Sp[0] = (W_)&stg_enter_info;
375 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
376 }
377 }
378
379 // ------------------------------------------------------------------------
380 // We now have an evaluated object (tagged_obj). The next thing to
381 // do is return it to the stack frame on top of the stack.
382 do_return:
383 obj = UNTAG_CLOSURE(tagged_obj);
384 ASSERT(closure_HNF(obj));
385
386 IF_DEBUG(interpreter,
387 debugBelch(
388 "\n---------------------------------------------------------------\n");
389 debugBelch("Returning: "); printObj(obj);
390 debugBelch("Sp = %p\n", Sp);
391 debugBelch("\n" );
392 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
393 debugBelch("\n\n");
394 );
395
396 IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size));
397
398 switch (get_itbl((StgClosure *)Sp)->type) {
399
400 case RET_SMALL: {
401 const StgInfoTable *info;
402
403 // NOTE: not using get_itbl().
404 info = ((StgClosure *)Sp)->header.info;
405 if (info == (StgInfoTable *)&stg_ap_v_info) {
406 n = 1; m = 0; goto do_apply;
407 }
408 if (info == (StgInfoTable *)&stg_ap_f_info) {
409 n = 1; m = 1; goto do_apply;
410 }
411 if (info == (StgInfoTable *)&stg_ap_d_info) {
412 n = 1; m = sizeofW(StgDouble); goto do_apply;
413 }
414 if (info == (StgInfoTable *)&stg_ap_l_info) {
415 n = 1; m = sizeofW(StgInt64); goto do_apply;
416 }
417 if (info == (StgInfoTable *)&stg_ap_n_info) {
418 n = 1; m = 1; goto do_apply;
419 }
420 if (info == (StgInfoTable *)&stg_ap_p_info) {
421 n = 1; m = 1; goto do_apply;
422 }
423 if (info == (StgInfoTable *)&stg_ap_pp_info) {
424 n = 2; m = 2; goto do_apply;
425 }
426 if (info == (StgInfoTable *)&stg_ap_ppp_info) {
427 n = 3; m = 3; goto do_apply;
428 }
429 if (info == (StgInfoTable *)&stg_ap_pppp_info) {
430 n = 4; m = 4; goto do_apply;
431 }
432 if (info == (StgInfoTable *)&stg_ap_ppppp_info) {
433 n = 5; m = 5; goto do_apply;
434 }
435 if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
436 n = 6; m = 6; goto do_apply;
437 }
438 goto do_return_unrecognised;
439 }
440
441 case UPDATE_FRAME:
442 // Returning to an update frame: do the update, pop the update
443 // frame, and continue with the next stack frame.
444 //
445 // NB. we must update with the *tagged* pointer. Some tags
446 // are not optional, and if we omit the tag bits when updating
447 // then bad things can happen (albeit very rarely). See #1925.
448 // What happened was an indirection was created with an
449 // untagged pointer, and this untagged pointer was propagated
450 // to a PAP by the GC, violating the invariant that PAPs
451 // always contain a tagged pointer to the function.
452 INTERP_TICK(it_retto_UPDATE);
453 updateThunk(cap, cap->r.rCurrentTSO,
454 ((StgUpdateFrame *)Sp)->updatee, tagged_obj);
455 Sp += sizeofW(StgUpdateFrame);
456 goto do_return;
457
458 case RET_BCO:
459 // Returning to an interpreted continuation: put the object on
460 // the stack, and start executing the BCO.
461 INTERP_TICK(it_retto_BCO);
462 Sp--;
463 Sp[0] = (W_)obj;
464 // NB. return the untagged object; the bytecode expects it to
465 // be untagged. XXX this doesn't seem right.
466 obj = (StgClosure*)Sp[2];
467 ASSERT(get_itbl(obj)->type == BCO);
468 goto run_BCO_return;
469
470 default:
471 do_return_unrecognised:
472 {
473 // Can't handle this return address; yield to scheduler
474 INTERP_TICK(it_retto_other);
475 IF_DEBUG(interpreter,
476 debugBelch("returning to unknown frame -- yielding to sched\n");
477 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
478 );
479 Sp -= 2;
480 Sp[1] = (W_)tagged_obj;
481 Sp[0] = (W_)&stg_enter_info;
482 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
483 }
484 }
485
486 // -------------------------------------------------------------------------
487 // Returning an unboxed value. The stack looks like this:
488 //
489 // | .... |
490 // +---------------+
491 // | fv2 |
492 // +---------------+
493 // | fv1 |
494 // +---------------+
495 // | BCO |
496 // +---------------+
497 // | stg_ctoi_ret_ |
498 // +---------------+
499 // | retval |
500 // +---------------+
501 // | XXXX_info |
502 // +---------------+
503 //
504 // where XXXX_info is one of the stg_gc_unbx_r1_info family.
505 //
506 // We're only interested in the case when the real return address
507 // is a BCO; otherwise we'll return to the scheduler.
508
509 do_return_unboxed:
510 {
511 int offset;
512
513 ASSERT( Sp[0] == (W_)&stg_gc_unbx_r1_info
514 || Sp[0] == (W_)&stg_gc_unpt_r1_info
515 || Sp[0] == (W_)&stg_gc_f1_info
516 || Sp[0] == (W_)&stg_gc_d1_info
517 || Sp[0] == (W_)&stg_gc_l1_info
518 || Sp[0] == (W_)&stg_gc_void_info // VoidRep
519 );
520
521 // get the offset of the stg_ctoi_ret_XXX itbl
522 offset = stack_frame_sizeW((StgClosure *)Sp);
523
524 switch (get_itbl((StgClosure *)Sp+offset)->type) {
525
526 case RET_BCO:
527 // Returning to an interpreted continuation: put the object on
528 // the stack, and start executing the BCO.
529 INTERP_TICK(it_retto_BCO);
530 obj = (StgClosure*)Sp[offset+1];
531 ASSERT(get_itbl(obj)->type == BCO);
532 goto run_BCO_return_unboxed;
533
534 default:
535 {
536 // Can't handle this return address; yield to scheduler
537 INTERP_TICK(it_retto_other);
538 IF_DEBUG(interpreter,
539 debugBelch("returning to unknown frame -- yielding to sched\n");
540 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
541 );
542 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
543 }
544 }
545 }
546 // not reached.
547
548
549 // -------------------------------------------------------------------------
550 // Application...
551
552 do_apply:
553 ASSERT(obj == UNTAG_CLOSURE(tagged_obj));
554 // we have a function to apply (obj), and n arguments taking up m
555 // words on the stack. The info table (stg_ap_pp_info or whatever)
556 // is on top of the arguments on the stack.
557 {
558 switch (get_itbl(obj)->type) {
559
560 case PAP: {
561 StgPAP *pap;
562 nat i, arity;
563
564 pap = (StgPAP *)obj;
565
566 // we only cope with PAPs whose function is a BCO
567 if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) {
568 goto defer_apply_to_sched;
569 }
570
571 // Stack check: we're about to unpack the PAP onto the
572 // stack. The (+1) is for the (arity < n) case, where we
573 // also need space for an extra info pointer.
574 if (Sp - (pap->n_args + 1) < SpLim) {
575 Sp -= 2;
576 Sp[1] = (W_)tagged_obj;
577 Sp[0] = (W_)&stg_enter_info;
578 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
579 }
580
581 Sp++;
582 arity = pap->arity;
583 ASSERT(arity > 0);
584 if (arity < n) {
585 // n must be greater than 1, and the only kinds of
586 // application we support with more than one argument
587 // are all pointers...
588 //
589 // Shuffle the args for this function down, and put
590 // the appropriate info table in the gap.
591 for (i = 0; i < arity; i++) {
592 Sp[(int)i-1] = Sp[i];
593 // ^^^^^ careful, i-1 might be negative, but i in unsigned
594 }
595 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
596 Sp--;
597 // unpack the PAP's arguments onto the stack
598 Sp -= pap->n_args;
599 for (i = 0; i < pap->n_args; i++) {
600 Sp[i] = (W_)pap->payload[i];
601 }
602 obj = UNTAG_CLOSURE(pap->fun);
603 goto run_BCO_fun;
604 }
605 else if (arity == n) {
606 Sp -= pap->n_args;
607 for (i = 0; i < pap->n_args; i++) {
608 Sp[i] = (W_)pap->payload[i];
609 }
610 obj = UNTAG_CLOSURE(pap->fun);
611 goto run_BCO_fun;
612 }
613 else /* arity > n */ {
614 // build a new PAP and return it.
615 StgPAP *new_pap;
616 new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m));
617 SET_HDR(new_pap,&stg_PAP_info,CCCS);
618 new_pap->arity = pap->arity - n;
619 new_pap->n_args = pap->n_args + m;
620 new_pap->fun = pap->fun;
621 for (i = 0; i < pap->n_args; i++) {
622 new_pap->payload[i] = pap->payload[i];
623 }
624 for (i = 0; i < m; i++) {
625 new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
626 }
627 tagged_obj = (StgClosure *)new_pap;
628 Sp += m;
629 goto do_return;
630 }
631 }
632
633 case BCO: {
634 nat arity, i;
635
636 Sp++;
637 arity = ((StgBCO *)obj)->arity;
638 ASSERT(arity > 0);
639 if (arity < n) {
640 // n must be greater than 1, and the only kinds of
641 // application we support with more than one argument
642 // are all pointers...
643 //
644 // Shuffle the args for this function down, and put
645 // the appropriate info table in the gap.
646 for (i = 0; i < arity; i++) {
647 Sp[(int)i-1] = Sp[i];
648 // ^^^^^ careful, i-1 might be negative, but i in unsigned
649 }
650 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
651 Sp--;
652 goto run_BCO_fun;
653 }
654 else if (arity == n) {
655 goto run_BCO_fun;
656 }
657 else /* arity > n */ {
658 // build a PAP and return it.
659 StgPAP *pap;
660 nat i;
661 pap = (StgPAP *)allocate(cap, PAP_sizeW(m));
662 SET_HDR(pap, &stg_PAP_info,CCCS);
663 pap->arity = arity - n;
664 pap->fun = obj;
665 pap->n_args = m;
666 for (i = 0; i < m; i++) {
667 pap->payload[i] = (StgClosure *)Sp[i];
668 }
669 tagged_obj = (StgClosure *)pap;
670 Sp += m;
671 goto do_return;
672 }
673 }
674
675 // No point in us applying machine-code functions
676 default:
677 defer_apply_to_sched:
678 Sp -= 2;
679 Sp[1] = (W_)tagged_obj;
680 Sp[0] = (W_)&stg_enter_info;
681 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
682 }
683
684 // ------------------------------------------------------------------------
685 // Ok, we now have a bco (obj), and its arguments are all on the
686 // stack. We can start executing the byte codes.
687 //
688 // The stack is in one of two states. First, if this BCO is a
689 // function:
690 //
691 // | .... |
692 // +---------------+
693 // | arg2 |
694 // +---------------+
695 // | arg1 |
696 // +---------------+
697 //
698 // Second, if this BCO is a continuation:
699 //
700 // | .... |
701 // +---------------+
702 // | fv2 |
703 // +---------------+
704 // | fv1 |
705 // +---------------+
706 // | BCO |
707 // +---------------+
708 // | stg_ctoi_ret_ |
709 // +---------------+
710 // | retval |
711 // +---------------+
712 //
713 // where retval is the value being returned to this continuation.
714 // In the event of a stack check, heap check, or context switch,
715 // we need to leave the stack in a sane state so the garbage
716 // collector can find all the pointers.
717 //
718 // (1) BCO is a function: the BCO's bitmap describes the
719 // pointerhood of the arguments.
720 //
721 // (2) BCO is a continuation: BCO's bitmap describes the
722 // pointerhood of the free variables.
723 //
724 // Sadly we have three different kinds of stack/heap/cswitch check
725 // to do:
726
727
728 run_BCO_return:
729 // Heap check
730 if (doYouWantToGC(cap)) {
731 Sp--; Sp[0] = (W_)&stg_enter_info;
732 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
733 }
734 // Stack checks aren't necessary at return points, the stack use
735 // is aggregated into the enclosing function entry point.
736
737 goto run_BCO;
738
739 run_BCO_return_unboxed:
740 // Heap check
741 if (doYouWantToGC(cap)) {
742 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
743 }
744 // Stack checks aren't necessary at return points, the stack use
745 // is aggregated into the enclosing function entry point.
746
747 goto run_BCO;
748
749 run_BCO_fun:
750 IF_DEBUG(sanity,
751 Sp -= 2;
752 Sp[1] = (W_)obj;
753 Sp[0] = (W_)&stg_apply_interp_info;
754 checkStackChunk(Sp,SpLim);
755 Sp += 2;
756 );
757
758 // Heap check
759 if (doYouWantToGC(cap)) {
760 Sp -= 2;
761 Sp[1] = (W_)obj;
762 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
763 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
764 }
765
766 // Stack check
767 if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
768 Sp -= 2;
769 Sp[1] = (W_)obj;
770 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
771 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
772 }
773
774 goto run_BCO;
775
776 // Now, actually interpret the BCO... (no returning to the
777 // scheduler again until the stack is in an orderly state).
778 run_BCO:
779 INTERP_TICK(it_BCO_entries);
780 {
781 register int bciPtr = 0; /* instruction pointer */
782 register StgWord16 bci;
783 register StgBCO* bco = (StgBCO*)obj;
784 register StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
785 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
786 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
787 #ifdef DEBUG
788 int bcoSize;
789 bcoSize = BCO_READ_NEXT_WORD;
790 #else
791 BCO_NEXT_WORD;
792 #endif
793 IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
794
795 #ifdef INTERP_STATS
796 it_lastopc = 0; /* no opcode */
797 #endif
798
799 nextInsn:
800 ASSERT(bciPtr < bcoSize);
801 IF_DEBUG(interpreter,
802 //if (do_print_stack) {
803 //debugBelch("\n-- BEGIN stack\n");
804 //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
805 //debugBelch("-- END stack\n\n");
806 //}
807 debugBelch("Sp = %p pc = %-4d ", Sp, bciPtr);
808 disInstr(bco,bciPtr);
809 if (0) { int i;
810 debugBelch("\n");
811 for (i = 8; i >= 0; i--) {
812 debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i)));
813 }
814 debugBelch("\n");
815 }
816 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
817 );
818
819
820 INTERP_TICK(it_insns);
821
822 #ifdef INTERP_STATS
823 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
824 it_ofreq[ (int)instrs[bciPtr] ] ++;
825 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
826 it_lastopc = (int)instrs[bciPtr];
827 #endif
828
829 bci = BCO_NEXT;
830 /* We use the high 8 bits for flags, only the highest of which is
831 * currently allocated */
832 ASSERT((bci & 0xFF00) == (bci & 0x8000));
833
834 switch (bci & 0xFF) {
835
836 /* check for a breakpoint on the beginning of a let binding */
837 case bci_BRK_FUN:
838 {
839 int arg1_brk_array, arg2_array_index, arg3_freeVars;
840 StgArrWords *breakPoints;
841 int returning_from_break; // are we resuming execution from a breakpoint?
842 // if yes, then don't break this time around
843 StgClosure *ioAction; // the io action to run at a breakpoint
844
845 StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap
846 int i;
847 int size_words;
848
849 arg1_brk_array = BCO_NEXT; // 1st arg of break instruction
850 arg2_array_index = BCO_NEXT; // 2nd arg of break instruction
851 arg3_freeVars = BCO_NEXT; // 3rd arg of break instruction
852
853 // check if we are returning from a breakpoint - this info
854 // is stored in the flags field of the current TSO
855 returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
856
857 // if we are returning from a break then skip this section
858 // and continue executing
859 if (!returning_from_break)
860 {
861 breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
862
863 // stop the current thread if either the
864 // "rts_stop_next_breakpoint" flag is true OR if the
865 // breakpoint flag for this particular expression is
866 // true
867 if (rts_stop_next_breakpoint == rtsTrue ||
868 breakPoints->payload[arg2_array_index] == rtsTrue)
869 {
870 // make sure we don't automatically stop at the
871 // next breakpoint
872 rts_stop_next_breakpoint = rtsFalse;
873
874 // allocate memory for a new AP_STACK, enough to
875 // store the top stack frame plus an
876 // stg_apply_interp_info pointer and a pointer to
877 // the BCO
878 size_words = BCO_BITMAP_SIZE(obj) + 2;
879 new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
880 SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
881 new_aps->size = size_words;
882 new_aps->fun = &stg_dummy_ret_closure;
883
884 // fill in the payload of the AP_STACK
885 new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
886 new_aps->payload[1] = (StgClosure *)obj;
887
888 // copy the contents of the top stack frame into the AP_STACK
889 for (i = 2; i < size_words; i++)
890 {
891 new_aps->payload[i] = (StgClosure *)Sp[i-2];
892 }
893
894 // prepare the stack so that we can call the
895 // rts_breakpoint_io_action and ensure that the stack is
896 // in a reasonable state for the GC and so that
897 // execution of this BCO can continue when we resume
898 ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
899 Sp -= 8;
900 Sp[7] = (W_)obj;
901 Sp[6] = (W_)&stg_apply_interp_info;
902 Sp[5] = (W_)new_aps; // the AP_STACK
903 Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
904 Sp[3] = (W_)False_closure; // True <=> a breakpoint
905 Sp[2] = (W_)&stg_ap_pppv_info;
906 Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
907 Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
908 // set the flag in the TSO to say that we are now
909 // stopping at a breakpoint so that when we resume
910 // we don't stop on the same breakpoint that we
911 // already stopped at just now
912 cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
913
914 // stop this thread and return to the scheduler -
915 // eventually we will come back and the IO action on
916 // the top of the stack will be executed
917 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
918 }
919 }
920 // record that this thread is not stopped at a breakpoint anymore
921 cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
922
923 // continue normal execution of the byte code instructions
924 goto nextInsn;
925 }
926
927 case bci_STKCHECK: {
928 // Explicit stack check at the beginning of a function
929 // *only* (stack checks in case alternatives are
930 // propagated to the enclosing function).
931 StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
932 if (Sp - stk_words_reqd < SpLim) {
933 Sp -= 2;
934 Sp[1] = (W_)obj;
935 Sp[0] = (W_)&stg_apply_interp_info;
936 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
937 } else {
938 goto nextInsn;
939 }
940 }
941
942 case bci_PUSH_L: {
943 int o1 = BCO_NEXT;
944 Sp[-1] = Sp[o1];
945 Sp--;
946 goto nextInsn;
947 }
948
949 case bci_PUSH_LL: {
950 int o1 = BCO_NEXT;
951 int o2 = BCO_NEXT;
952 Sp[-1] = Sp[o1];
953 Sp[-2] = Sp[o2];
954 Sp -= 2;
955 goto nextInsn;
956 }
957
958 case bci_PUSH_LLL: {
959 int o1 = BCO_NEXT;
960 int o2 = BCO_NEXT;
961 int o3 = BCO_NEXT;
962 Sp[-1] = Sp[o1];
963 Sp[-2] = Sp[o2];
964 Sp[-3] = Sp[o3];
965 Sp -= 3;
966 goto nextInsn;
967 }
968
969 case bci_PUSH_G: {
970 int o1 = BCO_NEXT;
971 Sp[-1] = BCO_PTR(o1);
972 Sp -= 1;
973 goto nextInsn;
974 }
975
976 case bci_PUSH_ALTS: {
977 int o_bco = BCO_NEXT;
978 Sp[-2] = (W_)&stg_ctoi_R1p_info;
979 Sp[-1] = BCO_PTR(o_bco);
980 Sp -= 2;
981 goto nextInsn;
982 }
983
984 case bci_PUSH_ALTS_P: {
985 int o_bco = BCO_NEXT;
986 Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
987 Sp[-1] = BCO_PTR(o_bco);
988 Sp -= 2;
989 goto nextInsn;
990 }
991
992 case bci_PUSH_ALTS_N: {
993 int o_bco = BCO_NEXT;
994 Sp[-2] = (W_)&stg_ctoi_R1n_info;
995 Sp[-1] = BCO_PTR(o_bco);
996 Sp -= 2;
997 goto nextInsn;
998 }
999
1000 case bci_PUSH_ALTS_F: {
1001 int o_bco = BCO_NEXT;
1002 Sp[-2] = (W_)&stg_ctoi_F1_info;
1003 Sp[-1] = BCO_PTR(o_bco);
1004 Sp -= 2;
1005 goto nextInsn;
1006 }
1007
1008 case bci_PUSH_ALTS_D: {
1009 int o_bco = BCO_NEXT;
1010 Sp[-2] = (W_)&stg_ctoi_D1_info;
1011 Sp[-1] = BCO_PTR(o_bco);
1012 Sp -= 2;
1013 goto nextInsn;
1014 }
1015
1016 case bci_PUSH_ALTS_L: {
1017 int o_bco = BCO_NEXT;
1018 Sp[-2] = (W_)&stg_ctoi_L1_info;
1019 Sp[-1] = BCO_PTR(o_bco);
1020 Sp -= 2;
1021 goto nextInsn;
1022 }
1023
1024 case bci_PUSH_ALTS_V: {
1025 int o_bco = BCO_NEXT;
1026 Sp[-2] = (W_)&stg_ctoi_V_info;
1027 Sp[-1] = BCO_PTR(o_bco);
1028 Sp -= 2;
1029 goto nextInsn;
1030 }
1031
1032 case bci_PUSH_APPLY_N:
1033 Sp--; Sp[0] = (W_)&stg_ap_n_info;
1034 goto nextInsn;
1035 case bci_PUSH_APPLY_V:
1036 Sp--; Sp[0] = (W_)&stg_ap_v_info;
1037 goto nextInsn;
1038 case bci_PUSH_APPLY_F:
1039 Sp--; Sp[0] = (W_)&stg_ap_f_info;
1040 goto nextInsn;
1041 case bci_PUSH_APPLY_D:
1042 Sp--; Sp[0] = (W_)&stg_ap_d_info;
1043 goto nextInsn;
1044 case bci_PUSH_APPLY_L:
1045 Sp--; Sp[0] = (W_)&stg_ap_l_info;
1046 goto nextInsn;
1047 case bci_PUSH_APPLY_P:
1048 Sp--; Sp[0] = (W_)&stg_ap_p_info;
1049 goto nextInsn;
1050 case bci_PUSH_APPLY_PP:
1051 Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1052 goto nextInsn;
1053 case bci_PUSH_APPLY_PPP:
1054 Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1055 goto nextInsn;
1056 case bci_PUSH_APPLY_PPPP:
1057 Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1058 goto nextInsn;
1059 case bci_PUSH_APPLY_PPPPP:
1060 Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1061 goto nextInsn;
1062 case bci_PUSH_APPLY_PPPPPP:
1063 Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1064 goto nextInsn;
1065
1066 case bci_PUSH_UBX: {
1067 int i;
1068 int o_lits = BCO_NEXT;
1069 int n_words = BCO_NEXT;
1070 Sp -= n_words;
1071 for (i = 0; i < n_words; i++) {
1072 Sp[i] = (W_)BCO_LIT(o_lits+i);
1073 }
1074 goto nextInsn;
1075 }
1076
1077 case bci_SLIDE: {
1078 int n = BCO_NEXT;
1079 int by = BCO_NEXT;
1080 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1081 while(--n >= 0) {
1082 Sp[n+by] = Sp[n];
1083 }
1084 Sp += by;
1085 INTERP_TICK(it_slides);
1086 goto nextInsn;
1087 }
1088
1089 case bci_ALLOC_AP: {
1090 StgAP* ap;
1091 int n_payload = BCO_NEXT;
1092 ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1093 Sp[-1] = (W_)ap;
1094 ap->n_args = n_payload;
1095 SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
1096 Sp --;
1097 goto nextInsn;
1098 }
1099
1100 case bci_ALLOC_AP_NOUPD: {
1101 StgAP* ap;
1102 int n_payload = BCO_NEXT;
1103 ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1104 Sp[-1] = (W_)ap;
1105 ap->n_args = n_payload;
1106 SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
1107 Sp --;
1108 goto nextInsn;
1109 }
1110
1111 case bci_ALLOC_PAP: {
1112 StgPAP* pap;
1113 int arity = BCO_NEXT;
1114 int n_payload = BCO_NEXT;
1115 pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload));
1116 Sp[-1] = (W_)pap;
1117 pap->n_args = n_payload;
1118 pap->arity = arity;
1119 SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
1120 Sp --;
1121 goto nextInsn;
1122 }
1123
1124 case bci_MKAP: {
1125 int i;
1126 int stkoff = BCO_NEXT;
1127 int n_payload = BCO_NEXT;
1128 StgAP* ap = (StgAP*)Sp[stkoff];
1129 ASSERT((int)ap->n_args == n_payload);
1130 ap->fun = (StgClosure*)Sp[0];
1131
1132 // The function should be a BCO, and its bitmap should
1133 // cover the payload of the AP correctly.
1134 ASSERT(get_itbl(ap->fun)->type == BCO
1135 && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1136
1137 for (i = 0; i < n_payload; i++)
1138 ap->payload[i] = (StgClosure*)Sp[i+1];
1139 Sp += n_payload+1;
1140 IF_DEBUG(interpreter,
1141 debugBelch("\tBuilt ");
1142 printObj((StgClosure*)ap);
1143 );
1144 goto nextInsn;
1145 }
1146
1147 case bci_MKPAP: {
1148 int i;
1149 int stkoff = BCO_NEXT;
1150 int n_payload = BCO_NEXT;
1151 StgPAP* pap = (StgPAP*)Sp[stkoff];
1152 ASSERT((int)pap->n_args == n_payload);
1153 pap->fun = (StgClosure*)Sp[0];
1154
1155 // The function should be a BCO
1156 ASSERT(get_itbl(pap->fun)->type == BCO);
1157
1158 for (i = 0; i < n_payload; i++)
1159 pap->payload[i] = (StgClosure*)Sp[i+1];
1160 Sp += n_payload+1;
1161 IF_DEBUG(interpreter,
1162 debugBelch("\tBuilt ");
1163 printObj((StgClosure*)pap);
1164 );
1165 goto nextInsn;
1166 }
1167
1168 case bci_UNPACK: {
1169 /* Unpack N ptr words from t.o.s constructor */
1170 int i;
1171 int n_words = BCO_NEXT;
1172 StgClosure* con = (StgClosure*)Sp[0];
1173 Sp -= n_words;
1174 for (i = 0; i < n_words; i++) {
1175 Sp[i] = (W_)con->payload[i];
1176 }
1177 goto nextInsn;
1178 }
1179
1180 case bci_PACK: {
1181 int i;
1182 int o_itbl = BCO_NEXT;
1183 int n_words = BCO_NEXT;
1184 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
1185 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
1186 itbl->layout.payload.nptrs );
1187 StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
1188 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1189 SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
1190 for (i = 0; i < n_words; i++) {
1191 con->payload[i] = (StgClosure*)Sp[i];
1192 }
1193 Sp += n_words;
1194 Sp --;
1195 Sp[0] = (W_)con;
1196 IF_DEBUG(interpreter,
1197 debugBelch("\tBuilt ");
1198 printObj((StgClosure*)con);
1199 );
1200 goto nextInsn;
1201 }
1202
1203 case bci_TESTLT_P: {
1204 unsigned int discr = BCO_NEXT;
1205 int failto = BCO_GET_LARGE_ARG;
1206 StgClosure* con = (StgClosure*)Sp[0];
1207 if (GET_TAG(con) >= discr) {
1208 bciPtr = failto;
1209 }
1210 goto nextInsn;
1211 }
1212
1213 case bci_TESTEQ_P: {
1214 unsigned int discr = BCO_NEXT;
1215 int failto = BCO_GET_LARGE_ARG;
1216 StgClosure* con = (StgClosure*)Sp[0];
1217 if (GET_TAG(con) != discr) {
1218 bciPtr = failto;
1219 }
1220 goto nextInsn;
1221 }
1222
1223 case bci_TESTLT_I: {
1224 // There should be an Int at Sp[1], and an info table at Sp[0].
1225 int discr = BCO_NEXT;
1226 int failto = BCO_GET_LARGE_ARG;
1227 I_ stackInt = (I_)Sp[1];
1228 if (stackInt >= (I_)BCO_LIT(discr))
1229 bciPtr = failto;
1230 goto nextInsn;
1231 }
1232
1233 case bci_TESTEQ_I: {
1234 // There should be an Int at Sp[1], and an info table at Sp[0].
1235 int discr = BCO_NEXT;
1236 int failto = BCO_GET_LARGE_ARG;
1237 I_ stackInt = (I_)Sp[1];
1238 if (stackInt != (I_)BCO_LIT(discr)) {
1239 bciPtr = failto;
1240 }
1241 goto nextInsn;
1242 }
1243
1244 case bci_TESTLT_W: {
1245 // There should be an Int at Sp[1], and an info table at Sp[0].
1246 int discr = BCO_NEXT;
1247 int failto = BCO_GET_LARGE_ARG;
1248 W_ stackWord = (W_)Sp[1];
1249 if (stackWord >= (W_)BCO_LIT(discr))
1250 bciPtr = failto;
1251 goto nextInsn;
1252 }
1253
1254 case bci_TESTEQ_W: {
1255 // There should be an Int at Sp[1], and an info table at Sp[0].
1256 int discr = BCO_NEXT;
1257 int failto = BCO_GET_LARGE_ARG;
1258 W_ stackWord = (W_)Sp[1];
1259 if (stackWord != (W_)BCO_LIT(discr)) {
1260 bciPtr = failto;
1261 }
1262 goto nextInsn;
1263 }
1264
1265 case bci_TESTLT_D: {
1266 // There should be a Double at Sp[1], and an info table at Sp[0].
1267 int discr = BCO_NEXT;
1268 int failto = BCO_GET_LARGE_ARG;
1269 StgDouble stackDbl, discrDbl;
1270 stackDbl = PK_DBL( & Sp[1] );
1271 discrDbl = PK_DBL( & BCO_LIT(discr) );
1272 if (stackDbl >= discrDbl) {
1273 bciPtr = failto;
1274 }
1275 goto nextInsn;
1276 }
1277
1278 case bci_TESTEQ_D: {
1279 // There should be a Double at Sp[1], and an info table at Sp[0].
1280 int discr = BCO_NEXT;
1281 int failto = BCO_GET_LARGE_ARG;
1282 StgDouble stackDbl, discrDbl;
1283 stackDbl = PK_DBL( & Sp[1] );
1284 discrDbl = PK_DBL( & BCO_LIT(discr) );
1285 if (stackDbl != discrDbl) {
1286 bciPtr = failto;
1287 }
1288 goto nextInsn;
1289 }
1290
1291 case bci_TESTLT_F: {
1292 // There should be a Float at Sp[1], and an info table at Sp[0].
1293 int discr = BCO_NEXT;
1294 int failto = BCO_GET_LARGE_ARG;
1295 StgFloat stackFlt, discrFlt;
1296 stackFlt = PK_FLT( & Sp[1] );
1297 discrFlt = PK_FLT( & BCO_LIT(discr) );
1298 if (stackFlt >= discrFlt) {
1299 bciPtr = failto;
1300 }
1301 goto nextInsn;
1302 }
1303
1304 case bci_TESTEQ_F: {
1305 // There should be a Float at Sp[1], and an info table at Sp[0].
1306 int discr = BCO_NEXT;
1307 int failto = BCO_GET_LARGE_ARG;
1308 StgFloat stackFlt, discrFlt;
1309 stackFlt = PK_FLT( & Sp[1] );
1310 discrFlt = PK_FLT( & BCO_LIT(discr) );
1311 if (stackFlt != discrFlt) {
1312 bciPtr = failto;
1313 }
1314 goto nextInsn;
1315 }
1316
1317 // Control-flow ish things
1318 case bci_ENTER:
1319 // Context-switch check. We put it here to ensure that
1320 // the interpreter has done at least *some* work before
1321 // context switching: sometimes the scheduler can invoke
1322 // the interpreter with context_switch == 1, particularly
1323 // if the -C0 flag has been given on the cmd line.
1324 if (cap->r.rHpLim == NULL) {
1325 Sp--; Sp[0] = (W_)&stg_enter_info;
1326 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1327 }
1328 goto eval;
1329
1330 case bci_RETURN:
1331 tagged_obj = (StgClosure *)Sp[0];
1332 Sp++;
1333 goto do_return;
1334
1335 case bci_RETURN_P:
1336 Sp--;
1337 Sp[0] = (W_)&stg_gc_unpt_r1_info;
1338 goto do_return_unboxed;
1339 case bci_RETURN_N:
1340 Sp--;
1341 Sp[0] = (W_)&stg_gc_unbx_r1_info;
1342 goto do_return_unboxed;
1343 case bci_RETURN_F:
1344 Sp--;
1345 Sp[0] = (W_)&stg_gc_f1_info;
1346 goto do_return_unboxed;
1347 case bci_RETURN_D:
1348 Sp--;
1349 Sp[0] = (W_)&stg_gc_d1_info;
1350 goto do_return_unboxed;
1351 case bci_RETURN_L:
1352 Sp--;
1353 Sp[0] = (W_)&stg_gc_l1_info;
1354 goto do_return_unboxed;
1355 case bci_RETURN_V:
1356 Sp--;
1357 Sp[0] = (W_)&stg_gc_void_info;
1358 goto do_return_unboxed;
1359
1360 case bci_SWIZZLE: {
1361 int stkoff = BCO_NEXT;
1362 signed short n = (signed short)(BCO_NEXT);
1363 Sp[stkoff] += (W_)n;
1364 goto nextInsn;
1365 }
1366
1367 case bci_CCALL: {
1368 void *tok;
1369 int stk_offset = BCO_NEXT;
1370 int o_itbl = BCO_NEXT;
1371 int interruptible = BCO_NEXT;
1372 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1373 int ret_dyn_size =
1374 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1375 + sizeofW(StgRetDyn);
1376
1377 /* the stack looks like this:
1378
1379 | | <- Sp + stk_offset
1380 +-------------+
1381 | |
1382 | args |
1383 | | <- Sp + ret_size + 1
1384 +-------------+
1385 | C fun | <- Sp + ret_size
1386 +-------------+
1387 | ret | <- Sp
1388 +-------------+
1389
1390 ret is a placeholder for the return address, and may be
1391 up to 2 words.
1392
1393 We need to copy the args out of the TSO, because when
1394 we call suspendThread() we no longer own the TSO stack,
1395 and it may move at any time - indeed suspendThread()
1396 itself may do stack squeezing and move our args.
1397 So we make a copy of the argument block.
1398 */
1399
1400 #define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1401
1402 ffi_cif *cif = (ffi_cif *)marshall_fn;
1403 nat nargs = cif->nargs;
1404 nat ret_size;
1405 nat i;
1406 StgPtr p;
1407 W_ ret[2]; // max needed
1408 W_ *arguments[stk_offset]; // max needed
1409 void *argptrs[nargs];
1410 void (*fn)(void);
1411
1412 if (cif->rtype->type == FFI_TYPE_VOID) {
1413 // necessary because cif->rtype->size == 1 for void,
1414 // but the bytecode generator has not pushed a
1415 // placeholder in this case.
1416 ret_size = 0;
1417 } else {
1418 ret_size = ROUND_UP_WDS(cif->rtype->size);
1419 }
1420
1421 memcpy(arguments, Sp+ret_size+1,
1422 sizeof(W_) * (stk_offset-1-ret_size));
1423
1424 // libffi expects the args as an array of pointers to
1425 // values, so we have to construct this array before making
1426 // the call.
1427 p = (StgPtr)arguments;
1428 for (i = 0; i < nargs; i++) {
1429 argptrs[i] = (void *)p;
1430 // get the size from the cif
1431 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1432 }
1433
1434 // this is the function we're going to call
1435 fn = (void(*)(void))Sp[ret_size];
1436
1437 // Restore the Haskell thread's current value of errno
1438 errno = cap->r.rCurrentTSO->saved_errno;
1439
1440 // There are a bunch of non-ptr words on the stack (the
1441 // ccall args, the ccall fun address and space for the
1442 // result), which we need to cover with an info table
1443 // since we might GC during this call.
1444 //
1445 // We know how many (non-ptr) words there are before the
1446 // next valid stack frame: it is the stk_offset arg to the
1447 // CCALL instruction. So we build a RET_DYN stack frame
1448 // on the stack frame to describe this chunk of stack.
1449 //
1450 Sp -= ret_dyn_size;
1451 ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset);
1452 ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1453
1454 // save obj (pointer to the current BCO), since this
1455 // might move during the call. We use the R1 slot in the
1456 // RET_DYN frame for this, hence R1_PTR above.
1457 ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
1458
1459 SAVE_STACK_POINTERS;
1460 tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse);
1461
1462 // We already made a copy of the arguments above.
1463 ffi_call(cif, fn, ret, argptrs);
1464
1465 // And restart the thread again, popping the RET_DYN frame.
1466 cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
1467 LOAD_STACK_POINTERS;
1468
1469 if (Sp[0] != (W_)&stg_gc_gen_info) {
1470 // the stack is not how we left it. This probably
1471 // means that an exception got raised on exit from the
1472 // foreign call, so we should just continue with
1473 // whatever is on top of the stack now.
1474 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
1475 }
1476
1477 // Re-load the pointer to the BCO from the RET_DYN frame,
1478 // it might have moved during the call. Also reload the
1479 // pointers to the components of the BCO.
1480 obj = ((StgRetDyn *)Sp)->payload[0];
1481 bco = (StgBCO*)obj;
1482 instrs = (StgWord16*)(bco->instrs->payload);
1483 literals = (StgWord*)(&bco->literals->payload[0]);
1484 ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
1485
1486 Sp += ret_dyn_size;
1487
1488 // Save the Haskell thread's current value of errno
1489 cap->r.rCurrentTSO->saved_errno = errno;
1490
1491 // Copy the return value back to the TSO stack. It is at
1492 // most 2 words large, and resides at arguments[0].
1493 memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1494
1495 goto nextInsn;
1496 }
1497
1498 case bci_JMP: {
1499 /* BCO_NEXT modifies bciPtr, so be conservative. */
1500 int nextpc = BCO_GET_LARGE_ARG;
1501 bciPtr = nextpc;
1502 goto nextInsn;
1503 }
1504
1505 case bci_CASEFAIL:
1506 barf("interpretBCO: hit a CASEFAIL");
1507
1508 // Errors
1509 default:
1510 barf("interpretBCO: unknown or unimplemented opcode %d",
1511 (int)(bci & 0xFF));
1512
1513 } /* switch on opcode */
1514 }
1515 }
1516
1517 barf("interpretBCO: fell off end of the interpreter");
1518 }