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