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