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