Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
[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(__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_gc_unbx_r1_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_gc_unbx_r1_info
516 || Sp[0] == (W_)&stg_gc_unpt_r1_info
517 || Sp[0] == (W_)&stg_gc_f1_info
518 || Sp[0] == (W_)&stg_gc_d1_info
519 || Sp[0] == (W_)&stg_gc_l1_info
520 || Sp[0] == (W_)&stg_gc_void_info // VoidRep
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_READ_NEXT_WORD;
792 #else
793 BCO_NEXT_WORD;
794 #endif
795 IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
796
797 #ifdef INTERP_STATS
798 it_lastopc = 0; /* no opcode */
799 #endif
800
801 nextInsn:
802 ASSERT(bciPtr < bcoSize);
803 IF_DEBUG(interpreter,
804 //if (do_print_stack) {
805 //debugBelch("\n-- BEGIN stack\n");
806 //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
807 //debugBelch("-- END stack\n\n");
808 //}
809 debugBelch("Sp = %p pc = %-4d ", Sp, bciPtr);
810 disInstr(bco,bciPtr);
811 if (0) { int i;
812 debugBelch("\n");
813 for (i = 8; i >= 0; i--) {
814 debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i)));
815 }
816 debugBelch("\n");
817 }
818 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
819 );
820
821
822 INTERP_TICK(it_insns);
823
824 #ifdef INTERP_STATS
825 ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
826 it_ofreq[ (int)instrs[bciPtr] ] ++;
827 it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
828 it_lastopc = (int)instrs[bciPtr];
829 #endif
830
831 bci = BCO_NEXT;
832 /* We use the high 8 bits for flags, only the highest of which is
833 * currently allocated */
834 ASSERT((bci & 0xFF00) == (bci & 0x8000));
835
836 switch (bci & 0xFF) {
837
838 /* check for a breakpoint on the beginning of a let binding */
839 case bci_BRK_FUN:
840 {
841 int arg1_brk_array, arg2_array_index, arg3_freeVars;
842 StgArrWords *breakPoints;
843 int returning_from_break; // are we resuming execution from a breakpoint?
844 // if yes, then don't break this time around
845 StgClosure *ioAction; // the io action to run at a breakpoint
846
847 StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap
848 int i;
849 int size_words;
850
851 arg1_brk_array = BCO_GET_LARGE_ARG; // 1st arg of break instruction
852 arg2_array_index = BCO_NEXT; // 2nd arg of break instruction
853 arg3_freeVars = BCO_GET_LARGE_ARG; // 3rd arg of break instruction
854
855 // check if we are returning from a breakpoint - this info
856 // is stored in the flags field of the current TSO
857 returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
858
859 // if we are returning from a break then skip this section
860 // and continue executing
861 if (!returning_from_break)
862 {
863 breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
864
865 // stop the current thread if either the
866 // "rts_stop_next_breakpoint" flag is true OR if the
867 // breakpoint flag for this particular expression is
868 // true
869 if (rts_stop_next_breakpoint == rtsTrue ||
870 breakPoints->payload[arg2_array_index] == rtsTrue)
871 {
872 // make sure we don't automatically stop at the
873 // next breakpoint
874 rts_stop_next_breakpoint = rtsFalse;
875
876 // allocate memory for a new AP_STACK, enough to
877 // store the top stack frame plus an
878 // stg_apply_interp_info pointer and a pointer to
879 // the BCO
880 size_words = BCO_BITMAP_SIZE(obj) + 2;
881 new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
882 SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
883 new_aps->size = size_words;
884 new_aps->fun = &stg_dummy_ret_closure;
885
886 // fill in the payload of the AP_STACK
887 new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
888 new_aps->payload[1] = (StgClosure *)obj;
889
890 // copy the contents of the top stack frame into the AP_STACK
891 for (i = 2; i < size_words; i++)
892 {
893 new_aps->payload[i] = (StgClosure *)Sp[i-2];
894 }
895
896 // prepare the stack so that we can call the
897 // rts_breakpoint_io_action and ensure that the stack is
898 // in a reasonable state for the GC and so that
899 // execution of this BCO can continue when we resume
900 ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
901 Sp -= 8;
902 Sp[7] = (W_)obj;
903 Sp[6] = (W_)&stg_apply_interp_info;
904 Sp[5] = (W_)new_aps; // the AP_STACK
905 Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
906 Sp[3] = (W_)False_closure; // True <=> a breakpoint
907 Sp[2] = (W_)&stg_ap_pppv_info;
908 Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
909 Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
910 // set the flag in the TSO to say that we are now
911 // stopping at a breakpoint so that when we resume
912 // we don't stop on the same breakpoint that we
913 // already stopped at just now
914 cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
915
916 // stop this thread and return to the scheduler -
917 // eventually we will come back and the IO action on
918 // the top of the stack will be executed
919 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
920 }
921 }
922 // record that this thread is not stopped at a breakpoint anymore
923 cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
924
925 // continue normal execution of the byte code instructions
926 goto nextInsn;
927 }
928
929 case bci_STKCHECK: {
930 // Explicit stack check at the beginning of a function
931 // *only* (stack checks in case alternatives are
932 // propagated to the enclosing function).
933 StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
934 if (Sp - stk_words_reqd < SpLim) {
935 Sp -= 2;
936 Sp[1] = (W_)obj;
937 Sp[0] = (W_)&stg_apply_interp_info;
938 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
939 } else {
940 goto nextInsn;
941 }
942 }
943
944 case bci_PUSH_L: {
945 int o1 = BCO_NEXT;
946 Sp[-1] = Sp[o1];
947 Sp--;
948 goto nextInsn;
949 }
950
951 case bci_PUSH_LL: {
952 int o1 = BCO_NEXT;
953 int o2 = BCO_NEXT;
954 Sp[-1] = Sp[o1];
955 Sp[-2] = Sp[o2];
956 Sp -= 2;
957 goto nextInsn;
958 }
959
960 case bci_PUSH_LLL: {
961 int o1 = BCO_NEXT;
962 int o2 = BCO_NEXT;
963 int o3 = BCO_NEXT;
964 Sp[-1] = Sp[o1];
965 Sp[-2] = Sp[o2];
966 Sp[-3] = Sp[o3];
967 Sp -= 3;
968 goto nextInsn;
969 }
970
971 case bci_PUSH_G: {
972 int o1 = BCO_GET_LARGE_ARG;
973 Sp[-1] = BCO_PTR(o1);
974 Sp -= 1;
975 goto nextInsn;
976 }
977
978 case bci_PUSH_ALTS: {
979 int o_bco = BCO_GET_LARGE_ARG;
980 Sp[-2] = (W_)&stg_ctoi_R1p_info;
981 Sp[-1] = BCO_PTR(o_bco);
982 Sp -= 2;
983 goto nextInsn;
984 }
985
986 case bci_PUSH_ALTS_P: {
987 int o_bco = BCO_GET_LARGE_ARG;
988 Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
989 Sp[-1] = BCO_PTR(o_bco);
990 Sp -= 2;
991 goto nextInsn;
992 }
993
994 case bci_PUSH_ALTS_N: {
995 int o_bco = BCO_GET_LARGE_ARG;
996 Sp[-2] = (W_)&stg_ctoi_R1n_info;
997 Sp[-1] = BCO_PTR(o_bco);
998 Sp -= 2;
999 goto nextInsn;
1000 }
1001
1002 case bci_PUSH_ALTS_F: {
1003 int o_bco = BCO_GET_LARGE_ARG;
1004 Sp[-2] = (W_)&stg_ctoi_F1_info;
1005 Sp[-1] = BCO_PTR(o_bco);
1006 Sp -= 2;
1007 goto nextInsn;
1008 }
1009
1010 case bci_PUSH_ALTS_D: {
1011 int o_bco = BCO_GET_LARGE_ARG;
1012 Sp[-2] = (W_)&stg_ctoi_D1_info;
1013 Sp[-1] = BCO_PTR(o_bco);
1014 Sp -= 2;
1015 goto nextInsn;
1016 }
1017
1018 case bci_PUSH_ALTS_L: {
1019 int o_bco = BCO_GET_LARGE_ARG;
1020 Sp[-2] = (W_)&stg_ctoi_L1_info;
1021 Sp[-1] = BCO_PTR(o_bco);
1022 Sp -= 2;
1023 goto nextInsn;
1024 }
1025
1026 case bci_PUSH_ALTS_V: {
1027 int o_bco = BCO_GET_LARGE_ARG;
1028 Sp[-2] = (W_)&stg_ctoi_V_info;
1029 Sp[-1] = BCO_PTR(o_bco);
1030 Sp -= 2;
1031 goto nextInsn;
1032 }
1033
1034 case bci_PUSH_APPLY_N:
1035 Sp--; Sp[0] = (W_)&stg_ap_n_info;
1036 goto nextInsn;
1037 case bci_PUSH_APPLY_V:
1038 Sp--; Sp[0] = (W_)&stg_ap_v_info;
1039 goto nextInsn;
1040 case bci_PUSH_APPLY_F:
1041 Sp--; Sp[0] = (W_)&stg_ap_f_info;
1042 goto nextInsn;
1043 case bci_PUSH_APPLY_D:
1044 Sp--; Sp[0] = (W_)&stg_ap_d_info;
1045 goto nextInsn;
1046 case bci_PUSH_APPLY_L:
1047 Sp--; Sp[0] = (W_)&stg_ap_l_info;
1048 goto nextInsn;
1049 case bci_PUSH_APPLY_P:
1050 Sp--; Sp[0] = (W_)&stg_ap_p_info;
1051 goto nextInsn;
1052 case bci_PUSH_APPLY_PP:
1053 Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1054 goto nextInsn;
1055 case bci_PUSH_APPLY_PPP:
1056 Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1057 goto nextInsn;
1058 case bci_PUSH_APPLY_PPPP:
1059 Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1060 goto nextInsn;
1061 case bci_PUSH_APPLY_PPPPP:
1062 Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1063 goto nextInsn;
1064 case bci_PUSH_APPLY_PPPPPP:
1065 Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1066 goto nextInsn;
1067
1068 case bci_PUSH_UBX: {
1069 int i;
1070 int o_lits = BCO_GET_LARGE_ARG;
1071 int n_words = BCO_NEXT;
1072 Sp -= n_words;
1073 for (i = 0; i < n_words; i++) {
1074 Sp[i] = (W_)BCO_LIT(o_lits+i);
1075 }
1076 goto nextInsn;
1077 }
1078
1079 case bci_SLIDE: {
1080 int n = BCO_NEXT;
1081 int by = BCO_NEXT;
1082 /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1083 while(--n >= 0) {
1084 Sp[n+by] = Sp[n];
1085 }
1086 Sp += by;
1087 INTERP_TICK(it_slides);
1088 goto nextInsn;
1089 }
1090
1091 case bci_ALLOC_AP: {
1092 StgAP* ap;
1093 int n_payload = BCO_NEXT;
1094 ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1095 Sp[-1] = (W_)ap;
1096 ap->n_args = n_payload;
1097 SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
1098 Sp --;
1099 goto nextInsn;
1100 }
1101
1102 case bci_ALLOC_AP_NOUPD: {
1103 StgAP* ap;
1104 int n_payload = BCO_NEXT;
1105 ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1106 Sp[-1] = (W_)ap;
1107 ap->n_args = n_payload;
1108 SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
1109 Sp --;
1110 goto nextInsn;
1111 }
1112
1113 case bci_ALLOC_PAP: {
1114 StgPAP* pap;
1115 int arity = BCO_NEXT;
1116 int n_payload = BCO_NEXT;
1117 pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload));
1118 Sp[-1] = (W_)pap;
1119 pap->n_args = n_payload;
1120 pap->arity = arity;
1121 SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
1122 Sp --;
1123 goto nextInsn;
1124 }
1125
1126 case bci_MKAP: {
1127 int i;
1128 int stkoff = BCO_NEXT;
1129 int n_payload = BCO_NEXT;
1130 StgAP* ap = (StgAP*)Sp[stkoff];
1131 ASSERT((int)ap->n_args == n_payload);
1132 ap->fun = (StgClosure*)Sp[0];
1133
1134 // The function should be a BCO, and its bitmap should
1135 // cover the payload of the AP correctly.
1136 ASSERT(get_itbl(ap->fun)->type == BCO
1137 && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1138
1139 for (i = 0; i < n_payload; i++)
1140 ap->payload[i] = (StgClosure*)Sp[i+1];
1141 Sp += n_payload+1;
1142 IF_DEBUG(interpreter,
1143 debugBelch("\tBuilt ");
1144 printObj((StgClosure*)ap);
1145 );
1146 goto nextInsn;
1147 }
1148
1149 case bci_MKPAP: {
1150 int i;
1151 int stkoff = BCO_NEXT;
1152 int n_payload = BCO_NEXT;
1153 StgPAP* pap = (StgPAP*)Sp[stkoff];
1154 ASSERT((int)pap->n_args == n_payload);
1155 pap->fun = (StgClosure*)Sp[0];
1156
1157 // The function should be a BCO
1158 ASSERT(get_itbl(pap->fun)->type == BCO);
1159
1160 for (i = 0; i < n_payload; i++)
1161 pap->payload[i] = (StgClosure*)Sp[i+1];
1162 Sp += n_payload+1;
1163 IF_DEBUG(interpreter,
1164 debugBelch("\tBuilt ");
1165 printObj((StgClosure*)pap);
1166 );
1167 goto nextInsn;
1168 }
1169
1170 case bci_UNPACK: {
1171 /* Unpack N ptr words from t.o.s constructor */
1172 int i;
1173 int n_words = BCO_NEXT;
1174 StgClosure* con = (StgClosure*)Sp[0];
1175 Sp -= n_words;
1176 for (i = 0; i < n_words; i++) {
1177 Sp[i] = (W_)con->payload[i];
1178 }
1179 goto nextInsn;
1180 }
1181
1182 case bci_PACK: {
1183 int i;
1184 int o_itbl = BCO_GET_LARGE_ARG;
1185 int n_words = BCO_NEXT;
1186 StgInfoTable* itbl = INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
1187 int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
1188 itbl->layout.payload.nptrs );
1189 StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
1190 ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1191 SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
1192 for (i = 0; i < n_words; i++) {
1193 con->payload[i] = (StgClosure*)Sp[i];
1194 }
1195 Sp += n_words;
1196 Sp --;
1197 Sp[0] = (W_)con;
1198 IF_DEBUG(interpreter,
1199 debugBelch("\tBuilt ");
1200 printObj((StgClosure*)con);
1201 );
1202 goto nextInsn;
1203 }
1204
1205 case bci_TESTLT_P: {
1206 unsigned int discr = BCO_NEXT;
1207 int failto = BCO_GET_LARGE_ARG;
1208 StgClosure* con = (StgClosure*)Sp[0];
1209 if (GET_TAG(con) >= discr) {
1210 bciPtr = failto;
1211 }
1212 goto nextInsn;
1213 }
1214
1215 case bci_TESTEQ_P: {
1216 unsigned int discr = BCO_NEXT;
1217 int failto = BCO_GET_LARGE_ARG;
1218 StgClosure* con = (StgClosure*)Sp[0];
1219 if (GET_TAG(con) != discr) {
1220 bciPtr = failto;
1221 }
1222 goto nextInsn;
1223 }
1224
1225 case bci_TESTLT_I: {
1226 // There should be an Int at Sp[1], and an info table at Sp[0].
1227 int discr = BCO_GET_LARGE_ARG;
1228 int failto = BCO_GET_LARGE_ARG;
1229 I_ stackInt = (I_)Sp[1];
1230 if (stackInt >= (I_)BCO_LIT(discr))
1231 bciPtr = failto;
1232 goto nextInsn;
1233 }
1234
1235 case bci_TESTEQ_I: {
1236 // There should be an Int at Sp[1], and an info table at Sp[0].
1237 int discr = BCO_GET_LARGE_ARG;
1238 int failto = BCO_GET_LARGE_ARG;
1239 I_ stackInt = (I_)Sp[1];
1240 if (stackInt != (I_)BCO_LIT(discr)) {
1241 bciPtr = failto;
1242 }
1243 goto nextInsn;
1244 }
1245
1246 case bci_TESTLT_W: {
1247 // There should be an Int at Sp[1], and an info table at Sp[0].
1248 int discr = BCO_GET_LARGE_ARG;
1249 int failto = BCO_GET_LARGE_ARG;
1250 W_ stackWord = (W_)Sp[1];
1251 if (stackWord >= (W_)BCO_LIT(discr))
1252 bciPtr = failto;
1253 goto nextInsn;
1254 }
1255
1256 case bci_TESTEQ_W: {
1257 // There should be an Int at Sp[1], and an info table at Sp[0].
1258 int discr = BCO_GET_LARGE_ARG;
1259 int failto = BCO_GET_LARGE_ARG;
1260 W_ stackWord = (W_)Sp[1];
1261 if (stackWord != (W_)BCO_LIT(discr)) {
1262 bciPtr = failto;
1263 }
1264 goto nextInsn;
1265 }
1266
1267 case bci_TESTLT_D: {
1268 // There should be a Double at Sp[1], and an info table at Sp[0].
1269 int discr = BCO_GET_LARGE_ARG;
1270 int failto = BCO_GET_LARGE_ARG;
1271 StgDouble stackDbl, discrDbl;
1272 stackDbl = PK_DBL( & Sp[1] );
1273 discrDbl = PK_DBL( & BCO_LIT(discr) );
1274 if (stackDbl >= discrDbl) {
1275 bciPtr = failto;
1276 }
1277 goto nextInsn;
1278 }
1279
1280 case bci_TESTEQ_D: {
1281 // There should be a Double at Sp[1], and an info table at Sp[0].
1282 int discr = BCO_GET_LARGE_ARG;
1283 int failto = BCO_GET_LARGE_ARG;
1284 StgDouble stackDbl, discrDbl;
1285 stackDbl = PK_DBL( & Sp[1] );
1286 discrDbl = PK_DBL( & BCO_LIT(discr) );
1287 if (stackDbl != discrDbl) {
1288 bciPtr = failto;
1289 }
1290 goto nextInsn;
1291 }
1292
1293 case bci_TESTLT_F: {
1294 // There should be a Float at Sp[1], and an info table at Sp[0].
1295 int discr = BCO_GET_LARGE_ARG;
1296 int failto = BCO_GET_LARGE_ARG;
1297 StgFloat stackFlt, discrFlt;
1298 stackFlt = PK_FLT( & Sp[1] );
1299 discrFlt = PK_FLT( & BCO_LIT(discr) );
1300 if (stackFlt >= discrFlt) {
1301 bciPtr = failto;
1302 }
1303 goto nextInsn;
1304 }
1305
1306 case bci_TESTEQ_F: {
1307 // There should be a Float at Sp[1], and an info table at Sp[0].
1308 int discr = BCO_GET_LARGE_ARG;
1309 int failto = BCO_GET_LARGE_ARG;
1310 StgFloat stackFlt, discrFlt;
1311 stackFlt = PK_FLT( & Sp[1] );
1312 discrFlt = PK_FLT( & BCO_LIT(discr) );
1313 if (stackFlt != discrFlt) {
1314 bciPtr = failto;
1315 }
1316 goto nextInsn;
1317 }
1318
1319 // Control-flow ish things
1320 case bci_ENTER:
1321 // Context-switch check. We put it here to ensure that
1322 // the interpreter has done at least *some* work before
1323 // context switching: sometimes the scheduler can invoke
1324 // the interpreter with context_switch == 1, particularly
1325 // if the -C0 flag has been given on the cmd line.
1326 if (cap->r.rHpLim == NULL) {
1327 Sp--; Sp[0] = (W_)&stg_enter_info;
1328 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1329 }
1330 goto eval;
1331
1332 case bci_RETURN:
1333 tagged_obj = (StgClosure *)Sp[0];
1334 Sp++;
1335 goto do_return;
1336
1337 case bci_RETURN_P:
1338 Sp--;
1339 Sp[0] = (W_)&stg_gc_unpt_r1_info;
1340 goto do_return_unboxed;
1341 case bci_RETURN_N:
1342 Sp--;
1343 Sp[0] = (W_)&stg_gc_unbx_r1_info;
1344 goto do_return_unboxed;
1345 case bci_RETURN_F:
1346 Sp--;
1347 Sp[0] = (W_)&stg_gc_f1_info;
1348 goto do_return_unboxed;
1349 case bci_RETURN_D:
1350 Sp--;
1351 Sp[0] = (W_)&stg_gc_d1_info;
1352 goto do_return_unboxed;
1353 case bci_RETURN_L:
1354 Sp--;
1355 Sp[0] = (W_)&stg_gc_l1_info;
1356 goto do_return_unboxed;
1357 case bci_RETURN_V:
1358 Sp--;
1359 Sp[0] = (W_)&stg_gc_void_info;
1360 goto do_return_unboxed;
1361
1362 case bci_SWIZZLE: {
1363 int stkoff = BCO_NEXT;
1364 signed short n = (signed short)(BCO_NEXT);
1365 Sp[stkoff] += (W_)n;
1366 goto nextInsn;
1367 }
1368
1369 case bci_CCALL: {
1370 void *tok;
1371 int stk_offset = BCO_NEXT;
1372 int o_itbl = BCO_GET_LARGE_ARG;
1373 int interruptible = BCO_NEXT;
1374 void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1375 int ret_dyn_size =
1376 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1377 + sizeofW(StgRetDyn);
1378
1379 /* the stack looks like this:
1380
1381 | | <- Sp + stk_offset
1382 +-------------+
1383 | |
1384 | args |
1385 | | <- Sp + ret_size + 1
1386 +-------------+
1387 | C fun | <- Sp + ret_size
1388 +-------------+
1389 | ret | <- Sp
1390 +-------------+
1391
1392 ret is a placeholder for the return address, and may be
1393 up to 2 words.
1394
1395 We need to copy the args out of the TSO, because when
1396 we call suspendThread() we no longer own the TSO stack,
1397 and it may move at any time - indeed suspendThread()
1398 itself may do stack squeezing and move our args.
1399 So we make a copy of the argument block.
1400 */
1401
1402 #define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1403
1404 ffi_cif *cif = (ffi_cif *)marshall_fn;
1405 nat nargs = cif->nargs;
1406 nat ret_size;
1407 nat i;
1408 StgPtr p;
1409 W_ ret[2]; // max needed
1410 W_ *arguments[stk_offset]; // max needed
1411 void *argptrs[nargs];
1412 void (*fn)(void);
1413
1414 if (cif->rtype->type == FFI_TYPE_VOID) {
1415 // necessary because cif->rtype->size == 1 for void,
1416 // but the bytecode generator has not pushed a
1417 // placeholder in this case.
1418 ret_size = 0;
1419 } else {
1420 ret_size = ROUND_UP_WDS(cif->rtype->size);
1421 }
1422
1423 memcpy(arguments, Sp+ret_size+1,
1424 sizeof(W_) * (stk_offset-1-ret_size));
1425
1426 // libffi expects the args as an array of pointers to
1427 // values, so we have to construct this array before making
1428 // the call.
1429 p = (StgPtr)arguments;
1430 for (i = 0; i < nargs; i++) {
1431 argptrs[i] = (void *)p;
1432 // get the size from the cif
1433 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1434 }
1435
1436 // this is the function we're going to call
1437 fn = (void(*)(void))Sp[ret_size];
1438
1439 // Restore the Haskell thread's current value of errno
1440 errno = cap->r.rCurrentTSO->saved_errno;
1441
1442 // There are a bunch of non-ptr words on the stack (the
1443 // ccall args, the ccall fun address and space for the
1444 // result), which we need to cover with an info table
1445 // since we might GC during this call.
1446 //
1447 // We know how many (non-ptr) words there are before the
1448 // next valid stack frame: it is the stk_offset arg to the
1449 // CCALL instruction. So we build a RET_DYN stack frame
1450 // on the stack frame to describe this chunk of stack.
1451 //
1452 Sp -= ret_dyn_size;
1453 ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset);
1454 ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1455
1456 // save obj (pointer to the current BCO), since this
1457 // might move during the call. We use the R1 slot in the
1458 // RET_DYN frame for this, hence R1_PTR above.
1459 ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
1460
1461 SAVE_STACK_POINTERS;
1462 tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse);
1463
1464 // We already made a copy of the arguments above.
1465 ffi_call(cif, fn, ret, argptrs);
1466
1467 // And restart the thread again, popping the RET_DYN frame.
1468 cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
1469 LOAD_STACK_POINTERS;
1470
1471 if (Sp[0] != (W_)&stg_gc_gen_info) {
1472 // the stack is not how we left it. This probably
1473 // means that an exception got raised on exit from the
1474 // foreign call, so we should just continue with
1475 // whatever is on top of the stack now.
1476 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
1477 }
1478
1479 // Re-load the pointer to the BCO from the RET_DYN frame,
1480 // it might have moved during the call. Also reload the
1481 // pointers to the components of the BCO.
1482 obj = ((StgRetDyn *)Sp)->payload[0];
1483 bco = (StgBCO*)obj;
1484 instrs = (StgWord16*)(bco->instrs->payload);
1485 literals = (StgWord*)(&bco->literals->payload[0]);
1486 ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
1487
1488 Sp += ret_dyn_size;
1489
1490 // Save the Haskell thread's current value of errno
1491 cap->r.rCurrentTSO->saved_errno = errno;
1492
1493 // Copy the return value back to the TSO stack. It is at
1494 // most 2 words large, and resides at arguments[0].
1495 memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1496
1497 goto nextInsn;
1498 }
1499
1500 case bci_JMP: {
1501 /* BCO_NEXT modifies bciPtr, so be conservative. */
1502 int nextpc = BCO_GET_LARGE_ARG;
1503 bciPtr = nextpc;
1504 goto nextInsn;
1505 }
1506
1507 case bci_CASEFAIL:
1508 barf("interpretBCO: hit a CASEFAIL");
1509
1510 // Errors
1511 default:
1512 barf("interpretBCO: unknown or unimplemented opcode %d",
1513 (int)(bci & 0xFF));
1514
1515 } /* switch on opcode */
1516 }
1517 }
1518
1519 barf("interpretBCO: fell off end of the interpreter");
1520 }