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