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->sp; \
69 /* We don't change this ... */ \
70 SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
72 #define SAVE_STACK_POINTERS \
74 cap->r.rCurrentTSO->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->stack+cap->r.rCurrentTSO->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 ) {
281 case IND_OLDGEN_PERM:
284 tagged_obj = ((StgInd*)obj)->indirectee;
295 case CONSTR_NOCAF_STATIC:
309 ASSERT(((StgBCO *)obj)->arity > 0);
313 case AP: /* Copied from stg_AP_entry. */
322 if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
324 Sp[1] = (W_)tagged_obj;
325 Sp[0] = (W_)&stg_enter_info;
326 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
329 /* Ok; we're safe. Party on. Push an update frame. */
330 Sp -= sizeofW(StgUpdateFrame);
332 StgUpdateFrame *__frame;
333 __frame = (StgUpdateFrame *)Sp;
334 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
335 __frame->updatee = (StgClosure *)(ap);
338 /* Reload the stack */
340 for (i=0; i < words; i++) {
341 Sp[i] = (W_)ap->payload[i];
344 obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
345 ASSERT(get_itbl(obj)->type == BCO);
354 j = get_itbl(obj)->type;
355 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
356 it_unknown_entries[j]++;
357 it_total_unknown_entries++;
361 // Can't handle this object; yield to scheduler
362 IF_DEBUG(interpreter,
363 debugBelch("evaluating unknown closure -- yielding to sched\n");
367 Sp[1] = (W_)tagged_obj;
368 Sp[0] = (W_)&stg_enter_info;
369 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
373 // ------------------------------------------------------------------------
374 // We now have an evaluated object (tagged_obj). The next thing to
375 // do is return it to the stack frame on top of the stack.
377 obj = UNTAG_CLOSURE(tagged_obj);
378 ASSERT(closure_HNF(obj));
380 IF_DEBUG(interpreter,
382 "\n---------------------------------------------------------------\n");
383 debugBelch("Returning: "); printObj(obj);
384 debugBelch("Sp = %p\n", Sp);
386 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
390 IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
392 switch (get_itbl((StgClosure *)Sp)->type) {
395 const StgInfoTable *info;
397 // NOTE: not using get_itbl().
398 info = ((StgClosure *)Sp)->header.info;
399 if (info == (StgInfoTable *)&stg_ap_v_info) {
400 n = 1; m = 0; goto do_apply;
402 if (info == (StgInfoTable *)&stg_ap_f_info) {
403 n = 1; m = 1; goto do_apply;
405 if (info == (StgInfoTable *)&stg_ap_d_info) {
406 n = 1; m = sizeofW(StgDouble); goto do_apply;
408 if (info == (StgInfoTable *)&stg_ap_l_info) {
409 n = 1; m = sizeofW(StgInt64); goto do_apply;
411 if (info == (StgInfoTable *)&stg_ap_n_info) {
412 n = 1; m = 1; goto do_apply;
414 if (info == (StgInfoTable *)&stg_ap_p_info) {
415 n = 1; m = 1; goto do_apply;
417 if (info == (StgInfoTable *)&stg_ap_pp_info) {
418 n = 2; m = 2; goto do_apply;
420 if (info == (StgInfoTable *)&stg_ap_ppp_info) {
421 n = 3; m = 3; goto do_apply;
423 if (info == (StgInfoTable *)&stg_ap_pppp_info) {
424 n = 4; m = 4; goto do_apply;
426 if (info == (StgInfoTable *)&stg_ap_ppppp_info) {
427 n = 5; m = 5; goto do_apply;
429 if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
430 n = 6; m = 6; goto do_apply;
432 goto do_return_unrecognised;
436 // Returning to an update frame: do the update, pop the update
437 // frame, and continue with the next stack frame.
439 // NB. we must update with the *tagged* pointer. Some tags
440 // are not optional, and if we omit the tag bits when updating
441 // then bad things can happen (albeit very rarely). See #1925.
442 // What happened was an indirection was created with an
443 // untagged pointer, and this untagged pointer was propagated
444 // to a PAP by the GC, violating the invariant that PAPs
445 // always contain a tagged pointer to the function.
446 INTERP_TICK(it_retto_UPDATE);
447 updateThunk(cap, cap->r.rCurrentTSO,
448 ((StgUpdateFrame *)Sp)->updatee, tagged_obj);
449 Sp += sizeofW(StgUpdateFrame);
453 // Returning to an interpreted continuation: put the object on
454 // the stack, and start executing the BCO.
455 INTERP_TICK(it_retto_BCO);
458 // NB. return the untagged object; the bytecode expects it to
459 // be untagged. XXX this doesn't seem right.
460 obj = (StgClosure*)Sp[2];
461 ASSERT(get_itbl(obj)->type == BCO);
465 do_return_unrecognised:
467 // Can't handle this return address; yield to scheduler
468 INTERP_TICK(it_retto_other);
469 IF_DEBUG(interpreter,
470 debugBelch("returning to unknown frame -- yielding to sched\n");
471 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
474 Sp[1] = (W_)tagged_obj;
475 Sp[0] = (W_)&stg_enter_info;
476 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
480 // -------------------------------------------------------------------------
481 // Returning an unboxed value. The stack looks like this:
498 // where XXXX_info is one of the stg_gc_unbx_r1_info family.
500 // We're only interested in the case when the real return address
501 // is a BCO; otherwise we'll return to the scheduler.
507 ASSERT( Sp[0] == (W_)&stg_gc_unbx_r1_info
508 || Sp[0] == (W_)&stg_gc_unpt_r1_info
509 || Sp[0] == (W_)&stg_gc_f1_info
510 || Sp[0] == (W_)&stg_gc_d1_info
511 || Sp[0] == (W_)&stg_gc_l1_info
512 || Sp[0] == (W_)&stg_gc_void_info // VoidRep
515 // get the offset of the stg_ctoi_ret_XXX itbl
516 offset = stack_frame_sizeW((StgClosure *)Sp);
518 switch (get_itbl((StgClosure *)Sp+offset)->type) {
521 // Returning to an interpreted continuation: put the object on
522 // the stack, and start executing the BCO.
523 INTERP_TICK(it_retto_BCO);
524 obj = (StgClosure*)Sp[offset+1];
525 ASSERT(get_itbl(obj)->type == BCO);
526 goto run_BCO_return_unboxed;
530 // Can't handle this return address; yield to scheduler
531 INTERP_TICK(it_retto_other);
532 IF_DEBUG(interpreter,
533 debugBelch("returning to unknown frame -- yielding to sched\n");
534 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
536 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
543 // -------------------------------------------------------------------------
547 ASSERT(obj == UNTAG_CLOSURE(tagged_obj));
548 // we have a function to apply (obj), and n arguments taking up m
549 // words on the stack. The info table (stg_ap_pp_info or whatever)
550 // is on top of the arguments on the stack.
552 switch (get_itbl(obj)->type) {
560 // we only cope with PAPs whose function is a BCO
561 if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) {
562 goto defer_apply_to_sched;
565 // Stack check: we're about to unpack the PAP onto the
566 // stack. The (+1) is for the (arity < n) case, where we
567 // also need space for an extra info pointer.
568 if (Sp - (pap->n_args + 1) < SpLim) {
570 Sp[1] = (W_)tagged_obj;
571 Sp[0] = (W_)&stg_enter_info;
572 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
579 // n must be greater than 1, and the only kinds of
580 // application we support with more than one argument
581 // are all pointers...
583 // Shuffle the args for this function down, and put
584 // the appropriate info table in the gap.
585 for (i = 0; i < arity; i++) {
586 Sp[(int)i-1] = Sp[i];
587 // ^^^^^ careful, i-1 might be negative, but i in unsigned
589 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
591 // unpack the PAP's arguments onto the stack
593 for (i = 0; i < pap->n_args; i++) {
594 Sp[i] = (W_)pap->payload[i];
596 obj = UNTAG_CLOSURE(pap->fun);
599 else if (arity == n) {
601 for (i = 0; i < pap->n_args; i++) {
602 Sp[i] = (W_)pap->payload[i];
604 obj = UNTAG_CLOSURE(pap->fun);
607 else /* arity > n */ {
608 // build a new PAP and return it.
610 new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m));
611 SET_HDR(new_pap,&stg_PAP_info,CCCS);
612 new_pap->arity = pap->arity - n;
613 new_pap->n_args = pap->n_args + m;
614 new_pap->fun = pap->fun;
615 for (i = 0; i < pap->n_args; i++) {
616 new_pap->payload[i] = pap->payload[i];
618 for (i = 0; i < m; i++) {
619 new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
621 tagged_obj = (StgClosure *)new_pap;
631 arity = ((StgBCO *)obj)->arity;
634 // n must be greater than 1, and the only kinds of
635 // application we support with more than one argument
636 // are all pointers...
638 // Shuffle the args for this function down, and put
639 // the appropriate info table in the gap.
640 for (i = 0; i < arity; i++) {
641 Sp[(int)i-1] = Sp[i];
642 // ^^^^^ careful, i-1 might be negative, but i in unsigned
644 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
648 else if (arity == n) {
651 else /* arity > n */ {
652 // build a PAP and return it.
655 pap = (StgPAP *)allocate(cap, PAP_sizeW(m));
656 SET_HDR(pap, &stg_PAP_info,CCCS);
657 pap->arity = arity - n;
660 for (i = 0; i < m; i++) {
661 pap->payload[i] = (StgClosure *)Sp[i];
663 tagged_obj = (StgClosure *)pap;
669 // No point in us applying machine-code functions
671 defer_apply_to_sched:
673 Sp[1] = (W_)tagged_obj;
674 Sp[0] = (W_)&stg_enter_info;
675 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
678 // ------------------------------------------------------------------------
679 // Ok, we now have a bco (obj), and its arguments are all on the
680 // stack. We can start executing the byte codes.
682 // The stack is in one of two states. First, if this BCO is a
692 // Second, if this BCO is a continuation:
707 // where retval is the value being returned to this continuation.
708 // In the event of a stack check, heap check, or context switch,
709 // we need to leave the stack in a sane state so the garbage
710 // collector can find all the pointers.
712 // (1) BCO is a function: the BCO's bitmap describes the
713 // pointerhood of the arguments.
715 // (2) BCO is a continuation: BCO's bitmap describes the
716 // pointerhood of the free variables.
718 // Sadly we have three different kinds of stack/heap/cswitch check
724 if (doYouWantToGC(cap)) {
725 Sp--; Sp[0] = (W_)&stg_enter_info;
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.
733 run_BCO_return_unboxed:
735 if (doYouWantToGC(cap)) {
736 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
738 // Stack checks aren't necessary at return points, the stack use
739 // is aggregated into the enclosing function entry point.
747 Sp[0] = (W_)&stg_apply_interp_info;
748 checkStackChunk(Sp,SpLim);
753 if (doYouWantToGC(cap)) {
756 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
757 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
761 if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
764 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
765 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
770 // Now, actually interpret the BCO... (no returning to the
771 // scheduler again until the stack is in an orderly state).
773 INTERP_TICK(it_BCO_entries);
775 register int bciPtr = 0; /* instruction pointer */
776 register StgWord16 bci;
777 register StgBCO* bco = (StgBCO*)obj;
778 register StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
779 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
780 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
782 bcoSize = BCO_NEXT_WORD;
783 IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
786 it_lastopc = 0; /* no opcode */
790 ASSERT(bciPtr < bcoSize);
791 IF_DEBUG(interpreter,
792 //if (do_print_stack) {
793 //debugBelch("\n-- BEGIN stack\n");
794 //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
795 //debugBelch("-- END stack\n\n");
797 debugBelch("Sp = %p pc = %d ", Sp, bciPtr);
798 disInstr(bco,bciPtr);
801 for (i = 8; i >= 0; i--) {
802 debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i)));
806 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
810 INTERP_TICK(it_insns);
813 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
814 it_ofreq[ (int)instrs[bciPtr] ] ++;
815 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
816 it_lastopc = (int)instrs[bciPtr];
820 /* We use the high 8 bits for flags, only the highest of which is
821 * currently allocated */
822 ASSERT((bci & 0xFF00) == (bci & 0x8000));
824 switch (bci & 0xFF) {
826 /* check for a breakpoint on the beginning of a let binding */
829 int arg1_brk_array, arg2_array_index, arg3_freeVars;
830 StgArrWords *breakPoints;
831 int returning_from_break; // are we resuming execution from a breakpoint?
832 // if yes, then don't break this time around
833 StgClosure *ioAction; // the io action to run at a breakpoint
835 StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap
839 arg1_brk_array = BCO_NEXT; // 1st arg of break instruction
840 arg2_array_index = BCO_NEXT; // 2nd arg of break instruction
841 arg3_freeVars = BCO_NEXT; // 3rd arg of break instruction
843 // check if we are returning from a breakpoint - this info
844 // is stored in the flags field of the current TSO
845 returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
847 // if we are returning from a break then skip this section
848 // and continue executing
849 if (!returning_from_break)
851 breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
853 // stop the current thread if either the
854 // "rts_stop_next_breakpoint" flag is true OR if the
855 // breakpoint flag for this particular expression is
857 if (rts_stop_next_breakpoint == rtsTrue ||
858 breakPoints->payload[arg2_array_index] == rtsTrue)
860 // make sure we don't automatically stop at the
862 rts_stop_next_breakpoint = rtsFalse;
864 // allocate memory for a new AP_STACK, enough to
865 // store the top stack frame plus an
866 // stg_apply_interp_info pointer and a pointer to
868 size_words = BCO_BITMAP_SIZE(obj) + 2;
869 new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
870 SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
871 new_aps->size = size_words;
872 new_aps->fun = &stg_dummy_ret_closure;
874 // fill in the payload of the AP_STACK
875 new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
876 new_aps->payload[1] = (StgClosure *)obj;
878 // copy the contents of the top stack frame into the AP_STACK
879 for (i = 2; i < size_words; i++)
881 new_aps->payload[i] = (StgClosure *)Sp[i-2];
884 // prepare the stack so that we can call the
885 // rts_breakpoint_io_action and ensure that the stack is
886 // in a reasonable state for the GC and so that
887 // execution of this BCO can continue when we resume
888 ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
891 Sp[7] = (W_)&stg_apply_interp_info;
892 Sp[6] = (W_)&stg_noforceIO_info; // see [unreg] below
893 Sp[5] = (W_)new_aps; // the AP_STACK
894 Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
895 Sp[3] = (W_)False_closure; // True <=> a breakpoint
896 Sp[2] = (W_)&stg_ap_pppv_info;
897 Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
898 Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
899 // Note [unreg]: in unregisterised mode, the return
900 // convention for IO is different. The
901 // stg_noForceIO_info stack frame is necessary to
902 // account for this difference.
904 // set the flag in the TSO to say that we are now
905 // stopping at a breakpoint so that when we resume
906 // we don't stop on the same breakpoint that we
907 // already stopped at just now
908 cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
910 // stop this thread and return to the scheduler -
911 // eventually we will come back and the IO action on
912 // the top of the stack will be executed
913 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
916 // record that this thread is not stopped at a breakpoint anymore
917 cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
919 // continue normal execution of the byte code instructions
924 // Explicit stack check at the beginning of a function
925 // *only* (stack checks in case alternatives are
926 // propagated to the enclosing function).
927 StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
928 if (Sp - stk_words_reqd < SpLim) {
931 Sp[0] = (W_)&stg_apply_interp_info;
932 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
967 Sp[-1] = BCO_PTR(o1);
972 case bci_PUSH_ALTS: {
973 int o_bco = BCO_NEXT;
974 Sp[-2] = (W_)&stg_ctoi_R1p_info;
975 Sp[-1] = BCO_PTR(o_bco);
980 case bci_PUSH_ALTS_P: {
981 int o_bco = BCO_NEXT;
982 Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
983 Sp[-1] = BCO_PTR(o_bco);
988 case bci_PUSH_ALTS_N: {
989 int o_bco = BCO_NEXT;
990 Sp[-2] = (W_)&stg_ctoi_R1n_info;
991 Sp[-1] = BCO_PTR(o_bco);
996 case bci_PUSH_ALTS_F: {
997 int o_bco = BCO_NEXT;
998 Sp[-2] = (W_)&stg_ctoi_F1_info;
999 Sp[-1] = BCO_PTR(o_bco);
1004 case bci_PUSH_ALTS_D: {
1005 int o_bco = BCO_NEXT;
1006 Sp[-2] = (W_)&stg_ctoi_D1_info;
1007 Sp[-1] = BCO_PTR(o_bco);
1012 case bci_PUSH_ALTS_L: {
1013 int o_bco = BCO_NEXT;
1014 Sp[-2] = (W_)&stg_ctoi_L1_info;
1015 Sp[-1] = BCO_PTR(o_bco);
1020 case bci_PUSH_ALTS_V: {
1021 int o_bco = BCO_NEXT;
1022 Sp[-2] = (W_)&stg_ctoi_V_info;
1023 Sp[-1] = BCO_PTR(o_bco);
1028 case bci_PUSH_APPLY_N:
1029 Sp--; Sp[0] = (W_)&stg_ap_n_info;
1031 case bci_PUSH_APPLY_V:
1032 Sp--; Sp[0] = (W_)&stg_ap_v_info;
1034 case bci_PUSH_APPLY_F:
1035 Sp--; Sp[0] = (W_)&stg_ap_f_info;
1037 case bci_PUSH_APPLY_D:
1038 Sp--; Sp[0] = (W_)&stg_ap_d_info;
1040 case bci_PUSH_APPLY_L:
1041 Sp--; Sp[0] = (W_)&stg_ap_l_info;
1043 case bci_PUSH_APPLY_P:
1044 Sp--; Sp[0] = (W_)&stg_ap_p_info;
1046 case bci_PUSH_APPLY_PP:
1047 Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1049 case bci_PUSH_APPLY_PPP:
1050 Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1052 case bci_PUSH_APPLY_PPPP:
1053 Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1055 case bci_PUSH_APPLY_PPPPP:
1056 Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1058 case bci_PUSH_APPLY_PPPPPP:
1059 Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1062 case bci_PUSH_UBX: {
1064 int o_lits = BCO_NEXT;
1065 int n_words = BCO_NEXT;
1067 for (i = 0; i < n_words; i++) {
1068 Sp[i] = (W_)BCO_LIT(o_lits+i);
1076 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1081 INTERP_TICK(it_slides);
1085 case bci_ALLOC_AP: {
1087 int n_payload = BCO_NEXT;
1088 ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1090 ap->n_args = n_payload;
1091 SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
1096 case bci_ALLOC_AP_NOUPD: {
1098 int n_payload = BCO_NEXT;
1099 ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1101 ap->n_args = n_payload;
1102 SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
1107 case bci_ALLOC_PAP: {
1109 int arity = BCO_NEXT;
1110 int n_payload = BCO_NEXT;
1111 pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload));
1113 pap->n_args = n_payload;
1115 SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
1122 int stkoff = BCO_NEXT;
1123 int n_payload = BCO_NEXT;
1124 StgAP* ap = (StgAP*)Sp[stkoff];
1125 ASSERT((int)ap->n_args == n_payload);
1126 ap->fun = (StgClosure*)Sp[0];
1128 // The function should be a BCO, and its bitmap should
1129 // cover the payload of the AP correctly.
1130 ASSERT(get_itbl(ap->fun)->type == BCO
1131 && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1133 for (i = 0; i < n_payload; i++)
1134 ap->payload[i] = (StgClosure*)Sp[i+1];
1136 IF_DEBUG(interpreter,
1137 debugBelch("\tBuilt ");
1138 printObj((StgClosure*)ap);
1145 int stkoff = BCO_NEXT;
1146 int n_payload = BCO_NEXT;
1147 StgPAP* pap = (StgPAP*)Sp[stkoff];
1148 ASSERT((int)pap->n_args == n_payload);
1149 pap->fun = (StgClosure*)Sp[0];
1151 // The function should be a BCO
1152 ASSERT(get_itbl(pap->fun)->type == BCO);
1154 for (i = 0; i < n_payload; i++)
1155 pap->payload[i] = (StgClosure*)Sp[i+1];
1157 IF_DEBUG(interpreter,
1158 debugBelch("\tBuilt ");
1159 printObj((StgClosure*)pap);
1165 /* Unpack N ptr words from t.o.s constructor */
1167 int n_words = BCO_NEXT;
1168 StgClosure* con = (StgClosure*)Sp[0];
1170 for (i = 0; i < n_words; i++) {
1171 Sp[i] = (W_)con->payload[i];
1178 int o_itbl = BCO_NEXT;
1179 int n_words = BCO_NEXT;
1180 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
1181 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
1182 itbl->layout.payload.nptrs );
1183 StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
1184 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1185 SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
1186 for (i = 0; i < n_words; i++) {
1187 con->payload[i] = (StgClosure*)Sp[i];
1192 IF_DEBUG(interpreter,
1193 debugBelch("\tBuilt ");
1194 printObj((StgClosure*)con);
1199 case bci_TESTLT_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_TESTEQ_P: {
1210 unsigned int discr = BCO_NEXT;
1211 int failto = BCO_GET_LARGE_ARG;
1212 StgClosure* con = (StgClosure*)Sp[0];
1213 if (GET_TAG(con) != discr) {
1219 case bci_TESTLT_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))
1229 case bci_TESTEQ_I: {
1230 // There should be an Int at Sp[1], and an info table at Sp[0].
1231 int discr = BCO_NEXT;
1232 int failto = BCO_GET_LARGE_ARG;
1233 I_ stackInt = (I_)Sp[1];
1234 if (stackInt != (I_)BCO_LIT(discr)) {
1240 case bci_TESTLT_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))
1250 case bci_TESTEQ_W: {
1251 // There should be an Int at Sp[1], and an info table at Sp[0].
1252 int discr = BCO_NEXT;
1253 int failto = BCO_GET_LARGE_ARG;
1254 W_ stackWord = (W_)Sp[1];
1255 if (stackWord != (W_)BCO_LIT(discr)) {
1261 case bci_TESTLT_D: {
1262 // There should be a Double at Sp[1], and an info table at Sp[0].
1263 int discr = BCO_NEXT;
1264 int failto = BCO_GET_LARGE_ARG;
1265 StgDouble stackDbl, discrDbl;
1266 stackDbl = PK_DBL( & Sp[1] );
1267 discrDbl = PK_DBL( & BCO_LIT(discr) );
1268 if (stackDbl >= discrDbl) {
1274 case bci_TESTEQ_D: {
1275 // There should be a Double at Sp[1], and an info table at Sp[0].
1276 int discr = BCO_NEXT;
1277 int failto = BCO_GET_LARGE_ARG;
1278 StgDouble stackDbl, discrDbl;
1279 stackDbl = PK_DBL( & Sp[1] );
1280 discrDbl = PK_DBL( & BCO_LIT(discr) );
1281 if (stackDbl != discrDbl) {
1287 case bci_TESTLT_F: {
1288 // There should be a Float at Sp[1], and an info table at Sp[0].
1289 int discr = BCO_NEXT;
1290 int failto = BCO_GET_LARGE_ARG;
1291 StgFloat stackFlt, discrFlt;
1292 stackFlt = PK_FLT( & Sp[1] );
1293 discrFlt = PK_FLT( & BCO_LIT(discr) );
1294 if (stackFlt >= discrFlt) {
1300 case bci_TESTEQ_F: {
1301 // There should be a Float at Sp[1], and an info table at Sp[0].
1302 int discr = BCO_NEXT;
1303 int failto = BCO_GET_LARGE_ARG;
1304 StgFloat stackFlt, discrFlt;
1305 stackFlt = PK_FLT( & Sp[1] );
1306 discrFlt = PK_FLT( & BCO_LIT(discr) );
1307 if (stackFlt != discrFlt) {
1313 // Control-flow ish things
1315 // Context-switch check. We put it here to ensure that
1316 // the interpreter has done at least *some* work before
1317 // context switching: sometimes the scheduler can invoke
1318 // the interpreter with context_switch == 1, particularly
1319 // if the -C0 flag has been given on the cmd line.
1320 if (cap->r.rHpLim == NULL) {
1321 Sp--; Sp[0] = (W_)&stg_enter_info;
1322 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1327 tagged_obj = (StgClosure *)Sp[0];
1333 Sp[0] = (W_)&stg_gc_unpt_r1_info;
1334 goto do_return_unboxed;
1337 Sp[0] = (W_)&stg_gc_unbx_r1_info;
1338 goto do_return_unboxed;
1341 Sp[0] = (W_)&stg_gc_f1_info;
1342 goto do_return_unboxed;
1345 Sp[0] = (W_)&stg_gc_d1_info;
1346 goto do_return_unboxed;
1349 Sp[0] = (W_)&stg_gc_l1_info;
1350 goto do_return_unboxed;
1353 Sp[0] = (W_)&stg_gc_void_info;
1354 goto do_return_unboxed;
1357 int stkoff = BCO_NEXT;
1358 signed short n = (signed short)(BCO_NEXT);
1359 Sp[stkoff] += (W_)n;
1365 int stk_offset = BCO_NEXT;
1366 int o_itbl = BCO_NEXT;
1367 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1369 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1370 + sizeofW(StgRetDyn);
1372 /* the stack looks like this:
1374 | | <- Sp + stk_offset
1378 | | <- Sp + ret_size + 1
1380 | C fun | <- Sp + ret_size
1385 ret is a placeholder for the return address, and may be
1388 We need to copy the args out of the TSO, because when
1389 we call suspendThread() we no longer own the TSO stack,
1390 and it may move at any time - indeed suspendThread()
1391 itself may do stack squeezing and move our args.
1392 So we make a copy of the argument block.
1395 #define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1397 ffi_cif *cif = (ffi_cif *)marshall_fn;
1398 nat nargs = cif->nargs;
1402 W_ ret[2]; // max needed
1403 W_ *arguments[stk_offset]; // max needed
1404 void *argptrs[nargs];
1407 if (cif->rtype->type == FFI_TYPE_VOID) {
1408 // necessary because cif->rtype->size == 1 for void,
1409 // but the bytecode generator has not pushed a
1410 // placeholder in this case.
1413 ret_size = ROUND_UP_WDS(cif->rtype->size);
1416 memcpy(arguments, Sp+ret_size+1,
1417 sizeof(W_) * (stk_offset-1-ret_size));
1419 // libffi expects the args as an array of pointers to
1420 // values, so we have to construct this array before making
1422 p = (StgPtr)arguments;
1423 for (i = 0; i < nargs; i++) {
1424 argptrs[i] = (void *)p;
1425 // get the size from the cif
1426 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1429 // this is the function we're going to call
1430 fn = (void(*)(void))Sp[ret_size];
1432 // Restore the Haskell thread's current value of errno
1433 errno = cap->r.rCurrentTSO->saved_errno;
1435 // There are a bunch of non-ptr words on the stack (the
1436 // ccall args, the ccall fun address and space for the
1437 // result), which we need to cover with an info table
1438 // since we might GC during this call.
1440 // We know how many (non-ptr) words there are before the
1441 // next valid stack frame: it is the stk_offset arg to the
1442 // CCALL instruction. So we build a RET_DYN stack frame
1443 // on the stack frame to describe this chunk of stack.
1446 ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset);
1447 ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1449 // save obj (pointer to the current BCO), since this
1450 // might move during the call. We use the R1 slot in the
1451 // RET_DYN frame for this, hence R1_PTR above.
1452 ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
1454 SAVE_STACK_POINTERS;
1455 tok = suspendThread(&cap->r);
1457 // We already made a copy of the arguments above.
1458 ffi_call(cif, fn, ret, argptrs);
1460 // And restart the thread again, popping the RET_DYN frame.
1461 cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
1462 LOAD_STACK_POINTERS;
1464 // Re-load the pointer to the BCO from the RET_DYN frame,
1465 // it might have moved during the call. Also reload the
1466 // pointers to the components of the BCO.
1467 obj = ((StgRetDyn *)Sp)->payload[0];
1469 instrs = (StgWord16*)(bco->instrs->payload);
1470 literals = (StgWord*)(&bco->literals->payload[0]);
1471 ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
1475 // Save the Haskell thread's current value of errno
1476 cap->r.rCurrentTSO->saved_errno = errno;
1478 // Copy the return value back to the TSO stack. It is at
1479 // most 2 words large, and resides at arguments[0].
1480 memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1486 /* BCO_NEXT modifies bciPtr, so be conservative. */
1487 int nextpc = BCO_GET_LARGE_ARG;
1493 barf("interpretBCO: hit a CASEFAIL");
1497 barf("interpretBCO: unknown or unimplemented opcode %d",
1500 } /* switch on opcode */
1504 barf("interpretBCO: fell off end of the interpreter");