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