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