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