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