2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Interpreter.c,v $
9 * $Date: 2001/11/08 12:46:31 $
10 * ---------------------------------------------------------------------------*/
12 #include "PosixSource.h"
23 #include "Bytecodes.h"
25 #include "Disassembler.h"
26 #include "Interpreter.h"
29 /* --------------------------------------------------------------------------
30 * The new bytecode interpreter
31 * ------------------------------------------------------------------------*/
33 /* The interpreter can be compiled so it just interprets BCOs and
34 hands literally everything else to the scheduler. This gives a
35 "reference interpreter" which is correct but slow -- useful for
36 debugging. By default, we handle certain closures specially so as
37 to dramatically cut down on the number of deferrals to the
38 scheduler. Ie normally you don't want REFERENCE_INTERPRETER to be
41 /* #define REFERENCE_INTERPRETER */
43 /* Gather stats about entry, opcode, opcode-pair frequencies. For
44 tuning the interpreter. */
46 /* #define INTERP_STATS */
50 /* iSp points to the lowest live word on the stack. */
52 #define StackWord(n) iSp[n]
53 #define BCO_NEXT instrs[bciPtr++]
54 #define BCO_PTR(n) (W_)ptrs[n]
55 #define BCO_LIT(n) (W_)literals[n]
56 #define BCO_ITBL(n) itbls[n]
58 #define LOAD_STACK_POINTERS \
59 iSp = cap->r.rCurrentTSO->sp; \
60 iSu = cap->r.rCurrentTSO->su; \
61 /* We don't change this ... */ \
62 iSpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
65 #define SAVE_STACK_POINTERS \
66 cap->r.rCurrentTSO->sp = iSp; \
67 cap->r.rCurrentTSO->su = iSu;
69 #define RETURN(retcode) \
70 SAVE_STACK_POINTERS; return retcode;
73 static __inline__ StgPtr allocate_UPD ( int n_words )
75 if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE)
76 n_words = MIN_UPD_SIZE + sizeofW(StgHeader);
77 return allocate(n_words);
80 static __inline__ StgPtr allocate_NONUPD ( int n_words )
82 if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
83 n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader);
84 return allocate(n_words);
89 /* Hacky stats, for tuning the interpreter ... */
90 int it_unknown_entries[N_CLOSURE_TYPES];
91 int it_total_unknown_entries;
103 int it_oofreq[27][27];
106 void interp_startup ( void )
109 it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
110 it_total_entries = it_total_unknown_entries = 0;
111 for (i = 0; i < N_CLOSURE_TYPES; i++)
112 it_unknown_entries[i] = 0;
113 it_slides = it_insns = it_BCO_entries = 0;
114 for (i = 0; i < 27; i++) it_ofreq[i] = 0;
115 for (i = 0; i < 27; i++)
116 for (j = 0; j < 27; j++)
121 void interp_shutdown ( void )
123 int i, j, k, o_max, i_max, j_max;
124 fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
125 it_retto_BCO + it_retto_UPDATE + it_retto_other,
126 it_retto_BCO, it_retto_UPDATE, it_retto_other );
127 fprintf(stderr, "%d total entries, %d unknown entries \n",
128 it_total_entries, it_total_unknown_entries);
129 for (i = 0; i < N_CLOSURE_TYPES; i++) {
130 if (it_unknown_entries[i] == 0) continue;
131 fprintf(stderr, " type %2d: unknown entries (%4.1f%%) == %d\n",
132 i, 100.0 * ((double)it_unknown_entries[i]) /
133 ((double)it_total_unknown_entries),
134 it_unknown_entries[i]);
136 fprintf(stderr, "%d insns, %d slides, %d BCO_entries\n",
137 it_insns, it_slides, it_BCO_entries);
138 for (i = 0; i < 27; i++)
139 fprintf(stderr, "opcode %2d got %d\n", i, it_ofreq[i] );
141 for (k = 1; k < 20; k++) {
144 for (i = 0; i < 27; i++) {
145 for (j = 0; j < 27; j++) {
146 if (it_oofreq[i][j] > o_max) {
147 o_max = it_oofreq[i][j];
148 i_max = i; j_max = j;
153 fprintf ( stderr, "%d: count (%4.1f%%) %6d is %d then %d\n",
154 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
156 it_oofreq[i_max][j_max] = 0;
163 StgThreadReturnCode interpretBCO ( Capability* cap )
165 /* On entry, the closure to interpret is on the top of the
168 /* Use of register here is primarily to make it clear to compilers
169 that these entities are non-aliasable.
171 register W_* iSp; /* local state -- stack pointer */
172 register StgUpdateFrame* iSu; /* local state -- frame pointer */
173 register StgPtr iSpLim; /* local state -- stack lim pointer */
174 register StgClosure* obj;
178 /* Main object-entering loop. Object to be entered is on top of
182 obj = (StgClosure*)StackWord(0); iSp++;
192 "\n---------------------------------------------------------------\n");
193 fprintf(stderr,"Entering: "); printObj(obj);
194 fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu);
195 fprintf(stderr, "\n" );
198 // iSp--; StackWord(0) = obj;
199 // checkStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
202 printStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
203 fprintf(stderr, "\n\n");
208 switch ( get_itbl(obj)->type ) {
211 barf("Invalid object %p",(StgPtr)obj);
213 # ifndef REFERENCE_INTERPRETER
218 case IND_OLDGEN_PERM:
221 obj = ((StgInd*)obj)->indirectee;
232 case CONSTR_CHARLIKE:
234 case CONSTR_NOCAF_STATIC:
235 nextEnter_obj_CONSTR:
237 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(0);
238 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info) {
242 /* Returning this constr to a BCO. Push the constr on
243 the stack and enter the return continuation BCO, which
244 is immediately underneath ret_itbl. */
245 StackWord(-1) = (W_)obj;
246 obj = (StgClosure*)StackWord(1);
248 if (get_itbl(obj)->type == BCO)
249 goto nextEnter_obj_BCO; /* fast-track common case */
251 goto nextEnter_obj; /* a safe fallback */
253 if (ret_itbl == (StgInfoTable*)&stg_upd_frame_info) {
257 /* Returning this constr to an update frame. Do the
258 update and re-enter the constr. */
259 ASSERT((W_*)iSu == iSp);
260 UPD_IND(iSu->updatee, obj);
262 iSp += sizeofW(StgUpdateFrame);
263 goto nextEnter_obj_CONSTR;
266 else it_retto_other++;
272 /* Copied from stg_AP_UPD_entry. */
275 StgAP_UPD *ap = (StgAP_UPD*)obj;
278 /* Stack check. If a stack overflow might occur, don't enter
279 the closure; let the scheduler handle it instead. */
280 if (iSp - (words+sizeofW(StgUpdateFrame)) < iSpLim)
283 /* Ok; we're safe. Party on. Push an update frame. */
284 iSp -= sizeofW(StgUpdateFrame);
286 StgUpdateFrame *__frame;
287 __frame = (StgUpdateFrame *)iSp;
288 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
290 __frame->updatee = (StgClosure *)(ap);
294 /* Reload the stack */
296 for (i=0; i < words; i++) StackWord(i) = (W_)ap->payload[i];
298 obj = (StgClosure*)ap->fun;
303 /* Copied from stg_PAP_entry. */
306 StgPAP* pap = (StgPAP *)obj;
309 * remove any update frames on the top of the stack, by just
310 * performing the update here.
312 while ((W_)iSu - (W_)iSp == 0) {
314 switch (get_itbl(iSu)->type) {
317 /* We're sitting on top of an update frame, so let's
319 UPD_IND(iSu->updatee, pap);
321 iSp += sizeofW(StgUpdateFrame);
325 /* Too complicated ... adopt the Usual Solution. */
326 /* fprintf(stderr, "!!! SEQ frame in PAP update\n"); */
330 /* can't happen, see stg_update_PAP */
331 barf("interpretBCO: PAP_entry: CATCH_FRAME");
334 barf("interpretBCO: PAP_entry: strange activation record");
340 /* Stack check. If a stack overflow might occur, don't enter
341 the closure; let the scheduler handle it instead. */
342 if (iSp - words < iSpLim)
347 for (i=0; i < words; i++) StackWord(i) = (W_)pap->payload[i];
349 obj = (StgClosure*)pap->fun;
353 # endif /* ndef REFERENCE_INTERPRETER */
356 /* ---------------------------------------------------- */
357 /* Start of the bytecode interpreter */
358 /* ---------------------------------------------------- */
364 int do_print_stack = 1;
365 register int bciPtr = 1; /* instruction pointer */
366 register StgBCO* bco = (StgBCO*)obj;
367 register UShort* instrs = (UShort*)(&bco->instrs->payload[0]);
368 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
369 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
370 register StgInfoTable** itbls = (StgInfoTable**)
371 (&bco->itbls->payload[0]);
374 if (doYouWantToGC()) {
375 iSp--; StackWord(0) = (W_)bco;
376 cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
377 RETURN(HeapOverflow);
380 /* "Standard" stack check */
381 if (iSp - (INTERP_STACK_CHECK_THRESH+1) < iSpLim) {
383 StackWord(0) = (W_)obj;
384 cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
385 RETURN(StackOverflow);
388 /* Context-switch check */
389 if (context_switch) {
391 StackWord(0) = (W_)obj;
392 cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
393 RETURN(ThreadYielding);
398 it_lastopc = 0; /* no opcode */
403 ASSERT(bciPtr <= instrs[0]);
405 //if (do_print_stack) {
406 //fprintf(stderr, "\n-- BEGIN stack\n");
407 //printStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
408 //fprintf(stderr, "-- END stack\n\n");
411 fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr);
412 disInstr(bco,bciPtr);
414 fprintf(stderr,"\n");
415 for (i = 8; i >= 0; i--)
416 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i)));
417 fprintf(stderr,"\n");
419 //if (do_print_stack) checkStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
424 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
425 it_ofreq[ (int)instrs[bciPtr] ] ++;
426 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
427 it_lastopc = (int)instrs[bciPtr];
433 /* An explicit stack check; we hope these will be
435 int stk_words_reqd = BCO_NEXT + 1;
436 if (iSp - stk_words_reqd < iSpLim) {
438 StackWord(0) = (W_)obj;
439 cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
440 RETURN(StackOverflow);
447 int arg_words_reqd = BCO_NEXT;
448 int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
449 if (arg_words_avail >= arg_words_reqd) goto nextInsn;
451 # ifndef REFERENCE_INTERPRETER
453 /* Optimisation: if there are no args avail and the
454 t-o-s is an update frame, do the update, and
455 re-enter the object. */
456 if (arg_words_avail == 0
457 && get_itbl(iSu)->type == UPDATE_FRAME) {
458 UPD_IND(iSu->updatee, obj);
460 iSp += sizeofW(StgUpdateFrame);
461 goto nextEnter_obj_BCO;
464 # endif /* ndef REFERENCE_INTERPRETER */
466 /* Handle arg check failure. General case: copy the
467 spare args into a PAP frame. */
468 pap = (StgPAP*)allocate_UPD(PAP_sizeW(arg_words_avail));
469 SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
470 pap->n_args = arg_words_avail;
472 for (i = 0; i < arg_words_avail; i++)
473 pap->payload[i] = (StgClosure*)StackWord(i);
475 /* Push on the stack and defer to the scheduler. */
478 StackWord(0) = (W_)pap;
480 fprintf(stderr,"\tBuilt ");
481 printObj((StgClosure*)pap);
483 cap->r.rCurrentTSO->what_next = ThreadEnterGHC;
484 RETURN(ThreadYielding);
488 ASSERT((W_*)iSp+o1 < (W_*)iSu);
489 StackWord(-1) = StackWord(o1);
497 ASSERT((W_*)iSp+o1 < (W_*)iSu);
498 ASSERT((W_*)iSp+o2 < (W_*)iSu);
499 StackWord(-1) = StackWord(o1);
500 StackWord(-2) = StackWord(o2);
508 ASSERT((W_*)iSp+o1 < (W_*)iSu);
509 ASSERT((W_*)iSp+o2 < (W_*)iSu);
510 ASSERT((W_*)iSp+o3 < (W_*)iSu);
511 StackWord(-1) = StackWord(o1);
512 StackWord(-2) = StackWord(o2);
513 StackWord(-3) = StackWord(o3);
519 StackWord(-1) = BCO_PTR(o1);
524 int o_bco = BCO_NEXT;
525 int o_itbl = BCO_NEXT;
526 StackWord(-2) = BCO_LIT(o_itbl);
527 StackWord(-1) = BCO_PTR(o_bco);
533 int o_lits = BCO_NEXT;
534 int n_words = BCO_NEXT;
536 for (i = 0; i < n_words; i++)
537 StackWord(i) = BCO_LIT(o_lits+i);
542 W_ tag = (W_)(BCO_NEXT);
550 ASSERT((W_*)iSp+n+by <= (W_*)iSu);
551 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
553 StackWord(n+by) = StackWord(n);
563 int n_payload = BCO_NEXT - 1;
564 int request = AP_sizeW(n_payload);
565 ap = (StgAP_UPD*)allocate_UPD(request);
566 StackWord(-1) = (W_)ap;
567 ap->n_args = n_payload;
568 SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM/*ToDo*/)
574 int stkoff = BCO_NEXT;
575 int n_payload = BCO_NEXT - 1;
576 StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
577 ASSERT((int)ap->n_args == n_payload);
578 ap->fun = (StgClosure*)StackWord(0);
579 for (i = 0; i < n_payload; i++)
580 ap->payload[i] = (StgClosure*)StackWord(i+1);
583 fprintf(stderr,"\tBuilt ");
584 printObj((StgClosure*)ap);
589 /* Unpack N ptr words from t.o.s constructor */
590 /* The common case ! */
592 int n_words = BCO_NEXT;
593 StgClosure* con = (StgClosure*)StackWord(0);
595 for (i = 0; i < n_words; i++)
596 StackWord(i) = (W_)con->payload[i];
600 /* Unpack N (non-ptr) words from offset M in the
601 constructor K words down the stack, and then push
602 N as a tag, on top of it. Slow but general; we
603 hope it will be the rare case. */
605 int n_words = BCO_NEXT;
606 int con_off = BCO_NEXT;
607 int stk_off = BCO_NEXT;
608 StgClosure* con = (StgClosure*)StackWord(stk_off);
610 for (i = 0; i < n_words; i++)
611 StackWord(i) = (W_)con->payload[con_off + i];
613 StackWord(0) = n_words;
618 int o_itbl = BCO_NEXT;
619 int n_words = BCO_NEXT;
620 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
621 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
622 itbl->layout.payload.nptrs );
623 StgClosure* con = (StgClosure*)allocate_NONUPD(request);
624 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
625 SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
626 for (i = 0; i < n_words; i++)
627 con->payload[i] = (StgClosure*)StackWord(i);
630 StackWord(0) = (W_)con;
632 fprintf(stderr,"\tBuilt ");
633 printObj((StgClosure*)con);
638 int discr = BCO_NEXT;
639 int failto = BCO_NEXT;
640 StgClosure* con = (StgClosure*)StackWord(0);
641 if (constrTag(con) >= discr)
646 int discr = BCO_NEXT;
647 int failto = BCO_NEXT;
648 StgClosure* con = (StgClosure*)StackWord(0);
649 if (constrTag(con) != discr)
654 /* The top thing on the stack should be a tagged int. */
655 int discr = BCO_NEXT;
656 int failto = BCO_NEXT;
657 I_ stackInt = (I_)StackWord(1);
658 ASSERT(1 == StackWord(0));
659 if (stackInt >= (I_)BCO_LIT(discr))
664 /* The top thing on the stack should be a tagged int. */
665 int discr = BCO_NEXT;
666 int failto = BCO_NEXT;
667 I_ stackInt = (I_)StackWord(1);
668 ASSERT(1 == StackWord(0));
669 if (stackInt != (I_)BCO_LIT(discr))
674 /* The top thing on the stack should be a tagged double. */
675 int discr = BCO_NEXT;
676 int failto = BCO_NEXT;
677 StgDouble stackDbl, discrDbl;
678 ASSERT(sizeofW(StgDouble) == StackWord(0));
679 stackDbl = PK_DBL( & StackWord(1) );
680 discrDbl = PK_DBL( & BCO_LIT(discr) );
681 if (stackDbl >= discrDbl)
686 /* The top thing on the stack should be a tagged double. */
687 int discr = BCO_NEXT;
688 int failto = BCO_NEXT;
689 StgDouble stackDbl, discrDbl;
690 ASSERT(sizeofW(StgDouble) == StackWord(0));
691 stackDbl = PK_DBL( & StackWord(1) );
692 discrDbl = PK_DBL( & BCO_LIT(discr) );
693 if (stackDbl != discrDbl)
698 /* The top thing on the stack should be a tagged float. */
699 int discr = BCO_NEXT;
700 int failto = BCO_NEXT;
701 StgFloat stackFlt, discrFlt;
702 ASSERT(sizeofW(StgFloat) == StackWord(0));
703 stackFlt = PK_FLT( & StackWord(1) );
704 discrFlt = PK_FLT( & BCO_LIT(discr) );
705 if (stackFlt >= discrFlt)
710 /* The top thing on the stack should be a tagged float. */
711 int discr = BCO_NEXT;
712 int failto = BCO_NEXT;
713 StgFloat stackFlt, discrFlt;
714 ASSERT(sizeofW(StgFloat) == StackWord(0));
715 stackFlt = PK_FLT( & StackWord(1) );
716 discrFlt = PK_FLT( & BCO_LIT(discr) );
717 if (stackFlt != discrFlt)
722 /* Control-flow ish things */
727 /* Figure out whether returning to interpreted or
729 int o_itoc_itbl = BCO_NEXT;
730 int tag = StackWord(0);
731 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
732 ASSERT(tag <= 2); /* say ... */
733 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
734 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
735 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
736 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info
737 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_V_info) {
738 /* Returning to interpreted code. Interpret the BCO
739 immediately underneath the itbl. */
740 StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
742 StackWord(0) = (W_)ret_bco;
745 /* Returning (unboxed value) to compiled code.
746 Replace tag with a suitable itbl and ask the
747 scheduler to run it. The itbl code will copy
748 the TOS value into R1/F1/D1 and do a standard
749 compiled-code return. */
750 StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
751 if (magic_itbl != NULL) {
752 StackWord(0) = (W_)magic_itbl;
753 cap->r.rCurrentTSO->what_next = ThreadRunGHC;
754 RETURN(ThreadYielding);
756 /* Special case -- returning a VoidRep to
757 compiled code. T.O.S is the VoidRep tag,
758 and underneath is the return itbl. Zap the
759 tag and enter the itbl. */
760 ASSERT(StackWord(0) == (W_)NULL);
762 cap->r.rCurrentTSO->what_next = ThreadRunGHC;
763 RETURN(ThreadYielding);
768 int stkoff = BCO_NEXT;
769 signed short n = (signed short)(BCO_NEXT);
770 StackWord(stkoff) += (W_)n;
775 int o_itbl = BCO_NEXT;
776 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
778 tok = suspendThread(cap);
779 marshall_fn ( (void*)(& StackWord(0) ) );
780 cap = resumeThread(tok);
785 /* BCO_NEXT modifies bciPtr, so be conservative. */
786 int nextpc = BCO_NEXT;
791 barf("interpretBCO: hit a CASEFAIL");
795 barf("interpretBCO: unknown or unimplemented opcode");
797 } /* switch on opcode */
799 barf("interpretBCO: fell off end of insn loop");
802 /* ---------------------------------------------------- */
803 /* End of the bytecode interpreter */
804 /* ---------------------------------------------------- */
809 { int j = get_itbl(obj)->type;
810 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
811 it_unknown_entries[j]++;
812 it_total_unknown_entries++;
816 /* Can't handle this object; yield to sched. */
818 fprintf(stderr, "entering unknown closure -- yielding to sched\n");
821 iSp--; StackWord(0) = (W_)obj;
822 cap->r.rCurrentTSO->what_next = ThreadEnterGHC;
823 RETURN(ThreadYielding);
825 } /* switch on object kind */
827 barf("fallen off end of object-type switch in interpretBCO()");