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 // ------------------------------------------------------------------------
202 // We have a closure to evaluate. Stack looks like:
206 // Sp | -------------------> closure
209 if (Sp[0] == (W_)&stg_enter_info) {
214 // ------------------------------------------------------------------------
217 // We have a BCO application to perform. Stack looks like:
228 else if (Sp[0] == (W_)&stg_apply_interp_info) {
229 obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
234 // ------------------------------------------------------------------------
237 // We have an unboxed value to return. See comment before
238 // do_return_unboxed, below.
241 goto do_return_unboxed;
244 // Evaluate the object on top of the stack.
246 tagged_obj = (StgClosure*)Sp[0]; Sp++;
249 obj = UNTAG_CLOSURE(tagged_obj);
250 INTERP_TICK(it_total_evals);
252 IF_DEBUG(interpreter,
254 "\n---------------------------------------------------------------\n");
255 debugBelch("Evaluating: "); printObj(obj);
256 debugBelch("Sp = %p\n", Sp);
259 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
263 IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
265 switch ( get_itbl(obj)->type ) {
270 case IND_OLDGEN_PERM:
273 tagged_obj = ((StgInd*)obj)->indirectee;
284 case CONSTR_NOCAF_STATIC:
298 ASSERT(((StgBCO *)obj)->arity > 0);
302 case AP: /* Copied from stg_AP_entry. */
311 if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
313 Sp[1] = (W_)tagged_obj;
314 Sp[0] = (W_)&stg_enter_info;
315 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
318 /* Ok; we're safe. Party on. Push an update frame. */
319 Sp -= sizeofW(StgUpdateFrame);
321 StgUpdateFrame *__frame;
322 __frame = (StgUpdateFrame *)Sp;
323 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
324 __frame->updatee = (StgClosure *)(ap);
327 /* Reload the stack */
329 for (i=0; i < words; i++) {
330 Sp[i] = (W_)ap->payload[i];
333 obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
334 ASSERT(get_itbl(obj)->type == BCO);
343 j = get_itbl(obj)->type;
344 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
345 it_unknown_entries[j]++;
346 it_total_unknown_entries++;
350 // Can't handle this object; yield to scheduler
351 IF_DEBUG(interpreter,
352 debugBelch("evaluating unknown closure -- yielding to sched\n");
356 Sp[1] = (W_)tagged_obj;
357 Sp[0] = (W_)&stg_enter_info;
358 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
362 // ------------------------------------------------------------------------
363 // We now have an evaluated object (tagged_obj). The next thing to
364 // do is return it to the stack frame on top of the stack.
366 obj = UNTAG_CLOSURE(tagged_obj);
367 ASSERT(closure_HNF(obj));
369 IF_DEBUG(interpreter,
371 "\n---------------------------------------------------------------\n");
372 debugBelch("Returning: "); printObj(obj);
373 debugBelch("Sp = %p\n", Sp);
375 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
379 IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
381 switch (get_itbl((StgClosure *)Sp)->type) {
384 const StgInfoTable *info;
386 // NOTE: not using get_itbl().
387 info = ((StgClosure *)Sp)->header.info;
388 if (info == (StgInfoTable *)&stg_ap_v_info) {
389 n = 1; m = 0; goto do_apply;
391 if (info == (StgInfoTable *)&stg_ap_f_info) {
392 n = 1; m = 1; goto do_apply;
394 if (info == (StgInfoTable *)&stg_ap_d_info) {
395 n = 1; m = sizeofW(StgDouble); goto do_apply;
397 if (info == (StgInfoTable *)&stg_ap_l_info) {
398 n = 1; m = sizeofW(StgInt64); goto do_apply;
400 if (info == (StgInfoTable *)&stg_ap_n_info) {
401 n = 1; m = 1; goto do_apply;
403 if (info == (StgInfoTable *)&stg_ap_p_info) {
404 n = 1; m = 1; goto do_apply;
406 if (info == (StgInfoTable *)&stg_ap_pp_info) {
407 n = 2; m = 2; goto do_apply;
409 if (info == (StgInfoTable *)&stg_ap_ppp_info) {
410 n = 3; m = 3; goto do_apply;
412 if (info == (StgInfoTable *)&stg_ap_pppp_info) {
413 n = 4; m = 4; goto do_apply;
415 if (info == (StgInfoTable *)&stg_ap_ppppp_info) {
416 n = 5; m = 5; goto do_apply;
418 if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
419 n = 6; m = 6; goto do_apply;
421 goto do_return_unrecognised;
425 // Returning to an update frame: do the update, pop the update
426 // frame, and continue with the next stack frame.
428 // NB. we must update with the *tagged* pointer. Some tags
429 // are not optional, and if we omit the tag bits when updating
430 // then bad things can happen (albeit very rarely). See #1925.
431 // What happened was an indirection was created with an
432 // untagged pointer, and this untagged pointer was propagated
433 // to a PAP by the GC, violating the invariant that PAPs
434 // always contain a tagged pointer to the function.
435 INTERP_TICK(it_retto_UPDATE);
436 UPD_IND(((StgUpdateFrame *)Sp)->updatee, tagged_obj);
437 Sp += sizeofW(StgUpdateFrame);
441 // Returning to an interpreted continuation: put the object on
442 // the stack, and start executing the BCO.
443 INTERP_TICK(it_retto_BCO);
446 // NB. return the untagged object; the bytecode expects it to
447 // be untagged. XXX this doesn't seem right.
448 obj = (StgClosure*)Sp[2];
449 ASSERT(get_itbl(obj)->type == BCO);
453 do_return_unrecognised:
455 // Can't handle this return address; yield to scheduler
456 INTERP_TICK(it_retto_other);
457 IF_DEBUG(interpreter,
458 debugBelch("returning to unknown frame -- yielding to sched\n");
459 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
462 Sp[1] = (W_)tagged_obj;
463 Sp[0] = (W_)&stg_enter_info;
464 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
468 // -------------------------------------------------------------------------
469 // Returning an unboxed value. The stack looks like this:
486 // where XXXX_info is one of the stg_gc_unbx_r1_info family.
488 // We're only interested in the case when the real return address
489 // is a BCO; otherwise we'll return to the scheduler.
495 ASSERT( Sp[0] == (W_)&stg_gc_unbx_r1_info
496 || Sp[0] == (W_)&stg_gc_unpt_r1_info
497 || Sp[0] == (W_)&stg_gc_f1_info
498 || Sp[0] == (W_)&stg_gc_d1_info
499 || Sp[0] == (W_)&stg_gc_l1_info
500 || Sp[0] == (W_)&stg_gc_void_info // VoidRep
503 // get the offset of the stg_ctoi_ret_XXX itbl
504 offset = stack_frame_sizeW((StgClosure *)Sp);
506 switch (get_itbl((StgClosure *)Sp+offset)->type) {
509 // Returning to an interpreted continuation: put the object on
510 // the stack, and start executing the BCO.
511 INTERP_TICK(it_retto_BCO);
512 obj = (StgClosure*)Sp[offset+1];
513 ASSERT(get_itbl(obj)->type == BCO);
514 goto run_BCO_return_unboxed;
518 // Can't handle this return address; yield to scheduler
519 INTERP_TICK(it_retto_other);
520 IF_DEBUG(interpreter,
521 debugBelch("returning to unknown frame -- yielding to sched\n");
522 printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
524 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
531 // -------------------------------------------------------------------------
535 ASSERT(obj == UNTAG_CLOSURE(tagged_obj));
536 // we have a function to apply (obj), and n arguments taking up m
537 // words on the stack. The info table (stg_ap_pp_info or whatever)
538 // is on top of the arguments on the stack.
540 switch (get_itbl(obj)->type) {
548 // we only cope with PAPs whose function is a BCO
549 if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) {
550 goto defer_apply_to_sched;
553 // Stack check: we're about to unpack the PAP onto the
554 // stack. The (+1) is for the (arity < n) case, where we
555 // also need space for an extra info pointer.
556 if (Sp - (pap->n_args + 1) < SpLim) {
558 Sp[1] = (W_)tagged_obj;
559 Sp[0] = (W_)&stg_enter_info;
560 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
567 // n must be greater than 1, and the only kinds of
568 // application we support with more than one argument
569 // are all pointers...
571 // Shuffle the args for this function down, and put
572 // the appropriate info table in the gap.
573 for (i = 0; i < arity; i++) {
574 Sp[(int)i-1] = Sp[i];
575 // ^^^^^ careful, i-1 might be negative, but i in unsigned
577 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
579 // unpack the PAP's arguments onto the stack
581 for (i = 0; i < pap->n_args; i++) {
582 Sp[i] = (W_)pap->payload[i];
584 obj = UNTAG_CLOSURE(pap->fun);
587 else if (arity == n) {
589 for (i = 0; i < pap->n_args; i++) {
590 Sp[i] = (W_)pap->payload[i];
592 obj = UNTAG_CLOSURE(pap->fun);
595 else /* arity > n */ {
596 // build a new PAP and return it.
598 new_pap = (StgPAP *)allocate(PAP_sizeW(pap->n_args + m));
599 SET_HDR(new_pap,&stg_PAP_info,CCCS);
600 new_pap->arity = pap->arity - n;
601 new_pap->n_args = pap->n_args + m;
602 new_pap->fun = pap->fun;
603 for (i = 0; i < pap->n_args; i++) {
604 new_pap->payload[i] = pap->payload[i];
606 for (i = 0; i < m; i++) {
607 new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
609 tagged_obj = (StgClosure *)new_pap;
619 arity = ((StgBCO *)obj)->arity;
622 // n must be greater than 1, and the only kinds of
623 // application we support with more than one argument
624 // are all pointers...
626 // Shuffle the args for this function down, and put
627 // the appropriate info table in the gap.
628 for (i = 0; i < arity; i++) {
629 Sp[(int)i-1] = Sp[i];
630 // ^^^^^ careful, i-1 might be negative, but i in unsigned
632 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
636 else if (arity == n) {
639 else /* arity > n */ {
640 // build a PAP and return it.
643 pap = (StgPAP *)allocate(PAP_sizeW(m));
644 SET_HDR(pap, &stg_PAP_info,CCCS);
645 pap->arity = arity - n;
648 for (i = 0; i < m; i++) {
649 pap->payload[i] = (StgClosure *)Sp[i];
651 tagged_obj = (StgClosure *)pap;
657 // No point in us applying machine-code functions
659 defer_apply_to_sched:
661 Sp[1] = (W_)tagged_obj;
662 Sp[0] = (W_)&stg_enter_info;
663 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
666 // ------------------------------------------------------------------------
667 // Ok, we now have a bco (obj), and its arguments are all on the
668 // stack. We can start executing the byte codes.
670 // The stack is in one of two states. First, if this BCO is a
680 // Second, if this BCO is a continuation:
695 // where retval is the value being returned to this continuation.
696 // In the event of a stack check, heap check, or context switch,
697 // we need to leave the stack in a sane state so the garbage
698 // collector can find all the pointers.
700 // (1) BCO is a function: the BCO's bitmap describes the
701 // pointerhood of the arguments.
703 // (2) BCO is a continuation: BCO's bitmap describes the
704 // pointerhood of the free variables.
706 // Sadly we have three different kinds of stack/heap/cswitch check
712 if (doYouWantToGC()) {
713 Sp--; Sp[0] = (W_)&stg_enter_info;
714 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
716 // Stack checks aren't necessary at return points, the stack use
717 // is aggregated into the enclosing function entry point.
721 run_BCO_return_unboxed:
723 if (doYouWantToGC()) {
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.
735 Sp[0] = (W_)&stg_apply_interp_info;
736 checkStackChunk(Sp,SpLim);
741 if (doYouWantToGC()) {
744 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
745 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
749 if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
752 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
753 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
758 // Now, actually interpret the BCO... (no returning to the
759 // scheduler again until the stack is in an orderly state).
761 INTERP_TICK(it_BCO_entries);
763 register int bciPtr = 1; /* instruction pointer */
764 register StgWord16 bci;
765 register StgBCO* bco = (StgBCO*)obj;
766 register StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
767 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
768 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
771 it_lastopc = 0; /* no opcode */
775 ASSERT(bciPtr <= instrs[0]);
776 IF_DEBUG(interpreter,
777 //if (do_print_stack) {
778 //debugBelch("\n-- BEGIN stack\n");
779 //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
780 //debugBelch("-- END stack\n\n");
782 debugBelch("Sp = %p pc = %d ", Sp, bciPtr);
783 disInstr(bco,bciPtr);
786 for (i = 8; i >= 0; i--) {
787 debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i)));
791 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
795 INTERP_TICK(it_insns);
798 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
799 it_ofreq[ (int)instrs[bciPtr] ] ++;
800 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
801 it_lastopc = (int)instrs[bciPtr];
805 /* We use the high 8 bits for flags, only the highest of which is
806 * currently allocated */
807 ASSERT((bci & 0xFF00) == (bci & 0x8000));
809 switch (bci & 0xFF) {
811 /* check for a breakpoint on the beginning of a let binding */
814 int arg1_brk_array, arg2_array_index, arg3_freeVars;
815 StgArrWords *breakPoints;
816 int returning_from_break; // are we resuming execution from a breakpoint?
817 // if yes, then don't break this time around
818 StgClosure *ioAction; // the io action to run at a breakpoint
820 StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap
824 arg1_brk_array = BCO_NEXT; // 1st arg of break instruction
825 arg2_array_index = BCO_NEXT; // 2nd arg of break instruction
826 arg3_freeVars = BCO_NEXT; // 3rd arg of break instruction
828 // check if we are returning from a breakpoint - this info
829 // is stored in the flags field of the current TSO
830 returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
832 // if we are returning from a break then skip this section
833 // and continue executing
834 if (!returning_from_break)
836 breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
838 // stop the current thread if either the
839 // "rts_stop_next_breakpoint" flag is true OR if the
840 // breakpoint flag for this particular expression is
842 if (rts_stop_next_breakpoint == rtsTrue ||
843 breakPoints->payload[arg2_array_index] == rtsTrue)
845 // make sure we don't automatically stop at the
847 rts_stop_next_breakpoint = rtsFalse;
849 // allocate memory for a new AP_STACK, enough to
850 // store the top stack frame plus an
851 // stg_apply_interp_info pointer and a pointer to
853 size_words = BCO_BITMAP_SIZE(obj) + 2;
854 new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words));
855 SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
856 new_aps->size = size_words;
857 new_aps->fun = &stg_dummy_ret_closure;
859 // fill in the payload of the AP_STACK
860 new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
861 new_aps->payload[1] = (StgClosure *)obj;
863 // copy the contents of the top stack frame into the AP_STACK
864 for (i = 2; i < size_words; i++)
866 new_aps->payload[i] = (StgClosure *)Sp[i-2];
869 // prepare the stack so that we can call the
870 // rts_breakpoint_io_action and ensure that the stack is
871 // in a reasonable state for the GC and so that
872 // execution of this BCO can continue when we resume
873 ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
876 Sp[7] = (W_)&stg_apply_interp_info;
877 Sp[6] = (W_)&stg_noforceIO_info; // see [unreg] below
878 Sp[5] = (W_)new_aps; // the AP_STACK
879 Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
880 Sp[3] = (W_)False_closure; // True <=> a breakpoint
881 Sp[2] = (W_)&stg_ap_pppv_info;
882 Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
883 Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
884 // Note [unreg]: in unregisterised mode, the return
885 // convention for IO is different. The
886 // stg_noForceIO_info stack frame is necessary to
887 // account for this difference.
889 // set the flag in the TSO to say that we are now
890 // stopping at a breakpoint so that when we resume
891 // we don't stop on the same breakpoint that we
892 // already stopped at just now
893 cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
895 // stop this thread and return to the scheduler -
896 // eventually we will come back and the IO action on
897 // the top of the stack will be executed
898 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
901 // record that this thread is not stopped at a breakpoint anymore
902 cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
904 // continue normal execution of the byte code instructions
909 // Explicit stack check at the beginning of a function
910 // *only* (stack checks in case alternatives are
911 // propagated to the enclosing function).
912 StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
913 if (Sp - stk_words_reqd < SpLim) {
916 Sp[0] = (W_)&stg_apply_interp_info;
917 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
952 Sp[-1] = BCO_PTR(o1);
957 case bci_PUSH_ALTS: {
958 int o_bco = BCO_NEXT;
959 Sp[-2] = (W_)&stg_ctoi_R1p_info;
960 Sp[-1] = BCO_PTR(o_bco);
965 case bci_PUSH_ALTS_P: {
966 int o_bco = BCO_NEXT;
967 Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
968 Sp[-1] = BCO_PTR(o_bco);
973 case bci_PUSH_ALTS_N: {
974 int o_bco = BCO_NEXT;
975 Sp[-2] = (W_)&stg_ctoi_R1n_info;
976 Sp[-1] = BCO_PTR(o_bco);
981 case bci_PUSH_ALTS_F: {
982 int o_bco = BCO_NEXT;
983 Sp[-2] = (W_)&stg_ctoi_F1_info;
984 Sp[-1] = BCO_PTR(o_bco);
989 case bci_PUSH_ALTS_D: {
990 int o_bco = BCO_NEXT;
991 Sp[-2] = (W_)&stg_ctoi_D1_info;
992 Sp[-1] = BCO_PTR(o_bco);
997 case bci_PUSH_ALTS_L: {
998 int o_bco = BCO_NEXT;
999 Sp[-2] = (W_)&stg_ctoi_L1_info;
1000 Sp[-1] = BCO_PTR(o_bco);
1005 case bci_PUSH_ALTS_V: {
1006 int o_bco = BCO_NEXT;
1007 Sp[-2] = (W_)&stg_ctoi_V_info;
1008 Sp[-1] = BCO_PTR(o_bco);
1013 case bci_PUSH_APPLY_N:
1014 Sp--; Sp[0] = (W_)&stg_ap_n_info;
1016 case bci_PUSH_APPLY_V:
1017 Sp--; Sp[0] = (W_)&stg_ap_v_info;
1019 case bci_PUSH_APPLY_F:
1020 Sp--; Sp[0] = (W_)&stg_ap_f_info;
1022 case bci_PUSH_APPLY_D:
1023 Sp--; Sp[0] = (W_)&stg_ap_d_info;
1025 case bci_PUSH_APPLY_L:
1026 Sp--; Sp[0] = (W_)&stg_ap_l_info;
1028 case bci_PUSH_APPLY_P:
1029 Sp--; Sp[0] = (W_)&stg_ap_p_info;
1031 case bci_PUSH_APPLY_PP:
1032 Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1034 case bci_PUSH_APPLY_PPP:
1035 Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1037 case bci_PUSH_APPLY_PPPP:
1038 Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1040 case bci_PUSH_APPLY_PPPPP:
1041 Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1043 case bci_PUSH_APPLY_PPPPPP:
1044 Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1047 case bci_PUSH_UBX: {
1049 int o_lits = BCO_NEXT;
1050 int n_words = BCO_NEXT;
1052 for (i = 0; i < n_words; i++) {
1053 Sp[i] = (W_)BCO_LIT(o_lits+i);
1061 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1066 INTERP_TICK(it_slides);
1070 case bci_ALLOC_AP: {
1072 int n_payload = BCO_NEXT;
1073 ap = (StgAP*)allocate(AP_sizeW(n_payload));
1075 ap->n_args = n_payload;
1076 SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
1081 case bci_ALLOC_AP_NOUPD: {
1083 int n_payload = BCO_NEXT;
1084 ap = (StgAP*)allocate(AP_sizeW(n_payload));
1086 ap->n_args = n_payload;
1087 SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
1092 case bci_ALLOC_PAP: {
1094 int arity = BCO_NEXT;
1095 int n_payload = BCO_NEXT;
1096 pap = (StgPAP*)allocate(PAP_sizeW(n_payload));
1098 pap->n_args = n_payload;
1100 SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
1107 int stkoff = BCO_NEXT;
1108 int n_payload = BCO_NEXT;
1109 StgAP* ap = (StgAP*)Sp[stkoff];
1110 ASSERT((int)ap->n_args == n_payload);
1111 ap->fun = (StgClosure*)Sp[0];
1113 // The function should be a BCO, and its bitmap should
1114 // cover the payload of the AP correctly.
1115 ASSERT(get_itbl(ap->fun)->type == BCO
1116 && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1118 for (i = 0; i < n_payload; i++)
1119 ap->payload[i] = (StgClosure*)Sp[i+1];
1121 IF_DEBUG(interpreter,
1122 debugBelch("\tBuilt ");
1123 printObj((StgClosure*)ap);
1130 int stkoff = BCO_NEXT;
1131 int n_payload = BCO_NEXT;
1132 StgPAP* pap = (StgPAP*)Sp[stkoff];
1133 ASSERT((int)pap->n_args == n_payload);
1134 pap->fun = (StgClosure*)Sp[0];
1136 // The function should be a BCO
1137 ASSERT(get_itbl(pap->fun)->type == BCO);
1139 for (i = 0; i < n_payload; i++)
1140 pap->payload[i] = (StgClosure*)Sp[i+1];
1142 IF_DEBUG(interpreter,
1143 debugBelch("\tBuilt ");
1144 printObj((StgClosure*)pap);
1150 /* Unpack N ptr words from t.o.s constructor */
1152 int n_words = BCO_NEXT;
1153 StgClosure* con = (StgClosure*)Sp[0];
1155 for (i = 0; i < n_words; i++) {
1156 Sp[i] = (W_)con->payload[i];
1163 int o_itbl = BCO_NEXT;
1164 int n_words = BCO_NEXT;
1165 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
1166 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
1167 itbl->layout.payload.nptrs );
1168 StgClosure* con = (StgClosure*)allocate_NONUPD(request);
1169 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1170 SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
1171 for (i = 0; i < n_words; i++) {
1172 con->payload[i] = (StgClosure*)Sp[i];
1177 IF_DEBUG(interpreter,
1178 debugBelch("\tBuilt ");
1179 printObj((StgClosure*)con);
1184 case bci_TESTLT_P: {
1185 unsigned int discr = BCO_NEXT;
1186 int failto = BCO_NEXT;
1187 StgClosure* con = (StgClosure*)Sp[0];
1188 if (GET_TAG(con) >= discr) {
1194 case bci_TESTEQ_P: {
1195 unsigned int discr = BCO_NEXT;
1196 int failto = BCO_NEXT;
1197 StgClosure* con = (StgClosure*)Sp[0];
1198 if (GET_TAG(con) != discr) {
1204 case bci_TESTLT_I: {
1205 // There should be an Int at Sp[1], and an info table at Sp[0].
1206 int discr = BCO_NEXT;
1207 int failto = BCO_NEXT;
1208 I_ stackInt = (I_)Sp[1];
1209 if (stackInt >= (I_)BCO_LIT(discr))
1214 case bci_TESTEQ_I: {
1215 // There should be an Int at Sp[1], and an info table at Sp[0].
1216 int discr = BCO_NEXT;
1217 int failto = BCO_NEXT;
1218 I_ stackInt = (I_)Sp[1];
1219 if (stackInt != (I_)BCO_LIT(discr)) {
1225 case bci_TESTLT_D: {
1226 // There should be a Double at Sp[1], and an info table at Sp[0].
1227 int discr = BCO_NEXT;
1228 int failto = BCO_NEXT;
1229 StgDouble stackDbl, discrDbl;
1230 stackDbl = PK_DBL( & Sp[1] );
1231 discrDbl = PK_DBL( & BCO_LIT(discr) );
1232 if (stackDbl >= discrDbl) {
1238 case bci_TESTEQ_D: {
1239 // There should be a Double at Sp[1], and an info table at Sp[0].
1240 int discr = BCO_NEXT;
1241 int failto = BCO_NEXT;
1242 StgDouble stackDbl, discrDbl;
1243 stackDbl = PK_DBL( & Sp[1] );
1244 discrDbl = PK_DBL( & BCO_LIT(discr) );
1245 if (stackDbl != discrDbl) {
1251 case bci_TESTLT_F: {
1252 // There should be a Float at Sp[1], and an info table at Sp[0].
1253 int discr = BCO_NEXT;
1254 int failto = BCO_NEXT;
1255 StgFloat stackFlt, discrFlt;
1256 stackFlt = PK_FLT( & Sp[1] );
1257 discrFlt = PK_FLT( & BCO_LIT(discr) );
1258 if (stackFlt >= discrFlt) {
1264 case bci_TESTEQ_F: {
1265 // There should be a Float at Sp[1], and an info table at Sp[0].
1266 int discr = BCO_NEXT;
1267 int failto = BCO_NEXT;
1268 StgFloat stackFlt, discrFlt;
1269 stackFlt = PK_FLT( & Sp[1] );
1270 discrFlt = PK_FLT( & BCO_LIT(discr) );
1271 if (stackFlt != discrFlt) {
1277 // Control-flow ish things
1279 // Context-switch check. We put it here to ensure that
1280 // the interpreter has done at least *some* work before
1281 // context switching: sometimes the scheduler can invoke
1282 // the interpreter with context_switch == 1, particularly
1283 // if the -C0 flag has been given on the cmd line.
1284 if (cap->context_switch) {
1285 Sp--; Sp[0] = (W_)&stg_enter_info;
1286 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1291 tagged_obj = (StgClosure *)Sp[0];
1297 Sp[0] = (W_)&stg_gc_unpt_r1_info;
1298 goto do_return_unboxed;
1301 Sp[0] = (W_)&stg_gc_unbx_r1_info;
1302 goto do_return_unboxed;
1305 Sp[0] = (W_)&stg_gc_f1_info;
1306 goto do_return_unboxed;
1309 Sp[0] = (W_)&stg_gc_d1_info;
1310 goto do_return_unboxed;
1313 Sp[0] = (W_)&stg_gc_l1_info;
1314 goto do_return_unboxed;
1317 Sp[0] = (W_)&stg_gc_void_info;
1318 goto do_return_unboxed;
1321 int stkoff = BCO_NEXT;
1322 signed short n = (signed short)(BCO_NEXT);
1323 Sp[stkoff] += (W_)n;
1329 int stk_offset = BCO_NEXT;
1330 int o_itbl = BCO_NEXT;
1331 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1333 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1334 + sizeofW(StgRetDyn);
1336 /* the stack looks like this:
1338 | | <- Sp + stk_offset
1342 | | <- Sp + ret_size + 1
1344 | C fun | <- Sp + ret_size
1349 ret is a placeholder for the return address, and may be
1352 We need to copy the args out of the TSO, because when
1353 we call suspendThread() we no longer own the TSO stack,
1354 and it may move at any time - indeed suspendThread()
1355 itself may do stack squeezing and move our args.
1356 So we make a copy of the argument block.
1359 #define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1361 ffi_cif *cif = (ffi_cif *)marshall_fn;
1362 nat nargs = cif->nargs;
1366 W_ ret[2]; // max needed
1367 W_ *arguments[stk_offset]; // max needed
1368 void *argptrs[nargs];
1371 if (cif->rtype->type == FFI_TYPE_VOID) {
1372 // necessary because cif->rtype->size == 1 for void,
1373 // but the bytecode generator has not pushed a
1374 // placeholder in this case.
1377 ret_size = ROUND_UP_WDS(cif->rtype->size);
1380 memcpy(arguments, Sp+ret_size+1,
1381 sizeof(W_) * (stk_offset-1-ret_size));
1383 // libffi expects the args as an array of pointers to
1384 // values, so we have to construct this array before making
1386 p = (StgPtr)arguments;
1387 for (i = 0; i < nargs; i++) {
1388 argptrs[i] = (void *)p;
1389 // get the size from the cif
1390 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1393 // this is the function we're going to call
1394 fn = (void(*)(void))Sp[ret_size];
1396 // Restore the Haskell thread's current value of errno
1397 errno = cap->r.rCurrentTSO->saved_errno;
1399 // There are a bunch of non-ptr words on the stack (the
1400 // ccall args, the ccall fun address and space for the
1401 // result), which we need to cover with an info table
1402 // since we might GC during this call.
1404 // We know how many (non-ptr) words there are before the
1405 // next valid stack frame: it is the stk_offset arg to the
1406 // CCALL instruction. So we build a RET_DYN stack frame
1407 // on the stack frame to describe this chunk of stack.
1410 ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset);
1411 ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1413 // save obj (pointer to the current BCO), since this
1414 // might move during the call. We use the R1 slot in the
1415 // RET_DYN frame for this, hence R1_PTR above.
1416 ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
1418 SAVE_STACK_POINTERS;
1419 tok = suspendThread(&cap->r);
1421 // We already made a copy of the arguments above.
1422 ffi_call(cif, fn, ret, argptrs);
1424 // And restart the thread again, popping the RET_DYN frame.
1425 cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - sizeof(StgFunTable)));
1426 LOAD_STACK_POINTERS;
1428 // Re-load the pointer to the BCO from the RET_DYN frame,
1429 // it might have moved during the call. Also reload the
1430 // pointers to the components of the BCO.
1431 obj = ((StgRetDyn *)Sp)->payload[0];
1433 instrs = (StgWord16*)(bco->instrs->payload);
1434 literals = (StgWord*)(&bco->literals->payload[0]);
1435 ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
1439 // Save the Haskell thread's current value of errno
1440 cap->r.rCurrentTSO->saved_errno = errno;
1442 // Copy the return value back to the TSO stack. It is at
1443 // most 2 words large, and resides at arguments[0].
1444 memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1450 /* BCO_NEXT modifies bciPtr, so be conservative. */
1451 int nextpc = BCO_NEXT;
1457 barf("interpretBCO: hit a CASEFAIL");
1461 barf("interpretBCO: unknown or unimplemented opcode %d",
1464 } /* switch on opcode */
1468 barf("interpretBCO: fell off end of the interpreter");