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