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