1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
|
/* -----------------------------------------------------------------------------
* Bytecode evaluator
*
* Copyright (c) 1994-2000.
*
* $RCSfile: Interpreter.c,v $
* $Revision: 1.6 $
* $Date: 2001/01/03 15:30:48 $
* ---------------------------------------------------------------------------*/
#ifdef GHCI
#include "Rts.h"
#include "RtsAPI.h"
#include "RtsUtils.h"
#include "Closures.h"
#include "TSO.h"
#include "Schedule.h"
#include "RtsFlags.h"
#include "Storage.h"
#include "Updates.h"
#include "Bytecodes.h"
#include "Printer.h"
#include "Disassembler.h"
#include "Interpreter.h"
/* --------------------------------------------------------------------------
* The new bytecode interpreter
* ------------------------------------------------------------------------*/
/* Sp points to the lowest live word on the stack. */
#define StackWord(n) iSp[n]
#define BCO_NEXT instrs[bciPtr++]
#define BCO_PTR(n) (W_)ptrs[n]
#define BCO_LIT(n) (W_)literals[n]
#define BCO_ITBL(n) itbls[n]
StgThreadReturnCode interpretBCO ( Capability* cap )
{
/* On entry, the closure to interpret is on the top of the
stack. */
/* Use of register here is primarily to make it clear to compilers
that these entities are non-aliasable.
*/
register W_* iSp; /* local state -- stack pointer */
register StgUpdateFrame* iSu; /* local state -- frame pointer */
register StgPtr iSpLim; /* local state -- stack lim pointer */
register StgClosure* obj;
iSp = cap->rCurrentTSO->sp;
iSu = cap->rCurrentTSO->su;
iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
IF_DEBUG(evaluator,
fprintf(stderr,
"\n---------------------------------------------------------------\n");
fprintf(stderr,"Entering: "); printObj((StgClosure*)StackWord(0));
fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu);
fprintf(stderr, "\n" );
printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
fprintf(stderr, "\n\n");
);
/* Main object-entering loop. Object to be entered is on top of
stack. */
nextEnter:
obj = (StgClosure*)StackWord(0); iSp++;
switch ( get_itbl(obj)->type ) {
case INVALID_OBJECT:
barf("Invalid object %p",(StgPtr)obj);
case BCO:
/* ---------------------------------------------------- */
/* Start of the bytecode interpreter */
/* ---------------------------------------------------- */
{
register int bciPtr = 1; /* instruction pointer */
register StgBCO* bco = (StgBCO*)obj;
register UShort* instrs = (UShort*)(&bco->instrs->payload[0]);
register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
register StgInfoTable** itbls = (StgInfoTable**)
(&bco->itbls->payload[0]);
if (doYouWantToGC()) {
iSp--; StackWord(0) = (W_)bco;
return HeapOverflow;
}
nextInsn:
ASSERT(bciPtr <= instrs[0]);
IF_DEBUG(evaluator,
fprintf(stderr,"iSp = %p\tiSu = %p\tpc = %d\t", iSp, iSu, bciPtr);
disInstr(bco,bciPtr);
if (0) { int i;
fprintf(stderr,"\n");
for (i = 8; i >= 0; i--)
fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i)));
}
fprintf(stderr,"\n");
);
switch (BCO_NEXT) {
case bci_ARGCHECK: {
int i;
StgPAP* pap;
int arg_words_reqd = BCO_NEXT;
int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
if (arg_words_avail >= arg_words_reqd) goto nextInsn;
/* Handle arg check failure. Copy the spare args
into a PAP frame. */
pap = (StgPAP*)allocate(PAP_sizeW(arg_words_avail));
SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
pap->n_args = arg_words_avail;
for (i = 0; i < arg_words_avail; i++)
pap->payload[i] = (StgClosure*)StackWord(i);
/* Push on the stack and defer to the scheduler. */
iSp = (StgPtr)iSu;
iSp --;
StackWord(0) = (W_)pap;
return ThreadEnterGHC;
}
case bci_PUSH_L: {
int o1 = BCO_NEXT;
StackWord(-1) = StackWord(o1);
iSp--;
goto nextInsn;
}
case bci_PUSH_LL: {
int o1 = BCO_NEXT;
int o2 = BCO_NEXT;
StackWord(-1) = StackWord(o1);
StackWord(-2) = StackWord(o2);
iSp -= 2;
goto nextInsn;
}
case bci_PUSH_LLL: {
int o1 = BCO_NEXT;
int o2 = BCO_NEXT;
int o3 = BCO_NEXT;
StackWord(-1) = StackWord(o1);
StackWord(-2) = StackWord(o2);
StackWord(-3) = StackWord(o3);
iSp -= 3;
goto nextInsn;
}
case bci_PUSH_G: {
int o1 = BCO_NEXT;
StackWord(-1) = BCO_PTR(o1);
iSp -= 1;
goto nextInsn;
}
case bci_PUSH_AS: {
int o_bco = BCO_NEXT;
int o_itbl = BCO_NEXT;
StackWord(-1) = BCO_LIT(o_itbl);
StackWord(-2) = BCO_PTR(o_bco);
iSp -= 2;
goto nextInsn;
}
case bci_PUSH_UBX: {
int o_lits = BCO_NEXT;
int n_words = BCO_NEXT;
for (; n_words > 0; n_words--) {
iSp --;
StackWord(0) = BCO_LIT(o_lits);
o_lits++;
}
goto nextInsn;
}
case bci_PUSH_TAG: {
W_ tag = (W_)(BCO_NEXT);
StackWord(-1) = tag;
iSp --;
goto nextInsn;
}
case bci_SLIDE: {
int n = BCO_NEXT;
int by = BCO_NEXT;
ASSERT(iSp+n+by <= (W_*)iSu);
/* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
while(--n >= 0) {
StackWord(n+by) = StackWord(n);
}
iSp += by;
goto nextInsn;
}
case bci_ALLOC: {
int n_payload = BCO_NEXT;
P_ p = allocate(AP_sizeW(n_payload));
StackWord(-1) = (W_)p;
iSp --;
goto nextInsn;
}
case bci_MKAP: {
int i;
int stkoff = BCO_NEXT;
int n_payload = BCO_NEXT - 1;
StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
ap->n_args = n_payload;
ap->fun = (StgClosure*)StackWord(0);
for (i = 0; i < n_payload; i++)
ap->payload[i] = (StgClosure*)StackWord(i+1);
iSp += n_payload+1;
goto nextInsn;
}
case bci_UNPACK: {
/* Unpack N ptr words from t.o.s constructor */
/* The common case ! */
int i;
int n_words = BCO_NEXT;
StgClosure* con = (StgClosure*)StackWord(0);
iSp -= n_words;
for (i = 0; i < n_words; i++)
StackWord(i) = (W_)con->payload[i];
goto nextInsn;
}
case bci_UPK_TAG: {
/* Unpack N (non-ptr) words from offset M in the
constructor K words down the stack, and then push
N as a tag, on top of it. Slow but general; we
hope it will be the rare case. */
int i;
int n_words = BCO_NEXT;
int con_off = BCO_NEXT;
int stk_off = BCO_NEXT;
StgClosure* con = (StgClosure*)StackWord(stk_off);
iSp -= n_words;
for (i = 0; i < n_words; i++)
StackWord(i) = (W_)con->payload[con_off + i];
iSp --;
StackWord(0) = n_words;
goto nextInsn;
}
case bci_PACK: {
int i;
int o_itbl = BCO_NEXT;
int n_words = BCO_NEXT;
StgInfoTable* itbl = BCO_ITBL(o_itbl);
/* A bit of a kludge since n_words = n_p + n_np */
int request = CONSTR_sizeW( n_words, 0 );
StgClosure* con = (StgClosure*)allocate(request);
SET_HDR(con, itbl, CCS_SYSTEM/*ToDo*/);
for (i = 0; i < n_words; i++)
con->payload[i] = (StgClosure*)StackWord(i);
iSp += n_words;
iSp --;
StackWord(0) = (W_)con;
goto nextInsn;
}
case bci_TESTLT_P: {
int discr = BCO_NEXT;
int failto = BCO_NEXT;
StgClosure* con = (StgClosure*)StackWord(0);
if (constrTag(con) < discr)
bciPtr = failto;
goto nextInsn;
}
case bci_TESTEQ_P: {
int discr = BCO_NEXT;
int failto = BCO_NEXT;
StgClosure* con = (StgClosure*)StackWord(0);
if (constrTag(con) != discr)
bciPtr = failto;
goto nextInsn;
}
/* Control-flow ish things */
case bci_ENTER: {
goto nextEnter;
}
case bci_RETURN: {
/* Figure out whether returning to interpreted or
compiled code. */
int o_itoc_itbl = BCO_NEXT;
int tag = StackWord(0);
StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag+1 +1);
ASSERT(tag <= 2); /* say ... */
if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1_info
/* || ret_itbl == stg_ctoi_ret_F1_info
|| ret_itbl == stg_ctoi_ret_D1_info */) {
/* Returning to interpreted code. Interpret the BCO
immediately underneath the itbl. */
StgBCO* ret_bco = (StgBCO*)StackWord(tag+1 +1+1);
iSp --;
StackWord(0) = (W_)ret_bco;
goto nextEnter;
} else {
/* Returning (unboxed value) to compiled code.
Replace tag with a suitable itbl and ask the
scheduler to run it. The itbl code will copy
the TOS value into R1/F1/D1 and do a standard
compiled-code return. */
StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
StackWord(0) = (W_)magic_itbl;
return ThreadRunGHC;
}
}
case bci_CASEFAIL:
barf("interpretBCO: hit a CASEFAIL");
/* As yet unimplemented */
case bci_TESTLT_I:
case bci_TESTEQ_I:
case bci_TESTLT_F:
case bci_TESTEQ_F:
case bci_TESTLT_D:
case bci_TESTEQ_D:
/* Errors */
default:
barf("interpretBCO: unknown or unimplemented opcode");
} /* switch on opcode */
barf("interpretBCO: fell off end of insn loop");
}
/* ---------------------------------------------------- */
/* End of the bytecode interpreter */
/* ---------------------------------------------------- */
default: {
/* Can't handle this object; yield to sched. */
fprintf(stderr, "entering unknown closure -- yielding to sched\n");
printObj(obj);
cap->rCurrentTSO->what_next = ThreadEnterGHC;
iSp--; StackWord(0) = (W_)obj;
return ThreadYielding;
}
} /* switch on object kind */
barf("fallen off end of object-type switch in interpretBCO()");
}
#endif /* GHCI */
|
