2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Interpreter.c,v $
9 * $Date: 2002/02/15 22:15:08 $
10 * ---------------------------------------------------------------------------*/
13 #include "PosixSource.h"
15 /* Hack and slash.. */
28 #include "Bytecodes.h"
30 #include "Disassembler.h"
31 #include "Interpreter.h"
34 /* --------------------------------------------------------------------------
35 * The new bytecode interpreter
36 * ------------------------------------------------------------------------*/
38 /* The interpreter can be compiled so it just interprets BCOs and
39 hands literally everything else to the scheduler. This gives a
40 "reference interpreter" which is correct but slow -- useful for
41 debugging. By default, we handle certain closures specially so as
42 to dramatically cut down on the number of deferrals to the
43 scheduler. Ie normally you don't want REFERENCE_INTERPRETER to be
46 /* #define REFERENCE_INTERPRETER */
48 /* Gather stats about entry, opcode, opcode-pair frequencies. For
49 tuning the interpreter. */
51 /* #define INTERP_STATS */
55 /* iSp points to the lowest live word on the stack. */
57 #define StackWord(n) iSp[n]
58 #define BCO_NEXT instrs[bciPtr++]
59 #define BCO_PTR(n) (W_)ptrs[n]
60 #define BCO_LIT(n) (W_)literals[n]
61 #define BCO_ITBL(n) itbls[n]
63 #define LOAD_STACK_POINTERS \
64 iSp = cap->r.rCurrentTSO->sp; \
65 iSu = cap->r.rCurrentTSO->su; \
66 /* We don't change this ... */ \
67 iSpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
70 #define SAVE_STACK_POINTERS \
71 cap->r.rCurrentTSO->sp = iSp; \
72 cap->r.rCurrentTSO->su = iSu;
74 #define RETURN(retcode) \
75 SAVE_STACK_POINTERS; return retcode;
78 static __inline__ StgPtr allocate_UPD ( int n_words )
80 if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE)
81 n_words = MIN_UPD_SIZE + sizeofW(StgHeader);
82 return allocate(n_words);
85 static __inline__ StgPtr allocate_NONUPD ( int n_words )
87 if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
88 n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader);
89 return allocate(n_words);
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];
111 void interp_startup ( void )
114 it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
115 it_total_entries = it_total_unknown_entries = 0;
116 for (i = 0; i < N_CLOSURE_TYPES; i++)
117 it_unknown_entries[i] = 0;
118 it_slides = it_insns = it_BCO_entries = 0;
119 for (i = 0; i < 27; i++) it_ofreq[i] = 0;
120 for (i = 0; i < 27; i++)
121 for (j = 0; j < 27; j++)
126 void interp_shutdown ( void )
128 int i, j, k, o_max, i_max, j_max;
129 fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
130 it_retto_BCO + it_retto_UPDATE + it_retto_other,
131 it_retto_BCO, it_retto_UPDATE, it_retto_other );
132 fprintf(stderr, "%d total entries, %d unknown entries \n",
133 it_total_entries, it_total_unknown_entries);
134 for (i = 0; i < N_CLOSURE_TYPES; i++) {
135 if (it_unknown_entries[i] == 0) continue;
136 fprintf(stderr, " type %2d: unknown entries (%4.1f%%) == %d\n",
137 i, 100.0 * ((double)it_unknown_entries[i]) /
138 ((double)it_total_unknown_entries),
139 it_unknown_entries[i]);
141 fprintf(stderr, "%d insns, %d slides, %d BCO_entries\n",
142 it_insns, it_slides, it_BCO_entries);
143 for (i = 0; i < 27; i++)
144 fprintf(stderr, "opcode %2d got %d\n", i, it_ofreq[i] );
146 for (k = 1; k < 20; k++) {
149 for (i = 0; i < 27; i++) {
150 for (j = 0; j < 27; j++) {
151 if (it_oofreq[i][j] > o_max) {
152 o_max = it_oofreq[i][j];
153 i_max = i; j_max = j;
158 fprintf ( stderr, "%d: count (%4.1f%%) %6d is %d then %d\n",
159 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
161 it_oofreq[i_max][j_max] = 0;
168 StgThreadReturnCode interpretBCO ( Capability* cap )
170 /* On entry, the closure to interpret is on the top of the
173 /* Use of register here is primarily to make it clear to compilers
174 that these entities are non-aliasable.
176 register W_* iSp; /* local state -- stack pointer */
177 register StgUpdateFrame* iSu; /* local state -- frame pointer */
178 register StgPtr iSpLim; /* local state -- stack lim pointer */
179 register StgClosure* obj;
183 /* Main object-entering loop. Object to be entered is on top of
187 obj = (StgClosure*)StackWord(0); iSp++;
197 "\n---------------------------------------------------------------\n");
198 fprintf(stderr,"Entering: "); printObj(obj);
199 fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu);
200 fprintf(stderr, "\n" );
203 // iSp--; StackWord(0) = obj;
204 // checkStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
207 printStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
208 fprintf(stderr, "\n\n");
213 switch ( get_itbl(obj)->type ) {
216 barf("Invalid object %p",(StgPtr)obj);
218 # ifndef REFERENCE_INTERPRETER
223 case IND_OLDGEN_PERM:
226 obj = ((StgInd*)obj)->indirectee;
237 case CONSTR_CHARLIKE:
239 case CONSTR_NOCAF_STATIC:
240 nextEnter_obj_CONSTR:
242 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(0);
243 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info) {
247 /* Returning this constr to a BCO. Push the constr on
248 the stack and enter the return continuation BCO, which
249 is immediately underneath ret_itbl. */
250 StackWord(-1) = (W_)obj;
251 obj = (StgClosure*)StackWord(1);
253 if (get_itbl(obj)->type == BCO)
254 goto nextEnter_obj_BCO; /* fast-track common case */
256 goto nextEnter_obj; /* a safe fallback */
258 if (ret_itbl == (StgInfoTable*)&stg_upd_frame_info) {
262 /* Returning this constr to an update frame. Do the
263 update and re-enter the constr. */
264 ASSERT((W_*)iSu == iSp);
265 UPD_IND(iSu->updatee, obj);
267 iSp += sizeofW(StgUpdateFrame);
268 goto nextEnter_obj_CONSTR;
271 else it_retto_other++;
277 /* Copied from stg_AP_UPD_entry. */
280 StgAP_UPD *ap = (StgAP_UPD*)obj;
283 /* Stack check. If a stack overflow might occur, don't enter
284 the closure; let the scheduler handle it instead. */
285 if (iSp - (words+sizeofW(StgUpdateFrame)) < iSpLim)
288 /* Ok; we're safe. Party on. Push an update frame. */
289 iSp -= sizeofW(StgUpdateFrame);
291 StgUpdateFrame *__frame;
292 __frame = (StgUpdateFrame *)iSp;
293 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
295 __frame->updatee = (StgClosure *)(ap);
299 /* Reload the stack */
301 for (i=0; i < words; i++) StackWord(i) = (W_)ap->payload[i];
303 obj = (StgClosure*)ap->fun;
308 /* Copied from stg_PAP_entry. */
311 StgPAP* pap = (StgPAP *)obj;
314 * remove any update frames on the top of the stack, by just
315 * performing the update here.
317 while ((W_)iSu - (W_)iSp == 0) {
319 switch (get_itbl(iSu)->type) {
322 /* We're sitting on top of an update frame, so let's
324 UPD_IND(iSu->updatee, pap);
326 iSp += sizeofW(StgUpdateFrame);
330 /* Too complicated ... adopt the Usual Solution. */
331 /* fprintf(stderr, "!!! SEQ frame in PAP update\n"); */
335 /* can't happen, see stg_update_PAP */
336 barf("interpretBCO: PAP_entry: CATCH_FRAME");
339 barf("interpretBCO: PAP_entry: strange activation record");
345 /* Stack check. If a stack overflow might occur, don't enter
346 the closure; let the scheduler handle it instead. */
347 if (iSp - words < iSpLim)
352 for (i=0; i < words; i++) StackWord(i) = (W_)pap->payload[i];
354 obj = (StgClosure*)pap->fun;
358 # endif /* ndef REFERENCE_INTERPRETER */
361 /* ---------------------------------------------------- */
362 /* Start of the bytecode interpreter */
363 /* ---------------------------------------------------- */
369 int do_print_stack = 1;
370 register int bciPtr = 1; /* instruction pointer */
371 register StgBCO* bco = (StgBCO*)obj;
372 register UShort* instrs = (UShort*)(&bco->instrs->payload[0]);
373 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
374 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
375 register StgInfoTable** itbls = (StgInfoTable**)
376 (&bco->itbls->payload[0]);
379 if (doYouWantToGC()) {
380 iSp--; StackWord(0) = (W_)bco;
381 cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
382 RETURN(HeapOverflow);
385 /* "Standard" stack check */
386 if (iSp - (INTERP_STACK_CHECK_THRESH+1) < iSpLim) {
388 StackWord(0) = (W_)obj;
389 cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
390 RETURN(StackOverflow);
393 /* Context-switch check */
394 if (context_switch) {
396 StackWord(0) = (W_)obj;
397 cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
398 RETURN(ThreadYielding);
403 it_lastopc = 0; /* no opcode */
408 ASSERT(bciPtr <= instrs[0]);
410 //if (do_print_stack) {
411 //fprintf(stderr, "\n-- BEGIN stack\n");
412 //printStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
413 //fprintf(stderr, "-- END stack\n\n");
416 fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr);
417 disInstr(bco,bciPtr);
419 fprintf(stderr,"\n");
420 for (i = 8; i >= 0; i--)
421 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i)));
422 fprintf(stderr,"\n");
424 //if (do_print_stack) checkStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
429 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
430 it_ofreq[ (int)instrs[bciPtr] ] ++;
431 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
432 it_lastopc = (int)instrs[bciPtr];
438 /* An explicit stack check; we hope these will be
440 int stk_words_reqd = BCO_NEXT + 1;
441 if (iSp - stk_words_reqd < iSpLim) {
443 StackWord(0) = (W_)obj;
444 cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
445 RETURN(StackOverflow);
452 int arg_words_reqd = BCO_NEXT;
453 int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
454 if (arg_words_avail >= arg_words_reqd) goto nextInsn;
456 # ifndef REFERENCE_INTERPRETER
458 /* Optimisation: if there are no args avail and the
459 t-o-s is an update frame, do the update, and
460 re-enter the object. */
461 if (arg_words_avail == 0
462 && get_itbl(iSu)->type == UPDATE_FRAME) {
463 UPD_IND(iSu->updatee, obj);
465 iSp += sizeofW(StgUpdateFrame);
466 goto nextEnter_obj_BCO;
469 # endif /* ndef REFERENCE_INTERPRETER */
471 /* Handle arg check failure. General case: copy the
472 spare args into a PAP frame. */
473 pap = (StgPAP*)allocate_UPD(PAP_sizeW(arg_words_avail));
474 SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
475 pap->n_args = arg_words_avail;
477 for (i = 0; i < arg_words_avail; i++)
478 pap->payload[i] = (StgClosure*)StackWord(i);
480 /* Push on the stack and defer to the scheduler. */
483 StackWord(0) = (W_)pap;
485 fprintf(stderr,"\tBuilt ");
486 printObj((StgClosure*)pap);
488 cap->r.rCurrentTSO->what_next = ThreadEnterGHC;
489 RETURN(ThreadYielding);
493 ASSERT((W_*)iSp+o1 < (W_*)iSu);
494 StackWord(-1) = StackWord(o1);
502 ASSERT((W_*)iSp+o1 < (W_*)iSu);
503 ASSERT((W_*)iSp+o2 < (W_*)iSu);
504 StackWord(-1) = StackWord(o1);
505 StackWord(-2) = StackWord(o2);
513 ASSERT((W_*)iSp+o1 < (W_*)iSu);
514 ASSERT((W_*)iSp+o2 < (W_*)iSu);
515 ASSERT((W_*)iSp+o3 < (W_*)iSu);
516 StackWord(-1) = StackWord(o1);
517 StackWord(-2) = StackWord(o2);
518 StackWord(-3) = StackWord(o3);
524 StackWord(-1) = BCO_PTR(o1);
529 int o_bco = BCO_NEXT;
530 int o_itbl = BCO_NEXT;
531 StackWord(-2) = BCO_LIT(o_itbl);
532 StackWord(-1) = BCO_PTR(o_bco);
538 int o_lits = BCO_NEXT;
539 int n_words = BCO_NEXT;
541 for (i = 0; i < n_words; i++)
542 StackWord(i) = BCO_LIT(o_lits+i);
547 W_ tag = (W_)(BCO_NEXT);
555 ASSERT((W_*)iSp+n+by <= (W_*)iSu);
556 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
558 StackWord(n+by) = StackWord(n);
568 int n_payload = BCO_NEXT - 1;
569 int request = AP_sizeW(n_payload);
570 ap = (StgAP_UPD*)allocate_UPD(request);
571 StackWord(-1) = (W_)ap;
572 ap->n_args = n_payload;
573 SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM/*ToDo*/)
579 int stkoff = BCO_NEXT;
580 int n_payload = BCO_NEXT - 1;
581 StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
582 ASSERT((int)ap->n_args == n_payload);
583 ap->fun = (StgClosure*)StackWord(0);
584 for (i = 0; i < n_payload; i++)
585 ap->payload[i] = (StgClosure*)StackWord(i+1);
588 fprintf(stderr,"\tBuilt ");
589 printObj((StgClosure*)ap);
594 /* Unpack N ptr words from t.o.s constructor */
595 /* The common case ! */
597 int n_words = BCO_NEXT;
598 StgClosure* con = (StgClosure*)StackWord(0);
600 for (i = 0; i < n_words; i++)
601 StackWord(i) = (W_)con->payload[i];
605 /* Unpack N (non-ptr) words from offset M in the
606 constructor K words down the stack, and then push
607 N as a tag, on top of it. Slow but general; we
608 hope it will be the rare case. */
610 int n_words = BCO_NEXT;
611 int con_off = BCO_NEXT;
612 int stk_off = BCO_NEXT;
613 StgClosure* con = (StgClosure*)StackWord(stk_off);
615 for (i = 0; i < n_words; i++)
616 StackWord(i) = (W_)con->payload[con_off + i];
618 StackWord(0) = n_words;
623 int o_itbl = BCO_NEXT;
624 int n_words = BCO_NEXT;
625 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
626 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
627 itbl->layout.payload.nptrs );
628 StgClosure* con = (StgClosure*)allocate_NONUPD(request);
629 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
630 SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
631 for (i = 0; i < n_words; i++)
632 con->payload[i] = (StgClosure*)StackWord(i);
635 StackWord(0) = (W_)con;
637 fprintf(stderr,"\tBuilt ");
638 printObj((StgClosure*)con);
643 int discr = BCO_NEXT;
644 int failto = BCO_NEXT;
645 StgClosure* con = (StgClosure*)StackWord(0);
646 if (constrTag(con) >= discr)
651 int discr = BCO_NEXT;
652 int failto = BCO_NEXT;
653 StgClosure* con = (StgClosure*)StackWord(0);
654 if (constrTag(con) != discr)
659 /* The top thing on the stack should be a tagged int. */
660 int discr = BCO_NEXT;
661 int failto = BCO_NEXT;
662 I_ stackInt = (I_)StackWord(1);
663 ASSERT(1 == StackWord(0));
664 if (stackInt >= (I_)BCO_LIT(discr))
669 /* The top thing on the stack should be a tagged int. */
670 int discr = BCO_NEXT;
671 int failto = BCO_NEXT;
672 I_ stackInt = (I_)StackWord(1);
673 ASSERT(1 == StackWord(0));
674 if (stackInt != (I_)BCO_LIT(discr))
679 /* The top thing on the stack should be a tagged double. */
680 int discr = BCO_NEXT;
681 int failto = BCO_NEXT;
682 StgDouble stackDbl, discrDbl;
683 ASSERT(sizeofW(StgDouble) == StackWord(0));
684 stackDbl = PK_DBL( & StackWord(1) );
685 discrDbl = PK_DBL( & BCO_LIT(discr) );
686 if (stackDbl >= discrDbl)
691 /* The top thing on the stack should be a tagged double. */
692 int discr = BCO_NEXT;
693 int failto = BCO_NEXT;
694 StgDouble stackDbl, discrDbl;
695 ASSERT(sizeofW(StgDouble) == StackWord(0));
696 stackDbl = PK_DBL( & StackWord(1) );
697 discrDbl = PK_DBL( & BCO_LIT(discr) );
698 if (stackDbl != discrDbl)
703 /* The top thing on the stack should be a tagged float. */
704 int discr = BCO_NEXT;
705 int failto = BCO_NEXT;
706 StgFloat stackFlt, discrFlt;
707 ASSERT(sizeofW(StgFloat) == StackWord(0));
708 stackFlt = PK_FLT( & StackWord(1) );
709 discrFlt = PK_FLT( & BCO_LIT(discr) );
710 if (stackFlt >= discrFlt)
715 /* The top thing on the stack should be a tagged float. */
716 int discr = BCO_NEXT;
717 int failto = BCO_NEXT;
718 StgFloat stackFlt, discrFlt;
719 ASSERT(sizeofW(StgFloat) == StackWord(0));
720 stackFlt = PK_FLT( & StackWord(1) );
721 discrFlt = PK_FLT( & BCO_LIT(discr) );
722 if (stackFlt != discrFlt)
727 /* Control-flow ish things */
732 /* Figure out whether returning to interpreted or
734 int o_itoc_itbl = BCO_NEXT;
735 int tag = StackWord(0);
736 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
737 ASSERT(tag <= 2); /* say ... */
738 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
739 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
740 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
741 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info
742 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_V_info) {
743 /* Returning to interpreted code. Interpret the BCO
744 immediately underneath the itbl. */
745 StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
747 StackWord(0) = (W_)ret_bco;
750 /* Returning (unboxed value) to compiled code.
751 Replace tag with a suitable itbl and ask the
752 scheduler to run it. The itbl code will copy
753 the TOS value into R1/F1/D1 and do a standard
754 compiled-code return. */
755 StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
756 if (magic_itbl != NULL) {
757 StackWord(0) = (W_)magic_itbl;
758 cap->r.rCurrentTSO->what_next = ThreadRunGHC;
759 RETURN(ThreadYielding);
761 /* Special case -- returning a VoidRep to
762 compiled code. T.O.S is the VoidRep tag,
763 and underneath is the return itbl. Zap the
764 tag and enter the itbl. */
765 ASSERT(StackWord(0) == (W_)NULL);
767 cap->r.rCurrentTSO->what_next = ThreadRunGHC;
768 RETURN(ThreadYielding);
773 int stkoff = BCO_NEXT;
774 signed short n = (signed short)(BCO_NEXT);
775 StackWord(stkoff) += (W_)n;
780 int o_itbl = BCO_NEXT;
781 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
783 tok = suspendThread(&cap->r,rtsFalse);
784 marshall_fn ( (void*)(& StackWord(0) ) );
785 cap = (Capability *)((void *)resumeThread(tok,rtsFalse) - sizeof(StgFunTable));
790 /* BCO_NEXT modifies bciPtr, so be conservative. */
791 int nextpc = BCO_NEXT;
796 barf("interpretBCO: hit a CASEFAIL");
800 barf("interpretBCO: unknown or unimplemented opcode");
802 } /* switch on opcode */
804 barf("interpretBCO: fell off end of insn loop");
807 /* ---------------------------------------------------- */
808 /* End of the bytecode interpreter */
809 /* ---------------------------------------------------- */
814 { int j = get_itbl(obj)->type;
815 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
816 it_unknown_entries[j]++;
817 it_total_unknown_entries++;
821 /* Can't handle this object; yield to sched. */
823 fprintf(stderr, "entering unknown closure -- yielding to sched\n");
826 iSp--; StackWord(0) = (W_)obj;
827 cap->r.rCurrentTSO->what_next = ThreadEnterGHC;
828 RETURN(ThreadYielding);
830 } /* switch on object kind */
832 barf("fallen off end of object-type switch in interpretBCO()");