2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Interpreter.c,v $
9 * $Date: 2001/02/05 17:27:48 $
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[26][26];
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 < 26; i++) it_ofreq[i] = 0;
111 for (i = 0; i < 26; i++)
112 for (j = 0; j < 26; 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 < 26; 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 < 26; i++) {
141 for (j = 0; j < 26; 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]);
372 if (doYouWantToGC()) {
373 iSp--; StackWord(0) = (W_)bco;
374 cap->rCurrentTSO->what_next = ThreadEnterGHC;
375 RETURN(HeapOverflow);
379 it_lastopc = 0; /* no opcode */
384 ASSERT(bciPtr <= instrs[0]);
386 //if (do_print_stack) {
387 //fprintf(stderr, "\n-- BEGIN stack\n");
388 //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
389 //fprintf(stderr, "-- END stack\n\n");
392 fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr);
393 disInstr(bco,bciPtr);
395 fprintf(stderr,"\n");
396 for (i = 8; i >= 0; i--)
397 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i)));
398 fprintf(stderr,"\n");
400 //if (do_print_stack) checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
405 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 26 );
406 it_ofreq[ (int)instrs[bciPtr] ] ++;
407 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
408 it_lastopc = (int)instrs[bciPtr];
416 int arg_words_reqd = BCO_NEXT;
417 int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
418 if (arg_words_avail >= arg_words_reqd) goto nextInsn;
420 # ifndef REFERENCE_INTERPRETER
422 /* Optimisation: if there are no args avail and the
423 t-o-s is an update frame, do the update, and
424 re-enter the object. */
425 if (arg_words_avail == 0
426 && get_itbl(iSu)->type == UPDATE_FRAME) {
427 UPD_IND(iSu->updatee, obj);
429 iSp += sizeofW(StgUpdateFrame);
430 goto nextEnter_obj_BCO;
433 # endif /* ndef REFERENCE_INTERPRETER */
435 /* Handle arg check failure. General case: copy the
436 spare args into a PAP frame. */
437 pap = (StgPAP*)allocate_UPD(PAP_sizeW(arg_words_avail));
438 SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
439 pap->n_args = arg_words_avail;
441 for (i = 0; i < arg_words_avail; i++)
442 pap->payload[i] = (StgClosure*)StackWord(i);
444 /* Push on the stack and defer to the scheduler. */
447 StackWord(0) = (W_)pap;
449 fprintf(stderr,"\tBuilt ");
450 printObj((StgClosure*)pap);
452 cap->rCurrentTSO->what_next = ThreadEnterGHC;
453 RETURN(ThreadYielding);
457 ASSERT((W_*)iSp+o1 < (W_*)iSu);
458 StackWord(-1) = StackWord(o1);
466 ASSERT((W_*)iSp+o1 < (W_*)iSu);
467 ASSERT((W_*)iSp+o2 < (W_*)iSu);
468 StackWord(-1) = StackWord(o1);
469 StackWord(-2) = StackWord(o2);
477 ASSERT((W_*)iSp+o1 < (W_*)iSu);
478 ASSERT((W_*)iSp+o2 < (W_*)iSu);
479 ASSERT((W_*)iSp+o3 < (W_*)iSu);
480 StackWord(-1) = StackWord(o1);
481 StackWord(-2) = StackWord(o2);
482 StackWord(-3) = StackWord(o3);
488 StackWord(-1) = BCO_PTR(o1);
493 int o_bco = BCO_NEXT;
494 int o_itbl = BCO_NEXT;
495 StackWord(-2) = BCO_LIT(o_itbl);
496 StackWord(-1) = BCO_PTR(o_bco);
502 int o_lits = BCO_NEXT;
503 int n_words = BCO_NEXT;
505 for (i = 0; i < n_words; i++)
506 StackWord(i) = BCO_LIT(o_lits+i);
511 W_ tag = (W_)(BCO_NEXT);
519 ASSERT((W_*)iSp+n+by <= (W_*)iSu);
520 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
522 StackWord(n+by) = StackWord(n);
532 int n_payload = BCO_NEXT - 1;
533 int request = AP_sizeW(n_payload);
534 ap = (StgAP_UPD*)allocate_UPD(request);
535 StackWord(-1) = (W_)ap;
536 ap->n_args = n_payload;
537 SET_HDR(ap, &stg_AP_UPD_info, ??)
543 int stkoff = BCO_NEXT;
544 int n_payload = BCO_NEXT - 1;
545 StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
546 ASSERT((int)ap->n_args == n_payload);
547 ap->fun = (StgClosure*)StackWord(0);
548 for (i = 0; i < n_payload; i++)
549 ap->payload[i] = (StgClosure*)StackWord(i+1);
552 fprintf(stderr,"\tBuilt ");
553 printObj((StgClosure*)ap);
558 /* Unpack N ptr words from t.o.s constructor */
559 /* The common case ! */
561 int n_words = BCO_NEXT;
562 StgClosure* con = (StgClosure*)StackWord(0);
564 for (i = 0; i < n_words; i++)
565 StackWord(i) = (W_)con->payload[i];
569 /* Unpack N (non-ptr) words from offset M in the
570 constructor K words down the stack, and then push
571 N as a tag, on top of it. Slow but general; we
572 hope it will be the rare case. */
574 int n_words = BCO_NEXT;
575 int con_off = BCO_NEXT;
576 int stk_off = BCO_NEXT;
577 StgClosure* con = (StgClosure*)StackWord(stk_off);
579 for (i = 0; i < n_words; i++)
580 StackWord(i) = (W_)con->payload[con_off + i];
582 StackWord(0) = n_words;
587 int o_itbl = BCO_NEXT;
588 int n_words = BCO_NEXT;
589 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
590 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
591 itbl->layout.payload.nptrs );
592 StgClosure* con = (StgClosure*)allocate_NONUPD(request);
593 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
594 SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
595 for (i = 0; i < n_words; i++)
596 con->payload[i] = (StgClosure*)StackWord(i);
599 StackWord(0) = (W_)con;
601 fprintf(stderr,"\tBuilt ");
602 printObj((StgClosure*)con);
607 int discr = BCO_NEXT;
608 int failto = BCO_NEXT;
609 StgClosure* con = (StgClosure*)StackWord(0);
610 if (constrTag(con) >= discr)
615 int discr = BCO_NEXT;
616 int failto = BCO_NEXT;
617 StgClosure* con = (StgClosure*)StackWord(0);
618 if (constrTag(con) != discr)
623 /* The top thing on the stack should be a tagged int. */
624 int discr = BCO_NEXT;
625 int failto = BCO_NEXT;
626 I_ stackInt = (I_)StackWord(1);
627 ASSERT(1 == StackWord(0));
628 if (stackInt >= (I_)BCO_LIT(discr))
633 /* The top thing on the stack should be a tagged int. */
634 int discr = BCO_NEXT;
635 int failto = BCO_NEXT;
636 I_ stackInt = (I_)StackWord(1);
637 ASSERT(1 == StackWord(0));
638 if (stackInt != (I_)BCO_LIT(discr))
643 /* The top thing on the stack should be a tagged double. */
644 int discr = BCO_NEXT;
645 int failto = BCO_NEXT;
646 StgDouble stackDbl, discrDbl;
647 ASSERT(sizeofW(StgDouble) == StackWord(0));
648 stackDbl = PK_DBL( & StackWord(1) );
649 discrDbl = PK_DBL( & BCO_LIT(discr) );
650 if (stackDbl >= discrDbl)
655 /* The top thing on the stack should be a tagged double. */
656 int discr = BCO_NEXT;
657 int failto = BCO_NEXT;
658 StgDouble stackDbl, discrDbl;
659 ASSERT(sizeofW(StgDouble) == StackWord(0));
660 stackDbl = PK_DBL( & StackWord(1) );
661 discrDbl = PK_DBL( & BCO_LIT(discr) );
662 if (stackDbl != discrDbl)
667 /* Control-flow ish things */
672 /* Figure out whether returning to interpreted or
674 int o_itoc_itbl = BCO_NEXT;
675 int tag = StackWord(0);
676 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
677 ASSERT(tag <= 2); /* say ... */
678 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
679 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
680 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
681 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info) {
682 /* Returning to interpreted code. Interpret the BCO
683 immediately underneath the itbl. */
684 StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
686 StackWord(0) = (W_)ret_bco;
689 /* Returning (unboxed value) to compiled code.
690 Replace tag with a suitable itbl and ask the
691 scheduler to run it. The itbl code will copy
692 the TOS value into R1/F1/D1 and do a standard
693 compiled-code return. */
694 StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
695 StackWord(0) = (W_)magic_itbl;
696 cap->rCurrentTSO->what_next = ThreadRunGHC;
697 RETURN(ThreadYielding);
702 barf("interpretBCO: hit a CASEFAIL");
704 /* As yet unimplemented */
710 barf("interpretBCO: unknown or unimplemented opcode");
712 } /* switch on opcode */
714 barf("interpretBCO: fell off end of insn loop");
717 /* ---------------------------------------------------- */
718 /* End of the bytecode interpreter */
719 /* ---------------------------------------------------- */
724 { int j = get_itbl(obj)->type;
725 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
726 it_unknown_entries[j]++;
727 it_total_unknown_entries++;
731 /* Can't handle this object; yield to sched. */
733 fprintf(stderr, "entering unknown closure -- yielding to sched\n");
736 iSp--; StackWord(0) = (W_)obj;
737 cap->rCurrentTSO->what_next = ThreadEnterGHC;
738 RETURN(ThreadYielding);
740 } /* switch on object kind */
742 barf("fallen off end of object-type switch in interpretBCO()");