1 /* -----------------------------------------------------------------------------
4 * Copyright (c) The GHC Team, 1994-2002.
5 * ---------------------------------------------------------------------------*/
7 #include "PosixSource.h"
10 #include "rts/Bytecodes.h"
13 #include "sm/Storage.h"
14 #include "sm/Sanity.h"
21 #include "Disassembler.h"
22 #include "Interpreter.h"
23 #include "ThreadPaused.h"
26 #include <string.h> /* for memcpy */
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
34 #if defined(mingw32_HOST_OS) && !defined(__PIC__)
35 # define LIBFFI_NOT_DLL
40 /* --------------------------------------------------------------------------
41 * The bytecode interpreter
42 * ------------------------------------------------------------------------*/
44 /* Gather stats about entry, opcode, opcode-pair frequencies. For
45 tuning the interpreter. */
47 /* #define INTERP_STATS */
50 /* Sp points to the lowest live word on the stack. */
52 #define BCO_NEXT instrs[bciPtr++]
53 #define BCO_NEXT_32 (bciPtr += 2, (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1]))
54 #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]))
55 #if WORD_SIZE_IN_BITS == 32
56 #define BCO_NEXT_WORD BCO_NEXT_32
57 #elif WORD_SIZE_IN_BITS == 64
58 #define BCO_NEXT_WORD BCO_NEXT_64
60 #error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64
62 #define BCO_GET_LARGE_ARG ((bci & bci_FLAG_LARGE_ARGS) ? BCO_NEXT_WORD : BCO_NEXT)
64 #define BCO_PTR(n) (W_)ptrs[n]
65 #define BCO_LIT(n) literals[n]
67 #define LOAD_STACK_POINTERS \
68 Sp = cap->r.rCurrentTSO->stackobj->sp; \
69 /* We don't change this ... */ \
70 SpLim = tso_SpLim(cap->r.rCurrentTSO);
72 #define SAVE_STACK_POINTERS \
74 cap->r.rCurrentTSO->stackobj->sp = Sp
76 #define RETURN_TO_SCHEDULER(todo,retcode) \
77 SAVE_STACK_POINTERS; \
78 cap->r.rCurrentTSO->what_next = (todo); \
79 threadPaused(cap,cap->r.rCurrentTSO); \
80 cap->r.rRet = (retcode); \
83 #define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode) \
84 SAVE_STACK_POINTERS; \
85 cap->r.rCurrentTSO->what_next = (todo); \
86 cap->r.rRet = (retcode); \
91 allocate_NONUPD (Capability *cap, int n_words)
93 return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
96 int rts_stop_next_breakpoint = 0;
97 int rts_stop_on_exception = 0;
101 /* Hacky stats, for tuning the interpreter ... */
102 int it_unknown_entries[N_CLOSURE_TYPES];
103 int it_total_unknown_entries;
104 int it_total_entries;
115 int it_oofreq[27][27];
119 #define INTERP_TICK(n) (n)++
121 void interp_startup ( void )
124 it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
125 it_total_entries = it_total_unknown_entries = 0;
126 for (i = 0; i < N_CLOSURE_TYPES; i++)
127 it_unknown_entries[i] = 0;
128 it_slides = it_insns = it_BCO_entries = 0;
129 for (i = 0; i < 27; i++) it_ofreq[i] = 0;
130 for (i = 0; i < 27; i++)
131 for (j = 0; j < 27; j++)
136 void interp_shutdown ( void )
138 int i, j, k, o_max, i_max, j_max;
139 debugBelch("%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
140 it_retto_BCO + it_retto_UPDATE + it_retto_other,
141 it_retto_BCO, it_retto_UPDATE, it_retto_other );
142 debugBelch("%d total entries, %d unknown entries \n",
143 it_total_entries, it_total_unknown_entries);
144 for (i = 0; i < N_CLOSURE_TYPES; i++) {
145 if (it_unknown_entries[i] == 0) continue;
146 debugBelch(" type %2d: unknown entries (%4.1f%%) == %d\n",
147 i, 100.0 * ((double)it_unknown_entries[i]) /
148 ((double)it_total_unknown_entries),
149 it_unknown_entries[i]);
151 debugBelch("%d insns, %d slides, %d BCO_entries\n",
152 it_insns, it_slides, it_BCO_entries);
153 for (i = 0; i < 27; i++)
154 debugBelch("opcode %2d got %d\n", i, it_ofreq[i] );
156 for (k = 1; k < 20; k++) {
159 for (i = 0; i < 27; i++) {
160 for (j = 0; j < 27; j++) {
161 if (it_oofreq[i][j] > o_max) {
162 o_max = it_oofreq[i][j];
163 i_max = i; j_max = j;
168 debugBelch("%d: count (%4.1f%%) %6d is %d then %d\n",
169 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
171 it_oofreq[i_max][j_max] = 0;
176 #else // !INTERP_STATS
178 #define INTERP_TICK(n) /* nothing */
182 static StgWord app_ptrs_itbl[] = {
185 (W_)&stg_ap_ppp_info,
186 (W_)&stg_ap_pppp_info,
187 (W_)&stg_ap_ppppp_info,
188 (W_)&stg_ap_pppppp_info,
191 HsStablePtr rts_breakpoint_io_action; // points to the IO action which is executed on a breakpoint
192 // it is set in main/GHC.hs:runStmt
195 interpretBCO (Capability* cap)
197 // Use of register here is primarily to make it clear to compilers
198 // that these entities are non-aliasable.
199 register StgPtr Sp; // local state -- stack pointer
200 register StgPtr SpLim; // local state -- stack lim pointer
201 register StgClosure *tagged_obj = 0, *obj;
206 cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
207 // goes to zero we must return to the scheduler.
209 // ------------------------------------------------------------------------
212 // We have a closure to evaluate. Stack looks like:
216 // Sp | -------------------> closure
219 if (Sp[0] == (W_)&stg_enter_info) {
224 // ------------------------------------------------------------------------
227 // We have a BCO application to perform. Stack looks like:
238 else if (Sp[0] == (W_)&stg_apply_interp_info) {
239 obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
244 // ------------------------------------------------------------------------
247 // We have an unboxed value to return. See comment before
248 // do_return_unboxed, below.
251 goto do_return_unboxed;
254 // Evaluate the object on top of the stack.
256 tagged_obj = (StgClosure*)Sp[0]; Sp++;
259 obj = UNTAG_CLOSURE(tagged_obj);
260 INTERP_TICK(it_total_evals);
262 IF_DEBUG(interpreter,
264 "\n---------------------------------------------------------------\n");
265 debugBelch("Evaluating: "); printObj(obj);
266 debugBelch("Sp = %p\n", Sp);
269 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
273 // IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
274 IF_DEBUG(sanity,checkStackFrame(Sp));
276 switch ( get_itbl(obj)->type ) {
282 tagged_obj = ((StgInd*)obj)->indirectee;
293 case CONSTR_NOCAF_STATIC:
307 ASSERT(((StgBCO *)obj)->arity > 0);
311 case AP: /* Copied from stg_AP_entry. */
320 if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
322 Sp[1] = (W_)tagged_obj;
323 Sp[0] = (W_)&stg_enter_info;
324 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
327 /* Ok; we're safe. Party on. Push an update frame. */
328 Sp -= sizeofW(StgUpdateFrame);
330 StgUpdateFrame *__frame;
331 __frame = (StgUpdateFrame *)Sp;
332 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
333 __frame->updatee = (StgClosure *)(ap);
336 /* Reload the stack */
338 for (i=0; i < words; i++) {
339 Sp[i] = (W_)ap->payload[i];
342 obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
343 ASSERT(get_itbl(obj)->type == BCO);
352 j = get_itbl(obj)->type;
353 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
354 it_unknown_entries[j]++;
355 it_total_unknown_entries++;
359 // Can't handle this object; yield to scheduler
360 IF_DEBUG(interpreter,
361 debugBelch("evaluating unknown closure -- yielding to sched\n");
365 Sp[1] = (W_)tagged_obj;
366 Sp[0] = (W_)&stg_enter_info;
367 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
371 // ------------------------------------------------------------------------
372 // We now have an evaluated object (tagged_obj). The next thing to
373 // do is return it to the stack frame on top of the stack.
375 obj = UNTAG_CLOSURE(tagged_obj);
376 ASSERT(closure_HNF(obj));
378 IF_DEBUG(interpreter,
380 "\n---------------------------------------------------------------\n");
381 debugBelch("Returning: "); printObj(obj);
382 debugBelch("Sp = %p\n", Sp);
384 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
388 IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size));
390 switch (get_itbl((StgClosure *)Sp)->type) {
393 const StgInfoTable *info;
395 // NOTE: not using get_itbl().
396 info = ((StgClosure *)Sp)->header.info;
397 if (info == (StgInfoTable *)&stg_ap_v_info) {
398 n = 1; m = 0; goto do_apply;
400 if (info == (StgInfoTable *)&stg_ap_f_info) {
401 n = 1; m = 1; goto do_apply;
403 if (info == (StgInfoTable *)&stg_ap_d_info) {
404 n = 1; m = sizeofW(StgDouble); goto do_apply;
406 if (info == (StgInfoTable *)&stg_ap_l_info) {
407 n = 1; m = sizeofW(StgInt64); goto do_apply;
409 if (info == (StgInfoTable *)&stg_ap_n_info) {
410 n = 1; m = 1; goto do_apply;
412 if (info == (StgInfoTable *)&stg_ap_p_info) {
413 n = 1; m = 1; goto do_apply;
415 if (info == (StgInfoTable *)&stg_ap_pp_info) {
416 n = 2; m = 2; goto do_apply;
418 if (info == (StgInfoTable *)&stg_ap_ppp_info) {
419 n = 3; m = 3; goto do_apply;
421 if (info == (StgInfoTable *)&stg_ap_pppp_info) {
422 n = 4; m = 4; goto do_apply;
424 if (info == (StgInfoTable *)&stg_ap_ppppp_info) {
425 n = 5; m = 5; goto do_apply;
427 if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
428 n = 6; m = 6; goto do_apply;
430 goto do_return_unrecognised;
434 // Returning to an update frame: do the update, pop the update
435 // frame, and continue with the next stack frame.
437 // NB. we must update with the *tagged* pointer. Some tags
438 // are not optional, and if we omit the tag bits when updating
439 // then bad things can happen (albeit very rarely). See #1925.
440 // What happened was an indirection was created with an
441 // untagged pointer, and this untagged pointer was propagated
442 // to a PAP by the GC, violating the invariant that PAPs
443 // always contain a tagged pointer to the function.
444 INTERP_TICK(it_retto_UPDATE);
445 updateThunk(cap, cap->r.rCurrentTSO,
446 ((StgUpdateFrame *)Sp)->updatee, tagged_obj);
447 Sp += sizeofW(StgUpdateFrame);
451 // Returning to an interpreted continuation: put the object on
452 // the stack, and start executing the BCO.
453 INTERP_TICK(it_retto_BCO);
456 // NB. return the untagged object; the bytecode expects it to
457 // be untagged. XXX this doesn't seem right.
458 obj = (StgClosure*)Sp[2];
459 ASSERT(get_itbl(obj)->type == BCO);
463 do_return_unrecognised:
465 // Can't handle this return address; yield to scheduler
466 INTERP_TICK(it_retto_other);
467 IF_DEBUG(interpreter,
468 debugBelch("returning to unknown frame -- yielding to sched\n");
469 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
472 Sp[1] = (W_)tagged_obj;
473 Sp[0] = (W_)&stg_enter_info;
474 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
478 // -------------------------------------------------------------------------
479 // Returning an unboxed value. The stack looks like this:
496 // where XXXX_info is one of the stg_gc_unbx_r1_info family.
498 // We're only interested in the case when the real return address
499 // is a BCO; otherwise we'll return to the scheduler.
505 ASSERT( Sp[0] == (W_)&stg_gc_unbx_r1_info
506 || Sp[0] == (W_)&stg_gc_unpt_r1_info
507 || Sp[0] == (W_)&stg_gc_f1_info
508 || Sp[0] == (W_)&stg_gc_d1_info
509 || Sp[0] == (W_)&stg_gc_l1_info
510 || Sp[0] == (W_)&stg_gc_void_info // VoidRep
513 // get the offset of the stg_ctoi_ret_XXX itbl
514 offset = stack_frame_sizeW((StgClosure *)Sp);
516 switch (get_itbl((StgClosure *)Sp+offset)->type) {
519 // Returning to an interpreted continuation: put the object on
520 // the stack, and start executing the BCO.
521 INTERP_TICK(it_retto_BCO);
522 obj = (StgClosure*)Sp[offset+1];
523 ASSERT(get_itbl(obj)->type == BCO);
524 goto run_BCO_return_unboxed;
528 // Can't handle this return address; yield to scheduler
529 INTERP_TICK(it_retto_other);
530 IF_DEBUG(interpreter,
531 debugBelch("returning to unknown frame -- yielding to sched\n");
532 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
534 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
541 // -------------------------------------------------------------------------
545 ASSERT(obj == UNTAG_CLOSURE(tagged_obj));
546 // we have a function to apply (obj), and n arguments taking up m
547 // words on the stack. The info table (stg_ap_pp_info or whatever)
548 // is on top of the arguments on the stack.
550 switch (get_itbl(obj)->type) {
558 // we only cope with PAPs whose function is a BCO
559 if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) {
560 goto defer_apply_to_sched;
563 // Stack check: we're about to unpack the PAP onto the
564 // stack. The (+1) is for the (arity < n) case, where we
565 // also need space for an extra info pointer.
566 if (Sp - (pap->n_args + 1) < SpLim) {
568 Sp[1] = (W_)tagged_obj;
569 Sp[0] = (W_)&stg_enter_info;
570 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
577 // n must be greater than 1, and the only kinds of
578 // application we support with more than one argument
579 // are all pointers...
581 // Shuffle the args for this function down, and put
582 // the appropriate info table in the gap.
583 for (i = 0; i < arity; i++) {
584 Sp[(int)i-1] = Sp[i];
585 // ^^^^^ careful, i-1 might be negative, but i in unsigned
587 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
589 // unpack the PAP's arguments onto the stack
591 for (i = 0; i < pap->n_args; i++) {
592 Sp[i] = (W_)pap->payload[i];
594 obj = UNTAG_CLOSURE(pap->fun);
597 else if (arity == n) {
599 for (i = 0; i < pap->n_args; i++) {
600 Sp[i] = (W_)pap->payload[i];
602 obj = UNTAG_CLOSURE(pap->fun);
605 else /* arity > n */ {
606 // build a new PAP and return it.
608 new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m));
609 SET_HDR(new_pap,&stg_PAP_info,CCCS);
610 new_pap->arity = pap->arity - n;
611 new_pap->n_args = pap->n_args + m;
612 new_pap->fun = pap->fun;
613 for (i = 0; i < pap->n_args; i++) {
614 new_pap->payload[i] = pap->payload[i];
616 for (i = 0; i < m; i++) {
617 new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
619 tagged_obj = (StgClosure *)new_pap;
629 arity = ((StgBCO *)obj)->arity;
632 // n must be greater than 1, and the only kinds of
633 // application we support with more than one argument
634 // are all pointers...
636 // Shuffle the args for this function down, and put
637 // the appropriate info table in the gap.
638 for (i = 0; i < arity; i++) {
639 Sp[(int)i-1] = Sp[i];
640 // ^^^^^ careful, i-1 might be negative, but i in unsigned
642 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
646 else if (arity == n) {
649 else /* arity > n */ {
650 // build a PAP and return it.
653 pap = (StgPAP *)allocate(cap, PAP_sizeW(m));
654 SET_HDR(pap, &stg_PAP_info,CCCS);
655 pap->arity = arity - n;
658 for (i = 0; i < m; i++) {
659 pap->payload[i] = (StgClosure *)Sp[i];
661 tagged_obj = (StgClosure *)pap;
667 // No point in us applying machine-code functions
669 defer_apply_to_sched:
671 Sp[1] = (W_)tagged_obj;
672 Sp[0] = (W_)&stg_enter_info;
673 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
676 // ------------------------------------------------------------------------
677 // Ok, we now have a bco (obj), and its arguments are all on the
678 // stack. We can start executing the byte codes.
680 // The stack is in one of two states. First, if this BCO is a
690 // Second, if this BCO is a continuation:
705 // where retval is the value being returned to this continuation.
706 // In the event of a stack check, heap check, or context switch,
707 // we need to leave the stack in a sane state so the garbage
708 // collector can find all the pointers.
710 // (1) BCO is a function: the BCO's bitmap describes the
711 // pointerhood of the arguments.
713 // (2) BCO is a continuation: BCO's bitmap describes the
714 // pointerhood of the free variables.
716 // Sadly we have three different kinds of stack/heap/cswitch check
722 if (doYouWantToGC(cap)) {
723 Sp--; Sp[0] = (W_)&stg_enter_info;
724 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
726 // Stack checks aren't necessary at return points, the stack use
727 // is aggregated into the enclosing function entry point.
731 run_BCO_return_unboxed:
733 if (doYouWantToGC(cap)) {
734 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
736 // Stack checks aren't necessary at return points, the stack use
737 // is aggregated into the enclosing function entry point.
745 Sp[0] = (W_)&stg_apply_interp_info;
746 checkStackChunk(Sp,SpLim);
751 if (doYouWantToGC(cap)) {
754 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
755 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
759 if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
762 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
763 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
768 // Now, actually interpret the BCO... (no returning to the
769 // scheduler again until the stack is in an orderly state).
771 INTERP_TICK(it_BCO_entries);
773 register int bciPtr = 0; /* instruction pointer */
774 register StgWord16 bci;
775 register StgBCO* bco = (StgBCO*)obj;
776 register StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
777 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
778 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
780 bcoSize = BCO_NEXT_WORD;
781 IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
784 it_lastopc = 0; /* no opcode */
788 ASSERT(bciPtr < bcoSize);
789 IF_DEBUG(interpreter,
790 //if (do_print_stack) {
791 //debugBelch("\n-- BEGIN stack\n");
792 //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
793 //debugBelch("-- END stack\n\n");
795 debugBelch("Sp = %p pc = %d ", Sp, bciPtr);
796 disInstr(bco,bciPtr);
799 for (i = 8; i >= 0; i--) {
800 debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i)));
804 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
808 INTERP_TICK(it_insns);
811 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
812 it_ofreq[ (int)instrs[bciPtr] ] ++;
813 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
814 it_lastopc = (int)instrs[bciPtr];
818 /* We use the high 8 bits for flags, only the highest of which is
819 * currently allocated */
820 ASSERT((bci & 0xFF00) == (bci & 0x8000));
822 switch (bci & 0xFF) {
824 /* check for a breakpoint on the beginning of a let binding */
827 int arg1_brk_array, arg2_array_index, arg3_freeVars;
828 StgArrWords *breakPoints;
829 int returning_from_break; // are we resuming execution from a breakpoint?
830 // if yes, then don't break this time around
831 StgClosure *ioAction; // the io action to run at a breakpoint
833 StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap
837 arg1_brk_array = BCO_NEXT; // 1st arg of break instruction
838 arg2_array_index = BCO_NEXT; // 2nd arg of break instruction
839 arg3_freeVars = BCO_NEXT; // 3rd arg of break instruction
841 // check if we are returning from a breakpoint - this info
842 // is stored in the flags field of the current TSO
843 returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
845 // if we are returning from a break then skip this section
846 // and continue executing
847 if (!returning_from_break)
849 breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
851 // stop the current thread if either the
852 // "rts_stop_next_breakpoint" flag is true OR if the
853 // breakpoint flag for this particular expression is
855 if (rts_stop_next_breakpoint == rtsTrue ||
856 breakPoints->payload[arg2_array_index] == rtsTrue)
858 // make sure we don't automatically stop at the
860 rts_stop_next_breakpoint = rtsFalse;
862 // allocate memory for a new AP_STACK, enough to
863 // store the top stack frame plus an
864 // stg_apply_interp_info pointer and a pointer to
866 size_words = BCO_BITMAP_SIZE(obj) + 2;
867 new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
868 SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
869 new_aps->size = size_words;
870 new_aps->fun = &stg_dummy_ret_closure;
872 // fill in the payload of the AP_STACK
873 new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
874 new_aps->payload[1] = (StgClosure *)obj;
876 // copy the contents of the top stack frame into the AP_STACK
877 for (i = 2; i < size_words; i++)
879 new_aps->payload[i] = (StgClosure *)Sp[i-2];
882 // prepare the stack so that we can call the
883 // rts_breakpoint_io_action and ensure that the stack is
884 // in a reasonable state for the GC and so that
885 // execution of this BCO can continue when we resume
886 ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
889 Sp[6] = (W_)&stg_apply_interp_info;
890 Sp[5] = (W_)new_aps; // the AP_STACK
891 Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
892 Sp[3] = (W_)False_closure; // True <=> a breakpoint
893 Sp[2] = (W_)&stg_ap_pppv_info;
894 Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
895 Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
896 // set the flag in the TSO to say that we are now
897 // stopping at a breakpoint so that when we resume
898 // we don't stop on the same breakpoint that we
899 // already stopped at just now
900 cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
902 // stop this thread and return to the scheduler -
903 // eventually we will come back and the IO action on
904 // the top of the stack will be executed
905 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
908 // record that this thread is not stopped at a breakpoint anymore
909 cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
911 // continue normal execution of the byte code instructions
916 // Explicit stack check at the beginning of a function
917 // *only* (stack checks in case alternatives are
918 // propagated to the enclosing function).
919 StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
920 if (Sp - stk_words_reqd < SpLim) {
923 Sp[0] = (W_)&stg_apply_interp_info;
924 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
959 Sp[-1] = BCO_PTR(o1);
964 case bci_PUSH_ALTS: {
965 int o_bco = BCO_NEXT;
966 Sp[-2] = (W_)&stg_ctoi_R1p_info;
967 Sp[-1] = BCO_PTR(o_bco);
972 case bci_PUSH_ALTS_P: {
973 int o_bco = BCO_NEXT;
974 Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
975 Sp[-1] = BCO_PTR(o_bco);
980 case bci_PUSH_ALTS_N: {
981 int o_bco = BCO_NEXT;
982 Sp[-2] = (W_)&stg_ctoi_R1n_info;
983 Sp[-1] = BCO_PTR(o_bco);
988 case bci_PUSH_ALTS_F: {
989 int o_bco = BCO_NEXT;
990 Sp[-2] = (W_)&stg_ctoi_F1_info;
991 Sp[-1] = BCO_PTR(o_bco);
996 case bci_PUSH_ALTS_D: {
997 int o_bco = BCO_NEXT;
998 Sp[-2] = (W_)&stg_ctoi_D1_info;
999 Sp[-1] = BCO_PTR(o_bco);
1004 case bci_PUSH_ALTS_L: {
1005 int o_bco = BCO_NEXT;
1006 Sp[-2] = (W_)&stg_ctoi_L1_info;
1007 Sp[-1] = BCO_PTR(o_bco);
1012 case bci_PUSH_ALTS_V: {
1013 int o_bco = BCO_NEXT;
1014 Sp[-2] = (W_)&stg_ctoi_V_info;
1015 Sp[-1] = BCO_PTR(o_bco);
1020 case bci_PUSH_APPLY_N:
1021 Sp--; Sp[0] = (W_)&stg_ap_n_info;
1023 case bci_PUSH_APPLY_V:
1024 Sp--; Sp[0] = (W_)&stg_ap_v_info;
1026 case bci_PUSH_APPLY_F:
1027 Sp--; Sp[0] = (W_)&stg_ap_f_info;
1029 case bci_PUSH_APPLY_D:
1030 Sp--; Sp[0] = (W_)&stg_ap_d_info;
1032 case bci_PUSH_APPLY_L:
1033 Sp--; Sp[0] = (W_)&stg_ap_l_info;
1035 case bci_PUSH_APPLY_P:
1036 Sp--; Sp[0] = (W_)&stg_ap_p_info;
1038 case bci_PUSH_APPLY_PP:
1039 Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1041 case bci_PUSH_APPLY_PPP:
1042 Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1044 case bci_PUSH_APPLY_PPPP:
1045 Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1047 case bci_PUSH_APPLY_PPPPP:
1048 Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1050 case bci_PUSH_APPLY_PPPPPP:
1051 Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1054 case bci_PUSH_UBX: {
1056 int o_lits = BCO_NEXT;
1057 int n_words = BCO_NEXT;
1059 for (i = 0; i < n_words; i++) {
1060 Sp[i] = (W_)BCO_LIT(o_lits+i);
1068 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1073 INTERP_TICK(it_slides);
1077 case bci_ALLOC_AP: {
1079 int n_payload = BCO_NEXT;
1080 ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1082 ap->n_args = n_payload;
1083 SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
1088 case bci_ALLOC_AP_NOUPD: {
1090 int n_payload = BCO_NEXT;
1091 ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1093 ap->n_args = n_payload;
1094 SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
1099 case bci_ALLOC_PAP: {
1101 int arity = BCO_NEXT;
1102 int n_payload = BCO_NEXT;
1103 pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload));
1105 pap->n_args = n_payload;
1107 SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
1114 int stkoff = BCO_NEXT;
1115 int n_payload = BCO_NEXT;
1116 StgAP* ap = (StgAP*)Sp[stkoff];
1117 ASSERT((int)ap->n_args == n_payload);
1118 ap->fun = (StgClosure*)Sp[0];
1120 // The function should be a BCO, and its bitmap should
1121 // cover the payload of the AP correctly.
1122 ASSERT(get_itbl(ap->fun)->type == BCO
1123 && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1125 for (i = 0; i < n_payload; i++)
1126 ap->payload[i] = (StgClosure*)Sp[i+1];
1128 IF_DEBUG(interpreter,
1129 debugBelch("\tBuilt ");
1130 printObj((StgClosure*)ap);
1137 int stkoff = BCO_NEXT;
1138 int n_payload = BCO_NEXT;
1139 StgPAP* pap = (StgPAP*)Sp[stkoff];
1140 ASSERT((int)pap->n_args == n_payload);
1141 pap->fun = (StgClosure*)Sp[0];
1143 // The function should be a BCO
1144 ASSERT(get_itbl(pap->fun)->type == BCO);
1146 for (i = 0; i < n_payload; i++)
1147 pap->payload[i] = (StgClosure*)Sp[i+1];
1149 IF_DEBUG(interpreter,
1150 debugBelch("\tBuilt ");
1151 printObj((StgClosure*)pap);
1157 /* Unpack N ptr words from t.o.s constructor */
1159 int n_words = BCO_NEXT;
1160 StgClosure* con = (StgClosure*)Sp[0];
1162 for (i = 0; i < n_words; i++) {
1163 Sp[i] = (W_)con->payload[i];
1170 int o_itbl = BCO_NEXT;
1171 int n_words = BCO_NEXT;
1172 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
1173 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
1174 itbl->layout.payload.nptrs );
1175 StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
1176 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1177 SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
1178 for (i = 0; i < n_words; i++) {
1179 con->payload[i] = (StgClosure*)Sp[i];
1184 IF_DEBUG(interpreter,
1185 debugBelch("\tBuilt ");
1186 printObj((StgClosure*)con);
1191 case bci_TESTLT_P: {
1192 unsigned int discr = BCO_NEXT;
1193 int failto = BCO_GET_LARGE_ARG;
1194 StgClosure* con = (StgClosure*)Sp[0];
1195 if (GET_TAG(con) >= discr) {
1201 case bci_TESTEQ_P: {
1202 unsigned int discr = BCO_NEXT;
1203 int failto = BCO_GET_LARGE_ARG;
1204 StgClosure* con = (StgClosure*)Sp[0];
1205 if (GET_TAG(con) != discr) {
1211 case bci_TESTLT_I: {
1212 // There should be an Int at Sp[1], and an info table at Sp[0].
1213 int discr = BCO_NEXT;
1214 int failto = BCO_GET_LARGE_ARG;
1215 I_ stackInt = (I_)Sp[1];
1216 if (stackInt >= (I_)BCO_LIT(discr))
1221 case bci_TESTEQ_I: {
1222 // There should be an Int at Sp[1], and an info table at Sp[0].
1223 int discr = BCO_NEXT;
1224 int failto = BCO_GET_LARGE_ARG;
1225 I_ stackInt = (I_)Sp[1];
1226 if (stackInt != (I_)BCO_LIT(discr)) {
1232 case bci_TESTLT_W: {
1233 // There should be an Int at Sp[1], and an info table at Sp[0].
1234 int discr = BCO_NEXT;
1235 int failto = BCO_GET_LARGE_ARG;
1236 W_ stackWord = (W_)Sp[1];
1237 if (stackWord >= (W_)BCO_LIT(discr))
1242 case bci_TESTEQ_W: {
1243 // There should be an Int at Sp[1], and an info table at Sp[0].
1244 int discr = BCO_NEXT;
1245 int failto = BCO_GET_LARGE_ARG;
1246 W_ stackWord = (W_)Sp[1];
1247 if (stackWord != (W_)BCO_LIT(discr)) {
1253 case bci_TESTLT_D: {
1254 // There should be a Double at Sp[1], and an info table at Sp[0].
1255 int discr = BCO_NEXT;
1256 int failto = BCO_GET_LARGE_ARG;
1257 StgDouble stackDbl, discrDbl;
1258 stackDbl = PK_DBL( & Sp[1] );
1259 discrDbl = PK_DBL( & BCO_LIT(discr) );
1260 if (stackDbl >= discrDbl) {
1266 case bci_TESTEQ_D: {
1267 // There should be a Double at Sp[1], and an info table at Sp[0].
1268 int discr = BCO_NEXT;
1269 int failto = BCO_GET_LARGE_ARG;
1270 StgDouble stackDbl, discrDbl;
1271 stackDbl = PK_DBL( & Sp[1] );
1272 discrDbl = PK_DBL( & BCO_LIT(discr) );
1273 if (stackDbl != discrDbl) {
1279 case bci_TESTLT_F: {
1280 // There should be a Float at Sp[1], and an info table at Sp[0].
1281 int discr = BCO_NEXT;
1282 int failto = BCO_GET_LARGE_ARG;
1283 StgFloat stackFlt, discrFlt;
1284 stackFlt = PK_FLT( & Sp[1] );
1285 discrFlt = PK_FLT( & BCO_LIT(discr) );
1286 if (stackFlt >= discrFlt) {
1292 case bci_TESTEQ_F: {
1293 // There should be a Float at Sp[1], and an info table at Sp[0].
1294 int discr = BCO_NEXT;
1295 int failto = BCO_GET_LARGE_ARG;
1296 StgFloat stackFlt, discrFlt;
1297 stackFlt = PK_FLT( & Sp[1] );
1298 discrFlt = PK_FLT( & BCO_LIT(discr) );
1299 if (stackFlt != discrFlt) {
1305 // Control-flow ish things
1307 // Context-switch check. We put it here to ensure that
1308 // the interpreter has done at least *some* work before
1309 // context switching: sometimes the scheduler can invoke
1310 // the interpreter with context_switch == 1, particularly
1311 // if the -C0 flag has been given on the cmd line.
1312 if (cap->r.rHpLim == NULL) {
1313 Sp--; Sp[0] = (W_)&stg_enter_info;
1314 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1319 tagged_obj = (StgClosure *)Sp[0];
1325 Sp[0] = (W_)&stg_gc_unpt_r1_info;
1326 goto do_return_unboxed;
1329 Sp[0] = (W_)&stg_gc_unbx_r1_info;
1330 goto do_return_unboxed;
1333 Sp[0] = (W_)&stg_gc_f1_info;
1334 goto do_return_unboxed;
1337 Sp[0] = (W_)&stg_gc_d1_info;
1338 goto do_return_unboxed;
1341 Sp[0] = (W_)&stg_gc_l1_info;
1342 goto do_return_unboxed;
1345 Sp[0] = (W_)&stg_gc_void_info;
1346 goto do_return_unboxed;
1349 int stkoff = BCO_NEXT;
1350 signed short n = (signed short)(BCO_NEXT);
1351 Sp[stkoff] += (W_)n;
1357 int stk_offset = BCO_NEXT;
1358 int o_itbl = BCO_NEXT;
1359 int interruptible = BCO_NEXT;
1360 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1362 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1363 + sizeofW(StgRetDyn);
1365 /* the stack looks like this:
1367 | | <- Sp + stk_offset
1371 | | <- Sp + ret_size + 1
1373 | C fun | <- Sp + ret_size
1378 ret is a placeholder for the return address, and may be
1381 We need to copy the args out of the TSO, because when
1382 we call suspendThread() we no longer own the TSO stack,
1383 and it may move at any time - indeed suspendThread()
1384 itself may do stack squeezing and move our args.
1385 So we make a copy of the argument block.
1388 #define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1390 ffi_cif *cif = (ffi_cif *)marshall_fn;
1391 nat nargs = cif->nargs;
1395 W_ ret[2]; // max needed
1396 W_ *arguments[stk_offset]; // max needed
1397 void *argptrs[nargs];
1400 if (cif->rtype->type == FFI_TYPE_VOID) {
1401 // necessary because cif->rtype->size == 1 for void,
1402 // but the bytecode generator has not pushed a
1403 // placeholder in this case.
1406 ret_size = ROUND_UP_WDS(cif->rtype->size);
1409 memcpy(arguments, Sp+ret_size+1,
1410 sizeof(W_) * (stk_offset-1-ret_size));
1412 // libffi expects the args as an array of pointers to
1413 // values, so we have to construct this array before making
1415 p = (StgPtr)arguments;
1416 for (i = 0; i < nargs; i++) {
1417 argptrs[i] = (void *)p;
1418 // get the size from the cif
1419 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1422 // this is the function we're going to call
1423 fn = (void(*)(void))Sp[ret_size];
1425 // Restore the Haskell thread's current value of errno
1426 errno = cap->r.rCurrentTSO->saved_errno;
1428 // There are a bunch of non-ptr words on the stack (the
1429 // ccall args, the ccall fun address and space for the
1430 // result), which we need to cover with an info table
1431 // since we might GC during this call.
1433 // We know how many (non-ptr) words there are before the
1434 // next valid stack frame: it is the stk_offset arg to the
1435 // CCALL instruction. So we build a RET_DYN stack frame
1436 // on the stack frame to describe this chunk of stack.
1439 ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset);
1440 ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1442 // save obj (pointer to the current BCO), since this
1443 // might move during the call. We use the R1 slot in the
1444 // RET_DYN frame for this, hence R1_PTR above.
1445 ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
1447 SAVE_STACK_POINTERS;
1448 tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse);
1450 // We already made a copy of the arguments above.
1451 ffi_call(cif, fn, ret, argptrs);
1453 // And restart the thread again, popping the RET_DYN frame.
1454 cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
1455 LOAD_STACK_POINTERS;
1457 if (Sp[0] != (W_)&stg_gc_gen_info) {
1458 // the stack is not how we left it. This probably
1459 // means that an exception got raised on exit from the
1460 // foreign call, so we should just continue with
1461 // whatever is on top of the stack now.
1462 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
1465 // Re-load the pointer to the BCO from the RET_DYN frame,
1466 // it might have moved during the call. Also reload the
1467 // pointers to the components of the BCO.
1468 obj = ((StgRetDyn *)Sp)->payload[0];
1470 instrs = (StgWord16*)(bco->instrs->payload);
1471 literals = (StgWord*)(&bco->literals->payload[0]);
1472 ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
1476 // Save the Haskell thread's current value of errno
1477 cap->r.rCurrentTSO->saved_errno = errno;
1479 // Copy the return value back to the TSO stack. It is at
1480 // most 2 words large, and resides at arguments[0].
1481 memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1487 /* BCO_NEXT modifies bciPtr, so be conservative. */
1488 int nextpc = BCO_GET_LARGE_ARG;
1494 barf("interpretBCO: hit a CASEFAIL");
1498 barf("interpretBCO: unknown or unimplemented opcode %d",
1501 } /* switch on opcode */
1505 barf("interpretBCO: fell off end of the interpreter");