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