2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Interpreter.c,v $
9 * $Date: 2001/08/09 11:23:19 $
10 * ---------------------------------------------------------------------------*/
22 #include "Bytecodes.h"
24 #include "Disassembler.h"
25 #include "Interpreter.h"
28 /* --------------------------------------------------------------------------
29 * The new bytecode interpreter
30 * ------------------------------------------------------------------------*/
32 /* The interpreter can be compiled so it just interprets BCOs and
33 hands literally everything else to the scheduler. This gives a
34 "reference interpreter" which is correct but slow -- useful for
35 debugging. By default, we handle certain closures specially so as
36 to dramatically cut down on the number of deferrals to the
37 scheduler. Ie normally you don't want REFERENCE_INTERPRETER to be
40 /* #define REFERENCE_INTERPRETER */
42 /* Gather stats about entry, opcode, opcode-pair frequencies. For
43 tuning the interpreter. */
45 /* #define INTERP_STATS */
49 /* iSp points to the lowest live word on the stack. */
51 #define StackWord(n) iSp[n]
52 #define BCO_NEXT instrs[bciPtr++]
53 #define BCO_PTR(n) (W_)ptrs[n]
54 #define BCO_LIT(n) (W_)literals[n]
55 #define BCO_ITBL(n) itbls[n]
57 #define LOAD_STACK_POINTERS \
58 iSp = cap->rCurrentTSO->sp; \
59 iSu = cap->rCurrentTSO->su; \
60 /* We don't change this ... */ \
61 iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
64 #define SAVE_STACK_POINTERS \
65 cap->rCurrentTSO->sp = iSp; \
66 cap->rCurrentTSO->su = iSu;
68 #define RETURN(retcode) \
69 SAVE_STACK_POINTERS; return retcode;
72 static __inline__ StgPtr allocate_UPD ( int n_words )
74 if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE)
75 n_words = MIN_UPD_SIZE + sizeofW(StgHeader);
76 return allocate(n_words);
79 static __inline__ StgPtr allocate_NONUPD ( int n_words )
81 if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
82 n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader);
83 return allocate(n_words);
88 /* Hacky stats, for tuning the interpreter ... */
89 int it_unknown_entries[N_CLOSURE_TYPES];
90 int it_total_unknown_entries;
102 int it_oofreq[27][27];
105 void interp_startup ( void )
108 it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
109 it_total_entries = it_total_unknown_entries = 0;
110 for (i = 0; i < N_CLOSURE_TYPES; i++)
111 it_unknown_entries[i] = 0;
112 it_slides = it_insns = it_BCO_entries = 0;
113 for (i = 0; i < 27; i++) it_ofreq[i] = 0;
114 for (i = 0; i < 27; i++)
115 for (j = 0; j < 27; j++)
120 void interp_shutdown ( void )
122 int i, j, k, o_max, i_max, j_max;
123 fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
124 it_retto_BCO + it_retto_UPDATE + it_retto_other,
125 it_retto_BCO, it_retto_UPDATE, it_retto_other );
126 fprintf(stderr, "%d total entries, %d unknown entries \n",
127 it_total_entries, it_total_unknown_entries);
128 for (i = 0; i < N_CLOSURE_TYPES; i++) {
129 if (it_unknown_entries[i] == 0) continue;
130 fprintf(stderr, " type %2d: unknown entries (%4.1f%%) == %d\n",
131 i, 100.0 * ((double)it_unknown_entries[i]) /
132 ((double)it_total_unknown_entries),
133 it_unknown_entries[i]);
135 fprintf(stderr, "%d insns, %d slides, %d BCO_entries\n",
136 it_insns, it_slides, it_BCO_entries);
137 for (i = 0; i < 27; i++)
138 fprintf(stderr, "opcode %2d got %d\n", i, it_ofreq[i] );
140 for (k = 1; k < 20; k++) {
143 for (i = 0; i < 27; i++) {
144 for (j = 0; j < 27; j++) {
145 if (it_oofreq[i][j] > o_max) {
146 o_max = it_oofreq[i][j];
147 i_max = i; j_max = j;
152 fprintf ( stderr, "%d: count (%4.1f%%) %6d is %d then %d\n",
153 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
155 it_oofreq[i_max][j_max] = 0;
162 StgThreadReturnCode interpretBCO ( Capability* cap )
164 /* On entry, the closure to interpret is on the top of the
167 /* Use of register here is primarily to make it clear to compilers
168 that these entities are non-aliasable.
170 register W_* iSp; /* local state -- stack pointer */
171 register StgUpdateFrame* iSu; /* local state -- frame pointer */
172 register StgPtr iSpLim; /* local state -- stack lim pointer */
173 register StgClosure* obj;
177 /* Main object-entering loop. Object to be entered is on top of
181 obj = (StgClosure*)StackWord(0); iSp++;
191 "\n---------------------------------------------------------------\n");
192 fprintf(stderr,"Entering: "); printObj(obj);
193 fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu);
194 fprintf(stderr, "\n" );
197 // iSp--; StackWord(0) = obj;
198 // checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
201 printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
202 fprintf(stderr, "\n\n");
207 switch ( get_itbl(obj)->type ) {
210 barf("Invalid object %p",(StgPtr)obj);
212 # ifndef REFERENCE_INTERPRETER
217 case IND_OLDGEN_PERM:
220 obj = ((StgInd*)obj)->indirectee;
231 case CONSTR_CHARLIKE:
233 case CONSTR_NOCAF_STATIC:
234 nextEnter_obj_CONSTR:
236 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(0);
237 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info) {
241 /* Returning this constr to a BCO. Push the constr on
242 the stack and enter the return continuation BCO, which
243 is immediately underneath ret_itbl. */
244 StackWord(-1) = (W_)obj;
245 obj = (StgClosure*)StackWord(1);
247 if (get_itbl(obj)->type == BCO)
248 goto nextEnter_obj_BCO; /* fast-track common case */
250 goto nextEnter_obj; /* a safe fallback */
252 if (ret_itbl == (StgInfoTable*)&stg_upd_frame_info) {
256 /* Returning this constr to an update frame. Do the
257 update and re-enter the constr. */
258 ASSERT((W_*)iSu == iSp);
259 UPD_IND(iSu->updatee, obj);
261 iSp += sizeofW(StgUpdateFrame);
262 goto nextEnter_obj_CONSTR;
265 else it_retto_other++;
271 /* Copied from stg_AP_UPD_entry. */
274 StgAP_UPD *ap = (StgAP_UPD*)obj;
277 /* Stack check. If a stack overflow might occur, don't enter
278 the closure; let the scheduler handle it instead. */
279 if (iSp - (words+sizeofW(StgUpdateFrame)) < iSpLim)
282 /* Ok; we're safe. Party on. Push an update frame. */
283 iSp -= sizeofW(StgUpdateFrame);
285 StgUpdateFrame *__frame;
286 __frame = (StgUpdateFrame *)iSp;
287 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
289 __frame->updatee = (StgClosure *)(ap);
293 /* Reload the stack */
295 for (i=0; i < words; i++) StackWord(i) = (W_)ap->payload[i];
297 obj = (StgClosure*)ap->fun;
302 /* Copied from stg_PAP_entry. */
305 StgPAP* pap = (StgPAP *)obj;
308 * remove any update frames on the top of the stack, by just
309 * performing the update here.
311 while ((W_)iSu - (W_)iSp == 0) {
313 switch (get_itbl(iSu)->type) {
316 /* We're sitting on top of an update frame, so let's
318 UPD_IND(iSu->updatee, pap);
320 iSp += sizeofW(StgUpdateFrame);
324 /* Too complicated ... adopt the Usual Solution. */
325 /* fprintf(stderr, "!!! SEQ frame in PAP update\n"); */
329 /* can't happen, see stg_update_PAP */
330 barf("interpretBCO: PAP_entry: CATCH_FRAME");
333 barf("interpretBCO: PAP_entry: strange activation record");
339 /* Stack check. If a stack overflow might occur, don't enter
340 the closure; let the scheduler handle it instead. */
341 if (iSp - words < iSpLim)
346 for (i=0; i < words; i++) StackWord(i) = (W_)pap->payload[i];
348 obj = (StgClosure*)pap->fun;
352 # endif /* ndef REFERENCE_INTERPRETER */
355 /* ---------------------------------------------------- */
356 /* Start of the bytecode interpreter */
357 /* ---------------------------------------------------- */
363 int do_print_stack = 1;
364 register int bciPtr = 1; /* instruction pointer */
365 register StgBCO* bco = (StgBCO*)obj;
366 register UShort* instrs = (UShort*)(&bco->instrs->payload[0]);
367 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
368 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
369 register StgInfoTable** itbls = (StgInfoTable**)
370 (&bco->itbls->payload[0]);
373 if (doYouWantToGC()) {
374 iSp--; StackWord(0) = (W_)bco;
375 cap->rCurrentTSO->what_next = ThreadEnterInterp;
376 RETURN(HeapOverflow);
379 /* "Standard" stack check */
380 if (iSp - (INTERP_STACK_CHECK_THRESH+1) < iSpLim) {
382 StackWord(0) = (W_)obj;
383 cap->rCurrentTSO->what_next = ThreadEnterInterp;
384 RETURN(StackOverflow);
387 /* Context-switch check */
388 if (context_switch) {
390 StackWord(0) = (W_)obj;
391 cap->rCurrentTSO->what_next = ThreadEnterInterp;
392 RETURN(ThreadYielding);
397 it_lastopc = 0; /* no opcode */
402 ASSERT(bciPtr <= instrs[0]);
404 //if (do_print_stack) {
405 //fprintf(stderr, "\n-- BEGIN stack\n");
406 //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
407 //fprintf(stderr, "-- END stack\n\n");
410 fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr);
411 disInstr(bco,bciPtr);
413 fprintf(stderr,"\n");
414 for (i = 8; i >= 0; i--)
415 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i)));
416 fprintf(stderr,"\n");
418 //if (do_print_stack) checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
423 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
424 it_ofreq[ (int)instrs[bciPtr] ] ++;
425 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
426 it_lastopc = (int)instrs[bciPtr];
432 /* An explicit stack check; we hope these will be
434 int stk_words_reqd = BCO_NEXT + 1;
435 if (iSp - stk_words_reqd < iSpLim) {
437 StackWord(0) = (W_)obj;
438 cap->rCurrentTSO->what_next = ThreadEnterInterp;
439 RETURN(StackOverflow);
446 int arg_words_reqd = BCO_NEXT;
447 int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
448 if (arg_words_avail >= arg_words_reqd) goto nextInsn;
450 # ifndef REFERENCE_INTERPRETER
452 /* Optimisation: if there are no args avail and the
453 t-o-s is an update frame, do the update, and
454 re-enter the object. */
455 if (arg_words_avail == 0
456 && get_itbl(iSu)->type == UPDATE_FRAME) {
457 UPD_IND(iSu->updatee, obj);
459 iSp += sizeofW(StgUpdateFrame);
460 goto nextEnter_obj_BCO;
463 # endif /* ndef REFERENCE_INTERPRETER */
465 /* Handle arg check failure. General case: copy the
466 spare args into a PAP frame. */
467 pap = (StgPAP*)allocate_UPD(PAP_sizeW(arg_words_avail));
468 SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
469 pap->n_args = arg_words_avail;
471 for (i = 0; i < arg_words_avail; i++)
472 pap->payload[i] = (StgClosure*)StackWord(i);
474 /* Push on the stack and defer to the scheduler. */
477 StackWord(0) = (W_)pap;
479 fprintf(stderr,"\tBuilt ");
480 printObj((StgClosure*)pap);
482 cap->rCurrentTSO->what_next = ThreadEnterGHC;
483 RETURN(ThreadYielding);
487 ASSERT((W_*)iSp+o1 < (W_*)iSu);
488 StackWord(-1) = StackWord(o1);
496 ASSERT((W_*)iSp+o1 < (W_*)iSu);
497 ASSERT((W_*)iSp+o2 < (W_*)iSu);
498 StackWord(-1) = StackWord(o1);
499 StackWord(-2) = StackWord(o2);
507 ASSERT((W_*)iSp+o1 < (W_*)iSu);
508 ASSERT((W_*)iSp+o2 < (W_*)iSu);
509 ASSERT((W_*)iSp+o3 < (W_*)iSu);
510 StackWord(-1) = StackWord(o1);
511 StackWord(-2) = StackWord(o2);
512 StackWord(-3) = StackWord(o3);
518 StackWord(-1) = BCO_PTR(o1);
523 int o_bco = BCO_NEXT;
524 int o_itbl = BCO_NEXT;
525 StackWord(-2) = BCO_LIT(o_itbl);
526 StackWord(-1) = BCO_PTR(o_bco);
532 int o_lits = BCO_NEXT;
533 int n_words = BCO_NEXT;
535 for (i = 0; i < n_words; i++)
536 StackWord(i) = BCO_LIT(o_lits+i);
541 W_ tag = (W_)(BCO_NEXT);
549 ASSERT((W_*)iSp+n+by <= (W_*)iSu);
550 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
552 StackWord(n+by) = StackWord(n);
562 int n_payload = BCO_NEXT - 1;
563 int request = AP_sizeW(n_payload);
564 ap = (StgAP_UPD*)allocate_UPD(request);
565 StackWord(-1) = (W_)ap;
566 ap->n_args = n_payload;
567 SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM/*ToDo*/)
573 int stkoff = BCO_NEXT;
574 int n_payload = BCO_NEXT - 1;
575 StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
576 ASSERT((int)ap->n_args == n_payload);
577 ap->fun = (StgClosure*)StackWord(0);
578 for (i = 0; i < n_payload; i++)
579 ap->payload[i] = (StgClosure*)StackWord(i+1);
582 fprintf(stderr,"\tBuilt ");
583 printObj((StgClosure*)ap);
588 /* Unpack N ptr words from t.o.s constructor */
589 /* The common case ! */
591 int n_words = BCO_NEXT;
592 StgClosure* con = (StgClosure*)StackWord(0);
594 for (i = 0; i < n_words; i++)
595 StackWord(i) = (W_)con->payload[i];
599 /* Unpack N (non-ptr) words from offset M in the
600 constructor K words down the stack, and then push
601 N as a tag, on top of it. Slow but general; we
602 hope it will be the rare case. */
604 int n_words = BCO_NEXT;
605 int con_off = BCO_NEXT;
606 int stk_off = BCO_NEXT;
607 StgClosure* con = (StgClosure*)StackWord(stk_off);
609 for (i = 0; i < n_words; i++)
610 StackWord(i) = (W_)con->payload[con_off + i];
612 StackWord(0) = n_words;
617 int o_itbl = BCO_NEXT;
618 int n_words = BCO_NEXT;
619 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
620 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
621 itbl->layout.payload.nptrs );
622 StgClosure* con = (StgClosure*)allocate_NONUPD(request);
623 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
624 SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
625 for (i = 0; i < n_words; i++)
626 con->payload[i] = (StgClosure*)StackWord(i);
629 StackWord(0) = (W_)con;
631 fprintf(stderr,"\tBuilt ");
632 printObj((StgClosure*)con);
637 int discr = BCO_NEXT;
638 int failto = BCO_NEXT;
639 StgClosure* con = (StgClosure*)StackWord(0);
640 if (constrTag(con) >= discr)
645 int discr = BCO_NEXT;
646 int failto = BCO_NEXT;
647 StgClosure* con = (StgClosure*)StackWord(0);
648 if (constrTag(con) != discr)
653 /* The top thing on the stack should be a tagged int. */
654 int discr = BCO_NEXT;
655 int failto = BCO_NEXT;
656 I_ stackInt = (I_)StackWord(1);
657 ASSERT(1 == StackWord(0));
658 if (stackInt >= (I_)BCO_LIT(discr))
663 /* The top thing on the stack should be a tagged int. */
664 int discr = BCO_NEXT;
665 int failto = BCO_NEXT;
666 I_ stackInt = (I_)StackWord(1);
667 ASSERT(1 == StackWord(0));
668 if (stackInt != (I_)BCO_LIT(discr))
673 /* The top thing on the stack should be a tagged double. */
674 int discr = BCO_NEXT;
675 int failto = BCO_NEXT;
676 StgDouble stackDbl, discrDbl;
677 ASSERT(sizeofW(StgDouble) == StackWord(0));
678 stackDbl = PK_DBL( & StackWord(1) );
679 discrDbl = PK_DBL( & BCO_LIT(discr) );
680 if (stackDbl >= discrDbl)
685 /* The top thing on the stack should be a tagged double. */
686 int discr = BCO_NEXT;
687 int failto = BCO_NEXT;
688 StgDouble stackDbl, discrDbl;
689 ASSERT(sizeofW(StgDouble) == StackWord(0));
690 stackDbl = PK_DBL( & StackWord(1) );
691 discrDbl = PK_DBL( & BCO_LIT(discr) );
692 if (stackDbl != discrDbl)
697 /* The top thing on the stack should be a tagged float. */
698 int discr = BCO_NEXT;
699 int failto = BCO_NEXT;
700 StgFloat stackFlt, discrFlt;
701 ASSERT(sizeofW(StgFloat) == StackWord(0));
702 stackFlt = PK_FLT( & StackWord(1) );
703 discrFlt = PK_FLT( & BCO_LIT(discr) );
704 if (stackFlt >= discrFlt)
709 /* The top thing on the stack should be a tagged float. */
710 int discr = BCO_NEXT;
711 int failto = BCO_NEXT;
712 StgFloat stackFlt, discrFlt;
713 ASSERT(sizeofW(StgFloat) == StackWord(0));
714 stackFlt = PK_FLT( & StackWord(1) );
715 discrFlt = PK_FLT( & BCO_LIT(discr) );
716 if (stackFlt != discrFlt)
721 /* Control-flow ish things */
726 /* Figure out whether returning to interpreted or
728 int o_itoc_itbl = BCO_NEXT;
729 int tag = StackWord(0);
730 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
731 ASSERT(tag <= 2); /* say ... */
732 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
733 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
734 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
735 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info
736 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_V_info) {
737 /* Returning to interpreted code. Interpret the BCO
738 immediately underneath the itbl. */
739 StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
741 StackWord(0) = (W_)ret_bco;
744 /* Returning (unboxed value) to compiled code.
745 Replace tag with a suitable itbl and ask the
746 scheduler to run it. The itbl code will copy
747 the TOS value into R1/F1/D1 and do a standard
748 compiled-code return. */
749 StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
750 if (magic_itbl != NULL) {
751 StackWord(0) = (W_)magic_itbl;
752 cap->rCurrentTSO->what_next = ThreadRunGHC;
753 RETURN(ThreadYielding);
755 /* Special case -- returning a VoidRep to
756 compiled code. T.O.S is the VoidRep tag,
757 and underneath is the return itbl. Zap the
758 tag and enter the itbl. */
759 ASSERT(StackWord(0) == (W_)NULL);
761 cap->rCurrentTSO->what_next = ThreadRunGHC;
762 RETURN(ThreadYielding);
767 int stkoff = BCO_NEXT;
768 signed short n = (signed short)(BCO_NEXT);
769 StackWord(stkoff) += (W_)n;
774 int o_itbl = BCO_NEXT;
775 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
777 tok = suspendThread(cap);
778 marshall_fn ( (void*)(& StackWord(0) ) );
779 cap = resumeThread(tok);
784 /* BCO_NEXT modifies bciPtr, so be conservative. */
785 int nextpc = BCO_NEXT;
790 barf("interpretBCO: hit a CASEFAIL");
794 barf("interpretBCO: unknown or unimplemented opcode");
796 } /* switch on opcode */
798 barf("interpretBCO: fell off end of insn loop");
801 /* ---------------------------------------------------- */
802 /* End of the bytecode interpreter */
803 /* ---------------------------------------------------- */
808 { int j = get_itbl(obj)->type;
809 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
810 it_unknown_entries[j]++;
811 it_total_unknown_entries++;
815 /* Can't handle this object; yield to sched. */
817 fprintf(stderr, "entering unknown closure -- yielding to sched\n");
820 iSp--; StackWord(0) = (W_)obj;
821 cap->rCurrentTSO->what_next = ThreadEnterGHC;
822 RETURN(ThreadYielding);
824 } /* switch on object kind */
826 barf("fallen off end of object-type switch in interpretBCO()");