2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Interpreter.c,v $
9 * $Date: 2001/01/09 17:36:21 $
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 register int bciPtr = 1; /* instruction pointer */
133 register StgBCO* bco = (StgBCO*)obj;
134 register UShort* instrs = (UShort*)(&bco->instrs->payload[0]);
135 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
136 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
137 register StgInfoTable** itbls = (StgInfoTable**)
138 (&bco->itbls->payload[0]);
140 if (doYouWantToGC()) {
141 iSp--; StackWord(0) = (W_)bco;
142 RETURN(HeapOverflow);
147 ASSERT(bciPtr <= instrs[0]);
149 //fprintf(stderr, "\n-- BEGIN stack\n");
150 //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
151 //fprintf(stderr, "-- END stack\n\n");
152 fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr);
153 disInstr(bco,bciPtr);
155 fprintf(stderr,"\n");
156 for (i = 8; i >= 0; i--)
157 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i)));
158 fprintf(stderr,"\n");
162 // checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
169 int arg_words_reqd = BCO_NEXT;
170 int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
171 if (arg_words_avail >= arg_words_reqd) goto nextInsn;
172 /* Handle arg check failure. Copy the spare args
174 /* fprintf(stderr, "arg check fail %d %d\n", arg_words_reqd, arg_words_avail ); */
175 pap = (StgPAP*)allocate(PAP_sizeW(arg_words_avail));
176 SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
177 pap->n_args = arg_words_avail;
179 for (i = 0; i < arg_words_avail; i++)
180 pap->payload[i] = (StgClosure*)StackWord(i);
181 /* Push on the stack and defer to the scheduler. */
184 StackWord(0) = (W_)pap;
185 RETURN(ThreadEnterGHC);
189 ASSERT((W_*)iSp+o1 < (W_*)iSu);
190 StackWord(-1) = StackWord(o1);
197 StackWord(-1) = StackWord(o1);
198 StackWord(-2) = StackWord(o2);
206 StackWord(-1) = StackWord(o1);
207 StackWord(-2) = StackWord(o2);
208 StackWord(-3) = StackWord(o3);
214 StackWord(-1) = BCO_PTR(o1);
219 int o_bco = BCO_NEXT;
220 int o_itbl = BCO_NEXT;
221 StackWord(-2) = BCO_LIT(o_itbl);
222 StackWord(-1) = BCO_PTR(o_bco);
227 int o_lits = BCO_NEXT;
228 int n_words = BCO_NEXT;
229 for (; n_words > 0; n_words--) {
231 StackWord(0) = BCO_LIT(o_lits);
237 W_ tag = (W_)(BCO_NEXT);
245 ASSERT((W_*)iSp+n+by <= (W_*)iSu);
246 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
248 StackWord(n+by) = StackWord(n);
254 int n_payload = BCO_NEXT - 1;
255 StgAP_UPD* ap = (StgAP_UPD*)allocate(AP_sizeW(n_payload));
256 StackWord(-1) = (W_)ap;
257 ap->n_args = n_payload;
258 SET_HDR(ap, &stg_AP_UPD_info, ??)
264 int stkoff = BCO_NEXT;
265 int n_payload = BCO_NEXT - 1;
266 StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
267 ASSERT((int)ap->n_args == n_payload);
268 ap->fun = (StgClosure*)StackWord(0);
269 for (i = 0; i < n_payload; i++)
270 ap->payload[i] = (StgClosure*)StackWord(i+1);
275 /* Unpack N ptr words from t.o.s constructor */
276 /* The common case ! */
278 int n_words = BCO_NEXT;
279 StgClosure* con = (StgClosure*)StackWord(0);
281 for (i = 0; i < n_words; i++)
282 StackWord(i) = (W_)con->payload[i];
286 /* Unpack N (non-ptr) words from offset M in the
287 constructor K words down the stack, and then push
288 N as a tag, on top of it. Slow but general; we
289 hope it will be the rare case. */
291 int n_words = BCO_NEXT;
292 int con_off = BCO_NEXT;
293 int stk_off = BCO_NEXT;
294 StgClosure* con = (StgClosure*)StackWord(stk_off);
296 for (i = 0; i < n_words; i++)
297 StackWord(i) = (W_)con->payload[con_off + i];
299 StackWord(0) = n_words;
304 int o_itbl = BCO_NEXT;
305 int n_words = BCO_NEXT;
306 StgInfoTable* itbl = BCO_ITBL(o_itbl);
307 /* A bit of a kludge since n_words = n_p + n_np */
308 int request = CONSTR_sizeW( n_words, 0 );
309 StgClosure* con = (StgClosure*)allocate(request);
310 SET_HDR(con, itbl, CCS_SYSTEM/*ToDo*/);
311 for (i = 0; i < n_words; i++)
312 con->payload[i] = (StgClosure*)StackWord(i);
315 StackWord(0) = (W_)con;
319 int discr = BCO_NEXT;
320 int failto = BCO_NEXT;
321 StgClosure* con = (StgClosure*)StackWord(0);
322 if (constrTag(con) >= discr)
327 int discr = BCO_NEXT;
328 int failto = BCO_NEXT;
329 StgClosure* con = (StgClosure*)StackWord(0);
330 if (constrTag(con) != discr)
335 /* The top thing on the stack should be a tagged int. */
336 int discr = BCO_NEXT;
337 int failto = BCO_NEXT;
338 I_ stackInt = (I_)StackWord(1);
339 ASSERT(1 == StackWord(0));
340 fprintf(stderr, "TESTEQ_I: discr = %d, stack = %d\n",(I_)BCO_LIT(discr), stackInt);
341 if (stackInt != (I_)BCO_LIT(discr))
346 /* Control-flow ish things */
351 /* Figure out whether returning to interpreted or
353 int o_itoc_itbl = BCO_NEXT;
354 int tag = StackWord(0);
355 StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
356 ASSERT(tag <= 2); /* say ... */
357 if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1_info
358 /* || ret_itbl == stg_ctoi_ret_F1_info
359 || ret_itbl == stg_ctoi_ret_D1_info */) {
360 /* Returning to interpreted code. Interpret the BCO
361 immediately underneath the itbl. */
362 StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
364 StackWord(0) = (W_)ret_bco;
367 /* Returning (unboxed value) to compiled code.
368 Replace tag with a suitable itbl and ask the
369 scheduler to run it. The itbl code will copy
370 the TOS value into R1/F1/D1 and do a standard
371 compiled-code return. */
372 StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
373 StackWord(0) = (W_)magic_itbl;
374 RETURN(ThreadRunGHC);
379 barf("interpretBCO: hit a CASEFAIL");
381 /* As yet unimplemented */
390 barf("interpretBCO: unknown or unimplemented opcode");
392 } /* switch on opcode */
394 barf("interpretBCO: fell off end of insn loop");
397 /* ---------------------------------------------------- */
398 /* End of the bytecode interpreter */
399 /* ---------------------------------------------------- */
402 /* Can't handle this object; yield to sched. */
404 fprintf(stderr, "entering unknown closure -- yielding to sched\n");
407 cap->rCurrentTSO->what_next = ThreadEnterGHC;
408 iSp--; StackWord(0) = (W_)obj;
409 RETURN(ThreadYielding);
411 } /* switch on object kind */
413 barf("fallen off end of object-type switch in interpretBCO()");