Allow more than 64k instructions in a BCO; fixes #789
[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 = 0; /* 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 int bcoSize;
773 bcoSize = BCO_NEXT_WORD;
774 IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
775
776 #ifdef INTERP_STATS
777 it_lastopc = 0; /* no opcode */
778 #endif
779
780 nextInsn:
781 ASSERT(bciPtr < bcoSize);
782 IF_DEBUG(interpreter,
783 //if (do_print_stack) {
784 //debugBelch("\n-- BEGIN stack\n");
785 //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
786 //debugBelch("-- END stack\n\n");
787 //}
788 debugBelch("Sp = %p pc = %d ", Sp, bciPtr);
789 disInstr(bco,bciPtr);
790 if (0) { int i;
791 debugBelch("\n");
792 for (i = 8; i >= 0; i--) {
793 debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i)));
794 }
795 debugBelch("\n");
796 }
797 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
798 );
799
800
801 INTERP_TICK(it_insns);
802
803 #ifdef INTERP_STATS
804 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
805 it_ofreq[ (int)instrs[bciPtr] ] ++;
806 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
807 it_lastopc = (int)instrs[bciPtr];
808 #endif
809
810 bci = BCO_NEXT;
811 /* We use the high 8 bits for flags, only the highest of which is
812 * currently allocated */
813 ASSERT((bci & 0xFF00) == (bci & 0x8000));
814
815 switch (bci & 0xFF) {
816
817 /* check for a breakpoint on the beginning of a let binding */
818 case bci_BRK_FUN:
819 {
820 int arg1_brk_array, arg2_array_index, arg3_freeVars;
821 StgArrWords *breakPoints;
822 int returning_from_break; // are we resuming execution from a breakpoint?
823 // if yes, then don't break this time around
824 StgClosure *ioAction; // the io action to run at a breakpoint
825
826 StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap
827 int i;
828 int size_words;
829
830 arg1_brk_array = BCO_NEXT; // 1st arg of break instruction
831 arg2_array_index = BCO_NEXT; // 2nd arg of break instruction
832 arg3_freeVars = BCO_NEXT; // 3rd arg of break instruction
833
834 // check if we are returning from a breakpoint - this info
835 // is stored in the flags field of the current TSO
836 returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
837
838 // if we are returning from a break then skip this section
839 // and continue executing
840 if (!returning_from_break)
841 {
842 breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
843
844 // stop the current thread if either the
845 // "rts_stop_next_breakpoint" flag is true OR if the
846 // breakpoint flag for this particular expression is
847 // true
848 if (rts_stop_next_breakpoint == rtsTrue ||
849 breakPoints->payload[arg2_array_index] == rtsTrue)
850 {
851 // make sure we don't automatically stop at the
852 // next breakpoint
853 rts_stop_next_breakpoint = rtsFalse;
854
855 // allocate memory for a new AP_STACK, enough to
856 // store the top stack frame plus an
857 // stg_apply_interp_info pointer and a pointer to
858 // the BCO
859 size_words = BCO_BITMAP_SIZE(obj) + 2;
860 new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words));
861 SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
862 new_aps->size = size_words;
863 new_aps->fun = &stg_dummy_ret_closure;
864
865 // fill in the payload of the AP_STACK
866 new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
867 new_aps->payload[1] = (StgClosure *)obj;
868
869 // copy the contents of the top stack frame into the AP_STACK
870 for (i = 2; i < size_words; i++)
871 {
872 new_aps->payload[i] = (StgClosure *)Sp[i-2];
873 }
874
875 // prepare the stack so that we can call the
876 // rts_breakpoint_io_action and ensure that the stack is
877 // in a reasonable state for the GC and so that
878 // execution of this BCO can continue when we resume
879 ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
880 Sp -= 9;
881 Sp[8] = (W_)obj;
882 Sp[7] = (W_)&stg_apply_interp_info;
883 Sp[6] = (W_)&stg_noforceIO_info; // see [unreg] below
884 Sp[5] = (W_)new_aps; // the AP_STACK
885 Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
886 Sp[3] = (W_)False_closure; // True <=> a breakpoint
887 Sp[2] = (W_)&stg_ap_pppv_info;
888 Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
889 Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
890 // Note [unreg]: in unregisterised mode, the return
891 // convention for IO is different. The
892 // stg_noForceIO_info stack frame is necessary to
893 // account for this difference.
894
895 // set the flag in the TSO to say that we are now
896 // stopping at a breakpoint so that when we resume
897 // we don't stop on the same breakpoint that we
898 // already stopped at just now
899 cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
900
901 // stop this thread and return to the scheduler -
902 // eventually we will come back and the IO action on
903 // the top of the stack will be executed
904 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
905 }
906 }
907 // record that this thread is not stopped at a breakpoint anymore
908 cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
909
910 // continue normal execution of the byte code instructions
911 goto nextInsn;
912 }
913
914 case bci_STKCHECK: {
915 // Explicit stack check at the beginning of a function
916 // *only* (stack checks in case alternatives are
917 // propagated to the enclosing function).
918 StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
919 if (Sp - stk_words_reqd < SpLim) {
920 Sp -= 2;
921 Sp[1] = (W_)obj;
922 Sp[0] = (W_)&stg_apply_interp_info;
923 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
924 } else {
925 goto nextInsn;
926 }
927 }
928
929 case bci_PUSH_L: {
930 int o1 = BCO_NEXT;
931 Sp[-1] = Sp[o1];
932 Sp--;
933 goto nextInsn;
934 }
935
936 case bci_PUSH_LL: {
937 int o1 = BCO_NEXT;
938 int o2 = BCO_NEXT;
939 Sp[-1] = Sp[o1];
940 Sp[-2] = Sp[o2];
941 Sp -= 2;
942 goto nextInsn;
943 }
944
945 case bci_PUSH_LLL: {
946 int o1 = BCO_NEXT;
947 int o2 = BCO_NEXT;
948 int o3 = BCO_NEXT;
949 Sp[-1] = Sp[o1];
950 Sp[-2] = Sp[o2];
951 Sp[-3] = Sp[o3];
952 Sp -= 3;
953 goto nextInsn;
954 }
955
956 case bci_PUSH_G: {
957 int o1 = BCO_NEXT;
958 Sp[-1] = BCO_PTR(o1);
959 Sp -= 1;
960 goto nextInsn;
961 }
962
963 case bci_PUSH_ALTS: {
964 int o_bco = BCO_NEXT;
965 Sp[-2] = (W_)&stg_ctoi_R1p_info;
966 Sp[-1] = BCO_PTR(o_bco);
967 Sp -= 2;
968 goto nextInsn;
969 }
970
971 case bci_PUSH_ALTS_P: {
972 int o_bco = BCO_NEXT;
973 Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
974 Sp[-1] = BCO_PTR(o_bco);
975 Sp -= 2;
976 goto nextInsn;
977 }
978
979 case bci_PUSH_ALTS_N: {
980 int o_bco = BCO_NEXT;
981 Sp[-2] = (W_)&stg_ctoi_R1n_info;
982 Sp[-1] = BCO_PTR(o_bco);
983 Sp -= 2;
984 goto nextInsn;
985 }
986
987 case bci_PUSH_ALTS_F: {
988 int o_bco = BCO_NEXT;
989 Sp[-2] = (W_)&stg_ctoi_F1_info;
990 Sp[-1] = BCO_PTR(o_bco);
991 Sp -= 2;
992 goto nextInsn;
993 }
994
995 case bci_PUSH_ALTS_D: {
996 int o_bco = BCO_NEXT;
997 Sp[-2] = (W_)&stg_ctoi_D1_info;
998 Sp[-1] = BCO_PTR(o_bco);
999 Sp -= 2;
1000 goto nextInsn;
1001 }
1002
1003 case bci_PUSH_ALTS_L: {
1004 int o_bco = BCO_NEXT;
1005 Sp[-2] = (W_)&stg_ctoi_L1_info;
1006 Sp[-1] = BCO_PTR(o_bco);
1007 Sp -= 2;
1008 goto nextInsn;
1009 }
1010
1011 case bci_PUSH_ALTS_V: {
1012 int o_bco = BCO_NEXT;
1013 Sp[-2] = (W_)&stg_ctoi_V_info;
1014 Sp[-1] = BCO_PTR(o_bco);
1015 Sp -= 2;
1016 goto nextInsn;
1017 }
1018
1019 case bci_PUSH_APPLY_N:
1020 Sp--; Sp[0] = (W_)&stg_ap_n_info;
1021 goto nextInsn;
1022 case bci_PUSH_APPLY_V:
1023 Sp--; Sp[0] = (W_)&stg_ap_v_info;
1024 goto nextInsn;
1025 case bci_PUSH_APPLY_F:
1026 Sp--; Sp[0] = (W_)&stg_ap_f_info;
1027 goto nextInsn;
1028 case bci_PUSH_APPLY_D:
1029 Sp--; Sp[0] = (W_)&stg_ap_d_info;
1030 goto nextInsn;
1031 case bci_PUSH_APPLY_L:
1032 Sp--; Sp[0] = (W_)&stg_ap_l_info;
1033 goto nextInsn;
1034 case bci_PUSH_APPLY_P:
1035 Sp--; Sp[0] = (W_)&stg_ap_p_info;
1036 goto nextInsn;
1037 case bci_PUSH_APPLY_PP:
1038 Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1039 goto nextInsn;
1040 case bci_PUSH_APPLY_PPP:
1041 Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1042 goto nextInsn;
1043 case bci_PUSH_APPLY_PPPP:
1044 Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1045 goto nextInsn;
1046 case bci_PUSH_APPLY_PPPPP:
1047 Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1048 goto nextInsn;
1049 case bci_PUSH_APPLY_PPPPPP:
1050 Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1051 goto nextInsn;
1052
1053 case bci_PUSH_UBX: {
1054 int i;
1055 int o_lits = BCO_NEXT;
1056 int n_words = BCO_NEXT;
1057 Sp -= n_words;
1058 for (i = 0; i < n_words; i++) {
1059 Sp[i] = (W_)BCO_LIT(o_lits+i);
1060 }
1061 goto nextInsn;
1062 }
1063
1064 case bci_SLIDE: {
1065 int n = BCO_NEXT;
1066 int by = BCO_NEXT;
1067 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1068 while(--n >= 0) {
1069 Sp[n+by] = Sp[n];
1070 }
1071 Sp += by;
1072 INTERP_TICK(it_slides);
1073 goto nextInsn;
1074 }
1075
1076 case bci_ALLOC_AP: {
1077 StgAP* ap;
1078 int n_payload = BCO_NEXT;
1079 ap = (StgAP*)allocate(AP_sizeW(n_payload));
1080 Sp[-1] = (W_)ap;
1081 ap->n_args = n_payload;
1082 SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
1083 Sp --;
1084 goto nextInsn;
1085 }
1086
1087 case bci_ALLOC_AP_NOUPD: {
1088 StgAP* ap;
1089 int n_payload = BCO_NEXT;
1090 ap = (StgAP*)allocate(AP_sizeW(n_payload));
1091 Sp[-1] = (W_)ap;
1092 ap->n_args = n_payload;
1093 SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
1094 Sp --;
1095 goto nextInsn;
1096 }
1097
1098 case bci_ALLOC_PAP: {
1099 StgPAP* pap;
1100 int arity = BCO_NEXT;
1101 int n_payload = BCO_NEXT;
1102 pap = (StgPAP*)allocate(PAP_sizeW(n_payload));
1103 Sp[-1] = (W_)pap;
1104 pap->n_args = n_payload;
1105 pap->arity = arity;
1106 SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
1107 Sp --;
1108 goto nextInsn;
1109 }
1110
1111 case bci_MKAP: {
1112 int i;
1113 int stkoff = BCO_NEXT;
1114 int n_payload = BCO_NEXT;
1115 StgAP* ap = (StgAP*)Sp[stkoff];
1116 ASSERT((int)ap->n_args == n_payload);
1117 ap->fun = (StgClosure*)Sp[0];
1118
1119 // The function should be a BCO, and its bitmap should
1120 // cover the payload of the AP correctly.
1121 ASSERT(get_itbl(ap->fun)->type == BCO
1122 && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1123
1124 for (i = 0; i < n_payload; i++)
1125 ap->payload[i] = (StgClosure*)Sp[i+1];
1126 Sp += n_payload+1;
1127 IF_DEBUG(interpreter,
1128 debugBelch("\tBuilt ");
1129 printObj((StgClosure*)ap);
1130 );
1131 goto nextInsn;
1132 }
1133
1134 case bci_MKPAP: {
1135 int i;
1136 int stkoff = BCO_NEXT;
1137 int n_payload = BCO_NEXT;
1138 StgPAP* pap = (StgPAP*)Sp[stkoff];
1139 ASSERT((int)pap->n_args == n_payload);
1140 pap->fun = (StgClosure*)Sp[0];
1141
1142 // The function should be a BCO
1143 ASSERT(get_itbl(pap->fun)->type == BCO);
1144
1145 for (i = 0; i < n_payload; i++)
1146 pap->payload[i] = (StgClosure*)Sp[i+1];
1147 Sp += n_payload+1;
1148 IF_DEBUG(interpreter,
1149 debugBelch("\tBuilt ");
1150 printObj((StgClosure*)pap);
1151 );
1152 goto nextInsn;
1153 }
1154
1155 case bci_UNPACK: {
1156 /* Unpack N ptr words from t.o.s constructor */
1157 int i;
1158 int n_words = BCO_NEXT;
1159 StgClosure* con = (StgClosure*)Sp[0];
1160 Sp -= n_words;
1161 for (i = 0; i < n_words; i++) {
1162 Sp[i] = (W_)con->payload[i];
1163 }
1164 goto nextInsn;
1165 }
1166
1167 case bci_PACK: {
1168 int i;
1169 int o_itbl = BCO_NEXT;
1170 int n_words = BCO_NEXT;
1171 StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
1172 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
1173 itbl->layout.payload.nptrs );
1174 StgClosure* con = (StgClosure*)allocate_NONUPD(request);
1175 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1176 SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
1177 for (i = 0; i < n_words; i++) {
1178 con->payload[i] = (StgClosure*)Sp[i];
1179 }
1180 Sp += n_words;
1181 Sp --;
1182 Sp[0] = (W_)con;
1183 IF_DEBUG(interpreter,
1184 debugBelch("\tBuilt ");
1185 printObj((StgClosure*)con);
1186 );
1187 goto nextInsn;
1188 }
1189
1190 case bci_TESTLT_P: {
1191 unsigned int discr = BCO_NEXT;
1192 int failto = BCO_GET_LARGE_ARG;
1193 StgClosure* con = (StgClosure*)Sp[0];
1194 if (GET_TAG(con) >= discr) {
1195 bciPtr = failto;
1196 }
1197 goto nextInsn;
1198 }
1199
1200 case bci_TESTEQ_P: {
1201 unsigned int discr = BCO_NEXT;
1202 int failto = BCO_GET_LARGE_ARG;
1203 StgClosure* con = (StgClosure*)Sp[0];
1204 if (GET_TAG(con) != discr) {
1205 bciPtr = failto;
1206 }
1207 goto nextInsn;
1208 }
1209
1210 case bci_TESTLT_I: {
1211 // There should be an Int at Sp[1], and an info table at Sp[0].
1212 int discr = BCO_NEXT;
1213 int failto = BCO_GET_LARGE_ARG;
1214 I_ stackInt = (I_)Sp[1];
1215 if (stackInt >= (I_)BCO_LIT(discr))
1216 bciPtr = failto;
1217 goto nextInsn;
1218 }
1219
1220 case bci_TESTEQ_I: {
1221 // There should be an Int at Sp[1], and an info table at Sp[0].
1222 int discr = BCO_NEXT;
1223 int failto = BCO_GET_LARGE_ARG;
1224 I_ stackInt = (I_)Sp[1];
1225 if (stackInt != (I_)BCO_LIT(discr)) {
1226 bciPtr = failto;
1227 }
1228 goto nextInsn;
1229 }
1230
1231 case bci_TESTLT_D: {
1232 // There should be a Double at Sp[1], and an info table at Sp[0].
1233 int discr = BCO_NEXT;
1234 int failto = BCO_GET_LARGE_ARG;
1235 StgDouble stackDbl, discrDbl;
1236 stackDbl = PK_DBL( & Sp[1] );
1237 discrDbl = PK_DBL( & BCO_LIT(discr) );
1238 if (stackDbl >= discrDbl) {
1239 bciPtr = failto;
1240 }
1241 goto nextInsn;
1242 }
1243
1244 case bci_TESTEQ_D: {
1245 // There should be a Double at Sp[1], and an info table at Sp[0].
1246 int discr = BCO_NEXT;
1247 int failto = BCO_GET_LARGE_ARG;
1248 StgDouble stackDbl, discrDbl;
1249 stackDbl = PK_DBL( & Sp[1] );
1250 discrDbl = PK_DBL( & BCO_LIT(discr) );
1251 if (stackDbl != discrDbl) {
1252 bciPtr = failto;
1253 }
1254 goto nextInsn;
1255 }
1256
1257 case bci_TESTLT_F: {
1258 // There should be a Float at Sp[1], and an info table at Sp[0].
1259 int discr = BCO_NEXT;
1260 int failto = BCO_GET_LARGE_ARG;
1261 StgFloat stackFlt, discrFlt;
1262 stackFlt = PK_FLT( & Sp[1] );
1263 discrFlt = PK_FLT( & BCO_LIT(discr) );
1264 if (stackFlt >= discrFlt) {
1265 bciPtr = failto;
1266 }
1267 goto nextInsn;
1268 }
1269
1270 case bci_TESTEQ_F: {
1271 // There should be a Float at Sp[1], and an info table at Sp[0].
1272 int discr = BCO_NEXT;
1273 int failto = BCO_GET_LARGE_ARG;
1274 StgFloat stackFlt, discrFlt;
1275 stackFlt = PK_FLT( & Sp[1] );
1276 discrFlt = PK_FLT( & BCO_LIT(discr) );
1277 if (stackFlt != discrFlt) {
1278 bciPtr = failto;
1279 }
1280 goto nextInsn;
1281 }
1282
1283 // Control-flow ish things
1284 case bci_ENTER:
1285 // Context-switch check. We put it here to ensure that
1286 // the interpreter has done at least *some* work before
1287 // context switching: sometimes the scheduler can invoke
1288 // the interpreter with context_switch == 1, particularly
1289 // if the -C0 flag has been given on the cmd line.
1290 if (cap->r.rHpLim == NULL) {
1291 Sp--; Sp[0] = (W_)&stg_enter_info;
1292 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1293 }
1294 goto eval;
1295
1296 case bci_RETURN:
1297 tagged_obj = (StgClosure *)Sp[0];
1298 Sp++;
1299 goto do_return;
1300
1301 case bci_RETURN_P:
1302 Sp--;
1303 Sp[0] = (W_)&stg_gc_unpt_r1_info;
1304 goto do_return_unboxed;
1305 case bci_RETURN_N:
1306 Sp--;
1307 Sp[0] = (W_)&stg_gc_unbx_r1_info;
1308 goto do_return_unboxed;
1309 case bci_RETURN_F:
1310 Sp--;
1311 Sp[0] = (W_)&stg_gc_f1_info;
1312 goto do_return_unboxed;
1313 case bci_RETURN_D:
1314 Sp--;
1315 Sp[0] = (W_)&stg_gc_d1_info;
1316 goto do_return_unboxed;
1317 case bci_RETURN_L:
1318 Sp--;
1319 Sp[0] = (W_)&stg_gc_l1_info;
1320 goto do_return_unboxed;
1321 case bci_RETURN_V:
1322 Sp--;
1323 Sp[0] = (W_)&stg_gc_void_info;
1324 goto do_return_unboxed;
1325
1326 case bci_SWIZZLE: {
1327 int stkoff = BCO_NEXT;
1328 signed short n = (signed short)(BCO_NEXT);
1329 Sp[stkoff] += (W_)n;
1330 goto nextInsn;
1331 }
1332
1333 case bci_CCALL: {
1334 void *tok;
1335 int stk_offset = BCO_NEXT;
1336 int o_itbl = BCO_NEXT;
1337 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1338 int ret_dyn_size =
1339 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1340 + sizeofW(StgRetDyn);
1341
1342 /* the stack looks like this:
1343
1344 | | <- Sp + stk_offset
1345 +-------------+
1346 | |
1347 | args |
1348 | | <- Sp + ret_size + 1
1349 +-------------+
1350 | C fun | <- Sp + ret_size
1351 +-------------+
1352 | ret | <- Sp
1353 +-------------+
1354
1355 ret is a placeholder for the return address, and may be
1356 up to 2 words.
1357
1358 We need to copy the args out of the TSO, because when
1359 we call suspendThread() we no longer own the TSO stack,
1360 and it may move at any time - indeed suspendThread()
1361 itself may do stack squeezing and move our args.
1362 So we make a copy of the argument block.
1363 */
1364
1365 #define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1366
1367 ffi_cif *cif = (ffi_cif *)marshall_fn;
1368 nat nargs = cif->nargs;
1369 nat ret_size;
1370 nat i;
1371 StgPtr p;
1372 W_ ret[2]; // max needed
1373 W_ *arguments[stk_offset]; // max needed
1374 void *argptrs[nargs];
1375 void (*fn)(void);
1376
1377 if (cif->rtype->type == FFI_TYPE_VOID) {
1378 // necessary because cif->rtype->size == 1 for void,
1379 // but the bytecode generator has not pushed a
1380 // placeholder in this case.
1381 ret_size = 0;
1382 } else {
1383 ret_size = ROUND_UP_WDS(cif->rtype->size);
1384 }
1385
1386 memcpy(arguments, Sp+ret_size+1,
1387 sizeof(W_) * (stk_offset-1-ret_size));
1388
1389 // libffi expects the args as an array of pointers to
1390 // values, so we have to construct this array before making
1391 // the call.
1392 p = (StgPtr)arguments;
1393 for (i = 0; i < nargs; i++) {
1394 argptrs[i] = (void *)p;
1395 // get the size from the cif
1396 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1397 }
1398
1399 // this is the function we're going to call
1400 fn = (void(*)(void))Sp[ret_size];
1401
1402 // Restore the Haskell thread's current value of errno
1403 errno = cap->r.rCurrentTSO->saved_errno;
1404
1405 // There are a bunch of non-ptr words on the stack (the
1406 // ccall args, the ccall fun address and space for the
1407 // result), which we need to cover with an info table
1408 // since we might GC during this call.
1409 //
1410 // We know how many (non-ptr) words there are before the
1411 // next valid stack frame: it is the stk_offset arg to the
1412 // CCALL instruction. So we build a RET_DYN stack frame
1413 // on the stack frame to describe this chunk of stack.
1414 //
1415 Sp -= ret_dyn_size;
1416 ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset);
1417 ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1418
1419 // save obj (pointer to the current BCO), since this
1420 // might move during the call. We use the R1 slot in the
1421 // RET_DYN frame for this, hence R1_PTR above.
1422 ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
1423
1424 SAVE_STACK_POINTERS;
1425 tok = suspendThread(&cap->r);
1426
1427 // We already made a copy of the arguments above.
1428 ffi_call(cif, fn, ret, argptrs);
1429
1430 // And restart the thread again, popping the RET_DYN frame.
1431 cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
1432 LOAD_STACK_POINTERS;
1433
1434 // Re-load the pointer to the BCO from the RET_DYN frame,
1435 // it might have moved during the call. Also reload the
1436 // pointers to the components of the BCO.
1437 obj = ((StgRetDyn *)Sp)->payload[0];
1438 bco = (StgBCO*)obj;
1439 instrs = (StgWord16*)(bco->instrs->payload);
1440 literals = (StgWord*)(&bco->literals->payload[0]);
1441 ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
1442
1443 Sp += ret_dyn_size;
1444
1445 // Save the Haskell thread's current value of errno
1446 cap->r.rCurrentTSO->saved_errno = errno;
1447
1448 // Copy the return value back to the TSO stack. It is at
1449 // most 2 words large, and resides at arguments[0].
1450 memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1451
1452 goto nextInsn;
1453 }
1454
1455 case bci_JMP: {
1456 /* BCO_NEXT modifies bciPtr, so be conservative. */
1457 int nextpc = BCO_GET_LARGE_ARG;
1458 bciPtr = nextpc;
1459 goto nextInsn;
1460 }
1461
1462 case bci_CASEFAIL:
1463 barf("interpretBCO: hit a CASEFAIL");
1464
1465 // Errors
1466 default:
1467 barf("interpretBCO: unknown or unimplemented opcode %d",
1468 (int)(bci & 0xFF));
1469
1470 } /* switch on opcode */
1471 }
1472 }
1473
1474 barf("interpretBCO: fell off end of the interpreter");
1475 }