2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Interpreter.c,v $
9 * $Date: 2001/01/15 16:55:25 $
10 * ---------------------------------------------------------------------------*/
24 #include "Bytecodes.h"
26 #include "Disassembler.h"
27 #include "Interpreter.h"
30 /* --------------------------------------------------------------------------
31 * The new bytecode interpreter
32 * ------------------------------------------------------------------------*/
34 /* Sp points to the lowest live word on the stack. */
36 #define StackWord(n) iSp[n]
37 #define BCO_NEXT instrs[bciPtr++]
38 #define BCO_PTR(n) (W_)ptrs[n]
39 #define BCO_LIT(n) (W_)literals[n]
40 #define BCO_ITBL(n) itbls[n]
42 #define LOAD_STACK_POINTERS \
43 iSp = cap->rCurrentTSO->sp; iSu = cap->rCurrentTSO->su;
45 #define SAVE_STACK_POINTERS \
46 cap->rCurrentTSO->sp = iSp; cap->rCurrentTSO->su = iSu;
48 #define RETURN(retcode) \
49 SAVE_STACK_POINTERS; return retcode;
52 static __inline__ StgPtr allocate_UPD ( int n_words )
54 //fprintf(stderr, "alloc_UPD %d -> ", n_words );
55 if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE)
56 n_words = MIN_UPD_SIZE + sizeofW(StgHeader);
57 //fprintf(stderr, "%d\n", n_words );
58 return allocate(n_words);
61 static __inline__ StgPtr allocate_NONUPD ( int n_words )
63 //fprintf(stderr, "alloc_NONUPD %d -> ", n_words );
64 if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
65 n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader);
66 //fprintf(stderr, "%d\n", n_words );
67 return allocate(n_words);
71 StgThreadReturnCode interpretBCO ( Capability* cap )
73 /* On entry, the closure to interpret is on the top of the
76 /* Use of register here is primarily to make it clear to compilers
77 that these entities are non-aliasable.
79 register W_* iSp; /* local state -- stack pointer */
80 register StgUpdateFrame* iSu; /* local state -- frame pointer */
81 register StgPtr iSpLim; /* local state -- stack lim pointer */
82 register StgClosure* obj;
86 iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
88 /* Main object-entering loop. Object to be entered is on top of
92 obj = (StgClosure*)StackWord(0); iSp++;
96 "\n---------------------------------------------------------------\n");
97 fprintf(stderr,"Entering: "); printObj(obj);
98 fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu);
99 fprintf(stderr, "\n" );
102 // iSp--; StackWord(0) = obj;
103 // checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
106 printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
107 fprintf(stderr, "\n\n");
110 switch ( get_itbl(obj)->type ) {
112 barf("Invalid object %p",(StgPtr)obj);
118 StgAP_UPD *ap = (StgAP_UPD*)obj;
121 /* WARNING: do a stack overflow check here !
122 This code (copied from stg_AP_UPD_entry) is not correct without it. */
124 iSp -= sizeofW(StgUpdateFrame);
127 StgUpdateFrame *__frame;
128 __frame = (StgUpdateFrame *)iSp;
129 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
131 __frame->updatee = (StgClosure *)(ap);
137 /* Reload the stack */
138 for (i=0; i<Words; i++) StackWord(i) = (W_)ap->payload[i];
140 iSp--; StackWord(0) = (W_)ap->fun;
147 /* ---------------------------------------------------- */
148 /* Start of the bytecode interpreter */
149 /* ---------------------------------------------------- */
151 int do_print_stack = 1;
152 register int bciPtr = 1; /* instruction pointer */
153 register StgBCO* bco = (StgBCO*)obj;
154 register UShort* instrs = (UShort*)(&bco->instrs->payload[0]);
155 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
156 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
157 register StgInfoTable** itbls = (StgInfoTable**)
158 (&bco->itbls->payload[0]);
160 if (doYouWantToGC()) {
161 iSp--; StackWord(0) = (W_)bco;
162 RETURN(HeapOverflow);
167 ASSERT(bciPtr <= instrs[0]);
169 //if (do_print_stack) {
170 //fprintf(stderr, "\n-- BEGIN stack\n");
171 //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
172 //fprintf(stderr, "-- END stack\n\n");
175 fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr);
176 disInstr(bco,bciPtr);
178 fprintf(stderr,"\n");
179 for (i = 8; i >= 0; i--)
180 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i)));
181 fprintf(stderr,"\n");
183 //if (do_print_stack) checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
192 int arg_words_reqd = BCO_NEXT;
193 int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
194 if (arg_words_avail >= arg_words_reqd) goto nextInsn;
195 /* Handle arg check failure. Copy the spare args
197 /* fprintf(stderr, "arg check fail %d %d\n", arg_words_reqd, arg_words_avail ); */
198 pap = (StgPAP*)allocate_UPD(PAP_sizeW(arg_words_avail));
199 SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
200 pap->n_args = arg_words_avail;
202 for (i = 0; i < arg_words_avail; i++)
203 pap->payload[i] = (StgClosure*)StackWord(i);
204 /* Push on the stack and defer to the scheduler. */
207 StackWord(0) = (W_)pap;
209 fprintf(stderr,"\tBuilt ");
210 printObj((StgClosure*)pap);
212 RETURN(ThreadEnterGHC);
216 ASSERT((W_*)iSp+o1 < (W_*)iSu);
217 StackWord(-1) = StackWord(o1);
225 StackWord(-1) = StackWord(o1);
226 StackWord(-2) = StackWord(o2);
234 StackWord(-1) = StackWord(o1);
235 StackWord(-2) = StackWord(o2);
236 StackWord(-3) = StackWord(o3);
242 StackWord(-1) = BCO_PTR(o1);
247 int o_bco = BCO_NEXT;
248 int o_itbl = BCO_NEXT;
249 StackWord(-2) = BCO_LIT(o_itbl);
250 StackWord(-1) = BCO_PTR(o_bco);
256 int o_lits = BCO_NEXT;
257 int n_words = BCO_NEXT;
259 for (i = 0; i < n_words; i++)
260 StackWord(i) = BCO_LIT(o_lits+i);
265 W_ tag = (W_)(BCO_NEXT);
273 ASSERT((W_*)iSp+n+by <= (W_*)iSu);
274 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
276 StackWord(n+by) = StackWord(n);
283 int n_payload = BCO_NEXT - 1;
284 int request = AP_sizeW(n_payload);
285 ap = (StgAP_UPD*)allocate_UPD(request);
286 StackWord(-1) = (W_)ap;
287 ap->n_args = n_payload;
288 SET_HDR(ap, &stg_AP_UPD_info, ??)
294 int stkoff = BCO_NEXT;
295 int n_payload = BCO_NEXT - 1;
296 StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
297 ASSERT((int)ap->n_args == n_payload);
298 ap->fun = (StgClosure*)StackWord(0);
299 for (i = 0; i < n_payload; i++)
300 ap->payload[i] = (StgClosure*)StackWord(i+1);
303 fprintf(stderr,"\tBuilt ");
304 printObj((StgClosure*)ap);
309 /* Unpack N ptr words from t.o.s constructor */
310 /* The common case ! */
312 int n_words = BCO_NEXT;
313 StgClosure* con = (StgClosure*)StackWord(0);
315 for (i = 0; i < n_words; i++)
316 StackWord(i) = (W_)con->payload[i];
320 /* Unpack N (non-ptr) words from offset M in the
321 constructor K words down the stack, and then push
322 N as a tag, on top of it. Slow but general; we
323 hope it will be the rare case. */
325 int n_words = BCO_NEXT;
326 int con_off = BCO_NEXT;
327 int stk_off = BCO_NEXT;
328 StgClosure* con = (StgClosure*)StackWord(stk_off);
330 for (i = 0; i < n_words; i++)
331 StackWord(i) = (W_)con->payload[con_off + i];
333 StackWord(0) = n_words;
338 int o_itbl = BCO_NEXT;
339 int n_words = BCO_NEXT;
340 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
341 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
342 itbl->layout.payload.nptrs );
343 StgClosure* con = (StgClosure*)allocate_NONUPD(request);
344 //fprintf(stderr, "---PACK p %d, np %d\n",
345 // (int) itbl->layout.payload.ptrs,
346 // (int) itbl->layout.payload.nptrs );
347 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
348 SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
349 for (i = 0; i < n_words; i++)
350 con->payload[i] = (StgClosure*)StackWord(i);
353 StackWord(0) = (W_)con;
355 fprintf(stderr,"\tBuilt ");
356 printObj((StgClosure*)con);
361 int discr = BCO_NEXT;
362 int failto = BCO_NEXT;
363 StgClosure* con = (StgClosure*)StackWord(0);
364 if (constrTag(con) >= discr)
369 int discr = BCO_NEXT;
370 int failto = BCO_NEXT;
371 StgClosure* con = (StgClosure*)StackWord(0);
372 if (constrTag(con) != discr)
377 /* The top thing on the stack should be a tagged int. */
378 int discr = BCO_NEXT;
379 int failto = BCO_NEXT;
380 I_ stackInt = (I_)StackWord(1);
381 ASSERT(1 == StackWord(0));
382 if (stackInt >= (I_)BCO_LIT(discr))
387 /* The top thing on the stack should be a tagged int. */
388 int discr = BCO_NEXT;
389 int failto = BCO_NEXT;
390 I_ stackInt = (I_)StackWord(1);
391 ASSERT(1 == StackWord(0));
392 if (stackInt != (I_)BCO_LIT(discr))
397 /* The top thing on the stack should be a tagged double. */
398 int discr = BCO_NEXT;
399 int failto = BCO_NEXT;
400 StgDouble stackDbl, discrDbl;
401 ASSERT(sizeofW(StgDouble) == StackWord(0));
402 stackDbl = PK_DBL( & StackWord(1) );
403 discrDbl = PK_DBL( & BCO_LIT(discr) );
404 if (stackDbl >= discrDbl)
409 /* The top thing on the stack should be a tagged double. */
410 int discr = BCO_NEXT;
411 int failto = BCO_NEXT;
412 StgDouble stackDbl, discrDbl;
413 ASSERT(sizeofW(StgDouble) == StackWord(0));
414 stackDbl = PK_DBL( & StackWord(1) );
415 discrDbl = PK_DBL( & BCO_LIT(discr) );
416 if (stackDbl != discrDbl)
421 /* Control-flow ish things */
426 /* Figure out whether returning to interpreted or
428 int o_itoc_itbl = BCO_NEXT;
429 int tag = StackWord(0);
430 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
431 ASSERT(tag <= 2); /* say ... */
432 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
433 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
434 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
435 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info) {
436 /* Returning to interpreted code. Interpret the BCO
437 immediately underneath the itbl. */
438 StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
440 StackWord(0) = (W_)ret_bco;
443 /* Returning (unboxed value) to compiled code.
444 Replace tag with a suitable itbl and ask the
445 scheduler to run it. The itbl code will copy
446 the TOS value into R1/F1/D1 and do a standard
447 compiled-code return. */
448 StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
449 StackWord(0) = (W_)magic_itbl;
450 RETURN(ThreadRunGHC);
455 barf("interpretBCO: hit a CASEFAIL");
457 /* As yet unimplemented */
463 barf("interpretBCO: unknown or unimplemented opcode");
465 } /* switch on opcode */
467 barf("interpretBCO: fell off end of insn loop");
470 /* ---------------------------------------------------- */
471 /* End of the bytecode interpreter */
472 /* ---------------------------------------------------- */
475 /* Can't handle this object; yield to sched. */
477 fprintf(stderr, "entering unknown closure -- yielding to sched\n");
480 cap->rCurrentTSO->what_next = ThreadEnterGHC;
481 iSp--; StackWord(0) = (W_)obj;
482 RETURN(ThreadYielding);
484 } /* switch on object kind */
486 barf("fallen off end of object-type switch in interpretBCO()");