2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Interpreter.c,v $
9 * $Date: 2001/05/27 06:08:24 $
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; iSu = cap->rCurrentTSO->su;
60 #define SAVE_STACK_POINTERS \
61 cap->rCurrentTSO->sp = iSp; cap->rCurrentTSO->su = iSu;
63 #define RETURN(retcode) \
64 SAVE_STACK_POINTERS; return retcode;
67 static __inline__ StgPtr allocate_UPD ( int n_words )
69 if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE)
70 n_words = MIN_UPD_SIZE + sizeofW(StgHeader);
71 return allocate(n_words);
74 static __inline__ StgPtr allocate_NONUPD ( int n_words )
76 if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
77 n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader);
78 return allocate(n_words);
83 /* Hacky stats, for tuning the interpreter ... */
84 int it_unknown_entries[N_CLOSURE_TYPES];
85 int it_total_unknown_entries;
97 int it_oofreq[27][27];
100 void interp_startup ( void )
103 it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
104 it_total_entries = it_total_unknown_entries = 0;
105 for (i = 0; i < N_CLOSURE_TYPES; i++)
106 it_unknown_entries[i] = 0;
107 it_slides = it_insns = it_BCO_entries = 0;
108 for (i = 0; i < 27; i++) it_ofreq[i] = 0;
109 for (i = 0; i < 27; i++)
110 for (j = 0; j < 27; j++)
115 void interp_shutdown ( void )
117 int i, j, k, o_max, i_max, j_max;
118 fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
119 it_retto_BCO + it_retto_UPDATE + it_retto_other,
120 it_retto_BCO, it_retto_UPDATE, it_retto_other );
121 fprintf(stderr, "%d total entries, %d unknown entries \n",
122 it_total_entries, it_total_unknown_entries);
123 for (i = 0; i < N_CLOSURE_TYPES; i++) {
124 if (it_unknown_entries[i] == 0) continue;
125 fprintf(stderr, " type %2d: unknown entries (%4.1f%%) == %d\n",
126 i, 100.0 * ((double)it_unknown_entries[i]) /
127 ((double)it_total_unknown_entries),
128 it_unknown_entries[i]);
130 fprintf(stderr, "%d insns, %d slides, %d BCO_entries\n",
131 it_insns, it_slides, it_BCO_entries);
132 for (i = 0; i < 27; i++)
133 fprintf(stderr, "opcode %2d got %d\n", i, it_ofreq[i] );
135 for (k = 1; k < 20; k++) {
138 for (i = 0; i < 27; i++) {
139 for (j = 0; j < 27; j++) {
140 if (it_oofreq[i][j] > o_max) {
141 o_max = it_oofreq[i][j];
142 i_max = i; j_max = j;
147 fprintf ( stderr, "%d: count (%4.1f%%) %6d is %d then %d\n",
148 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
150 it_oofreq[i_max][j_max] = 0;
157 StgThreadReturnCode interpretBCO ( Capability* cap )
159 /* On entry, the closure to interpret is on the top of the
162 /* Use of register here is primarily to make it clear to compilers
163 that these entities are non-aliasable.
165 register W_* iSp; /* local state -- stack pointer */
166 register StgUpdateFrame* iSu; /* local state -- frame pointer */
167 register StgPtr iSpLim; /* local state -- stack lim pointer */
168 register StgClosure* obj;
172 /* We don't change this ... */
173 iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
175 /* Main object-entering loop. Object to be entered is on top of
179 obj = (StgClosure*)StackWord(0); iSp++;
189 "\n---------------------------------------------------------------\n");
190 fprintf(stderr,"Entering: "); printObj(obj);
191 fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu);
192 fprintf(stderr, "\n" );
195 // iSp--; StackWord(0) = obj;
196 // checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
199 printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
200 fprintf(stderr, "\n\n");
205 switch ( get_itbl(obj)->type ) {
208 barf("Invalid object %p",(StgPtr)obj);
210 # ifndef REFERENCE_INTERPRETER
215 case IND_OLDGEN_PERM:
218 obj = ((StgInd*)obj)->indirectee;
229 case CONSTR_CHARLIKE:
231 case CONSTR_NOCAF_STATIC:
232 nextEnter_obj_CONSTR:
234 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(0);
235 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info) {
239 /* Returning this constr to a BCO. Push the constr on
240 the stack and enter the return continuation BCO, which
241 is immediately underneath ret_itbl. */
242 StackWord(-1) = (W_)obj;
243 obj = (StgClosure*)StackWord(1);
245 if (get_itbl(obj)->type == BCO)
246 goto nextEnter_obj_BCO; /* fast-track common case */
248 goto nextEnter_obj; /* a safe fallback */
250 if (ret_itbl == (StgInfoTable*)&stg_upd_frame_info) {
254 /* Returning this constr to an update frame. Do the
255 update and re-enter the constr. */
256 ASSERT((W_*)iSu == iSp);
257 UPD_IND(iSu->updatee, obj);
259 iSp += sizeofW(StgUpdateFrame);
260 goto nextEnter_obj_CONSTR;
263 else it_retto_other++;
269 /* Copied from stg_AP_UPD_entry. */
272 StgAP_UPD *ap = (StgAP_UPD*)obj;
275 /* Stack check. If a stack overflow might occur, don't enter
276 the closure; let the scheduler handle it instead. */
277 if (iSp - (words+sizeofW(StgUpdateFrame)) < iSpLim)
280 /* Ok; we're safe. Party on. Push an update frame. */
281 iSp -= sizeofW(StgUpdateFrame);
283 StgUpdateFrame *__frame;
284 __frame = (StgUpdateFrame *)iSp;
285 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
287 __frame->updatee = (StgClosure *)(ap);
291 /* Reload the stack */
293 for (i=0; i < words; i++) StackWord(i) = (W_)ap->payload[i];
295 obj = (StgClosure*)ap->fun;
300 /* Copied from stg_PAP_entry. */
303 StgPAP* pap = (StgPAP *)obj;
306 * remove any update frames on the top of the stack, by just
307 * performing the update here.
309 while ((W_)iSu - (W_)iSp == 0) {
311 switch (get_itbl(iSu)->type) {
314 /* We're sitting on top of an update frame, so let's
316 UPD_IND(iSu->updatee, pap);
318 iSp += sizeofW(StgUpdateFrame);
322 /* Too complicated ... adopt the Usual Solution. */
323 /* fprintf(stderr, "!!! SEQ frame in PAP update\n"); */
327 /* can't happen, see stg_update_PAP */
328 barf("interpretBCO: PAP_entry: CATCH_FRAME");
331 barf("interpretBCO: PAP_entry: strange activation record");
337 /* Stack check. If a stack overflow might occur, don't enter
338 the closure; let the scheduler handle it instead. */
339 if (iSp - words < iSpLim)
344 for (i=0; i < words; i++) StackWord(i) = (W_)pap->payload[i];
346 obj = (StgClosure*)pap->fun;
350 # endif /* ndef REFERENCE_INTERPRETER */
353 /* ---------------------------------------------------- */
354 /* Start of the bytecode interpreter */
355 /* ---------------------------------------------------- */
361 int do_print_stack = 1;
362 register int bciPtr = 1; /* instruction pointer */
363 register StgBCO* bco = (StgBCO*)obj;
364 register UShort* instrs = (UShort*)(&bco->instrs->payload[0]);
365 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
366 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
367 register StgInfoTable** itbls = (StgInfoTable**)
368 (&bco->itbls->payload[0]);
371 if (doYouWantToGC()) {
372 iSp--; StackWord(0) = (W_)bco;
373 cap->rCurrentTSO->what_next = ThreadEnterInterp;
374 RETURN(HeapOverflow);
377 /* "Standard" stack check */
378 if (iSp - (INTERP_STACK_CHECK_THRESH+1) < iSpLim) {
380 StackWord(0) = (W_)obj;
381 cap->rCurrentTSO->what_next = ThreadEnterInterp;
382 RETURN(StackOverflow);
385 /* Context-switch check */
386 if (context_switch) {
388 StackWord(0) = (W_)obj;
389 cap->rCurrentTSO->what_next = ThreadEnterInterp;
390 RETURN(ThreadYielding);
395 it_lastopc = 0; /* no opcode */
400 ASSERT(bciPtr <= instrs[0]);
402 //if (do_print_stack) {
403 //fprintf(stderr, "\n-- BEGIN stack\n");
404 //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
405 //fprintf(stderr, "-- END stack\n\n");
408 fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr);
409 disInstr(bco,bciPtr);
411 fprintf(stderr,"\n");
412 for (i = 8; i >= 0; i--)
413 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i)));
414 fprintf(stderr,"\n");
416 //if (do_print_stack) checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
421 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
422 it_ofreq[ (int)instrs[bciPtr] ] ++;
423 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
424 it_lastopc = (int)instrs[bciPtr];
430 /* An explicit stack check; we hope these will be
432 int stk_words_reqd = BCO_NEXT + 1;
433 if (iSp - stk_words_reqd < iSpLim) {
435 StackWord(0) = (W_)obj;
436 cap->rCurrentTSO->what_next = ThreadEnterInterp;
437 RETURN(StackOverflow);
444 int arg_words_reqd = BCO_NEXT;
445 int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
446 if (arg_words_avail >= arg_words_reqd) goto nextInsn;
448 # ifndef REFERENCE_INTERPRETER
450 /* Optimisation: if there are no args avail and the
451 t-o-s is an update frame, do the update, and
452 re-enter the object. */
453 if (arg_words_avail == 0
454 && get_itbl(iSu)->type == UPDATE_FRAME) {
455 UPD_IND(iSu->updatee, obj);
457 iSp += sizeofW(StgUpdateFrame);
458 goto nextEnter_obj_BCO;
461 # endif /* ndef REFERENCE_INTERPRETER */
463 /* Handle arg check failure. General case: copy the
464 spare args into a PAP frame. */
465 pap = (StgPAP*)allocate_UPD(PAP_sizeW(arg_words_avail));
466 SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
467 pap->n_args = arg_words_avail;
469 for (i = 0; i < arg_words_avail; i++)
470 pap->payload[i] = (StgClosure*)StackWord(i);
472 /* Push on the stack and defer to the scheduler. */
475 StackWord(0) = (W_)pap;
477 fprintf(stderr,"\tBuilt ");
478 printObj((StgClosure*)pap);
480 cap->rCurrentTSO->what_next = ThreadEnterGHC;
481 RETURN(ThreadYielding);
485 ASSERT((W_*)iSp+o1 < (W_*)iSu);
486 StackWord(-1) = StackWord(o1);
494 ASSERT((W_*)iSp+o1 < (W_*)iSu);
495 ASSERT((W_*)iSp+o2 < (W_*)iSu);
496 StackWord(-1) = StackWord(o1);
497 StackWord(-2) = StackWord(o2);
505 ASSERT((W_*)iSp+o1 < (W_*)iSu);
506 ASSERT((W_*)iSp+o2 < (W_*)iSu);
507 ASSERT((W_*)iSp+o3 < (W_*)iSu);
508 StackWord(-1) = StackWord(o1);
509 StackWord(-2) = StackWord(o2);
510 StackWord(-3) = StackWord(o3);
516 StackWord(-1) = BCO_PTR(o1);
521 int o_bco = BCO_NEXT;
522 int o_itbl = BCO_NEXT;
523 StackWord(-2) = BCO_LIT(o_itbl);
524 StackWord(-1) = BCO_PTR(o_bco);
530 int o_lits = BCO_NEXT;
531 int n_words = BCO_NEXT;
533 for (i = 0; i < n_words; i++)
534 StackWord(i) = BCO_LIT(o_lits+i);
539 W_ tag = (W_)(BCO_NEXT);
547 ASSERT((W_*)iSp+n+by <= (W_*)iSu);
548 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
550 StackWord(n+by) = StackWord(n);
560 int n_payload = BCO_NEXT - 1;
561 int request = AP_sizeW(n_payload);
562 ap = (StgAP_UPD*)allocate_UPD(request);
563 StackWord(-1) = (W_)ap;
564 ap->n_args = n_payload;
565 SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM/*ToDo*/)
571 int stkoff = BCO_NEXT;
572 int n_payload = BCO_NEXT - 1;
573 StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
574 ASSERT((int)ap->n_args == n_payload);
575 ap->fun = (StgClosure*)StackWord(0);
576 for (i = 0; i < n_payload; i++)
577 ap->payload[i] = (StgClosure*)StackWord(i+1);
580 fprintf(stderr,"\tBuilt ");
581 printObj((StgClosure*)ap);
586 /* Unpack N ptr words from t.o.s constructor */
587 /* The common case ! */
589 int n_words = BCO_NEXT;
590 StgClosure* con = (StgClosure*)StackWord(0);
592 for (i = 0; i < n_words; i++)
593 StackWord(i) = (W_)con->payload[i];
597 /* Unpack N (non-ptr) words from offset M in the
598 constructor K words down the stack, and then push
599 N as a tag, on top of it. Slow but general; we
600 hope it will be the rare case. */
602 int n_words = BCO_NEXT;
603 int con_off = BCO_NEXT;
604 int stk_off = BCO_NEXT;
605 StgClosure* con = (StgClosure*)StackWord(stk_off);
607 for (i = 0; i < n_words; i++)
608 StackWord(i) = (W_)con->payload[con_off + i];
610 StackWord(0) = n_words;
615 int o_itbl = BCO_NEXT;
616 int n_words = BCO_NEXT;
617 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
618 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
619 itbl->layout.payload.nptrs );
620 StgClosure* con = (StgClosure*)allocate_NONUPD(request);
621 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
622 SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
623 for (i = 0; i < n_words; i++)
624 con->payload[i] = (StgClosure*)StackWord(i);
627 StackWord(0) = (W_)con;
629 fprintf(stderr,"\tBuilt ");
630 printObj((StgClosure*)con);
635 int discr = BCO_NEXT;
636 int failto = BCO_NEXT;
637 StgClosure* con = (StgClosure*)StackWord(0);
638 if (constrTag(con) >= discr)
643 int discr = BCO_NEXT;
644 int failto = BCO_NEXT;
645 StgClosure* con = (StgClosure*)StackWord(0);
646 if (constrTag(con) != discr)
651 /* The top thing on the stack should be a tagged int. */
652 int discr = BCO_NEXT;
653 int failto = BCO_NEXT;
654 I_ stackInt = (I_)StackWord(1);
655 ASSERT(1 == StackWord(0));
656 if (stackInt >= (I_)BCO_LIT(discr))
661 /* The top thing on the stack should be a tagged int. */
662 int discr = BCO_NEXT;
663 int failto = BCO_NEXT;
664 I_ stackInt = (I_)StackWord(1);
665 ASSERT(1 == StackWord(0));
666 if (stackInt != (I_)BCO_LIT(discr))
671 /* The top thing on the stack should be a tagged double. */
672 int discr = BCO_NEXT;
673 int failto = BCO_NEXT;
674 StgDouble stackDbl, discrDbl;
675 ASSERT(sizeofW(StgDouble) == StackWord(0));
676 stackDbl = PK_DBL( & StackWord(1) );
677 discrDbl = PK_DBL( & BCO_LIT(discr) );
678 if (stackDbl >= discrDbl)
683 /* The top thing on the stack should be a tagged double. */
684 int discr = BCO_NEXT;
685 int failto = BCO_NEXT;
686 StgDouble stackDbl, discrDbl;
687 ASSERT(sizeofW(StgDouble) == StackWord(0));
688 stackDbl = PK_DBL( & StackWord(1) );
689 discrDbl = PK_DBL( & BCO_LIT(discr) );
690 if (stackDbl != discrDbl)
695 /* The top thing on the stack should be a tagged float. */
696 int discr = BCO_NEXT;
697 int failto = BCO_NEXT;
698 StgFloat stackFlt, discrFlt;
699 ASSERT(sizeofW(StgFloat) == StackWord(0));
700 stackFlt = PK_FLT( & StackWord(1) );
701 discrFlt = PK_FLT( & BCO_LIT(discr) );
702 if (stackFlt >= discrFlt)
707 /* The top thing on the stack should be a tagged float. */
708 int discr = BCO_NEXT;
709 int failto = BCO_NEXT;
710 StgFloat stackFlt, discrFlt;
711 ASSERT(sizeofW(StgFloat) == StackWord(0));
712 stackFlt = PK_FLT( & StackWord(1) );
713 discrFlt = PK_FLT( & BCO_LIT(discr) );
714 if (stackFlt != discrFlt)
719 /* Control-flow ish things */
724 /* Figure out whether returning to interpreted or
726 int o_itoc_itbl = BCO_NEXT;
727 int tag = StackWord(0);
728 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
729 ASSERT(tag <= 2); /* say ... */
730 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
731 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
732 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
733 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info
734 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_V_info) {
735 /* Returning to interpreted code. Interpret the BCO
736 immediately underneath the itbl. */
737 StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
739 StackWord(0) = (W_)ret_bco;
742 /* Returning (unboxed value) to compiled code.
743 Replace tag with a suitable itbl and ask the
744 scheduler to run it. The itbl code will copy
745 the TOS value into R1/F1/D1 and do a standard
746 compiled-code return. */
747 StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
748 if (magic_itbl != NULL) {
749 StackWord(0) = (W_)magic_itbl;
750 cap->rCurrentTSO->what_next = ThreadRunGHC;
751 RETURN(ThreadYielding);
753 /* Special case -- returning a VoidRep to
754 compiled code. T.O.S is the VoidRep tag,
755 and underneath is the return itbl. Zap the
756 tag and enter the itbl. */
757 ASSERT(StackWord(0) == (W_)NULL);
759 cap->rCurrentTSO->what_next = ThreadRunGHC;
760 RETURN(ThreadYielding);
766 /* BCO_NEXT modifies bciPtr, so be conservative. */
767 int nextpc = BCO_NEXT;
772 barf("interpretBCO: hit a CASEFAIL");
776 barf("interpretBCO: unknown or unimplemented opcode");
778 } /* switch on opcode */
780 barf("interpretBCO: fell off end of insn loop");
783 /* ---------------------------------------------------- */
784 /* End of the bytecode interpreter */
785 /* ---------------------------------------------------- */
790 { int j = get_itbl(obj)->type;
791 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
792 it_unknown_entries[j]++;
793 it_total_unknown_entries++;
797 /* Can't handle this object; yield to sched. */
799 fprintf(stderr, "entering unknown closure -- yielding to sched\n");
802 iSp--; StackWord(0) = (W_)obj;
803 cap->rCurrentTSO->what_next = ThreadEnterGHC;
804 RETURN(ThreadYielding);
806 } /* switch on object kind */
808 barf("fallen off end of object-type switch in interpretBCO()");