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