1 /* -----------------------------------------------------------------------------
4 * Copyright (c) The GHC Team, 1994-2002.
5 * ---------------------------------------------------------------------------*/
7 #include "PosixSource.h"
15 #include "LdvProfile.h"
21 #include "Bytecodes.h"
23 #include "Disassembler.h"
24 #include "Interpreter.h"
26 #include <string.h> /* for memcpy */
33 /* --------------------------------------------------------------------------
34 * The bytecode interpreter
35 * ------------------------------------------------------------------------*/
37 /* Gather stats about entry, opcode, opcode-pair frequencies. For
38 tuning the interpreter. */
40 /* #define INTERP_STATS */
43 /* Sp points to the lowest live word on the stack. */
45 #define BCO_NEXT instrs[bciPtr++]
46 #define BCO_NEXT_32 (bciPtr += 2, (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1]))
47 #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]))
48 #if WORD_SIZE_IN_BITS == 32
49 #define BCO_NEXT_WORD BCO_NEXT_32
50 #elif WORD_SIZE_IN_BITS == 64
51 #define BCO_NEXT_WORD BCO_NEXT_64
53 #error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64
55 #define BCO_GET_LARGE_ARG ((bci & bci_FLAG_LARGE_ARGS) ? BCO_NEXT_WORD : BCO_NEXT)
57 #define BCO_PTR(n) (W_)ptrs[n]
58 #define BCO_LIT(n) literals[n]
60 #define LOAD_STACK_POINTERS \
61 Sp = cap->r.rCurrentTSO->sp; \
62 /* We don't change this ... */ \
63 SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
65 #define SAVE_STACK_POINTERS \
67 cap->r.rCurrentTSO->sp = Sp
69 #define RETURN_TO_SCHEDULER(todo,retcode) \
70 SAVE_STACK_POINTERS; \
71 cap->r.rCurrentTSO->what_next = (todo); \
72 threadPaused(cap,cap->r.rCurrentTSO); \
73 cap->r.rRet = (retcode); \
76 #define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode) \
77 SAVE_STACK_POINTERS; \
78 cap->r.rCurrentTSO->what_next = (todo); \
79 cap->r.rRet = (retcode); \
84 allocate_NONUPD (int n_words)
86 return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
89 int rts_stop_next_breakpoint = 0;
90 int rts_stop_on_exception = 0;
94 /* Hacky stats, for tuning the interpreter ... */
95 int it_unknown_entries[N_CLOSURE_TYPES];
96 int it_total_unknown_entries;
108 int it_oofreq[27][27];
112 #define INTERP_TICK(n) (n)++
114 void interp_startup ( void )
117 it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
118 it_total_entries = it_total_unknown_entries = 0;
119 for (i = 0; i < N_CLOSURE_TYPES; i++)
120 it_unknown_entries[i] = 0;
121 it_slides = it_insns = it_BCO_entries = 0;
122 for (i = 0; i < 27; i++) it_ofreq[i] = 0;
123 for (i = 0; i < 27; i++)
124 for (j = 0; j < 27; j++)
129 void interp_shutdown ( void )
131 int i, j, k, o_max, i_max, j_max;
132 debugBelch("%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
133 it_retto_BCO + it_retto_UPDATE + it_retto_other,
134 it_retto_BCO, it_retto_UPDATE, it_retto_other );
135 debugBelch("%d total entries, %d unknown entries \n",
136 it_total_entries, it_total_unknown_entries);
137 for (i = 0; i < N_CLOSURE_TYPES; i++) {
138 if (it_unknown_entries[i] == 0) continue;
139 debugBelch(" type %2d: unknown entries (%4.1f%%) == %d\n",
140 i, 100.0 * ((double)it_unknown_entries[i]) /
141 ((double)it_total_unknown_entries),
142 it_unknown_entries[i]);
144 debugBelch("%d insns, %d slides, %d BCO_entries\n",
145 it_insns, it_slides, it_BCO_entries);
146 for (i = 0; i < 27; i++)
147 debugBelch("opcode %2d got %d\n", i, it_ofreq[i] );
149 for (k = 1; k < 20; k++) {
152 for (i = 0; i < 27; i++) {
153 for (j = 0; j < 27; j++) {
154 if (it_oofreq[i][j] > o_max) {
155 o_max = it_oofreq[i][j];
156 i_max = i; j_max = j;
161 debugBelch("%d: count (%4.1f%%) %6d is %d then %d\n",
162 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
164 it_oofreq[i_max][j_max] = 0;
169 #else // !INTERP_STATS
171 #define INTERP_TICK(n) /* nothing */
175 static StgWord app_ptrs_itbl[] = {
178 (W_)&stg_ap_ppp_info,
179 (W_)&stg_ap_pppp_info,
180 (W_)&stg_ap_ppppp_info,
181 (W_)&stg_ap_pppppp_info,
184 HsStablePtr rts_breakpoint_io_action; // points to the IO action which is executed on a breakpoint
185 // it is set in main/GHC.hs:runStmt
188 interpretBCO (Capability* cap)
190 // Use of register here is primarily to make it clear to compilers
191 // that these entities are non-aliasable.
192 register StgPtr Sp; // local state -- stack pointer
193 register StgPtr SpLim; // local state -- stack lim pointer
194 register StgClosure *tagged_obj = 0, *obj;
199 cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
200 // goes to zero we must return to the scheduler.
202 // ------------------------------------------------------------------------
205 // We have a closure to evaluate. Stack looks like:
209 // Sp | -------------------> closure
212 if (Sp[0] == (W_)&stg_enter_info) {
217 // ------------------------------------------------------------------------
220 // We have a BCO application to perform. Stack looks like:
231 else if (Sp[0] == (W_)&stg_apply_interp_info) {
232 obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
237 // ------------------------------------------------------------------------
240 // We have an unboxed value to return. See comment before
241 // do_return_unboxed, below.
244 goto do_return_unboxed;
247 // Evaluate the object on top of the stack.
249 tagged_obj = (StgClosure*)Sp[0]; Sp++;
252 obj = UNTAG_CLOSURE(tagged_obj);
253 INTERP_TICK(it_total_evals);
255 IF_DEBUG(interpreter,
257 "\n---------------------------------------------------------------\n");
258 debugBelch("Evaluating: "); printObj(obj);
259 debugBelch("Sp = %p\n", Sp);
262 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
266 IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
268 switch ( get_itbl(obj)->type ) {
273 case IND_OLDGEN_PERM:
276 tagged_obj = ((StgInd*)obj)->indirectee;
287 case CONSTR_NOCAF_STATIC:
301 ASSERT(((StgBCO *)obj)->arity > 0);
305 case AP: /* Copied from stg_AP_entry. */
314 if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
316 Sp[1] = (W_)tagged_obj;
317 Sp[0] = (W_)&stg_enter_info;
318 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
321 /* Ok; we're safe. Party on. Push an update frame. */
322 Sp -= sizeofW(StgUpdateFrame);
324 StgUpdateFrame *__frame;
325 __frame = (StgUpdateFrame *)Sp;
326 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
327 __frame->updatee = (StgClosure *)(ap);
330 /* Reload the stack */
332 for (i=0; i < words; i++) {
333 Sp[i] = (W_)ap->payload[i];
336 obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
337 ASSERT(get_itbl(obj)->type == BCO);
346 j = get_itbl(obj)->type;
347 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
348 it_unknown_entries[j]++;
349 it_total_unknown_entries++;
353 // Can't handle this object; yield to scheduler
354 IF_DEBUG(interpreter,
355 debugBelch("evaluating unknown closure -- yielding to sched\n");
359 Sp[1] = (W_)tagged_obj;
360 Sp[0] = (W_)&stg_enter_info;
361 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
365 // ------------------------------------------------------------------------
366 // We now have an evaluated object (tagged_obj). The next thing to
367 // do is return it to the stack frame on top of the stack.
369 obj = UNTAG_CLOSURE(tagged_obj);
370 ASSERT(closure_HNF(obj));
372 IF_DEBUG(interpreter,
374 "\n---------------------------------------------------------------\n");
375 debugBelch("Returning: "); printObj(obj);
376 debugBelch("Sp = %p\n", Sp);
378 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
382 IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
384 switch (get_itbl((StgClosure *)Sp)->type) {
387 const StgInfoTable *info;
389 // NOTE: not using get_itbl().
390 info = ((StgClosure *)Sp)->header.info;
391 if (info == (StgInfoTable *)&stg_ap_v_info) {
392 n = 1; m = 0; goto do_apply;
394 if (info == (StgInfoTable *)&stg_ap_f_info) {
395 n = 1; m = 1; goto do_apply;
397 if (info == (StgInfoTable *)&stg_ap_d_info) {
398 n = 1; m = sizeofW(StgDouble); goto do_apply;
400 if (info == (StgInfoTable *)&stg_ap_l_info) {
401 n = 1; m = sizeofW(StgInt64); goto do_apply;
403 if (info == (StgInfoTable *)&stg_ap_n_info) {
404 n = 1; m = 1; goto do_apply;
406 if (info == (StgInfoTable *)&stg_ap_p_info) {
407 n = 1; m = 1; goto do_apply;
409 if (info == (StgInfoTable *)&stg_ap_pp_info) {
410 n = 2; m = 2; goto do_apply;
412 if (info == (StgInfoTable *)&stg_ap_ppp_info) {
413 n = 3; m = 3; goto do_apply;
415 if (info == (StgInfoTable *)&stg_ap_pppp_info) {
416 n = 4; m = 4; goto do_apply;
418 if (info == (StgInfoTable *)&stg_ap_ppppp_info) {
419 n = 5; m = 5; goto do_apply;
421 if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
422 n = 6; m = 6; goto do_apply;
424 goto do_return_unrecognised;
428 // Returning to an update frame: do the update, pop the update
429 // frame, and continue with the next stack frame.
431 // NB. we must update with the *tagged* pointer. Some tags
432 // are not optional, and if we omit the tag bits when updating
433 // then bad things can happen (albeit very rarely). See #1925.
434 // What happened was an indirection was created with an
435 // untagged pointer, and this untagged pointer was propagated
436 // to a PAP by the GC, violating the invariant that PAPs
437 // always contain a tagged pointer to the function.
438 INTERP_TICK(it_retto_UPDATE);
439 UPD_IND(((StgUpdateFrame *)Sp)->updatee, tagged_obj);
440 Sp += sizeofW(StgUpdateFrame);
444 // Returning to an interpreted continuation: put the object on
445 // the stack, and start executing the BCO.
446 INTERP_TICK(it_retto_BCO);
449 // NB. return the untagged object; the bytecode expects it to
450 // be untagged. XXX this doesn't seem right.
451 obj = (StgClosure*)Sp[2];
452 ASSERT(get_itbl(obj)->type == BCO);
456 do_return_unrecognised:
458 // Can't handle this return address; yield to scheduler
459 INTERP_TICK(it_retto_other);
460 IF_DEBUG(interpreter,
461 debugBelch("returning to unknown frame -- yielding to sched\n");
462 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
465 Sp[1] = (W_)tagged_obj;
466 Sp[0] = (W_)&stg_enter_info;
467 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
471 // -------------------------------------------------------------------------
472 // Returning an unboxed value. The stack looks like this:
489 // where XXXX_info is one of the stg_gc_unbx_r1_info family.
491 // We're only interested in the case when the real return address
492 // is a BCO; otherwise we'll return to the scheduler.
498 ASSERT( Sp[0] == (W_)&stg_gc_unbx_r1_info
499 || Sp[0] == (W_)&stg_gc_unpt_r1_info
500 || Sp[0] == (W_)&stg_gc_f1_info
501 || Sp[0] == (W_)&stg_gc_d1_info
502 || Sp[0] == (W_)&stg_gc_l1_info
503 || Sp[0] == (W_)&stg_gc_void_info // VoidRep
506 // get the offset of the stg_ctoi_ret_XXX itbl
507 offset = stack_frame_sizeW((StgClosure *)Sp);
509 switch (get_itbl((StgClosure *)Sp+offset)->type) {
512 // Returning to an interpreted continuation: put the object on
513 // the stack, and start executing the BCO.
514 INTERP_TICK(it_retto_BCO);
515 obj = (StgClosure*)Sp[offset+1];
516 ASSERT(get_itbl(obj)->type == BCO);
517 goto run_BCO_return_unboxed;
521 // Can't handle this return address; yield to scheduler
522 INTERP_TICK(it_retto_other);
523 IF_DEBUG(interpreter,
524 debugBelch("returning to unknown frame -- yielding to sched\n");
525 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
527 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
534 // -------------------------------------------------------------------------
538 ASSERT(obj == UNTAG_CLOSURE(tagged_obj));
539 // we have a function to apply (obj), and n arguments taking up m
540 // words on the stack. The info table (stg_ap_pp_info or whatever)
541 // is on top of the arguments on the stack.
543 switch (get_itbl(obj)->type) {
551 // we only cope with PAPs whose function is a BCO
552 if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) {
553 goto defer_apply_to_sched;
556 // Stack check: we're about to unpack the PAP onto the
557 // stack. The (+1) is for the (arity < n) case, where we
558 // also need space for an extra info pointer.
559 if (Sp - (pap->n_args + 1) < SpLim) {
561 Sp[1] = (W_)tagged_obj;
562 Sp[0] = (W_)&stg_enter_info;
563 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
570 // n must be greater than 1, and the only kinds of
571 // application we support with more than one argument
572 // are all pointers...
574 // Shuffle the args for this function down, and put
575 // the appropriate info table in the gap.
576 for (i = 0; i < arity; i++) {
577 Sp[(int)i-1] = Sp[i];
578 // ^^^^^ careful, i-1 might be negative, but i in unsigned
580 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
582 // unpack the PAP's arguments onto the stack
584 for (i = 0; i < pap->n_args; i++) {
585 Sp[i] = (W_)pap->payload[i];
587 obj = UNTAG_CLOSURE(pap->fun);
590 else if (arity == n) {
592 for (i = 0; i < pap->n_args; i++) {
593 Sp[i] = (W_)pap->payload[i];
595 obj = UNTAG_CLOSURE(pap->fun);
598 else /* arity > n */ {
599 // build a new PAP and return it.
601 new_pap = (StgPAP *)allocate(PAP_sizeW(pap->n_args + m));
602 SET_HDR(new_pap,&stg_PAP_info,CCCS);
603 new_pap->arity = pap->arity - n;
604 new_pap->n_args = pap->n_args + m;
605 new_pap->fun = pap->fun;
606 for (i = 0; i < pap->n_args; i++) {
607 new_pap->payload[i] = pap->payload[i];
609 for (i = 0; i < m; i++) {
610 new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
612 tagged_obj = (StgClosure *)new_pap;
622 arity = ((StgBCO *)obj)->arity;
625 // n must be greater than 1, and the only kinds of
626 // application we support with more than one argument
627 // are all pointers...
629 // Shuffle the args for this function down, and put
630 // the appropriate info table in the gap.
631 for (i = 0; i < arity; i++) {
632 Sp[(int)i-1] = Sp[i];
633 // ^^^^^ careful, i-1 might be negative, but i in unsigned
635 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
639 else if (arity == n) {
642 else /* arity > n */ {
643 // build a PAP and return it.
646 pap = (StgPAP *)allocate(PAP_sizeW(m));
647 SET_HDR(pap, &stg_PAP_info,CCCS);
648 pap->arity = arity - n;
651 for (i = 0; i < m; i++) {
652 pap->payload[i] = (StgClosure *)Sp[i];
654 tagged_obj = (StgClosure *)pap;
660 // No point in us applying machine-code functions
662 defer_apply_to_sched:
664 Sp[1] = (W_)tagged_obj;
665 Sp[0] = (W_)&stg_enter_info;
666 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
669 // ------------------------------------------------------------------------
670 // Ok, we now have a bco (obj), and its arguments are all on the
671 // stack. We can start executing the byte codes.
673 // The stack is in one of two states. First, if this BCO is a
683 // Second, if this BCO is a continuation:
698 // where retval is the value being returned to this continuation.
699 // In the event of a stack check, heap check, or context switch,
700 // we need to leave the stack in a sane state so the garbage
701 // collector can find all the pointers.
703 // (1) BCO is a function: the BCO's bitmap describes the
704 // pointerhood of the arguments.
706 // (2) BCO is a continuation: BCO's bitmap describes the
707 // pointerhood of the free variables.
709 // Sadly we have three different kinds of stack/heap/cswitch check
715 if (doYouWantToGC()) {
716 Sp--; Sp[0] = (W_)&stg_enter_info;
717 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
719 // Stack checks aren't necessary at return points, the stack use
720 // is aggregated into the enclosing function entry point.
724 run_BCO_return_unboxed:
726 if (doYouWantToGC()) {
727 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
729 // Stack checks aren't necessary at return points, the stack use
730 // is aggregated into the enclosing function entry point.
738 Sp[0] = (W_)&stg_apply_interp_info;
739 checkStackChunk(Sp,SpLim);
744 if (doYouWantToGC()) {
747 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
748 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
752 if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
755 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
756 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
761 // Now, actually interpret the BCO... (no returning to the
762 // scheduler again until the stack is in an orderly state).
764 INTERP_TICK(it_BCO_entries);
766 register int bciPtr = 1; /* instruction pointer */
767 register StgWord16 bci;
768 register StgBCO* bco = (StgBCO*)obj;
769 register StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
770 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
771 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
774 it_lastopc = 0; /* no opcode */
778 ASSERT(bciPtr <= instrs[0]);
779 IF_DEBUG(interpreter,
780 //if (do_print_stack) {
781 //debugBelch("\n-- BEGIN stack\n");
782 //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
783 //debugBelch("-- END stack\n\n");
785 debugBelch("Sp = %p pc = %d ", Sp, bciPtr);
786 disInstr(bco,bciPtr);
789 for (i = 8; i >= 0; i--) {
790 debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i)));
794 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
798 INTERP_TICK(it_insns);
801 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
802 it_ofreq[ (int)instrs[bciPtr] ] ++;
803 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
804 it_lastopc = (int)instrs[bciPtr];
808 /* We use the high 8 bits for flags, only the highest of which is
809 * currently allocated */
810 ASSERT((bci & 0xFF00) == (bci & 0x8000));
812 switch (bci & 0xFF) {
814 /* check for a breakpoint on the beginning of a let binding */
817 int arg1_brk_array, arg2_array_index, arg3_freeVars;
818 StgArrWords *breakPoints;
819 int returning_from_break; // are we resuming execution from a breakpoint?
820 // if yes, then don't break this time around
821 StgClosure *ioAction; // the io action to run at a breakpoint
823 StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap
827 arg1_brk_array = BCO_NEXT; // 1st arg of break instruction
828 arg2_array_index = BCO_NEXT; // 2nd arg of break instruction
829 arg3_freeVars = BCO_NEXT; // 3rd arg of break instruction
831 // check if we are returning from a breakpoint - this info
832 // is stored in the flags field of the current TSO
833 returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
835 // if we are returning from a break then skip this section
836 // and continue executing
837 if (!returning_from_break)
839 breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
841 // stop the current thread if either the
842 // "rts_stop_next_breakpoint" flag is true OR if the
843 // breakpoint flag for this particular expression is
845 if (rts_stop_next_breakpoint == rtsTrue ||
846 breakPoints->payload[arg2_array_index] == rtsTrue)
848 // make sure we don't automatically stop at the
850 rts_stop_next_breakpoint = rtsFalse;
852 // allocate memory for a new AP_STACK, enough to
853 // store the top stack frame plus an
854 // stg_apply_interp_info pointer and a pointer to
856 size_words = BCO_BITMAP_SIZE(obj) + 2;
857 new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words));
858 SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
859 new_aps->size = size_words;
860 new_aps->fun = &stg_dummy_ret_closure;
862 // fill in the payload of the AP_STACK
863 new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
864 new_aps->payload[1] = (StgClosure *)obj;
866 // copy the contents of the top stack frame into the AP_STACK
867 for (i = 2; i < size_words; i++)
869 new_aps->payload[i] = (StgClosure *)Sp[i-2];
872 // prepare the stack so that we can call the
873 // rts_breakpoint_io_action and ensure that the stack is
874 // in a reasonable state for the GC and so that
875 // execution of this BCO can continue when we resume
876 ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
879 Sp[7] = (W_)&stg_apply_interp_info;
880 Sp[6] = (W_)&stg_noforceIO_info; // see [unreg] below
881 Sp[5] = (W_)new_aps; // the AP_STACK
882 Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
883 Sp[3] = (W_)False_closure; // True <=> a breakpoint
884 Sp[2] = (W_)&stg_ap_pppv_info;
885 Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
886 Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
887 // Note [unreg]: in unregisterised mode, the return
888 // convention for IO is different. The
889 // stg_noForceIO_info stack frame is necessary to
890 // account for this difference.
892 // set the flag in the TSO to say that we are now
893 // stopping at a breakpoint so that when we resume
894 // we don't stop on the same breakpoint that we
895 // already stopped at just now
896 cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
898 // stop this thread and return to the scheduler -
899 // eventually we will come back and the IO action on
900 // the top of the stack will be executed
901 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
904 // record that this thread is not stopped at a breakpoint anymore
905 cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
907 // continue normal execution of the byte code instructions
912 // Explicit stack check at the beginning of a function
913 // *only* (stack checks in case alternatives are
914 // propagated to the enclosing function).
915 StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
916 if (Sp - stk_words_reqd < SpLim) {
919 Sp[0] = (W_)&stg_apply_interp_info;
920 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
955 Sp[-1] = BCO_PTR(o1);
960 case bci_PUSH_ALTS: {
961 int o_bco = BCO_NEXT;
962 Sp[-2] = (W_)&stg_ctoi_R1p_info;
963 Sp[-1] = BCO_PTR(o_bco);
968 case bci_PUSH_ALTS_P: {
969 int o_bco = BCO_NEXT;
970 Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
971 Sp[-1] = BCO_PTR(o_bco);
976 case bci_PUSH_ALTS_N: {
977 int o_bco = BCO_NEXT;
978 Sp[-2] = (W_)&stg_ctoi_R1n_info;
979 Sp[-1] = BCO_PTR(o_bco);
984 case bci_PUSH_ALTS_F: {
985 int o_bco = BCO_NEXT;
986 Sp[-2] = (W_)&stg_ctoi_F1_info;
987 Sp[-1] = BCO_PTR(o_bco);
992 case bci_PUSH_ALTS_D: {
993 int o_bco = BCO_NEXT;
994 Sp[-2] = (W_)&stg_ctoi_D1_info;
995 Sp[-1] = BCO_PTR(o_bco);
1000 case bci_PUSH_ALTS_L: {
1001 int o_bco = BCO_NEXT;
1002 Sp[-2] = (W_)&stg_ctoi_L1_info;
1003 Sp[-1] = BCO_PTR(o_bco);
1008 case bci_PUSH_ALTS_V: {
1009 int o_bco = BCO_NEXT;
1010 Sp[-2] = (W_)&stg_ctoi_V_info;
1011 Sp[-1] = BCO_PTR(o_bco);
1016 case bci_PUSH_APPLY_N:
1017 Sp--; Sp[0] = (W_)&stg_ap_n_info;
1019 case bci_PUSH_APPLY_V:
1020 Sp--; Sp[0] = (W_)&stg_ap_v_info;
1022 case bci_PUSH_APPLY_F:
1023 Sp--; Sp[0] = (W_)&stg_ap_f_info;
1025 case bci_PUSH_APPLY_D:
1026 Sp--; Sp[0] = (W_)&stg_ap_d_info;
1028 case bci_PUSH_APPLY_L:
1029 Sp--; Sp[0] = (W_)&stg_ap_l_info;
1031 case bci_PUSH_APPLY_P:
1032 Sp--; Sp[0] = (W_)&stg_ap_p_info;
1034 case bci_PUSH_APPLY_PP:
1035 Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1037 case bci_PUSH_APPLY_PPP:
1038 Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1040 case bci_PUSH_APPLY_PPPP:
1041 Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1043 case bci_PUSH_APPLY_PPPPP:
1044 Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1046 case bci_PUSH_APPLY_PPPPPP:
1047 Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1050 case bci_PUSH_UBX: {
1052 int o_lits = BCO_NEXT;
1053 int n_words = BCO_NEXT;
1055 for (i = 0; i < n_words; i++) {
1056 Sp[i] = (W_)BCO_LIT(o_lits+i);
1064 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1069 INTERP_TICK(it_slides);
1073 case bci_ALLOC_AP: {
1075 int n_payload = BCO_NEXT;
1076 ap = (StgAP*)allocate(AP_sizeW(n_payload));
1078 ap->n_args = n_payload;
1079 SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
1084 case bci_ALLOC_AP_NOUPD: {
1086 int n_payload = BCO_NEXT;
1087 ap = (StgAP*)allocate(AP_sizeW(n_payload));
1089 ap->n_args = n_payload;
1090 SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
1095 case bci_ALLOC_PAP: {
1097 int arity = BCO_NEXT;
1098 int n_payload = BCO_NEXT;
1099 pap = (StgPAP*)allocate(PAP_sizeW(n_payload));
1101 pap->n_args = n_payload;
1103 SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
1110 int stkoff = BCO_NEXT;
1111 int n_payload = BCO_NEXT;
1112 StgAP* ap = (StgAP*)Sp[stkoff];
1113 ASSERT((int)ap->n_args == n_payload);
1114 ap->fun = (StgClosure*)Sp[0];
1116 // The function should be a BCO, and its bitmap should
1117 // cover the payload of the AP correctly.
1118 ASSERT(get_itbl(ap->fun)->type == BCO
1119 && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1121 for (i = 0; i < n_payload; i++)
1122 ap->payload[i] = (StgClosure*)Sp[i+1];
1124 IF_DEBUG(interpreter,
1125 debugBelch("\tBuilt ");
1126 printObj((StgClosure*)ap);
1133 int stkoff = BCO_NEXT;
1134 int n_payload = BCO_NEXT;
1135 StgPAP* pap = (StgPAP*)Sp[stkoff];
1136 ASSERT((int)pap->n_args == n_payload);
1137 pap->fun = (StgClosure*)Sp[0];
1139 // The function should be a BCO
1140 ASSERT(get_itbl(pap->fun)->type == BCO);
1142 for (i = 0; i < n_payload; i++)
1143 pap->payload[i] = (StgClosure*)Sp[i+1];
1145 IF_DEBUG(interpreter,
1146 debugBelch("\tBuilt ");
1147 printObj((StgClosure*)pap);
1153 /* Unpack N ptr words from t.o.s constructor */
1155 int n_words = BCO_NEXT;
1156 StgClosure* con = (StgClosure*)Sp[0];
1158 for (i = 0; i < n_words; i++) {
1159 Sp[i] = (W_)con->payload[i];
1166 int o_itbl = BCO_NEXT;
1167 int n_words = BCO_NEXT;
1168 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
1169 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
1170 itbl->layout.payload.nptrs );
1171 StgClosure* con = (StgClosure*)allocate_NONUPD(request);
1172 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1173 SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
1174 for (i = 0; i < n_words; i++) {
1175 con->payload[i] = (StgClosure*)Sp[i];
1180 IF_DEBUG(interpreter,
1181 debugBelch("\tBuilt ");
1182 printObj((StgClosure*)con);
1187 case bci_TESTLT_P: {
1188 unsigned int discr = BCO_NEXT;
1189 int failto = BCO_NEXT;
1190 StgClosure* con = (StgClosure*)Sp[0];
1191 if (GET_TAG(con) >= discr) {
1197 case bci_TESTEQ_P: {
1198 unsigned int discr = BCO_NEXT;
1199 int failto = BCO_NEXT;
1200 StgClosure* con = (StgClosure*)Sp[0];
1201 if (GET_TAG(con) != discr) {
1207 case bci_TESTLT_I: {
1208 // There should be an Int at Sp[1], and an info table at Sp[0].
1209 int discr = BCO_NEXT;
1210 int failto = BCO_NEXT;
1211 I_ stackInt = (I_)Sp[1];
1212 if (stackInt >= (I_)BCO_LIT(discr))
1217 case bci_TESTEQ_I: {
1218 // There should be an Int at Sp[1], and an info table at Sp[0].
1219 int discr = BCO_NEXT;
1220 int failto = BCO_NEXT;
1221 I_ stackInt = (I_)Sp[1];
1222 if (stackInt != (I_)BCO_LIT(discr)) {
1228 case bci_TESTLT_D: {
1229 // There should be a Double at Sp[1], and an info table at Sp[0].
1230 int discr = BCO_NEXT;
1231 int failto = BCO_NEXT;
1232 StgDouble stackDbl, discrDbl;
1233 stackDbl = PK_DBL( & Sp[1] );
1234 discrDbl = PK_DBL( & BCO_LIT(discr) );
1235 if (stackDbl >= discrDbl) {
1241 case bci_TESTEQ_D: {
1242 // There should be a Double at Sp[1], and an info table at Sp[0].
1243 int discr = BCO_NEXT;
1244 int failto = BCO_NEXT;
1245 StgDouble stackDbl, discrDbl;
1246 stackDbl = PK_DBL( & Sp[1] );
1247 discrDbl = PK_DBL( & BCO_LIT(discr) );
1248 if (stackDbl != discrDbl) {
1254 case bci_TESTLT_F: {
1255 // There should be a Float at Sp[1], and an info table at Sp[0].
1256 int discr = BCO_NEXT;
1257 int failto = BCO_NEXT;
1258 StgFloat stackFlt, discrFlt;
1259 stackFlt = PK_FLT( & Sp[1] );
1260 discrFlt = PK_FLT( & BCO_LIT(discr) );
1261 if (stackFlt >= discrFlt) {
1267 case bci_TESTEQ_F: {
1268 // There should be a Float at Sp[1], and an info table at Sp[0].
1269 int discr = BCO_NEXT;
1270 int failto = BCO_NEXT;
1271 StgFloat stackFlt, discrFlt;
1272 stackFlt = PK_FLT( & Sp[1] );
1273 discrFlt = PK_FLT( & BCO_LIT(discr) );
1274 if (stackFlt != discrFlt) {
1280 // Control-flow ish things
1282 // Context-switch check. We put it here to ensure that
1283 // the interpreter has done at least *some* work before
1284 // context switching: sometimes the scheduler can invoke
1285 // the interpreter with context_switch == 1, particularly
1286 // if the -C0 flag has been given on the cmd line.
1287 if (cap->r.rHpLim == NULL) {
1288 Sp--; Sp[0] = (W_)&stg_enter_info;
1289 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1294 tagged_obj = (StgClosure *)Sp[0];
1300 Sp[0] = (W_)&stg_gc_unpt_r1_info;
1301 goto do_return_unboxed;
1304 Sp[0] = (W_)&stg_gc_unbx_r1_info;
1305 goto do_return_unboxed;
1308 Sp[0] = (W_)&stg_gc_f1_info;
1309 goto do_return_unboxed;
1312 Sp[0] = (W_)&stg_gc_d1_info;
1313 goto do_return_unboxed;
1316 Sp[0] = (W_)&stg_gc_l1_info;
1317 goto do_return_unboxed;
1320 Sp[0] = (W_)&stg_gc_void_info;
1321 goto do_return_unboxed;
1324 int stkoff = BCO_NEXT;
1325 signed short n = (signed short)(BCO_NEXT);
1326 Sp[stkoff] += (W_)n;
1332 int stk_offset = BCO_NEXT;
1333 int o_itbl = BCO_NEXT;
1334 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1336 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1337 + sizeofW(StgRetDyn);
1339 /* the stack looks like this:
1341 | | <- Sp + stk_offset
1345 | | <- Sp + ret_size + 1
1347 | C fun | <- Sp + ret_size
1352 ret is a placeholder for the return address, and may be
1355 We need to copy the args out of the TSO, because when
1356 we call suspendThread() we no longer own the TSO stack,
1357 and it may move at any time - indeed suspendThread()
1358 itself may do stack squeezing and move our args.
1359 So we make a copy of the argument block.
1362 #define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1364 ffi_cif *cif = (ffi_cif *)marshall_fn;
1365 nat nargs = cif->nargs;
1369 W_ ret[2]; // max needed
1370 W_ *arguments[stk_offset]; // max needed
1371 void *argptrs[nargs];
1374 if (cif->rtype->type == FFI_TYPE_VOID) {
1375 // necessary because cif->rtype->size == 1 for void,
1376 // but the bytecode generator has not pushed a
1377 // placeholder in this case.
1380 ret_size = ROUND_UP_WDS(cif->rtype->size);
1383 memcpy(arguments, Sp+ret_size+1,
1384 sizeof(W_) * (stk_offset-1-ret_size));
1386 // libffi expects the args as an array of pointers to
1387 // values, so we have to construct this array before making
1389 p = (StgPtr)arguments;
1390 for (i = 0; i < nargs; i++) {
1391 argptrs[i] = (void *)p;
1392 // get the size from the cif
1393 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1396 // this is the function we're going to call
1397 fn = (void(*)(void))Sp[ret_size];
1399 // Restore the Haskell thread's current value of errno
1400 errno = cap->r.rCurrentTSO->saved_errno;
1402 // There are a bunch of non-ptr words on the stack (the
1403 // ccall args, the ccall fun address and space for the
1404 // result), which we need to cover with an info table
1405 // since we might GC during this call.
1407 // We know how many (non-ptr) words there are before the
1408 // next valid stack frame: it is the stk_offset arg to the
1409 // CCALL instruction. So we build a RET_DYN stack frame
1410 // on the stack frame to describe this chunk of stack.
1413 ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset);
1414 ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1416 // save obj (pointer to the current BCO), since this
1417 // might move during the call. We use the R1 slot in the
1418 // RET_DYN frame for this, hence R1_PTR above.
1419 ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
1421 SAVE_STACK_POINTERS;
1422 tok = suspendThread(&cap->r);
1424 // We already made a copy of the arguments above.
1425 ffi_call(cif, fn, ret, argptrs);
1427 // And restart the thread again, popping the RET_DYN frame.
1428 cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
1429 LOAD_STACK_POINTERS;
1431 // Re-load the pointer to the BCO from the RET_DYN frame,
1432 // it might have moved during the call. Also reload the
1433 // pointers to the components of the BCO.
1434 obj = ((StgRetDyn *)Sp)->payload[0];
1436 instrs = (StgWord16*)(bco->instrs->payload);
1437 literals = (StgWord*)(&bco->literals->payload[0]);
1438 ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
1442 // Save the Haskell thread's current value of errno
1443 cap->r.rCurrentTSO->saved_errno = errno;
1445 // Copy the return value back to the TSO stack. It is at
1446 // most 2 words large, and resides at arguments[0].
1447 memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1453 /* BCO_NEXT modifies bciPtr, so be conservative. */
1454 int nextpc = BCO_NEXT;
1460 barf("interpretBCO: hit a CASEFAIL");
1464 barf("interpretBCO: unknown or unimplemented opcode %d",
1467 } /* switch on opcode */
1471 barf("interpretBCO: fell off end of the interpreter");