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