2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Interpreter.c,v $
9 * $Date: 2001/03/21 10:56:04 $
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 /* Control-flow ish things */
700 /* Figure out whether returning to interpreted or
702 int o_itoc_itbl = BCO_NEXT;
703 int tag = StackWord(0);
704 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
705 ASSERT(tag <= 2); /* say ... */
706 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
707 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
708 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
709 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info
710 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_V_info) {
711 /* Returning to interpreted code. Interpret the BCO
712 immediately underneath the itbl. */
713 StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
715 StackWord(0) = (W_)ret_bco;
718 /* Returning (unboxed value) to compiled code.
719 Replace tag with a suitable itbl and ask the
720 scheduler to run it. The itbl code will copy
721 the TOS value into R1/F1/D1 and do a standard
722 compiled-code return. */
723 StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
724 if (magic_itbl != NULL) {
725 StackWord(0) = (W_)magic_itbl;
726 cap->rCurrentTSO->what_next = ThreadRunGHC;
727 RETURN(ThreadYielding);
729 /* Special case -- returning a VoidRep to
730 compiled code. T.O.S is the VoidRep tag,
731 and underneath is the return itbl. Zap the
732 tag and enter the itbl. */
733 ASSERT(StackWord(0) == (W_)NULL);
735 cap->rCurrentTSO->what_next = ThreadRunGHC;
736 RETURN(ThreadYielding);
742 /* BCO_NEXT modifies bciPtr, so be conservative. */
743 int nextpc = BCO_NEXT;
748 barf("interpretBCO: hit a CASEFAIL");
750 /* As yet unimplemented */
756 barf("interpretBCO: unknown or unimplemented opcode");
758 } /* switch on opcode */
760 barf("interpretBCO: fell off end of insn loop");
763 /* ---------------------------------------------------- */
764 /* End of the bytecode interpreter */
765 /* ---------------------------------------------------- */
770 { int j = get_itbl(obj)->type;
771 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
772 it_unknown_entries[j]++;
773 it_total_unknown_entries++;
777 /* Can't handle this object; yield to sched. */
779 fprintf(stderr, "entering unknown closure -- yielding to sched\n");
782 iSp--; StackWord(0) = (W_)obj;
783 cap->rCurrentTSO->what_next = ThreadEnterGHC;
784 RETURN(ThreadYielding);
786 } /* switch on object kind */
788 barf("fallen off end of object-type switch in interpretBCO()");