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