1 /* -----------------------------------------------------------------------------
4 * Copyright (c) The GHC Team, 1994-2002.
5 * ---------------------------------------------------------------------------*/
7 #include "PosixSource.h"
10 #include "rts/Bytecodes.h"
13 #include "sm/Storage.h"
21 #include "Disassembler.h"
22 #include "Interpreter.h"
23 #include "ThreadPaused.h"
25 #include <string.h> /* for memcpy */
32 /* --------------------------------------------------------------------------
33 * The bytecode interpreter
34 * ------------------------------------------------------------------------*/
36 /* Gather stats about entry, opcode, opcode-pair frequencies. For
37 tuning the interpreter. */
39 /* #define INTERP_STATS */
42 /* Sp points to the lowest live word on the stack. */
44 #define BCO_NEXT instrs[bciPtr++]
45 #define BCO_NEXT_32 (bciPtr += 2, (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1]))
46 #define BCO_NEXT_64 (bciPtr += 4, (((StgWord) instrs[bciPtr-4]) << 48) + (((StgWord) instrs[bciPtr-3]) << 32) + (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1]))
47 #if WORD_SIZE_IN_BITS == 32
48 #define BCO_NEXT_WORD BCO_NEXT_32
49 #elif WORD_SIZE_IN_BITS == 64
50 #define BCO_NEXT_WORD BCO_NEXT_64
52 #error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64
54 #define BCO_GET_LARGE_ARG ((bci & bci_FLAG_LARGE_ARGS) ? BCO_NEXT_WORD : BCO_NEXT)
56 #define BCO_PTR(n) (W_)ptrs[n]
57 #define BCO_LIT(n) literals[n]
59 #define LOAD_STACK_POINTERS \
60 Sp = cap->r.rCurrentTSO->sp; \
61 /* We don't change this ... */ \
62 SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
64 #define SAVE_STACK_POINTERS \
66 cap->r.rCurrentTSO->sp = Sp
68 #define RETURN_TO_SCHEDULER(todo,retcode) \
69 SAVE_STACK_POINTERS; \
70 cap->r.rCurrentTSO->what_next = (todo); \
71 threadPaused(cap,cap->r.rCurrentTSO); \
72 cap->r.rRet = (retcode); \
75 #define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode) \
76 SAVE_STACK_POINTERS; \
77 cap->r.rCurrentTSO->what_next = (todo); \
78 cap->r.rRet = (retcode); \
83 allocate_NONUPD (Capability *cap, int n_words)
85 return allocateLocal(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
88 int rts_stop_next_breakpoint = 0;
89 int rts_stop_on_exception = 0;
93 /* Hacky stats, for tuning the interpreter ... */
94 int it_unknown_entries[N_CLOSURE_TYPES];
95 int it_total_unknown_entries;
107 int it_oofreq[27][27];
111 #define INTERP_TICK(n) (n)++
113 void interp_startup ( void )
116 it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
117 it_total_entries = it_total_unknown_entries = 0;
118 for (i = 0; i < N_CLOSURE_TYPES; i++)
119 it_unknown_entries[i] = 0;
120 it_slides = it_insns = it_BCO_entries = 0;
121 for (i = 0; i < 27; i++) it_ofreq[i] = 0;
122 for (i = 0; i < 27; i++)
123 for (j = 0; j < 27; j++)
128 void interp_shutdown ( void )
130 int i, j, k, o_max, i_max, j_max;
131 debugBelch("%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
132 it_retto_BCO + it_retto_UPDATE + it_retto_other,
133 it_retto_BCO, it_retto_UPDATE, it_retto_other );
134 debugBelch("%d total entries, %d unknown entries \n",
135 it_total_entries, it_total_unknown_entries);
136 for (i = 0; i < N_CLOSURE_TYPES; i++) {
137 if (it_unknown_entries[i] == 0) continue;
138 debugBelch(" type %2d: unknown entries (%4.1f%%) == %d\n",
139 i, 100.0 * ((double)it_unknown_entries[i]) /
140 ((double)it_total_unknown_entries),
141 it_unknown_entries[i]);
143 debugBelch("%d insns, %d slides, %d BCO_entries\n",
144 it_insns, it_slides, it_BCO_entries);
145 for (i = 0; i < 27; i++)
146 debugBelch("opcode %2d got %d\n", i, it_ofreq[i] );
148 for (k = 1; k < 20; k++) {
151 for (i = 0; i < 27; i++) {
152 for (j = 0; j < 27; j++) {
153 if (it_oofreq[i][j] > o_max) {
154 o_max = it_oofreq[i][j];
155 i_max = i; j_max = j;
160 debugBelch("%d: count (%4.1f%%) %6d is %d then %d\n",
161 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
163 it_oofreq[i_max][j_max] = 0;
168 #else // !INTERP_STATS
170 #define INTERP_TICK(n) /* nothing */
174 static StgWord app_ptrs_itbl[] = {
177 (W_)&stg_ap_ppp_info,
178 (W_)&stg_ap_pppp_info,
179 (W_)&stg_ap_ppppp_info,
180 (W_)&stg_ap_pppppp_info,
183 HsStablePtr rts_breakpoint_io_action; // points to the IO action which is executed on a breakpoint
184 // it is set in main/GHC.hs:runStmt
187 interpretBCO (Capability* cap)
189 // Use of register here is primarily to make it clear to compilers
190 // that these entities are non-aliasable.
191 register StgPtr Sp; // local state -- stack pointer
192 register StgPtr SpLim; // local state -- stack lim pointer
193 register StgClosure *tagged_obj = 0, *obj;
198 cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
199 // goes to zero we must return to the scheduler.
201 // ------------------------------------------------------------------------
204 // We have a closure to evaluate. Stack looks like:
208 // Sp | -------------------> closure
211 if (Sp[0] == (W_)&stg_enter_info) {
216 // ------------------------------------------------------------------------
219 // We have a BCO application to perform. Stack looks like:
230 else if (Sp[0] == (W_)&stg_apply_interp_info) {
231 obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
236 // ------------------------------------------------------------------------
239 // We have an unboxed value to return. See comment before
240 // do_return_unboxed, below.
243 goto do_return_unboxed;
246 // Evaluate the object on top of the stack.
248 tagged_obj = (StgClosure*)Sp[0]; Sp++;
251 obj = UNTAG_CLOSURE(tagged_obj);
252 INTERP_TICK(it_total_evals);
254 IF_DEBUG(interpreter,
256 "\n---------------------------------------------------------------\n");
257 debugBelch("Evaluating: "); printObj(obj);
258 debugBelch("Sp = %p\n", Sp);
261 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
265 IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
267 switch ( get_itbl(obj)->type ) {
272 case IND_OLDGEN_PERM:
275 tagged_obj = ((StgInd*)obj)->indirectee;
286 case CONSTR_NOCAF_STATIC:
300 ASSERT(((StgBCO *)obj)->arity > 0);
304 case AP: /* Copied from stg_AP_entry. */
313 if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
315 Sp[1] = (W_)tagged_obj;
316 Sp[0] = (W_)&stg_enter_info;
317 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
320 /* Ok; we're safe. Party on. Push an update frame. */
321 Sp -= sizeofW(StgUpdateFrame);
323 StgUpdateFrame *__frame;
324 __frame = (StgUpdateFrame *)Sp;
325 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
326 __frame->updatee = (StgClosure *)(ap);
329 /* Reload the stack */
331 for (i=0; i < words; i++) {
332 Sp[i] = (W_)ap->payload[i];
335 obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
336 ASSERT(get_itbl(obj)->type == BCO);
345 j = get_itbl(obj)->type;
346 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
347 it_unknown_entries[j]++;
348 it_total_unknown_entries++;
352 // Can't handle this object; yield to scheduler
353 IF_DEBUG(interpreter,
354 debugBelch("evaluating unknown closure -- yielding to sched\n");
358 Sp[1] = (W_)tagged_obj;
359 Sp[0] = (W_)&stg_enter_info;
360 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
364 // ------------------------------------------------------------------------
365 // We now have an evaluated object (tagged_obj). The next thing to
366 // do is return it to the stack frame on top of the stack.
368 obj = UNTAG_CLOSURE(tagged_obj);
369 ASSERT(closure_HNF(obj));
371 IF_DEBUG(interpreter,
373 "\n---------------------------------------------------------------\n");
374 debugBelch("Returning: "); printObj(obj);
375 debugBelch("Sp = %p\n", Sp);
377 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
381 IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
383 switch (get_itbl((StgClosure *)Sp)->type) {
386 const StgInfoTable *info;
388 // NOTE: not using get_itbl().
389 info = ((StgClosure *)Sp)->header.info;
390 if (info == (StgInfoTable *)&stg_ap_v_info) {
391 n = 1; m = 0; goto do_apply;
393 if (info == (StgInfoTable *)&stg_ap_f_info) {
394 n = 1; m = 1; goto do_apply;
396 if (info == (StgInfoTable *)&stg_ap_d_info) {
397 n = 1; m = sizeofW(StgDouble); goto do_apply;
399 if (info == (StgInfoTable *)&stg_ap_l_info) {
400 n = 1; m = sizeofW(StgInt64); goto do_apply;
402 if (info == (StgInfoTable *)&stg_ap_n_info) {
403 n = 1; m = 1; goto do_apply;
405 if (info == (StgInfoTable *)&stg_ap_p_info) {
406 n = 1; m = 1; goto do_apply;
408 if (info == (StgInfoTable *)&stg_ap_pp_info) {
409 n = 2; m = 2; goto do_apply;
411 if (info == (StgInfoTable *)&stg_ap_ppp_info) {
412 n = 3; m = 3; goto do_apply;
414 if (info == (StgInfoTable *)&stg_ap_pppp_info) {
415 n = 4; m = 4; goto do_apply;
417 if (info == (StgInfoTable *)&stg_ap_ppppp_info) {
418 n = 5; m = 5; goto do_apply;
420 if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
421 n = 6; m = 6; goto do_apply;
423 goto do_return_unrecognised;
427 // Returning to an update frame: do the update, pop the update
428 // frame, and continue with the next stack frame.
430 // NB. we must update with the *tagged* pointer. Some tags
431 // are not optional, and if we omit the tag bits when updating
432 // then bad things can happen (albeit very rarely). See #1925.
433 // What happened was an indirection was created with an
434 // untagged pointer, and this untagged pointer was propagated
435 // to a PAP by the GC, violating the invariant that PAPs
436 // always contain a tagged pointer to the function.
437 INTERP_TICK(it_retto_UPDATE);
438 UPD_IND(((StgUpdateFrame *)Sp)->updatee, tagged_obj);
439 Sp += sizeofW(StgUpdateFrame);
443 // Returning to an interpreted continuation: put the object on
444 // the stack, and start executing the BCO.
445 INTERP_TICK(it_retto_BCO);
448 // NB. return the untagged object; the bytecode expects it to
449 // be untagged. XXX this doesn't seem right.
450 obj = (StgClosure*)Sp[2];
451 ASSERT(get_itbl(obj)->type == BCO);
455 do_return_unrecognised:
457 // Can't handle this return address; yield to scheduler
458 INTERP_TICK(it_retto_other);
459 IF_DEBUG(interpreter,
460 debugBelch("returning to unknown frame -- yielding to sched\n");
461 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
464 Sp[1] = (W_)tagged_obj;
465 Sp[0] = (W_)&stg_enter_info;
466 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
470 // -------------------------------------------------------------------------
471 // Returning an unboxed value. The stack looks like this:
488 // where XXXX_info is one of the stg_gc_unbx_r1_info family.
490 // We're only interested in the case when the real return address
491 // is a BCO; otherwise we'll return to the scheduler.
497 ASSERT( Sp[0] == (W_)&stg_gc_unbx_r1_info
498 || Sp[0] == (W_)&stg_gc_unpt_r1_info
499 || Sp[0] == (W_)&stg_gc_f1_info
500 || Sp[0] == (W_)&stg_gc_d1_info
501 || Sp[0] == (W_)&stg_gc_l1_info
502 || Sp[0] == (W_)&stg_gc_void_info // VoidRep
505 // get the offset of the stg_ctoi_ret_XXX itbl
506 offset = stack_frame_sizeW((StgClosure *)Sp);
508 switch (get_itbl((StgClosure *)Sp+offset)->type) {
511 // Returning to an interpreted continuation: put the object on
512 // the stack, and start executing the BCO.
513 INTERP_TICK(it_retto_BCO);
514 obj = (StgClosure*)Sp[offset+1];
515 ASSERT(get_itbl(obj)->type == BCO);
516 goto run_BCO_return_unboxed;
520 // Can't handle this return address; yield to scheduler
521 INTERP_TICK(it_retto_other);
522 IF_DEBUG(interpreter,
523 debugBelch("returning to unknown frame -- yielding to sched\n");
524 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
526 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
533 // -------------------------------------------------------------------------
537 ASSERT(obj == UNTAG_CLOSURE(tagged_obj));
538 // we have a function to apply (obj), and n arguments taking up m
539 // words on the stack. The info table (stg_ap_pp_info or whatever)
540 // is on top of the arguments on the stack.
542 switch (get_itbl(obj)->type) {
550 // we only cope with PAPs whose function is a BCO
551 if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) {
552 goto defer_apply_to_sched;
555 // Stack check: we're about to unpack the PAP onto the
556 // stack. The (+1) is for the (arity < n) case, where we
557 // also need space for an extra info pointer.
558 if (Sp - (pap->n_args + 1) < SpLim) {
560 Sp[1] = (W_)tagged_obj;
561 Sp[0] = (W_)&stg_enter_info;
562 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
569 // n must be greater than 1, and the only kinds of
570 // application we support with more than one argument
571 // are all pointers...
573 // Shuffle the args for this function down, and put
574 // the appropriate info table in the gap.
575 for (i = 0; i < arity; i++) {
576 Sp[(int)i-1] = Sp[i];
577 // ^^^^^ careful, i-1 might be negative, but i in unsigned
579 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
581 // unpack the PAP's arguments onto the stack
583 for (i = 0; i < pap->n_args; i++) {
584 Sp[i] = (W_)pap->payload[i];
586 obj = UNTAG_CLOSURE(pap->fun);
589 else if (arity == n) {
591 for (i = 0; i < pap->n_args; i++) {
592 Sp[i] = (W_)pap->payload[i];
594 obj = UNTAG_CLOSURE(pap->fun);
597 else /* arity > n */ {
598 // build a new PAP and return it.
600 new_pap = (StgPAP *)allocateLocal(cap, PAP_sizeW(pap->n_args + m));
601 SET_HDR(new_pap,&stg_PAP_info,CCCS);
602 new_pap->arity = pap->arity - n;
603 new_pap->n_args = pap->n_args + m;
604 new_pap->fun = pap->fun;
605 for (i = 0; i < pap->n_args; i++) {
606 new_pap->payload[i] = pap->payload[i];
608 for (i = 0; i < m; i++) {
609 new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
611 tagged_obj = (StgClosure *)new_pap;
621 arity = ((StgBCO *)obj)->arity;
624 // n must be greater than 1, and the only kinds of
625 // application we support with more than one argument
626 // are all pointers...
628 // Shuffle the args for this function down, and put
629 // the appropriate info table in the gap.
630 for (i = 0; i < arity; i++) {
631 Sp[(int)i-1] = Sp[i];
632 // ^^^^^ careful, i-1 might be negative, but i in unsigned
634 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
638 else if (arity == n) {
641 else /* arity > n */ {
642 // build a PAP and return it.
645 pap = (StgPAP *)allocateLocal(cap, PAP_sizeW(m));
646 SET_HDR(pap, &stg_PAP_info,CCCS);
647 pap->arity = arity - n;
650 for (i = 0; i < m; i++) {
651 pap->payload[i] = (StgClosure *)Sp[i];
653 tagged_obj = (StgClosure *)pap;
659 // No point in us applying machine-code functions
661 defer_apply_to_sched:
663 Sp[1] = (W_)tagged_obj;
664 Sp[0] = (W_)&stg_enter_info;
665 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
668 // ------------------------------------------------------------------------
669 // Ok, we now have a bco (obj), and its arguments are all on the
670 // stack. We can start executing the byte codes.
672 // The stack is in one of two states. First, if this BCO is a
682 // Second, if this BCO is a continuation:
697 // where retval is the value being returned to this continuation.
698 // In the event of a stack check, heap check, or context switch,
699 // we need to leave the stack in a sane state so the garbage
700 // collector can find all the pointers.
702 // (1) BCO is a function: the BCO's bitmap describes the
703 // pointerhood of the arguments.
705 // (2) BCO is a continuation: BCO's bitmap describes the
706 // pointerhood of the free variables.
708 // Sadly we have three different kinds of stack/heap/cswitch check
714 if (doYouWantToGC()) {
715 Sp--; Sp[0] = (W_)&stg_enter_info;
716 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
718 // Stack checks aren't necessary at return points, the stack use
719 // is aggregated into the enclosing function entry point.
723 run_BCO_return_unboxed:
725 if (doYouWantToGC()) {
726 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
728 // Stack checks aren't necessary at return points, the stack use
729 // is aggregated into the enclosing function entry point.
737 Sp[0] = (W_)&stg_apply_interp_info;
738 checkStackChunk(Sp,SpLim);
743 if (doYouWantToGC()) {
746 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
747 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
751 if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
754 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
755 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
760 // Now, actually interpret the BCO... (no returning to the
761 // scheduler again until the stack is in an orderly state).
763 INTERP_TICK(it_BCO_entries);
765 register int bciPtr = 0; /* instruction pointer */
766 register StgWord16 bci;
767 register StgBCO* bco = (StgBCO*)obj;
768 register StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
769 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
770 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
772 bcoSize = BCO_NEXT_WORD;
773 IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
776 it_lastopc = 0; /* no opcode */
780 ASSERT(bciPtr < bcoSize);
781 IF_DEBUG(interpreter,
782 //if (do_print_stack) {
783 //debugBelch("\n-- BEGIN stack\n");
784 //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
785 //debugBelch("-- END stack\n\n");
787 debugBelch("Sp = %p pc = %d ", Sp, bciPtr);
788 disInstr(bco,bciPtr);
791 for (i = 8; i >= 0; i--) {
792 debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i)));
796 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
800 INTERP_TICK(it_insns);
803 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
804 it_ofreq[ (int)instrs[bciPtr] ] ++;
805 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
806 it_lastopc = (int)instrs[bciPtr];
810 /* We use the high 8 bits for flags, only the highest of which is
811 * currently allocated */
812 ASSERT((bci & 0xFF00) == (bci & 0x8000));
814 switch (bci & 0xFF) {
816 /* check for a breakpoint on the beginning of a let binding */
819 int arg1_brk_array, arg2_array_index, arg3_freeVars;
820 StgArrWords *breakPoints;
821 int returning_from_break; // are we resuming execution from a breakpoint?
822 // if yes, then don't break this time around
823 StgClosure *ioAction; // the io action to run at a breakpoint
825 StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap
829 arg1_brk_array = BCO_NEXT; // 1st arg of break instruction
830 arg2_array_index = BCO_NEXT; // 2nd arg of break instruction
831 arg3_freeVars = BCO_NEXT; // 3rd arg of break instruction
833 // check if we are returning from a breakpoint - this info
834 // is stored in the flags field of the current TSO
835 returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
837 // if we are returning from a break then skip this section
838 // and continue executing
839 if (!returning_from_break)
841 breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
843 // stop the current thread if either the
844 // "rts_stop_next_breakpoint" flag is true OR if the
845 // breakpoint flag for this particular expression is
847 if (rts_stop_next_breakpoint == rtsTrue ||
848 breakPoints->payload[arg2_array_index] == rtsTrue)
850 // make sure we don't automatically stop at the
852 rts_stop_next_breakpoint = rtsFalse;
854 // allocate memory for a new AP_STACK, enough to
855 // store the top stack frame plus an
856 // stg_apply_interp_info pointer and a pointer to
858 size_words = BCO_BITMAP_SIZE(obj) + 2;
859 new_aps = (StgAP_STACK *) allocateLocal(cap, AP_STACK_sizeW(size_words));
860 SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
861 new_aps->size = size_words;
862 new_aps->fun = &stg_dummy_ret_closure;
864 // fill in the payload of the AP_STACK
865 new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
866 new_aps->payload[1] = (StgClosure *)obj;
868 // copy the contents of the top stack frame into the AP_STACK
869 for (i = 2; i < size_words; i++)
871 new_aps->payload[i] = (StgClosure *)Sp[i-2];
874 // prepare the stack so that we can call the
875 // rts_breakpoint_io_action and ensure that the stack is
876 // in a reasonable state for the GC and so that
877 // execution of this BCO can continue when we resume
878 ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
881 Sp[7] = (W_)&stg_apply_interp_info;
882 Sp[6] = (W_)&stg_noforceIO_info; // see [unreg] below
883 Sp[5] = (W_)new_aps; // the AP_STACK
884 Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
885 Sp[3] = (W_)False_closure; // True <=> a breakpoint
886 Sp[2] = (W_)&stg_ap_pppv_info;
887 Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
888 Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
889 // Note [unreg]: in unregisterised mode, the return
890 // convention for IO is different. The
891 // stg_noForceIO_info stack frame is necessary to
892 // account for this difference.
894 // set the flag in the TSO to say that we are now
895 // stopping at a breakpoint so that when we resume
896 // we don't stop on the same breakpoint that we
897 // already stopped at just now
898 cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
900 // stop this thread and return to the scheduler -
901 // eventually we will come back and the IO action on
902 // the top of the stack will be executed
903 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
906 // record that this thread is not stopped at a breakpoint anymore
907 cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
909 // continue normal execution of the byte code instructions
914 // Explicit stack check at the beginning of a function
915 // *only* (stack checks in case alternatives are
916 // propagated to the enclosing function).
917 StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
918 if (Sp - stk_words_reqd < SpLim) {
921 Sp[0] = (W_)&stg_apply_interp_info;
922 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
957 Sp[-1] = BCO_PTR(o1);
962 case bci_PUSH_ALTS: {
963 int o_bco = BCO_NEXT;
964 Sp[-2] = (W_)&stg_ctoi_R1p_info;
965 Sp[-1] = BCO_PTR(o_bco);
970 case bci_PUSH_ALTS_P: {
971 int o_bco = BCO_NEXT;
972 Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
973 Sp[-1] = BCO_PTR(o_bco);
978 case bci_PUSH_ALTS_N: {
979 int o_bco = BCO_NEXT;
980 Sp[-2] = (W_)&stg_ctoi_R1n_info;
981 Sp[-1] = BCO_PTR(o_bco);
986 case bci_PUSH_ALTS_F: {
987 int o_bco = BCO_NEXT;
988 Sp[-2] = (W_)&stg_ctoi_F1_info;
989 Sp[-1] = BCO_PTR(o_bco);
994 case bci_PUSH_ALTS_D: {
995 int o_bco = BCO_NEXT;
996 Sp[-2] = (W_)&stg_ctoi_D1_info;
997 Sp[-1] = BCO_PTR(o_bco);
1002 case bci_PUSH_ALTS_L: {
1003 int o_bco = BCO_NEXT;
1004 Sp[-2] = (W_)&stg_ctoi_L1_info;
1005 Sp[-1] = BCO_PTR(o_bco);
1010 case bci_PUSH_ALTS_V: {
1011 int o_bco = BCO_NEXT;
1012 Sp[-2] = (W_)&stg_ctoi_V_info;
1013 Sp[-1] = BCO_PTR(o_bco);
1018 case bci_PUSH_APPLY_N:
1019 Sp--; Sp[0] = (W_)&stg_ap_n_info;
1021 case bci_PUSH_APPLY_V:
1022 Sp--; Sp[0] = (W_)&stg_ap_v_info;
1024 case bci_PUSH_APPLY_F:
1025 Sp--; Sp[0] = (W_)&stg_ap_f_info;
1027 case bci_PUSH_APPLY_D:
1028 Sp--; Sp[0] = (W_)&stg_ap_d_info;
1030 case bci_PUSH_APPLY_L:
1031 Sp--; Sp[0] = (W_)&stg_ap_l_info;
1033 case bci_PUSH_APPLY_P:
1034 Sp--; Sp[0] = (W_)&stg_ap_p_info;
1036 case bci_PUSH_APPLY_PP:
1037 Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1039 case bci_PUSH_APPLY_PPP:
1040 Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1042 case bci_PUSH_APPLY_PPPP:
1043 Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1045 case bci_PUSH_APPLY_PPPPP:
1046 Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1048 case bci_PUSH_APPLY_PPPPPP:
1049 Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1052 case bci_PUSH_UBX: {
1054 int o_lits = BCO_NEXT;
1055 int n_words = BCO_NEXT;
1057 for (i = 0; i < n_words; i++) {
1058 Sp[i] = (W_)BCO_LIT(o_lits+i);
1066 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1071 INTERP_TICK(it_slides);
1075 case bci_ALLOC_AP: {
1077 int n_payload = BCO_NEXT;
1078 ap = (StgAP*)allocateLocal(cap, AP_sizeW(n_payload));
1080 ap->n_args = n_payload;
1081 SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
1086 case bci_ALLOC_AP_NOUPD: {
1088 int n_payload = BCO_NEXT;
1089 ap = (StgAP*)allocateLocal(cap, AP_sizeW(n_payload));
1091 ap->n_args = n_payload;
1092 SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
1097 case bci_ALLOC_PAP: {
1099 int arity = BCO_NEXT;
1100 int n_payload = BCO_NEXT;
1101 pap = (StgPAP*)allocateLocal(cap, PAP_sizeW(n_payload));
1103 pap->n_args = n_payload;
1105 SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
1112 int stkoff = BCO_NEXT;
1113 int n_payload = BCO_NEXT;
1114 StgAP* ap = (StgAP*)Sp[stkoff];
1115 ASSERT((int)ap->n_args == n_payload);
1116 ap->fun = (StgClosure*)Sp[0];
1118 // The function should be a BCO, and its bitmap should
1119 // cover the payload of the AP correctly.
1120 ASSERT(get_itbl(ap->fun)->type == BCO
1121 && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1123 for (i = 0; i < n_payload; i++)
1124 ap->payload[i] = (StgClosure*)Sp[i+1];
1126 IF_DEBUG(interpreter,
1127 debugBelch("\tBuilt ");
1128 printObj((StgClosure*)ap);
1135 int stkoff = BCO_NEXT;
1136 int n_payload = BCO_NEXT;
1137 StgPAP* pap = (StgPAP*)Sp[stkoff];
1138 ASSERT((int)pap->n_args == n_payload);
1139 pap->fun = (StgClosure*)Sp[0];
1141 // The function should be a BCO
1142 ASSERT(get_itbl(pap->fun)->type == BCO);
1144 for (i = 0; i < n_payload; i++)
1145 pap->payload[i] = (StgClosure*)Sp[i+1];
1147 IF_DEBUG(interpreter,
1148 debugBelch("\tBuilt ");
1149 printObj((StgClosure*)pap);
1155 /* Unpack N ptr words from t.o.s constructor */
1157 int n_words = BCO_NEXT;
1158 StgClosure* con = (StgClosure*)Sp[0];
1160 for (i = 0; i < n_words; i++) {
1161 Sp[i] = (W_)con->payload[i];
1168 int o_itbl = BCO_NEXT;
1169 int n_words = BCO_NEXT;
1170 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
1171 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
1172 itbl->layout.payload.nptrs );
1173 StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
1174 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1175 SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
1176 for (i = 0; i < n_words; i++) {
1177 con->payload[i] = (StgClosure*)Sp[i];
1182 IF_DEBUG(interpreter,
1183 debugBelch("\tBuilt ");
1184 printObj((StgClosure*)con);
1189 case bci_TESTLT_P: {
1190 unsigned int discr = BCO_NEXT;
1191 int failto = BCO_GET_LARGE_ARG;
1192 StgClosure* con = (StgClosure*)Sp[0];
1193 if (GET_TAG(con) >= discr) {
1199 case bci_TESTEQ_P: {
1200 unsigned int discr = BCO_NEXT;
1201 int failto = BCO_GET_LARGE_ARG;
1202 StgClosure* con = (StgClosure*)Sp[0];
1203 if (GET_TAG(con) != discr) {
1209 case bci_TESTLT_I: {
1210 // There should be an Int at Sp[1], and an info table at Sp[0].
1211 int discr = BCO_NEXT;
1212 int failto = BCO_GET_LARGE_ARG;
1213 I_ stackInt = (I_)Sp[1];
1214 if (stackInt >= (I_)BCO_LIT(discr))
1219 case bci_TESTEQ_I: {
1220 // There should be an Int at Sp[1], and an info table at Sp[0].
1221 int discr = BCO_NEXT;
1222 int failto = BCO_GET_LARGE_ARG;
1223 I_ stackInt = (I_)Sp[1];
1224 if (stackInt != (I_)BCO_LIT(discr)) {
1230 case bci_TESTLT_W: {
1231 // There should be an Int at Sp[1], and an info table at Sp[0].
1232 int discr = BCO_NEXT;
1233 int failto = BCO_GET_LARGE_ARG;
1234 W_ stackWord = (W_)Sp[1];
1235 if (stackWord >= (W_)BCO_LIT(discr))
1240 case bci_TESTEQ_W: {
1241 // There should be an Int at Sp[1], and an info table at Sp[0].
1242 int discr = BCO_NEXT;
1243 int failto = BCO_GET_LARGE_ARG;
1244 W_ stackWord = (W_)Sp[1];
1245 if (stackWord != (W_)BCO_LIT(discr)) {
1251 case bci_TESTLT_D: {
1252 // There should be a Double at Sp[1], and an info table at Sp[0].
1253 int discr = BCO_NEXT;
1254 int failto = BCO_GET_LARGE_ARG;
1255 StgDouble stackDbl, discrDbl;
1256 stackDbl = PK_DBL( & Sp[1] );
1257 discrDbl = PK_DBL( & BCO_LIT(discr) );
1258 if (stackDbl >= discrDbl) {
1264 case bci_TESTEQ_D: {
1265 // There should be a Double at Sp[1], and an info table at Sp[0].
1266 int discr = BCO_NEXT;
1267 int failto = BCO_GET_LARGE_ARG;
1268 StgDouble stackDbl, discrDbl;
1269 stackDbl = PK_DBL( & Sp[1] );
1270 discrDbl = PK_DBL( & BCO_LIT(discr) );
1271 if (stackDbl != discrDbl) {
1277 case bci_TESTLT_F: {
1278 // There should be a Float at Sp[1], and an info table at Sp[0].
1279 int discr = BCO_NEXT;
1280 int failto = BCO_GET_LARGE_ARG;
1281 StgFloat stackFlt, discrFlt;
1282 stackFlt = PK_FLT( & Sp[1] );
1283 discrFlt = PK_FLT( & BCO_LIT(discr) );
1284 if (stackFlt >= discrFlt) {
1290 case bci_TESTEQ_F: {
1291 // There should be a Float at Sp[1], and an info table at Sp[0].
1292 int discr = BCO_NEXT;
1293 int failto = BCO_GET_LARGE_ARG;
1294 StgFloat stackFlt, discrFlt;
1295 stackFlt = PK_FLT( & Sp[1] );
1296 discrFlt = PK_FLT( & BCO_LIT(discr) );
1297 if (stackFlt != discrFlt) {
1303 // Control-flow ish things
1305 // Context-switch check. We put it here to ensure that
1306 // the interpreter has done at least *some* work before
1307 // context switching: sometimes the scheduler can invoke
1308 // the interpreter with context_switch == 1, particularly
1309 // if the -C0 flag has been given on the cmd line.
1310 if (cap->r.rHpLim == NULL) {
1311 Sp--; Sp[0] = (W_)&stg_enter_info;
1312 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1317 tagged_obj = (StgClosure *)Sp[0];
1323 Sp[0] = (W_)&stg_gc_unpt_r1_info;
1324 goto do_return_unboxed;
1327 Sp[0] = (W_)&stg_gc_unbx_r1_info;
1328 goto do_return_unboxed;
1331 Sp[0] = (W_)&stg_gc_f1_info;
1332 goto do_return_unboxed;
1335 Sp[0] = (W_)&stg_gc_d1_info;
1336 goto do_return_unboxed;
1339 Sp[0] = (W_)&stg_gc_l1_info;
1340 goto do_return_unboxed;
1343 Sp[0] = (W_)&stg_gc_void_info;
1344 goto do_return_unboxed;
1347 int stkoff = BCO_NEXT;
1348 signed short n = (signed short)(BCO_NEXT);
1349 Sp[stkoff] += (W_)n;
1355 int stk_offset = BCO_NEXT;
1356 int o_itbl = BCO_NEXT;
1357 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1359 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1360 + sizeofW(StgRetDyn);
1362 /* the stack looks like this:
1364 | | <- Sp + stk_offset
1368 | | <- Sp + ret_size + 1
1370 | C fun | <- Sp + ret_size
1375 ret is a placeholder for the return address, and may be
1378 We need to copy the args out of the TSO, because when
1379 we call suspendThread() we no longer own the TSO stack,
1380 and it may move at any time - indeed suspendThread()
1381 itself may do stack squeezing and move our args.
1382 So we make a copy of the argument block.
1385 #define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1387 ffi_cif *cif = (ffi_cif *)marshall_fn;
1388 nat nargs = cif->nargs;
1392 W_ ret[2]; // max needed
1393 W_ *arguments[stk_offset]; // max needed
1394 void *argptrs[nargs];
1397 if (cif->rtype->type == FFI_TYPE_VOID) {
1398 // necessary because cif->rtype->size == 1 for void,
1399 // but the bytecode generator has not pushed a
1400 // placeholder in this case.
1403 ret_size = ROUND_UP_WDS(cif->rtype->size);
1406 memcpy(arguments, Sp+ret_size+1,
1407 sizeof(W_) * (stk_offset-1-ret_size));
1409 // libffi expects the args as an array of pointers to
1410 // values, so we have to construct this array before making
1412 p = (StgPtr)arguments;
1413 for (i = 0; i < nargs; i++) {
1414 argptrs[i] = (void *)p;
1415 // get the size from the cif
1416 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1419 // this is the function we're going to call
1420 fn = (void(*)(void))Sp[ret_size];
1422 // Restore the Haskell thread's current value of errno
1423 errno = cap->r.rCurrentTSO->saved_errno;
1425 // There are a bunch of non-ptr words on the stack (the
1426 // ccall args, the ccall fun address and space for the
1427 // result), which we need to cover with an info table
1428 // since we might GC during this call.
1430 // We know how many (non-ptr) words there are before the
1431 // next valid stack frame: it is the stk_offset arg to the
1432 // CCALL instruction. So we build a RET_DYN stack frame
1433 // on the stack frame to describe this chunk of stack.
1436 ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset);
1437 ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1439 // save obj (pointer to the current BCO), since this
1440 // might move during the call. We use the R1 slot in the
1441 // RET_DYN frame for this, hence R1_PTR above.
1442 ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
1444 SAVE_STACK_POINTERS;
1445 tok = suspendThread(&cap->r);
1447 // We already made a copy of the arguments above.
1448 ffi_call(cif, fn, ret, argptrs);
1450 // And restart the thread again, popping the RET_DYN frame.
1451 cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
1452 LOAD_STACK_POINTERS;
1454 // Re-load the pointer to the BCO from the RET_DYN frame,
1455 // it might have moved during the call. Also reload the
1456 // pointers to the components of the BCO.
1457 obj = ((StgRetDyn *)Sp)->payload[0];
1459 instrs = (StgWord16*)(bco->instrs->payload);
1460 literals = (StgWord*)(&bco->literals->payload[0]);
1461 ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
1465 // Save the Haskell thread's current value of errno
1466 cap->r.rCurrentTSO->saved_errno = errno;
1468 // Copy the return value back to the TSO stack. It is at
1469 // most 2 words large, and resides at arguments[0].
1470 memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1476 /* BCO_NEXT modifies bciPtr, so be conservative. */
1477 int nextpc = BCO_GET_LARGE_ARG;
1483 barf("interpretBCO: hit a CASEFAIL");
1487 barf("interpretBCO: unknown or unimplemented opcode %d",
1490 } /* switch on opcode */
1494 barf("interpretBCO: fell off end of the interpreter");