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