Remote GHCi, -fexternal-interpreter
[ghc.git] / rts / Interpreter.c
1 /* -----------------------------------------------------------------------------
2 * Bytecode interpreter
3 *
4 * Copyright (c) The GHC Team, 1994-2002.
5 * ---------------------------------------------------------------------------*/
6
7 #include "PosixSource.h"
8 #include "Rts.h"
9 #include "RtsAPI.h"
10 #include "rts/Bytecodes.h"
11
12 // internal headers
13 #include "sm/Storage.h"
14 #include "sm/Sanity.h"
15 #include "RtsUtils.h"
16 #include "Schedule.h"
17 #include "Updates.h"
18 #include "Prelude.h"
19 #include "Stable.h"
20 #include "Printer.h"
21 #include "Disassembler.h"
22 #include "Interpreter.h"
23 #include "ThreadPaused.h"
24 #include "Threads.h"
25
26 #include <string.h> /* for memcpy */
27 #ifdef HAVE_ERRNO_H
28 #include <errno.h>
29 #endif
30
31 // When building the RTS in the non-dyn way on Windows, we don't
32 // want declspec(__dllimport__) on the front of function prototypes
33 // from libffi.
34 #if defined(mingw32_HOST_OS)
35 #if (defined(i386_HOST_ARCH) && !defined(__PIC__)) || defined(x86_64_HOST_ARCH)
36 # define LIBFFI_NOT_DLL
37 #endif
38 #endif
39
40 #include "ffi.h"
41
42 /* --------------------------------------------------------------------------
43 * The bytecode interpreter
44 * ------------------------------------------------------------------------*/
45
46 /* Gather stats about entry, opcode, opcode-pair frequencies. For
47 tuning the interpreter. */
48
49 /* #define INTERP_STATS */
50
51
52 /* Sp points to the lowest live word on the stack. */
53
54 #define BCO_NEXT instrs[bciPtr++]
55 #define BCO_NEXT_32 (bciPtr += 2)
56 #define BCO_READ_NEXT_32 (BCO_NEXT_32, (((StgWord) instrs[bciPtr-2]) << 16) \
57 + ( (StgWord) instrs[bciPtr-1]))
58 #define BCO_NEXT_64 (bciPtr += 4)
59 #define BCO_READ_NEXT_64 (BCO_NEXT_64, (((StgWord) instrs[bciPtr-4]) << 48) \
60 + (((StgWord) instrs[bciPtr-3]) << 32) \
61 + (((StgWord) instrs[bciPtr-2]) << 16) \
62 + ( (StgWord) instrs[bciPtr-1]))
63 #if WORD_SIZE_IN_BITS == 32
64 #define BCO_NEXT_WORD BCO_NEXT_32
65 #define BCO_READ_NEXT_WORD BCO_READ_NEXT_32
66 #elif WORD_SIZE_IN_BITS == 64
67 #define BCO_NEXT_WORD BCO_NEXT_64
68 #define BCO_READ_NEXT_WORD BCO_READ_NEXT_64
69 #else
70 #error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64
71 #endif
72 #define BCO_GET_LARGE_ARG ((bci & bci_FLAG_LARGE_ARGS) ? BCO_READ_NEXT_WORD : BCO_NEXT)
73
74 #define BCO_PTR(n) (W_)ptrs[n]
75 #define BCO_LIT(n) literals[n]
76
77 #define LOAD_STACK_POINTERS \
78 Sp = cap->r.rCurrentTSO->stackobj->sp; \
79 /* We don't change this ... */ \
80 SpLim = tso_SpLim(cap->r.rCurrentTSO);
81
82 #define SAVE_STACK_POINTERS \
83 cap->r.rCurrentTSO->stackobj->sp = Sp
84
85 // Note [Not true: ASSERT(Sp > SpLim)]
86 //
87 // SpLim has some headroom (RESERVED_STACK_WORDS) to allow for saving
88 // any necessary state on the stack when returning to the scheduler
89 // when a stack check fails.. The upshot of this is that Sp could be
90 // less than SpLim both when leaving to return to the scheduler.
91
92 #define RETURN_TO_SCHEDULER(todo,retcode) \
93 SAVE_STACK_POINTERS; \
94 cap->r.rCurrentTSO->what_next = (todo); \
95 threadPaused(cap,cap->r.rCurrentTSO); \
96 cap->r.rRet = (retcode); \
97 return cap;
98
99 #define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode) \
100 SAVE_STACK_POINTERS; \
101 cap->r.rCurrentTSO->what_next = (todo); \
102 cap->r.rRet = (retcode); \
103 return cap;
104
105
106 STATIC_INLINE StgPtr
107 allocate_NONUPD (Capability *cap, int n_words)
108 {
109 return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
110 }
111
112 int rts_stop_next_breakpoint = 0;
113 int rts_stop_on_exception = 0;
114
115 #ifdef INTERP_STATS
116
117 /* Hacky stats, for tuning the interpreter ... */
118 int it_unknown_entries[N_CLOSURE_TYPES];
119 int it_total_unknown_entries;
120 int it_total_entries;
121
122 int it_retto_BCO;
123 int it_retto_UPDATE;
124 int it_retto_other;
125
126 int it_slides;
127 int it_insns;
128 int it_BCO_entries;
129
130 int it_ofreq[27];
131 int it_oofreq[27][27];
132 int it_lastopc;
133
134
135 #define INTERP_TICK(n) (n)++
136
137 void interp_startup ( void )
138 {
139 int i, j;
140 it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
141 it_total_entries = it_total_unknown_entries = 0;
142 for (i = 0; i < N_CLOSURE_TYPES; i++)
143 it_unknown_entries[i] = 0;
144 it_slides = it_insns = it_BCO_entries = 0;
145 for (i = 0; i < 27; i++) it_ofreq[i] = 0;
146 for (i = 0; i < 27; i++)
147 for (j = 0; j < 27; j++)
148 it_oofreq[i][j] = 0;
149 it_lastopc = 0;
150 }
151
152 void interp_shutdown ( void )
153 {
154 int i, j, k, o_max, i_max, j_max;
155 debugBelch("%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
156 it_retto_BCO + it_retto_UPDATE + it_retto_other,
157 it_retto_BCO, it_retto_UPDATE, it_retto_other );
158 debugBelch("%d total entries, %d unknown entries \n",
159 it_total_entries, it_total_unknown_entries);
160 for (i = 0; i < N_CLOSURE_TYPES; i++) {
161 if (it_unknown_entries[i] == 0) continue;
162 debugBelch(" type %2d: unknown entries (%4.1f%%) == %d\n",
163 i, 100.0 * ((double)it_unknown_entries[i]) /
164 ((double)it_total_unknown_entries),
165 it_unknown_entries[i]);
166 }
167 debugBelch("%d insns, %d slides, %d BCO_entries\n",
168 it_insns, it_slides, it_BCO_entries);
169 for (i = 0; i < 27; i++)
170 debugBelch("opcode %2d got %d\n", i, it_ofreq[i] );
171
172 for (k = 1; k < 20; k++) {
173 o_max = 0;
174 i_max = j_max = 0;
175 for (i = 0; i < 27; i++) {
176 for (j = 0; j < 27; j++) {
177 if (it_oofreq[i][j] > o_max) {
178 o_max = it_oofreq[i][j];
179 i_max = i; j_max = j;
180 }
181 }
182 }
183
184 debugBelch("%d: count (%4.1f%%) %6d is %d then %d\n",
185 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
186 i_max, j_max );
187 it_oofreq[i_max][j_max] = 0;
188
189 }
190 }
191
192 #else // !INTERP_STATS
193
194 #define INTERP_TICK(n) /* nothing */
195
196 #endif
197
198 static StgWord app_ptrs_itbl[] = {
199 (W_)&stg_ap_p_info,
200 (W_)&stg_ap_pp_info,
201 (W_)&stg_ap_ppp_info,
202 (W_)&stg_ap_pppp_info,
203 (W_)&stg_ap_ppppp_info,
204 (W_)&stg_ap_pppppp_info,
205 };
206
207 HsStablePtr rts_breakpoint_io_action; // points to the IO action which is executed on a breakpoint
208 // it is set in main/GHC.hs:runStmt
209
210 Capability *
211 interpretBCO (Capability* cap)
212 {
213 // Use of register here is primarily to make it clear to compilers
214 // that these entities are non-aliasable.
215 register StgPtr Sp; // local state -- stack pointer
216 register StgPtr SpLim; // local state -- stack lim pointer
217 register StgClosure *tagged_obj = 0, *obj;
218 nat n, m;
219
220 LOAD_STACK_POINTERS;
221
222 cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
223 // goes to zero we must return to the scheduler.
224
225 // ------------------------------------------------------------------------
226 // Case 1:
227 //
228 // We have a closure to evaluate. Stack looks like:
229 //
230 // | XXXX_info |
231 // +---------------+
232 // Sp | -------------------> closure
233 // +---------------+
234 //
235 if (Sp[0] == (W_)&stg_enter_info) {
236 Sp++;
237 goto eval;
238 }
239
240 // ------------------------------------------------------------------------
241 // Case 2:
242 //
243 // We have a BCO application to perform. Stack looks like:
244 //
245 // | .... |
246 // +---------------+
247 // | arg1 |
248 // +---------------+
249 // | BCO |
250 // +---------------+
251 // Sp | RET_BCO |
252 // +---------------+
253 //
254 else if (Sp[0] == (W_)&stg_apply_interp_info) {
255 obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
256 Sp += 2;
257 goto run_BCO_fun;
258 }
259
260 // ------------------------------------------------------------------------
261 // Case 3:
262 //
263 // We have an unboxed value to return. See comment before
264 // do_return_unboxed, below.
265 //
266 else {
267 goto do_return_unboxed;
268 }
269
270 // Evaluate the object on top of the stack.
271 eval:
272 tagged_obj = (StgClosure*)Sp[0]; Sp++;
273
274 eval_obj:
275 obj = UNTAG_CLOSURE(tagged_obj);
276 INTERP_TICK(it_total_evals);
277
278 IF_DEBUG(interpreter,
279 debugBelch(
280 "\n---------------------------------------------------------------\n");
281 debugBelch("Evaluating: "); printObj(obj);
282 debugBelch("Sp = %p\n", Sp);
283 debugBelch("\n" );
284
285 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
286 debugBelch("\n\n");
287 );
288
289 // IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
290 IF_DEBUG(sanity,checkStackFrame(Sp));
291
292 switch ( get_itbl(obj)->type ) {
293
294 case IND:
295 case IND_PERM:
296 case IND_STATIC:
297 {
298 tagged_obj = ((StgInd*)obj)->indirectee;
299 goto eval_obj;
300 }
301
302 case CONSTR:
303 case CONSTR_1_0:
304 case CONSTR_0_1:
305 case CONSTR_2_0:
306 case CONSTR_1_1:
307 case CONSTR_0_2:
308 case CONSTR_STATIC:
309 case CONSTR_NOCAF_STATIC:
310 case FUN:
311 case FUN_1_0:
312 case FUN_0_1:
313 case FUN_2_0:
314 case FUN_1_1:
315 case FUN_0_2:
316 case FUN_STATIC:
317 case PAP:
318 // already in WHNF
319 break;
320
321 case BCO:
322 {
323 ASSERT(((StgBCO *)obj)->arity > 0);
324 break;
325 }
326
327 case AP: /* Copied from stg_AP_entry. */
328 {
329 nat i, words;
330 StgAP *ap;
331
332 ap = (StgAP*)obj;
333 words = ap->n_args;
334
335 // Stack check
336 if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
337 Sp -= 2;
338 Sp[1] = (W_)tagged_obj;
339 Sp[0] = (W_)&stg_enter_info;
340 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
341 }
342
343 ENTER_CCS_THUNK(cap,ap);
344
345 /* Ok; we're safe. Party on. Push an update frame. */
346 Sp -= sizeofW(StgUpdateFrame);
347 {
348 StgUpdateFrame *__frame;
349 __frame = (StgUpdateFrame *)Sp;
350 SET_INFO((StgClosure *)__frame, (StgInfoTable *)&stg_upd_frame_info);
351 __frame->updatee = (StgClosure *)(ap);
352 }
353
354 /* Reload the stack */
355 Sp -= words;
356 for (i=0; i < words; i++) {
357 Sp[i] = (W_)ap->payload[i];
358 }
359
360 obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
361 ASSERT(get_itbl(obj)->type == BCO);
362 goto run_BCO_fun;
363 }
364
365 default:
366 #ifdef INTERP_STATS
367 {
368 int j;
369
370 j = get_itbl(obj)->type;
371 ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
372 it_unknown_entries[j]++;
373 it_total_unknown_entries++;
374 }
375 #endif
376 {
377 // Can't handle this object; yield to scheduler
378 IF_DEBUG(interpreter,
379 debugBelch("evaluating unknown closure -- yielding to sched\n");
380 printObj(obj);
381 );
382 Sp -= 2;
383 Sp[1] = (W_)tagged_obj;
384 Sp[0] = (W_)&stg_enter_info;
385 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
386 }
387 }
388
389 // ------------------------------------------------------------------------
390 // We now have an evaluated object (tagged_obj). The next thing to
391 // do is return it to the stack frame on top of the stack.
392 do_return:
393 obj = UNTAG_CLOSURE(tagged_obj);
394 ASSERT(closure_HNF(obj));
395
396 IF_DEBUG(interpreter,
397 debugBelch(
398 "\n---------------------------------------------------------------\n");
399 debugBelch("Returning: "); printObj(obj);
400 debugBelch("Sp = %p\n", Sp);
401 debugBelch("\n" );
402 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
403 debugBelch("\n\n");
404 );
405
406 IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size));
407
408 switch (get_itbl((StgClosure *)Sp)->type) {
409
410 case RET_SMALL: {
411 const StgInfoTable *info;
412
413 // NOTE: not using get_itbl().
414 info = ((StgClosure *)Sp)->header.info;
415 if (info == (StgInfoTable *)&stg_ap_v_info) {
416 n = 1; m = 0; goto do_apply;
417 }
418 if (info == (StgInfoTable *)&stg_ap_f_info) {
419 n = 1; m = 1; goto do_apply;
420 }
421 if (info == (StgInfoTable *)&stg_ap_d_info) {
422 n = 1; m = sizeofW(StgDouble); goto do_apply;
423 }
424 if (info == (StgInfoTable *)&stg_ap_l_info) {
425 n = 1; m = sizeofW(StgInt64); goto do_apply;
426 }
427 if (info == (StgInfoTable *)&stg_ap_n_info) {
428 n = 1; m = 1; goto do_apply;
429 }
430 if (info == (StgInfoTable *)&stg_ap_p_info) {
431 n = 1; m = 1; goto do_apply;
432 }
433 if (info == (StgInfoTable *)&stg_ap_pp_info) {
434 n = 2; m = 2; goto do_apply;
435 }
436 if (info == (StgInfoTable *)&stg_ap_ppp_info) {
437 n = 3; m = 3; goto do_apply;
438 }
439 if (info == (StgInfoTable *)&stg_ap_pppp_info) {
440 n = 4; m = 4; goto do_apply;
441 }
442 if (info == (StgInfoTable *)&stg_ap_ppppp_info) {
443 n = 5; m = 5; goto do_apply;
444 }
445 if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
446 n = 6; m = 6; goto do_apply;
447 }
448 goto do_return_unrecognised;
449 }
450
451 case UPDATE_FRAME:
452 // Returning to an update frame: do the update, pop the update
453 // frame, and continue with the next stack frame.
454 //
455 // NB. we must update with the *tagged* pointer. Some tags
456 // are not optional, and if we omit the tag bits when updating
457 // then bad things can happen (albeit very rarely). See #1925.
458 // What happened was an indirection was created with an
459 // untagged pointer, and this untagged pointer was propagated
460 // to a PAP by the GC, violating the invariant that PAPs
461 // always contain a tagged pointer to the function.
462 INTERP_TICK(it_retto_UPDATE);
463 updateThunk(cap, cap->r.rCurrentTSO,
464 ((StgUpdateFrame *)Sp)->updatee, tagged_obj);
465 Sp += sizeofW(StgUpdateFrame);
466 goto do_return;
467
468 case RET_BCO:
469 // Returning to an interpreted continuation: put the object on
470 // the stack, and start executing the BCO.
471 INTERP_TICK(it_retto_BCO);
472 Sp--;
473 Sp[0] = (W_)obj;
474 // NB. return the untagged object; the bytecode expects it to
475 // be untagged. XXX this doesn't seem right.
476 obj = (StgClosure*)Sp[2];
477 ASSERT(get_itbl(obj)->type == BCO);
478 goto run_BCO_return;
479
480 default:
481 do_return_unrecognised:
482 {
483 // Can't handle this return address; yield to scheduler
484 INTERP_TICK(it_retto_other);
485 IF_DEBUG(interpreter,
486 debugBelch("returning to unknown frame -- yielding to sched\n");
487 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
488 );
489 Sp -= 2;
490 Sp[1] = (W_)tagged_obj;
491 Sp[0] = (W_)&stg_enter_info;
492 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
493 }
494 }
495
496 // -------------------------------------------------------------------------
497 // Returning an unboxed value. The stack looks like this:
498 //
499 // | .... |
500 // +---------------+
501 // | fv2 |
502 // +---------------+
503 // | fv1 |
504 // +---------------+
505 // | BCO |
506 // +---------------+
507 // | stg_ctoi_ret_ |
508 // +---------------+
509 // | retval |
510 // +---------------+
511 // | XXXX_info |
512 // +---------------+
513 //
514 // where XXXX_info is one of the stg_ret_*_info family.
515 //
516 // We're only interested in the case when the real return address
517 // is a BCO; otherwise we'll return to the scheduler.
518
519 do_return_unboxed:
520 {
521 int offset;
522
523 ASSERT( Sp[0] == (W_)&stg_ret_v_info
524 || Sp[0] == (W_)&stg_ret_p_info
525 || Sp[0] == (W_)&stg_ret_n_info
526 || Sp[0] == (W_)&stg_ret_f_info
527 || Sp[0] == (W_)&stg_ret_d_info
528 || Sp[0] == (W_)&stg_ret_l_info
529 );
530
531 // get the offset of the stg_ctoi_ret_XXX itbl
532 offset = stack_frame_sizeW((StgClosure *)Sp);
533
534 switch (get_itbl((StgClosure*)((StgPtr)Sp+offset))->type) {
535
536 case RET_BCO:
537 // Returning to an interpreted continuation: put the object on
538 // the stack, and start executing the BCO.
539 INTERP_TICK(it_retto_BCO);
540 obj = (StgClosure*)Sp[offset+1];
541 ASSERT(get_itbl(obj)->type == BCO);
542 goto run_BCO_return_unboxed;
543
544 default:
545 {
546 // Can't handle this return address; yield to scheduler
547 INTERP_TICK(it_retto_other);
548 IF_DEBUG(interpreter,
549 debugBelch("returning to unknown frame -- yielding to sched\n");
550 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
551 );
552 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
553 }
554 }
555 }
556 // not reached.
557
558
559 // -------------------------------------------------------------------------
560 // Application...
561
562 do_apply:
563 ASSERT(obj == UNTAG_CLOSURE(tagged_obj));
564 // we have a function to apply (obj), and n arguments taking up m
565 // words on the stack. The info table (stg_ap_pp_info or whatever)
566 // is on top of the arguments on the stack.
567 {
568 switch (get_itbl(obj)->type) {
569
570 case PAP: {
571 StgPAP *pap;
572 nat i, arity;
573
574 pap = (StgPAP *)obj;
575
576 // we only cope with PAPs whose function is a BCO
577 if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) {
578 goto defer_apply_to_sched;
579 }
580
581 // Stack check: we're about to unpack the PAP onto the
582 // stack. The (+1) is for the (arity < n) case, where we
583 // also need space for an extra info pointer.
584 if (Sp - (pap->n_args + 1) < SpLim) {
585 Sp -= 2;
586 Sp[1] = (W_)tagged_obj;
587 Sp[0] = (W_)&stg_enter_info;
588 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
589 }
590
591 Sp++;
592 arity = pap->arity;
593 ASSERT(arity > 0);
594 if (arity < n) {
595 // n must be greater than 1, and the only kinds of
596 // application we support with more than one argument
597 // are all pointers...
598 //
599 // Shuffle the args for this function down, and put
600 // the appropriate info table in the gap.
601 for (i = 0; i < arity; i++) {
602 Sp[(int)i-1] = Sp[i];
603 // ^^^^^ careful, i-1 might be negative, but i in unsigned
604 }
605 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
606 Sp--;
607 // unpack the PAP's arguments onto the stack
608 Sp -= pap->n_args;
609 for (i = 0; i < pap->n_args; i++) {
610 Sp[i] = (W_)pap->payload[i];
611 }
612 obj = UNTAG_CLOSURE(pap->fun);
613 goto run_BCO_fun;
614 }
615 else if (arity == n) {
616 Sp -= pap->n_args;
617 for (i = 0; i < pap->n_args; i++) {
618 Sp[i] = (W_)pap->payload[i];
619 }
620 obj = UNTAG_CLOSURE(pap->fun);
621 goto run_BCO_fun;
622 }
623 else /* arity > n */ {
624 // build a new PAP and return it.
625 StgPAP *new_pap;
626 new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m));
627 SET_HDR(new_pap,&stg_PAP_info,cap->r.rCCCS);
628 new_pap->arity = pap->arity - n;
629 new_pap->n_args = pap->n_args + m;
630 new_pap->fun = pap->fun;
631 for (i = 0; i < pap->n_args; i++) {
632 new_pap->payload[i] = pap->payload[i];
633 }
634 for (i = 0; i < m; i++) {
635 new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
636 }
637 tagged_obj = (StgClosure *)new_pap;
638 Sp += m;
639 goto do_return;
640 }
641 }
642
643 case BCO: {
644 nat arity, i;
645
646 Sp++;
647 arity = ((StgBCO *)obj)->arity;
648 ASSERT(arity > 0);
649 if (arity < n) {
650 // n must be greater than 1, and the only kinds of
651 // application we support with more than one argument
652 // are all pointers...
653 //
654 // Shuffle the args for this function down, and put
655 // the appropriate info table in the gap.
656 for (i = 0; i < arity; i++) {
657 Sp[(int)i-1] = Sp[i];
658 // ^^^^^ careful, i-1 might be negative, but i in unsigned
659 }
660 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
661 Sp--;
662 goto run_BCO_fun;
663 }
664 else if (arity == n) {
665 goto run_BCO_fun;
666 }
667 else /* arity > n */ {
668 // build a PAP and return it.
669 StgPAP *pap;
670 nat i;
671 pap = (StgPAP *)allocate(cap, PAP_sizeW(m));
672 SET_HDR(pap, &stg_PAP_info,cap->r.rCCCS);
673 pap->arity = arity - n;
674 pap->fun = obj;
675 pap->n_args = m;
676 for (i = 0; i < m; i++) {
677 pap->payload[i] = (StgClosure *)Sp[i];
678 }
679 tagged_obj = (StgClosure *)pap;
680 Sp += m;
681 goto do_return;
682 }
683 }
684
685 // No point in us applying machine-code functions
686 default:
687 defer_apply_to_sched:
688 Sp -= 2;
689 Sp[1] = (W_)tagged_obj;
690 Sp[0] = (W_)&stg_enter_info;
691 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
692 }
693
694 // ------------------------------------------------------------------------
695 // Ok, we now have a bco (obj), and its arguments are all on the
696 // stack. We can start executing the byte codes.
697 //
698 // The stack is in one of two states. First, if this BCO is a
699 // function:
700 //
701 // | .... |
702 // +---------------+
703 // | arg2 |
704 // +---------------+
705 // | arg1 |
706 // +---------------+
707 //
708 // Second, if this BCO is a continuation:
709 //
710 // | .... |
711 // +---------------+
712 // | fv2 |
713 // +---------------+
714 // | fv1 |
715 // +---------------+
716 // | BCO |
717 // +---------------+
718 // | stg_ctoi_ret_ |
719 // +---------------+
720 // | retval |
721 // +---------------+
722 //
723 // where retval is the value being returned to this continuation.
724 // In the event of a stack check, heap check, or context switch,
725 // we need to leave the stack in a sane state so the garbage
726 // collector can find all the pointers.
727 //
728 // (1) BCO is a function: the BCO's bitmap describes the
729 // pointerhood of the arguments.
730 //
731 // (2) BCO is a continuation: BCO's bitmap describes the
732 // pointerhood of the free variables.
733 //
734 // Sadly we have three different kinds of stack/heap/cswitch check
735 // to do:
736
737
738 run_BCO_return:
739 // Heap check
740 if (doYouWantToGC(cap)) {
741 Sp--; Sp[0] = (W_)&stg_enter_info;
742 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
743 }
744 // Stack checks aren't necessary at return points, the stack use
745 // is aggregated into the enclosing function entry point.
746
747 goto run_BCO;
748
749 run_BCO_return_unboxed:
750 // Heap check
751 if (doYouWantToGC(cap)) {
752 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
753 }
754 // Stack checks aren't necessary at return points, the stack use
755 // is aggregated into the enclosing function entry point.
756
757 goto run_BCO;
758
759 run_BCO_fun:
760 IF_DEBUG(sanity,
761 Sp -= 2;
762 Sp[1] = (W_)obj;
763 Sp[0] = (W_)&stg_apply_interp_info;
764 checkStackChunk(Sp,SpLim);
765 Sp += 2;
766 );
767
768 // Heap check
769 if (doYouWantToGC(cap)) {
770 Sp -= 2;
771 Sp[1] = (W_)obj;
772 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
773 RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
774 }
775
776 // Stack check
777 if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
778 Sp -= 2;
779 Sp[1] = (W_)obj;
780 Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
781 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
782 }
783
784 goto run_BCO;
785
786 // Now, actually interpret the BCO... (no returning to the
787 // scheduler again until the stack is in an orderly state).
788 run_BCO:
789 INTERP_TICK(it_BCO_entries);
790 {
791 register int bciPtr = 0; /* instruction pointer */
792 register StgWord16 bci;
793 register StgBCO* bco = (StgBCO*)obj;
794 register StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
795 register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
796 register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
797 #ifdef DEBUG
798 int bcoSize;
799 bcoSize = bco->instrs->bytes / sizeof(StgWord16);
800 #endif
801 IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
802
803 #ifdef INTERP_STATS
804 it_lastopc = 0; /* no opcode */
805 #endif
806
807 nextInsn:
808 ASSERT(bciPtr < bcoSize);
809 IF_DEBUG(interpreter,
810 //if (do_print_stack) {
811 //debugBelch("\n-- BEGIN stack\n");
812 //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
813 //debugBelch("-- END stack\n\n");
814 //}
815 debugBelch("Sp = %p pc = %-4d ", Sp, bciPtr);
816 disInstr(bco,bciPtr);
817 if (0) { int i;
818 debugBelch("\n");
819 for (i = 8; i >= 0; i--) {
820 debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i)));
821 }
822 debugBelch("\n");
823 }
824 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
825 );
826
827
828 INTERP_TICK(it_insns);
829
830 #ifdef INTERP_STATS
831 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
832 it_ofreq[ (int)instrs[bciPtr] ] ++;
833 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
834 it_lastopc = (int)instrs[bciPtr];
835 #endif
836
837 bci = BCO_NEXT;
838 /* We use the high 8 bits for flags, only the highest of which is
839 * currently allocated */
840 ASSERT((bci & 0xFF00) == (bci & 0x8000));
841
842 switch (bci & 0xFF) {
843
844 /* check for a breakpoint on the beginning of a let binding */
845 case bci_BRK_FUN:
846 {
847 int arg1_brk_array, arg2_array_index, arg3_freeVars;
848 StgArrBytes *breakPoints;
849 int returning_from_break; // are we resuming execution from a breakpoint?
850 // if yes, then don't break this time around
851 StgClosure *ioAction; // the io action to run at a breakpoint
852
853 StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap
854 int i;
855 int size_words;
856
857 arg1_brk_array = BCO_GET_LARGE_ARG; // 1st arg of break instruction
858 arg2_array_index = BCO_NEXT; // 2nd arg of break instruction
859 arg3_freeVars = BCO_GET_LARGE_ARG; // 3rd arg of break instruction
860
861 // check if we are returning from a breakpoint - this info
862 // is stored in the flags field of the current TSO
863 returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
864
865 // if we are returning from a break then skip this section
866 // and continue executing
867 if (!returning_from_break)
868 {
869 breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array);
870
871 // stop the current thread if either the
872 // "rts_stop_next_breakpoint" flag is true OR if the
873 // breakpoint flag for this particular expression is
874 // true
875 if (rts_stop_next_breakpoint == rtsTrue ||
876 breakPoints->payload[arg2_array_index] == rtsTrue)
877 {
878 // make sure we don't automatically stop at the
879 // next breakpoint
880 rts_stop_next_breakpoint = rtsFalse;
881
882 // allocate memory for a new AP_STACK, enough to
883 // store the top stack frame plus an
884 // stg_apply_interp_info pointer and a pointer to
885 // the BCO
886 size_words = BCO_BITMAP_SIZE(obj) + 2;
887 new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
888 SET_HDR(new_aps,&stg_AP_STACK_info,cap->r.rCCCS);
889 new_aps->size = size_words;
890 new_aps->fun = &stg_dummy_ret_closure;
891
892 // fill in the payload of the AP_STACK
893 new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
894 new_aps->payload[1] = (StgClosure *)obj;
895
896 // copy the contents of the top stack frame into the AP_STACK
897 for (i = 2; i < size_words; i++)
898 {
899 new_aps->payload[i] = (StgClosure *)Sp[i-2];
900 }
901
902 // prepare the stack so that we can call the
903 // rts_breakpoint_io_action and ensure that the stack is
904 // in a reasonable state for the GC and so that
905 // execution of this BCO can continue when we resume
906 ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
907 Sp -= 8;
908 Sp[7] = (W_)obj;
909 Sp[6] = (W_)&stg_apply_interp_info;
910 Sp[5] = (W_)new_aps; // the AP_STACK
911 Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
912 Sp[3] = (W_)False_closure; // True <=> a breakpoint
913 Sp[2] = (W_)&stg_ap_pppv_info;
914 Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
915 Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
916 // set the flag in the TSO to say that we are now
917 // stopping at a breakpoint so that when we resume
918 // we don't stop on the same breakpoint that we
919 // already stopped at just now
920 cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
921
922 // stop this thread and return to the scheduler -
923 // eventually we will come back and the IO action on
924 // the top of the stack will be executed
925 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
926 }
927 }
928 // record that this thread is not stopped at a breakpoint anymore
929 cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
930
931 // continue normal execution of the byte code instructions
932 goto nextInsn;
933 }
934
935 case bci_STKCHECK: {
936 // Explicit stack check at the beginning of a function
937 // *only* (stack checks in case alternatives are
938 // propagated to the enclosing function).
939 StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
940 if (Sp - stk_words_reqd < SpLim) {
941 Sp -= 2;
942 Sp[1] = (W_)obj;
943 Sp[0] = (W_)&stg_apply_interp_info;
944 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
945 } else {
946 goto nextInsn;
947 }
948 }
949
950 case bci_PUSH_L: {
951 int o1 = BCO_NEXT;
952 Sp[-1] = Sp[o1];
953 Sp--;
954 goto nextInsn;
955 }
956
957 case bci_PUSH_LL: {
958 int o1 = BCO_NEXT;
959 int o2 = BCO_NEXT;
960 Sp[-1] = Sp[o1];
961 Sp[-2] = Sp[o2];
962 Sp -= 2;
963 goto nextInsn;
964 }
965
966 case bci_PUSH_LLL: {
967 int o1 = BCO_NEXT;
968 int o2 = BCO_NEXT;
969 int o3 = BCO_NEXT;
970 Sp[-1] = Sp[o1];
971 Sp[-2] = Sp[o2];
972 Sp[-3] = Sp[o3];
973 Sp -= 3;
974 goto nextInsn;
975 }
976
977 case bci_PUSH_G: {
978 int o1 = BCO_GET_LARGE_ARG;
979 Sp[-1] = BCO_PTR(o1);
980 Sp -= 1;
981 goto nextInsn;
982 }
983
984 case bci_PUSH_ALTS: {
985 int o_bco = BCO_GET_LARGE_ARG;
986 Sp[-2] = (W_)&stg_ctoi_R1p_info;
987 Sp[-1] = BCO_PTR(o_bco);
988 Sp -= 2;
989 goto nextInsn;
990 }
991
992 case bci_PUSH_ALTS_P: {
993 int o_bco = BCO_GET_LARGE_ARG;
994 Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
995 Sp[-1] = BCO_PTR(o_bco);
996 Sp -= 2;
997 goto nextInsn;
998 }
999
1000 case bci_PUSH_ALTS_N: {
1001 int o_bco = BCO_GET_LARGE_ARG;
1002 Sp[-2] = (W_)&stg_ctoi_R1n_info;
1003 Sp[-1] = BCO_PTR(o_bco);
1004 Sp -= 2;
1005 goto nextInsn;
1006 }
1007
1008 case bci_PUSH_ALTS_F: {
1009 int o_bco = BCO_GET_LARGE_ARG;
1010 Sp[-2] = (W_)&stg_ctoi_F1_info;
1011 Sp[-1] = BCO_PTR(o_bco);
1012 Sp -= 2;
1013 goto nextInsn;
1014 }
1015
1016 case bci_PUSH_ALTS_D: {
1017 int o_bco = BCO_GET_LARGE_ARG;
1018 Sp[-2] = (W_)&stg_ctoi_D1_info;
1019 Sp[-1] = BCO_PTR(o_bco);
1020 Sp -= 2;
1021 goto nextInsn;
1022 }
1023
1024 case bci_PUSH_ALTS_L: {
1025 int o_bco = BCO_GET_LARGE_ARG;
1026 Sp[-2] = (W_)&stg_ctoi_L1_info;
1027 Sp[-1] = BCO_PTR(o_bco);
1028 Sp -= 2;
1029 goto nextInsn;
1030 }
1031
1032 case bci_PUSH_ALTS_V: {
1033 int o_bco = BCO_GET_LARGE_ARG;
1034 Sp[-2] = (W_)&stg_ctoi_V_info;
1035 Sp[-1] = BCO_PTR(o_bco);
1036 Sp -= 2;
1037 goto nextInsn;
1038 }
1039
1040 case bci_PUSH_APPLY_N:
1041 Sp--; Sp[0] = (W_)&stg_ap_n_info;
1042 goto nextInsn;
1043 case bci_PUSH_APPLY_V:
1044 Sp--; Sp[0] = (W_)&stg_ap_v_info;
1045 goto nextInsn;
1046 case bci_PUSH_APPLY_F:
1047 Sp--; Sp[0] = (W_)&stg_ap_f_info;
1048 goto nextInsn;
1049 case bci_PUSH_APPLY_D:
1050 Sp--; Sp[0] = (W_)&stg_ap_d_info;
1051 goto nextInsn;
1052 case bci_PUSH_APPLY_L:
1053 Sp--; Sp[0] = (W_)&stg_ap_l_info;
1054 goto nextInsn;
1055 case bci_PUSH_APPLY_P:
1056 Sp--; Sp[0] = (W_)&stg_ap_p_info;
1057 goto nextInsn;
1058 case bci_PUSH_APPLY_PP:
1059 Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1060 goto nextInsn;
1061 case bci_PUSH_APPLY_PPP:
1062 Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1063 goto nextInsn;
1064 case bci_PUSH_APPLY_PPPP:
1065 Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1066 goto nextInsn;
1067 case bci_PUSH_APPLY_PPPPP:
1068 Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1069 goto nextInsn;
1070 case bci_PUSH_APPLY_PPPPPP:
1071 Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1072 goto nextInsn;
1073
1074 case bci_PUSH_UBX: {
1075 int i;
1076 int o_lits = BCO_GET_LARGE_ARG;
1077 int n_words = BCO_NEXT;
1078 Sp -= n_words;
1079 for (i = 0; i < n_words; i++) {
1080 Sp[i] = (W_)BCO_LIT(o_lits+i);
1081 }
1082 goto nextInsn;
1083 }
1084
1085 case bci_SLIDE: {
1086 int n = BCO_NEXT;
1087 int by = BCO_NEXT;
1088 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1089 while(--n >= 0) {
1090 Sp[n+by] = Sp[n];
1091 }
1092 Sp += by;
1093 INTERP_TICK(it_slides);
1094 goto nextInsn;
1095 }
1096
1097 case bci_ALLOC_AP: {
1098 StgAP* ap;
1099 int n_payload = BCO_NEXT;
1100 ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1101 Sp[-1] = (W_)ap;
1102 ap->n_args = n_payload;
1103 SET_HDR(ap, &stg_AP_info, cap->r.rCCCS)
1104 Sp --;
1105 goto nextInsn;
1106 }
1107
1108 case bci_ALLOC_AP_NOUPD: {
1109 StgAP* ap;
1110 int n_payload = BCO_NEXT;
1111 ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1112 Sp[-1] = (W_)ap;
1113 ap->n_args = n_payload;
1114 SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS)
1115 Sp --;
1116 goto nextInsn;
1117 }
1118
1119 case bci_ALLOC_PAP: {
1120 StgPAP* pap;
1121 int arity = BCO_NEXT;
1122 int n_payload = BCO_NEXT;
1123 pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload));
1124 Sp[-1] = (W_)pap;
1125 pap->n_args = n_payload;
1126 pap->arity = arity;
1127 SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS)
1128 Sp --;
1129 goto nextInsn;
1130 }
1131
1132 case bci_MKAP: {
1133 int i;
1134 int stkoff = BCO_NEXT;
1135 int n_payload = BCO_NEXT;
1136 StgAP* ap = (StgAP*)Sp[stkoff];
1137 ASSERT((int)ap->n_args == n_payload);
1138 ap->fun = (StgClosure*)Sp[0];
1139
1140 // The function should be a BCO, and its bitmap should
1141 // cover the payload of the AP correctly.
1142 ASSERT(get_itbl(ap->fun)->type == BCO
1143 && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1144
1145 for (i = 0; i < n_payload; i++)
1146 ap->payload[i] = (StgClosure*)Sp[i+1];
1147 Sp += n_payload+1;
1148 IF_DEBUG(interpreter,
1149 debugBelch("\tBuilt ");
1150 printObj((StgClosure*)ap);
1151 );
1152 goto nextInsn;
1153 }
1154
1155 case bci_MKPAP: {
1156 int i;
1157 int stkoff = BCO_NEXT;
1158 int n_payload = BCO_NEXT;
1159 StgPAP* pap = (StgPAP*)Sp[stkoff];
1160 ASSERT((int)pap->n_args == n_payload);
1161 pap->fun = (StgClosure*)Sp[0];
1162
1163 // The function should be a BCO
1164 if (get_itbl(pap->fun)->type != BCO) {
1165 #ifdef DEBUG
1166 printClosure(pap->fun);
1167 #endif
1168 barf("bci_MKPAP");
1169 }
1170
1171 for (i = 0; i < n_payload; i++)
1172 pap->payload[i] = (StgClosure*)Sp[i+1];
1173 Sp += n_payload+1;
1174 IF_DEBUG(interpreter,
1175 debugBelch("\tBuilt ");
1176 printObj((StgClosure*)pap);
1177 );
1178 goto nextInsn;
1179 }
1180
1181 case bci_UNPACK: {
1182 /* Unpack N ptr words from t.o.s constructor */
1183 int i;
1184 int n_words = BCO_NEXT;
1185 StgClosure* con = (StgClosure*)Sp[0];
1186 Sp -= n_words;
1187 for (i = 0; i < n_words; i++) {
1188 Sp[i] = (W_)con->payload[i];
1189 }
1190 goto nextInsn;
1191 }
1192
1193 case bci_PACK: {
1194 int i;
1195 int o_itbl = BCO_GET_LARGE_ARG;
1196 int n_words = BCO_NEXT;
1197 StgInfoTable* itbl = INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
1198 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
1199 itbl->layout.payload.nptrs );
1200 StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
1201 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1202 SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), cap->r.rCCCS);
1203 for (i = 0; i < n_words; i++) {
1204 con->payload[i] = (StgClosure*)Sp[i];
1205 }
1206 Sp += n_words;
1207 Sp --;
1208 Sp[0] = (W_)con;
1209 IF_DEBUG(interpreter,
1210 debugBelch("\tBuilt ");
1211 printObj((StgClosure*)con);
1212 );
1213 goto nextInsn;
1214 }
1215
1216 case bci_TESTLT_P: {
1217 unsigned int discr = BCO_NEXT;
1218 int failto = BCO_GET_LARGE_ARG;
1219 StgClosure* con = (StgClosure*)Sp[0];
1220 if (GET_TAG(con) >= discr) {
1221 bciPtr = failto;
1222 }
1223 goto nextInsn;
1224 }
1225
1226 case bci_TESTEQ_P: {
1227 unsigned int discr = BCO_NEXT;
1228 int failto = BCO_GET_LARGE_ARG;
1229 StgClosure* con = (StgClosure*)Sp[0];
1230 if (GET_TAG(con) != discr) {
1231 bciPtr = failto;
1232 }
1233 goto nextInsn;
1234 }
1235
1236 case bci_TESTLT_I: {
1237 // There should be an Int at Sp[1], and an info table at Sp[0].
1238 int discr = BCO_GET_LARGE_ARG;
1239 int failto = BCO_GET_LARGE_ARG;
1240 I_ stackInt = (I_)Sp[1];
1241 if (stackInt >= (I_)BCO_LIT(discr))
1242 bciPtr = failto;
1243 goto nextInsn;
1244 }
1245
1246 case bci_TESTEQ_I: {
1247 // There should be an Int at Sp[1], and an info table at Sp[0].
1248 int discr = BCO_GET_LARGE_ARG;
1249 int failto = BCO_GET_LARGE_ARG;
1250 I_ stackInt = (I_)Sp[1];
1251 if (stackInt != (I_)BCO_LIT(discr)) {
1252 bciPtr = failto;
1253 }
1254 goto nextInsn;
1255 }
1256
1257 case bci_TESTLT_W: {
1258 // There should be an Int at Sp[1], and an info table at Sp[0].
1259 int discr = BCO_GET_LARGE_ARG;
1260 int failto = BCO_GET_LARGE_ARG;
1261 W_ stackWord = (W_)Sp[1];
1262 if (stackWord >= (W_)BCO_LIT(discr))
1263 bciPtr = failto;
1264 goto nextInsn;
1265 }
1266
1267 case bci_TESTEQ_W: {
1268 // There should be an Int at Sp[1], and an info table at Sp[0].
1269 int discr = BCO_GET_LARGE_ARG;
1270 int failto = BCO_GET_LARGE_ARG;
1271 W_ stackWord = (W_)Sp[1];
1272 if (stackWord != (W_)BCO_LIT(discr)) {
1273 bciPtr = failto;
1274 }
1275 goto nextInsn;
1276 }
1277
1278 case bci_TESTLT_D: {
1279 // There should be a Double at Sp[1], and an info table at Sp[0].
1280 int discr = BCO_GET_LARGE_ARG;
1281 int failto = BCO_GET_LARGE_ARG;
1282 StgDouble stackDbl, discrDbl;
1283 stackDbl = PK_DBL( & Sp[1] );
1284 discrDbl = PK_DBL( & BCO_LIT(discr) );
1285 if (stackDbl >= discrDbl) {
1286 bciPtr = failto;
1287 }
1288 goto nextInsn;
1289 }
1290
1291 case bci_TESTEQ_D: {
1292 // There should be a Double at Sp[1], and an info table at Sp[0].
1293 int discr = BCO_GET_LARGE_ARG;
1294 int failto = BCO_GET_LARGE_ARG;
1295 StgDouble stackDbl, discrDbl;
1296 stackDbl = PK_DBL( & Sp[1] );
1297 discrDbl = PK_DBL( & BCO_LIT(discr) );
1298 if (stackDbl != discrDbl) {
1299 bciPtr = failto;
1300 }
1301 goto nextInsn;
1302 }
1303
1304 case bci_TESTLT_F: {
1305 // There should be a Float at Sp[1], and an info table at Sp[0].
1306 int discr = BCO_GET_LARGE_ARG;
1307 int failto = BCO_GET_LARGE_ARG;
1308 StgFloat stackFlt, discrFlt;
1309 stackFlt = PK_FLT( & Sp[1] );
1310 discrFlt = PK_FLT( & BCO_LIT(discr) );
1311 if (stackFlt >= discrFlt) {
1312 bciPtr = failto;
1313 }
1314 goto nextInsn;
1315 }
1316
1317 case bci_TESTEQ_F: {
1318 // There should be a Float at Sp[1], and an info table at Sp[0].
1319 int discr = BCO_GET_LARGE_ARG;
1320 int failto = BCO_GET_LARGE_ARG;
1321 StgFloat stackFlt, discrFlt;
1322 stackFlt = PK_FLT( & Sp[1] );
1323 discrFlt = PK_FLT( & BCO_LIT(discr) );
1324 if (stackFlt != discrFlt) {
1325 bciPtr = failto;
1326 }
1327 goto nextInsn;
1328 }
1329
1330 // Control-flow ish things
1331 case bci_ENTER:
1332 // Context-switch check. We put it here to ensure that
1333 // the interpreter has done at least *some* work before
1334 // context switching: sometimes the scheduler can invoke
1335 // the interpreter with context_switch == 1, particularly
1336 // if the -C0 flag has been given on the cmd line.
1337 if (cap->r.rHpLim == NULL) {
1338 Sp--; Sp[0] = (W_)&stg_enter_info;
1339 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1340 }
1341 goto eval;
1342
1343 case bci_RETURN:
1344 tagged_obj = (StgClosure *)Sp[0];
1345 Sp++;
1346 goto do_return;
1347
1348 case bci_RETURN_P:
1349 Sp--;
1350 Sp[0] = (W_)&stg_ret_p_info;
1351 goto do_return_unboxed;
1352 case bci_RETURN_N:
1353 Sp--;
1354 Sp[0] = (W_)&stg_ret_n_info;
1355 goto do_return_unboxed;
1356 case bci_RETURN_F:
1357 Sp--;
1358 Sp[0] = (W_)&stg_ret_f_info;
1359 goto do_return_unboxed;
1360 case bci_RETURN_D:
1361 Sp--;
1362 Sp[0] = (W_)&stg_ret_d_info;
1363 goto do_return_unboxed;
1364 case bci_RETURN_L:
1365 Sp--;
1366 Sp[0] = (W_)&stg_ret_l_info;
1367 goto do_return_unboxed;
1368 case bci_RETURN_V:
1369 Sp--;
1370 Sp[0] = (W_)&stg_ret_v_info;
1371 goto do_return_unboxed;
1372
1373 case bci_SWIZZLE: {
1374 int stkoff = BCO_NEXT;
1375 signed short n = (signed short)(BCO_NEXT);
1376 Sp[stkoff] += (W_)n;
1377 goto nextInsn;
1378 }
1379
1380 case bci_CCALL: {
1381 void *tok;
1382 int stk_offset = BCO_NEXT;
1383 int o_itbl = BCO_GET_LARGE_ARG;
1384 int interruptible = BCO_NEXT;
1385 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1386
1387 /* the stack looks like this:
1388
1389 | | <- Sp + stk_offset
1390 +-------------+
1391 | |
1392 | args |
1393 | | <- Sp + ret_size + 1
1394 +-------------+
1395 | C fun | <- Sp + ret_size
1396 +-------------+
1397 | ret | <- Sp
1398 +-------------+
1399
1400 ret is a placeholder for the return address, and may be
1401 up to 2 words.
1402
1403 We need to copy the args out of the TSO, because when
1404 we call suspendThread() we no longer own the TSO stack,
1405 and it may move at any time - indeed suspendThread()
1406 itself may do stack squeezing and move our args.
1407 So we make a copy of the argument block.
1408 */
1409
1410 #define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1411
1412 ffi_cif *cif = (ffi_cif *)marshall_fn;
1413 nat nargs = cif->nargs;
1414 nat ret_size;
1415 nat i;
1416 int j;
1417 StgPtr p;
1418 W_ ret[2]; // max needed
1419 W_ *arguments[stk_offset]; // max needed
1420 void *argptrs[nargs];
1421 void (*fn)(void);
1422
1423 if (cif->rtype->type == FFI_TYPE_VOID) {
1424 // necessary because cif->rtype->size == 1 for void,
1425 // but the bytecode generator has not pushed a
1426 // placeholder in this case.
1427 ret_size = 0;
1428 } else {
1429 ret_size = ROUND_UP_WDS(cif->rtype->size);
1430 }
1431
1432 memcpy(arguments, Sp+ret_size+1,
1433 sizeof(W_) * (stk_offset-1-ret_size));
1434
1435 // libffi expects the args as an array of pointers to
1436 // values, so we have to construct this array before making
1437 // the call.
1438 p = (StgPtr)arguments;
1439 for (i = 0; i < nargs; i++) {
1440 argptrs[i] = (void *)p;
1441 // get the size from the cif
1442 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1443 }
1444
1445 // this is the function we're going to call
1446 fn = (void(*)(void))Sp[ret_size];
1447
1448 // Restore the Haskell thread's current value of errno
1449 errno = cap->r.rCurrentTSO->saved_errno;
1450
1451 // There are a bunch of non-ptr words on the stack (the
1452 // ccall args, the ccall fun address and space for the
1453 // result), which we need to cover with an info table
1454 // since we might GC during this call.
1455 //
1456 // We know how many (non-ptr) words there are before the
1457 // next valid stack frame: it is the stk_offset arg to the
1458 // CCALL instruction. So we overwrite this area of the
1459 // stack with empty stack frames (stg_ret_v_info);
1460 //
1461 for (j = 0; j < stk_offset; j++) {
1462 Sp[j] = (W_)&stg_ret_v_info; /* an empty stack frame */
1463 }
1464
1465 // save obj (pointer to the current BCO), since this
1466 // might move during the call. We push an stg_ret_p frame
1467 // for this.
1468 Sp -= 2;
1469 Sp[1] = (W_)obj;
1470 Sp[0] = (W_)&stg_ret_p_info;
1471
1472 SAVE_STACK_POINTERS;
1473 tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse);
1474
1475 // We already made a copy of the arguments above.
1476 ffi_call(cif, fn, ret, argptrs);
1477
1478 // And restart the thread again, popping the stg_ret_p frame.
1479 cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
1480 LOAD_STACK_POINTERS;
1481
1482 if (Sp[0] != (W_)&stg_ret_p_info) {
1483 // the stack is not how we left it. This probably
1484 // means that an exception got raised on exit from the
1485 // foreign call, so we should just continue with
1486 // whatever is on top of the stack now.
1487 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
1488 }
1489
1490 // Re-load the pointer to the BCO from the stg_ret_p frame,
1491 // it might have moved during the call. Also reload the
1492 // pointers to the components of the BCO.
1493 obj = (StgClosure*)Sp[1];
1494 bco = (StgBCO*)obj;
1495 instrs = (StgWord16*)(bco->instrs->payload);
1496 literals = (StgWord*)(&bco->literals->payload[0]);
1497 ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
1498
1499 Sp += 2; // pop the stg_ret_p frame
1500
1501 // Save the Haskell thread's current value of errno
1502 cap->r.rCurrentTSO->saved_errno = errno;
1503
1504 // Copy the return value back to the TSO stack. It is at
1505 // most 2 words large, and resides at arguments[0].
1506 memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1507
1508 goto nextInsn;
1509 }
1510
1511 case bci_JMP: {
1512 /* BCO_NEXT modifies bciPtr, so be conservative. */
1513 int nextpc = BCO_GET_LARGE_ARG;
1514 bciPtr = nextpc;
1515 goto nextInsn;
1516 }
1517
1518 case bci_CASEFAIL:
1519 barf("interpretBCO: hit a CASEFAIL");
1520
1521 // Errors
1522 default:
1523 barf("interpretBCO: unknown or unimplemented opcode %d",
1524 (int)(bci & 0xFF));
1525
1526 } /* switch on opcode */
1527 }
1528 }
1529
1530 barf("interpretBCO: fell off end of the interpreter");
1531 }