2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Interpreter.c,v $
9 * $Date: 2001/02/06 12:09:42 $
10 * ---------------------------------------------------------------------------*/
24 #include "Bytecodes.h"
26 #include "Disassembler.h"
27 #include "Interpreter.h"
30 /* --------------------------------------------------------------------------
31 * The new bytecode interpreter
32 * ------------------------------------------------------------------------*/
34 /* The interpreter can be compiled so it just interprets BCOs and
35 hands literally everything else to the scheduler. This gives a
36 "reference interpreter" which is correct but slow -- useful for
37 debugging. By default, we handle certain closures specially so as
38 to dramatically cut down on the number of deferrals to the
39 scheduler. Ie normally you don't want REFERENCE_INTERPRETER to be
42 /* #define REFERENCE_INTERPRETER */
44 /* Gather stats about entry, opcode, opcode-pair frequencies. For
45 tuning the interpreter. */
47 /* #define INTERP_STATS */
51 /* iSp points to the lowest live word on the stack. */
53 #define StackWord(n) iSp[n]
54 #define BCO_NEXT instrs[bciPtr++]
55 #define BCO_PTR(n) (W_)ptrs[n]
56 #define BCO_LIT(n) (W_)literals[n]
57 #define BCO_ITBL(n) itbls[n]
59 #define LOAD_STACK_POINTERS \
60 iSp = cap->rCurrentTSO->sp; iSu = cap->rCurrentTSO->su;
62 #define SAVE_STACK_POINTERS \
63 cap->rCurrentTSO->sp = iSp; cap->rCurrentTSO->su = iSu;
65 #define RETURN(retcode) \
66 SAVE_STACK_POINTERS; return retcode;
69 static __inline__ StgPtr allocate_UPD ( int n_words )
71 if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE)
72 n_words = MIN_UPD_SIZE + sizeofW(StgHeader);
73 return allocate(n_words);
76 static __inline__ StgPtr allocate_NONUPD ( int n_words )
78 if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
79 n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader);
80 return allocate(n_words);
85 /* Hacky stats, for tuning the interpreter ... */
86 int it_unknown_entries[N_CLOSURE_TYPES];
87 int it_total_unknown_entries;
99 int it_oofreq[27][27];
102 void interp_startup ( void )
105 it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
106 it_total_entries = it_total_unknown_entries = 0;
107 for (i = 0; i < N_CLOSURE_TYPES; i++)
108 it_unknown_entries[i] = 0;
109 it_slides = it_insns = it_BCO_entries = 0;
110 for (i = 0; i < 27; i++) it_ofreq[i] = 0;
111 for (i = 0; i < 27; i++)
112 for (j = 0; j < 27; j++)
117 void interp_shutdown ( void )
119 int i, j, k, o_max, i_max, j_max;
120 fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ???)\n",
121 it_retto_BCO + it_retto_UPDATE + it_retto_other,
122 it_retto_BCO, it_retto_UPDATE, it_retto_other );
123 fprintf(stderr, "%d total entries, %d unknown entries \n",
124 it_total_entries, it_total_unknown_entries);
125 for (i = 0; i < N_CLOSURE_TYPES; i++) {
126 if (it_unknown_entries[i] == 0) continue;
127 fprintf(stderr, " type %2d: unknown entries (%4.1f%%) == %d\n",
128 i, 100.0 * ((double)it_unknown_entries[i]) /
129 ((double)it_total_unknown_entries),
130 it_unknown_entries[i]);
132 fprintf(stderr, "%d insns, %d slides, %d BCO_entries\n",
133 it_insns, it_slides, it_BCO_entries);
134 for (i = 0; i < 27; i++)
135 fprintf(stderr, "opcode %2d got %d\n", i, it_ofreq[i] );
137 for (k = 1; k < 20; k++) {
140 for (i = 0; i < 27; i++) {
141 for (j = 0; j < 27; j++) {
142 if (it_oofreq[i][j] > o_max) {
143 o_max = it_oofreq[i][j];
144 i_max = i; j_max = j;
149 fprintf ( stderr, "%d: count (%4.1f%%) %6d is %d then %d\n",
150 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
152 it_oofreq[i_max][j_max] = 0;
159 StgThreadReturnCode interpretBCO ( Capability* cap )
161 /* On entry, the closure to interpret is on the top of the
164 /* Use of register here is primarily to make it clear to compilers
165 that these entities are non-aliasable.
167 register W_* iSp; /* local state -- stack pointer */
168 register StgUpdateFrame* iSu; /* local state -- frame pointer */
169 register StgPtr iSpLim; /* local state -- stack lim pointer */
170 register StgClosure* obj;
174 /* We don't change this ... */
175 iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
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, ??)
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 /* Control-flow ish things */
702 /* Figure out whether returning to interpreted or
704 int o_itoc_itbl = BCO_NEXT;
705 int tag = StackWord(0);
706 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
707 ASSERT(tag <= 2); /* say ... */
708 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
709 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
710 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
711 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info) {
712 /* Returning to interpreted code. Interpret the BCO
713 immediately underneath the itbl. */
714 StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
716 StackWord(0) = (W_)ret_bco;
719 /* Returning (unboxed value) to compiled code.
720 Replace tag with a suitable itbl and ask the
721 scheduler to run it. The itbl code will copy
722 the TOS value into R1/F1/D1 and do a standard
723 compiled-code return. */
724 StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
725 StackWord(0) = (W_)magic_itbl;
726 cap->rCurrentTSO->what_next = ThreadRunGHC;
727 RETURN(ThreadYielding);
732 barf("interpretBCO: hit a CASEFAIL");
734 /* As yet unimplemented */
740 barf("interpretBCO: unknown or unimplemented opcode");
742 } /* switch on opcode */
744 barf("interpretBCO: fell off end of insn loop");
747 /* ---------------------------------------------------- */
748 /* End of the bytecode interpreter */
749 /* ---------------------------------------------------- */
754 { int j = get_itbl(obj)->type;
755 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
756 it_unknown_entries[j]++;
757 it_total_unknown_entries++;
761 /* Can't handle this object; yield to sched. */
763 fprintf(stderr, "entering unknown closure -- yielding to sched\n");
766 iSp--; StackWord(0) = (W_)obj;
767 cap->rCurrentTSO->what_next = ThreadEnterGHC;
768 RETURN(ThreadYielding);
770 } /* switch on object kind */
772 barf("fallen off end of object-type switch in interpretBCO()");