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