2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Interpreter.c,v $
9 * $Date: 2001/01/10 17:21:18 $
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 StgThreadReturnCode interpretBCO ( Capability* cap )
54 /* On entry, the closure to interpret is on the top of the
57 /* Use of register here is primarily to make it clear to compilers
58 that these entities are non-aliasable.
60 register W_* iSp; /* local state -- stack pointer */
61 register StgUpdateFrame* iSu; /* local state -- frame pointer */
62 register StgPtr iSpLim; /* local state -- stack lim pointer */
63 register StgClosure* obj;
67 iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
69 /* Main object-entering loop. Object to be entered is on top of
73 obj = (StgClosure*)StackWord(0); iSp++;
77 "\n---------------------------------------------------------------\n");
78 fprintf(stderr,"Entering: "); printObj(obj);
79 fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu);
80 fprintf(stderr, "\n" );
83 // iSp--; StackWord(0) = obj;
84 // checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
87 printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
88 fprintf(stderr, "\n\n");
91 switch ( get_itbl(obj)->type ) {
93 barf("Invalid object %p",(StgPtr)obj);
99 StgAP_UPD *ap = (StgAP_UPD*)obj;
102 /* WARNING: do a stack overflow check here !
103 This code (copied from stg_AP_UPD_entry) is not correct without it. */
105 iSp -= sizeofW(StgUpdateFrame);
108 StgUpdateFrame *__frame;
109 __frame = (StgUpdateFrame *)iSp;
110 SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
112 __frame->updatee = (StgClosure *)(ap);
118 /* Reload the stack */
119 for (i=0; i<Words; i++) StackWord(i) = (W_)ap->payload[i];
121 iSp--; StackWord(0) = (W_)ap->fun;
128 /* ---------------------------------------------------- */
129 /* Start of the bytecode interpreter */
130 /* ---------------------------------------------------- */
132 int do_print_stack = 1;
133 register int bciPtr = 1; /* instruction pointer */
134 register StgBCO* bco = (StgBCO*)obj;
135 register UShort* instrs = (UShort*)(&bco->instrs->payload[0]);
136 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
137 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
138 register StgInfoTable** itbls = (StgInfoTable**)
139 (&bco->itbls->payload[0]);
141 if (doYouWantToGC()) {
142 iSp--; StackWord(0) = (W_)bco;
143 RETURN(HeapOverflow);
148 ASSERT(bciPtr <= instrs[0]);
150 //if (do_print_stack) {
151 //fprintf(stderr, "\n-- BEGIN stack\n");
152 //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
153 //fprintf(stderr, "-- END stack\n\n");
156 fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr);
157 disInstr(bco,bciPtr);
159 fprintf(stderr,"\n");
160 for (i = 8; i >= 0; i--)
161 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i)));
162 fprintf(stderr,"\n");
166 // checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
173 int arg_words_reqd = BCO_NEXT;
174 int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
175 if (arg_words_avail >= arg_words_reqd) goto nextInsn;
176 /* Handle arg check failure. Copy the spare args
178 /* fprintf(stderr, "arg check fail %d %d\n", arg_words_reqd, arg_words_avail ); */
179 pap = (StgPAP*)allocate(PAP_sizeW(arg_words_avail));
180 SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
181 pap->n_args = arg_words_avail;
183 for (i = 0; i < arg_words_avail; i++)
184 pap->payload[i] = (StgClosure*)StackWord(i);
185 /* Push on the stack and defer to the scheduler. */
188 StackWord(0) = (W_)pap;
189 RETURN(ThreadEnterGHC);
193 ASSERT((W_*)iSp+o1 < (W_*)iSu);
194 StackWord(-1) = StackWord(o1);
202 StackWord(-1) = StackWord(o1);
203 StackWord(-2) = StackWord(o2);
211 StackWord(-1) = StackWord(o1);
212 StackWord(-2) = StackWord(o2);
213 StackWord(-3) = StackWord(o3);
219 StackWord(-1) = BCO_PTR(o1);
224 int o_bco = BCO_NEXT;
225 int o_itbl = BCO_NEXT;
226 StackWord(-2) = BCO_LIT(o_itbl);
227 StackWord(-1) = BCO_PTR(o_bco);
233 int o_lits = BCO_NEXT;
234 int n_words = BCO_NEXT;
236 for (i = 0; i < n_words; i++)
237 StackWord(i) = BCO_LIT(o_lits+i);
242 W_ tag = (W_)(BCO_NEXT);
250 ASSERT((W_*)iSp+n+by <= (W_*)iSu);
251 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
253 StackWord(n+by) = StackWord(n);
259 int n_payload = BCO_NEXT - 1;
260 StgAP_UPD* ap = (StgAP_UPD*)allocate(AP_sizeW(n_payload));
261 StackWord(-1) = (W_)ap;
262 ap->n_args = n_payload;
263 SET_HDR(ap, &stg_AP_UPD_info, ??)
269 int stkoff = BCO_NEXT;
270 int n_payload = BCO_NEXT - 1;
271 StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
272 ASSERT((int)ap->n_args == n_payload);
273 ap->fun = (StgClosure*)StackWord(0);
274 for (i = 0; i < n_payload; i++)
275 ap->payload[i] = (StgClosure*)StackWord(i+1);
280 /* Unpack N ptr words from t.o.s constructor */
281 /* The common case ! */
283 int n_words = BCO_NEXT;
284 StgClosure* con = (StgClosure*)StackWord(0);
286 for (i = 0; i < n_words; i++)
287 StackWord(i) = (W_)con->payload[i];
291 /* Unpack N (non-ptr) words from offset M in the
292 constructor K words down the stack, and then push
293 N as a tag, on top of it. Slow but general; we
294 hope it will be the rare case. */
296 int n_words = BCO_NEXT;
297 int con_off = BCO_NEXT;
298 int stk_off = BCO_NEXT;
299 StgClosure* con = (StgClosure*)StackWord(stk_off);
301 for (i = 0; i < n_words; i++)
302 StackWord(i) = (W_)con->payload[con_off + i];
304 StackWord(0) = n_words;
309 int o_itbl = BCO_NEXT;
310 int n_words = BCO_NEXT;
311 StgInfoTable* itbl = BCO_ITBL(o_itbl);
312 /* A bit of a kludge since n_words = n_p + n_np */
313 int request = CONSTR_sizeW( n_words, 0 );
314 StgClosure* con = (StgClosure*)allocate(request);
315 SET_HDR(con, itbl, CCS_SYSTEM/*ToDo*/);
316 for (i = 0; i < n_words; i++)
317 con->payload[i] = (StgClosure*)StackWord(i);
320 StackWord(0) = (W_)con;
324 int discr = BCO_NEXT;
325 int failto = BCO_NEXT;
326 StgClosure* con = (StgClosure*)StackWord(0);
327 if (constrTag(con) >= discr)
332 int discr = BCO_NEXT;
333 int failto = BCO_NEXT;
334 StgClosure* con = (StgClosure*)StackWord(0);
335 if (constrTag(con) != discr)
340 /* The top thing on the stack should be a tagged int. */
341 int discr = BCO_NEXT;
342 int failto = BCO_NEXT;
343 I_ stackInt = (I_)StackWord(1);
344 ASSERT(1 == StackWord(0));
345 if (stackInt >= (I_)BCO_LIT(discr))
350 /* The top thing on the stack should be a tagged int. */
351 int discr = BCO_NEXT;
352 int failto = BCO_NEXT;
353 I_ stackInt = (I_)StackWord(1);
354 ASSERT(1 == StackWord(0));
355 if (stackInt != (I_)BCO_LIT(discr))
360 /* The top thing on the stack should be a tagged double. */
361 int discr = BCO_NEXT;
362 int failto = BCO_NEXT;
363 StgDouble stackDbl, discrDbl;
364 ASSERT(sizeofW(StgDouble) == StackWord(0));
365 stackDbl = PK_DBL( & StackWord(1) );
366 discrDbl = PK_DBL( & BCO_LIT(discr) );
367 if (stackDbl >= discrDbl)
372 /* The top thing on the stack should be a tagged double. */
373 int discr = BCO_NEXT;
374 int failto = BCO_NEXT;
375 StgDouble stackDbl, discrDbl;
376 ASSERT(sizeofW(StgDouble) == StackWord(0));
377 stackDbl = PK_DBL( & StackWord(1) );
378 discrDbl = PK_DBL( & BCO_LIT(discr) );
379 if (stackDbl != discrDbl)
384 /* Control-flow ish things */
389 /* Figure out whether returning to interpreted or
391 int o_itoc_itbl = BCO_NEXT;
392 int tag = StackWord(0);
393 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
394 ASSERT(tag <= 2); /* say ... */
395 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1_info
396 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
397 || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info) {
398 /* Returning to interpreted code. Interpret the BCO
399 immediately underneath the itbl. */
400 StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
402 StackWord(0) = (W_)ret_bco;
405 /* Returning (unboxed value) to compiled code.
406 Replace tag with a suitable itbl and ask the
407 scheduler to run it. The itbl code will copy
408 the TOS value into R1/F1/D1 and do a standard
409 compiled-code return. */
410 StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
411 StackWord(0) = (W_)magic_itbl;
412 RETURN(ThreadRunGHC);
417 barf("interpretBCO: hit a CASEFAIL");
419 /* As yet unimplemented */
425 barf("interpretBCO: unknown or unimplemented opcode");
427 } /* switch on opcode */
429 barf("interpretBCO: fell off end of insn loop");
432 /* ---------------------------------------------------- */
433 /* End of the bytecode interpreter */
434 /* ---------------------------------------------------- */
437 /* Can't handle this object; yield to sched. */
439 fprintf(stderr, "entering unknown closure -- yielding to sched\n");
442 cap->rCurrentTSO->what_next = ThreadEnterGHC;
443 iSp--; StackWord(0) = (W_)obj;
444 RETURN(ThreadYielding);
446 } /* switch on object kind */
448 barf("fallen off end of object-type switch in interpretBCO()");