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 "Disassembler.h"
  22 #include "Interpreter.h"
  23 #include "ThreadPaused.h"
  24 #include "Threads.h"
  25
  26 #include <string.h>     /* for memcpy */
  27 #ifdef HAVE_ERRNO_H
  28 #include <errno.h>
  29 #endif
  30
  31 // When building the RTS in the non-dyn way on Windows, we don't
  32 //      want declspec(__dllimport__) on the front of function prototypes
  33 //      from libffi.
  34 #if defined(mingw32_HOST_OS) && !defined(__PIC__)
  35 # define LIBFFI_NOT_DLL
  36 #endif
  37
  38 #include "ffi.h"
  39
  40 /* --------------------------------------------------------------------------
  41  * The bytecode interpreter
  42  * ------------------------------------------------------------------------*/
  43
  44 /* Gather stats about entry, opcode, opcode-pair frequencies.  For
  45    tuning the interpreter. */
  46
  47 /* #define INTERP_STATS */
  48
  49
  50 /* Sp points to the lowest live word on the stack. */
  51
  52 #define BCO_NEXT      instrs[bciPtr++]
  53 #define BCO_NEXT_32   (bciPtr += 2, (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1]))
  54 #define BCO_NEXT_64   (bciPtr += 4, (((StgWord) instrs[bciPtr-4]) << 48) + (((StgWord) instrs[bciPtr-3]) << 32) + (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1]))
  55 #if WORD_SIZE_IN_BITS == 32
  56 #define BCO_NEXT_WORD BCO_NEXT_32
  57 #elif WORD_SIZE_IN_BITS == 64
  58 #define BCO_NEXT_WORD BCO_NEXT_64
  59 #else
  60 #error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64
  61 #endif
  62 #define BCO_GET_LARGE_ARG ((bci & bci_FLAG_LARGE_ARGS) ? BCO_NEXT_WORD : BCO_NEXT)
  63
  64 #define BCO_PTR(n)    (W_)ptrs[n]
  65 #define BCO_LIT(n)    literals[n]
  66
  67 #define LOAD_STACK_POINTERS                                     \
  68     Sp = cap->r.rCurrentTSO->sp;                                \
  69     /* We don't change this ... */                              \
  70     SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
  71
  72 #define SAVE_STACK_POINTERS                     \
  73     ASSERT(Sp > SpLim); \
  74     cap->r.rCurrentTSO->sp = Sp
  75
  76 #define RETURN_TO_SCHEDULER(todo,retcode)       \
  77    SAVE_STACK_POINTERS;                         \
  78    cap->r.rCurrentTSO->what_next = (todo);      \
  79    threadPaused(cap,cap->r.rCurrentTSO);                \
  80    cap->r.rRet = (retcode);                     \
  81    return cap;
  82
  83 #define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode)      \
  84    SAVE_STACK_POINTERS;                                 \
  85    cap->r.rCurrentTSO->what_next = (todo);              \
  86    cap->r.rRet = (retcode);                             \
  87    return cap;
  88
  89
  90 STATIC_INLINE StgPtr
  91 allocate_NONUPD (Capability *cap, int n_words)
  92 {
  93     return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
  94 }
  95
  96 int rts_stop_next_breakpoint = 0;
  97 int rts_stop_on_exception = 0;
  98
  99 #ifdef INTERP_STATS
 100
 101 /* Hacky stats, for tuning the interpreter ... */
 102 int it_unknown_entries[N_CLOSURE_TYPES];
 103 int it_total_unknown_entries;
 104 int it_total_entries;
 105
 106 int it_retto_BCO;
 107 int it_retto_UPDATE;
 108 int it_retto_other;
 109
 110 int it_slides;
 111 int it_insns;
 112 int it_BCO_entries;
 113
 114 int it_ofreq[27];
 115 int it_oofreq[27][27];
 116 int it_lastopc;
 117
 118
 119 #define INTERP_TICK(n) (n)++
 120
 121 void interp_startup ( void )
 122 {
 123    int i, j;
 124    it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
 125    it_total_entries = it_total_unknown_entries = 0;
 126    for (i = 0; i < N_CLOSURE_TYPES; i++)
 127       it_unknown_entries[i] = 0;
 128    it_slides = it_insns = it_BCO_entries = 0;
 129    for (i = 0; i < 27; i++) it_ofreq[i] = 0;
 130    for (i = 0; i < 27; i++)
 131      for (j = 0; j < 27; j++)
 132         it_oofreq[i][j] = 0;
 133    it_lastopc = 0;
 134 }
 135
 136 void interp_shutdown ( void )
 137 {
 138    int i, j, k, o_max, i_max, j_max;
 139    debugBelch("%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
 140                    it_retto_BCO + it_retto_UPDATE + it_retto_other,
 141                    it_retto_BCO, it_retto_UPDATE, it_retto_other );
 142    debugBelch("%d total entries, %d unknown entries \n",
 143                    it_total_entries, it_total_unknown_entries);
 144    for (i = 0; i < N_CLOSURE_TYPES; i++) {
 145      if (it_unknown_entries[i] == 0) continue;
 146      debugBelch("   type %2d: unknown entries (%4.1f%%) == %d\n",
 147              i, 100.0 * ((double)it_unknown_entries[i]) /
 148                         ((double)it_total_unknown_entries),
 149              it_unknown_entries[i]);
 150    }
 151    debugBelch("%d insns, %d slides, %d BCO_entries\n",
 152                    it_insns, it_slides, it_BCO_entries);
 153    for (i = 0; i < 27; i++)
 154       debugBelch("opcode %2d got %d\n", i, it_ofreq[i] );
 155
 156    for (k = 1; k < 20; k++) {
 157       o_max = 0;
 158       i_max = j_max = 0;
 159       for (i = 0; i < 27; i++) {
 160          for (j = 0; j < 27; j++) {
 161             if (it_oofreq[i][j] > o_max) {
 162                o_max = it_oofreq[i][j];
 163                i_max = i; j_max = j;
 164             }
 165          }
 166       }
 167
 168       debugBelch("%d:  count (%4.1f%%) %6d   is %d then %d\n",
 169                 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
 170                    i_max, j_max );
 171       it_oofreq[i_max][j_max] = 0;
 172
 173    }
 174 }
 175
 176 #else // !INTERP_STATS
 177
 178 #define INTERP_TICK(n) /* nothing */
 179
 180 #endif
 181
 182 static StgWord app_ptrs_itbl[] = {
 183     (W_)&stg_ap_p_info,
 184     (W_)&stg_ap_pp_info,
 185     (W_)&stg_ap_ppp_info,
 186     (W_)&stg_ap_pppp_info,
 187     (W_)&stg_ap_ppppp_info,
 188     (W_)&stg_ap_pppppp_info,
 189 };
 190
 191 HsStablePtr rts_breakpoint_io_action; // points to the IO action which is executed on a breakpoint
 192                                 // it is set in main/GHC.hs:runStmt
 193
 194 Capability *
 195 interpretBCO (Capability* cap)
 196 {
 197     // Use of register here is primarily to make it clear to compilers
 198     // that these entities are non-aliasable.
 199     register StgPtr       Sp;    // local state -- stack pointer
 200     register StgPtr       SpLim; // local state -- stack lim pointer
 201     register StgClosure   *tagged_obj = 0, *obj;
 202     nat n, m;
 203
 204     LOAD_STACK_POINTERS;
 205
 206     cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
 207                            // goes to zero we must return to the scheduler.
 208
 209     // ------------------------------------------------------------------------
 210     // Case 1:
 211     //
 212     //       We have a closure to evaluate.  Stack looks like:
 213     //
 214     //          |   XXXX_info   |
 215     //          +---------------+
 216     //       Sp |      -------------------> closure
 217     //          +---------------+
 218     //
 219     if (Sp[0] == (W_)&stg_enter_info) {
 220        Sp++;
 221        goto eval;
 222     }
 223
 224     // ------------------------------------------------------------------------
 225     // Case 2:
 226     //
 227     //       We have a BCO application to perform.  Stack looks like:
 228     //
 229     //          |     ....      |
 230     //          +---------------+
 231     //          |     arg1      |
 232     //          +---------------+
 233     //          |     BCO       |
 234     //          +---------------+
 235     //       Sp |   RET_BCO     |
 236     //          +---------------+
 237     //
 238     else if (Sp[0] == (W_)&stg_apply_interp_info) {
 239         obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
 240         Sp += 2;
 241         goto run_BCO_fun;
 242     }
 243
 244     // ------------------------------------------------------------------------
 245     // Case 3:
 246     //
 247     //       We have an unboxed value to return.  See comment before
 248     //       do_return_unboxed, below.
 249     //
 250     else {
 251         goto do_return_unboxed;
 252     }
 253
 254     // Evaluate the object on top of the stack.
 255 eval:
 256     tagged_obj = (StgClosure*)Sp[0]; Sp++;
 257
 258 eval_obj:
 259     obj = UNTAG_CLOSURE(tagged_obj);
 260     INTERP_TICK(it_total_evals);
 261
 262     IF_DEBUG(interpreter,
 263              debugBelch(
 264              "\n---------------------------------------------------------------\n");
 265              debugBelch("Evaluating: "); printObj(obj);
 266              debugBelch("Sp = %p\n", Sp);
 267              debugBelch("\n" );
 268
 269              printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
 270              debugBelch("\n\n");
 271             );
 272
 273 //    IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
 274     IF_DEBUG(sanity,checkStackFrame(Sp));
 275
 276     switch ( get_itbl(obj)->type ) {
 277
 278     case IND:
 279     case IND_PERM:
 280     case IND_STATIC:
 281     {
 282         tagged_obj = ((StgInd*)obj)->indirectee;
 283         goto eval_obj;
 284     }
 285
 286     case CONSTR:
 287     case CONSTR_1_0:
 288     case CONSTR_0_1:
 289     case CONSTR_2_0:
 290     case CONSTR_1_1:
 291     case CONSTR_0_2:
 292     case CONSTR_STATIC:
 293     case CONSTR_NOCAF_STATIC:
 294     case FUN:
 295     case FUN_1_0:
 296     case FUN_0_1:
 297     case FUN_2_0:
 298     case FUN_1_1:
 299     case FUN_0_2:
 300     case FUN_STATIC:
 301     case PAP:
 302         // already in WHNF
 303         break;
 304
 305     case BCO:
 306     {
 307         ASSERT(((StgBCO *)obj)->arity > 0);
 308         break;
 309     }
 310
 311     case AP:    /* Copied from stg_AP_entry. */
 312     {
 313         nat i, words;
 314         StgAP *ap;
 315
 316         ap = (StgAP*)obj;
 317         words = ap->n_args;
 318
 319         // Stack check
 320         if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
 321             Sp -= 2;
 322             Sp[1] = (W_)tagged_obj;
 323             Sp[0] = (W_)&stg_enter_info;
 324             RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
 325         }
 326
 327         /* Ok; we're safe.  Party on.  Push an update frame. */
 328         Sp -= sizeofW(StgUpdateFrame);
 329         {
 330             StgUpdateFrame *__frame;
 331             __frame = (StgUpdateFrame *)Sp;
 332             SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
 333             __frame->updatee = (StgClosure *)(ap);
 334         }
 335
 336         /* Reload the stack */
 337         Sp -= words;
 338         for (i=0; i < words; i++) {
 339             Sp[i] = (W_)ap->payload[i];
 340         }
 341
 342         obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
 343         ASSERT(get_itbl(obj)->type == BCO);
 344         goto run_BCO_fun;
 345     }
 346
 347     default:
 348 #ifdef INTERP_STATS
 349     {
 350         int j;
 351
 352         j = get_itbl(obj)->type;
 353         ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
 354         it_unknown_entries[j]++;
 355         it_total_unknown_entries++;
 356     }
 357 #endif
 358     {
 359         // Can't handle this object; yield to scheduler
 360         IF_DEBUG(interpreter,
 361                  debugBelch("evaluating unknown closure -- yielding to sched\n");
 362                  printObj(obj);
 363             );
 364         Sp -= 2;
 365         Sp[1] = (W_)tagged_obj;
 366         Sp[0] = (W_)&stg_enter_info;
 367         RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
 368     }
 369     }
 370
 371     // ------------------------------------------------------------------------
 372     // We now have an evaluated object (tagged_obj).  The next thing to
 373     // do is return it to the stack frame on top of the stack.
 374 do_return:
 375     obj = UNTAG_CLOSURE(tagged_obj);
 376     ASSERT(closure_HNF(obj));
 377
 378     IF_DEBUG(interpreter,
 379              debugBelch(
 380              "\n---------------------------------------------------------------\n");
 381              debugBelch("Returning: "); printObj(obj);
 382              debugBelch("Sp = %p\n", Sp);
 383              debugBelch("\n" );
 384              printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
 385              debugBelch("\n\n");
 386             );
 387
 388     IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
 389
 390     switch (get_itbl((StgClosure *)Sp)->type) {
 391
 392     case RET_SMALL: {
 393         const StgInfoTable *info;
 394
 395         // NOTE: not using get_itbl().
 396         info = ((StgClosure *)Sp)->header.info;
 397         if (info == (StgInfoTable *)&stg_ap_v_info) {
 398             n = 1; m = 0; goto do_apply;
 399         }
 400         if (info == (StgInfoTable *)&stg_ap_f_info) {
 401             n = 1; m = 1; goto do_apply;
 402         }
 403         if (info == (StgInfoTable *)&stg_ap_d_info) {
 404             n = 1; m = sizeofW(StgDouble); goto do_apply;
 405         }
 406         if (info == (StgInfoTable *)&stg_ap_l_info) {
 407             n = 1; m = sizeofW(StgInt64); goto do_apply;
 408         }
 409         if (info == (StgInfoTable *)&stg_ap_n_info) {
 410             n = 1; m = 1; goto do_apply;
 411         }
 412         if (info == (StgInfoTable *)&stg_ap_p_info) {
 413             n = 1; m = 1; goto do_apply;
 414         }
 415         if (info == (StgInfoTable *)&stg_ap_pp_info) {
 416             n = 2; m = 2; goto do_apply;
 417         }
 418         if (info == (StgInfoTable *)&stg_ap_ppp_info) {
 419             n = 3; m = 3; goto do_apply;
 420         }
 421         if (info == (StgInfoTable *)&stg_ap_pppp_info) {
 422             n = 4; m = 4; goto do_apply;
 423         }
 424         if (info == (StgInfoTable *)&stg_ap_ppppp_info) {
 425             n = 5; m = 5; goto do_apply;
 426         }
 427         if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
 428             n = 6; m = 6; goto do_apply;
 429         }
 430         goto do_return_unrecognised;
 431     }
 432
 433     case UPDATE_FRAME:
 434         // Returning to an update frame: do the update, pop the update
 435         // frame, and continue with the next stack frame.
 436         //
 437         // NB. we must update with the *tagged* pointer.  Some tags
 438         // are not optional, and if we omit the tag bits when updating
 439         // then bad things can happen (albeit very rarely).  See #1925.
 440         // What happened was an indirection was created with an
 441         // untagged pointer, and this untagged pointer was propagated
 442         // to a PAP by the GC, violating the invariant that PAPs
 443         // always contain a tagged pointer to the function.
 444         INTERP_TICK(it_retto_UPDATE);
 445         updateThunk(cap, cap->r.rCurrentTSO,
 446                     ((StgUpdateFrame *)Sp)->updatee, tagged_obj);
 447         Sp += sizeofW(StgUpdateFrame);
 448         goto do_return;
 449
 450     case RET_BCO:
 451         // Returning to an interpreted continuation: put the object on
 452         // the stack, and start executing the BCO.
 453         INTERP_TICK(it_retto_BCO);
 454         Sp--;
 455         Sp[0] = (W_)obj;
 456         // NB. return the untagged object; the bytecode expects it to
 457         // be untagged.  XXX this doesn't seem right.
 458         obj = (StgClosure*)Sp[2];
 459         ASSERT(get_itbl(obj)->type == BCO);
 460         goto run_BCO_return;
 461
 462     default:
 463     do_return_unrecognised:
 464     {
 465         // Can't handle this return address; yield to scheduler
 466         INTERP_TICK(it_retto_other);
 467         IF_DEBUG(interpreter,
 468                  debugBelch("returning to unknown frame -- yielding to sched\n");
 469                  printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
 470             );
 471         Sp -= 2;
 472         Sp[1] = (W_)tagged_obj;
 473         Sp[0] = (W_)&stg_enter_info;
 474         RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
 475     }
 476     }
 477
 478     // -------------------------------------------------------------------------
 479     // Returning an unboxed value.  The stack looks like this:
 480     //
 481     //    |     ....      |
 482     //    +---------------+
 483     //    |     fv2       |
 484     //    +---------------+
 485     //    |     fv1       |
 486     //    +---------------+
 487     //    |     BCO       |
 488     //    +---------------+
 489     //    | stg_ctoi_ret_ |
 490     //    +---------------+
 491     //    |    retval     |
 492     //    +---------------+
 493     //    |   XXXX_info   |
 494     //    +---------------+
 495     //
 496     // where XXXX_info is one of the stg_gc_unbx_r1_info family.
 497     //
 498     // We're only interested in the case when the real return address
 499     // is a BCO; otherwise we'll return to the scheduler.
 500
 501 do_return_unboxed:
 502     {
 503         int offset;
 504
 505         ASSERT( Sp[0] == (W_)&stg_gc_unbx_r1_info
 506                 || Sp[0] == (W_)&stg_gc_unpt_r1_info
 507                 || Sp[0] == (W_)&stg_gc_f1_info
 508                 || Sp[0] == (W_)&stg_gc_d1_info
 509                 || Sp[0] == (W_)&stg_gc_l1_info
 510                 || Sp[0] == (W_)&stg_gc_void_info // VoidRep
 511             );
 512
 513         // get the offset of the stg_ctoi_ret_XXX itbl
 514         offset = stack_frame_sizeW((StgClosure *)Sp);
 515
 516         switch (get_itbl((StgClosure *)Sp+offset)->type) {
 517
 518         case RET_BCO:
 519             // Returning to an interpreted continuation: put the object on
 520             // the stack, and start executing the BCO.
 521             INTERP_TICK(it_retto_BCO);
 522             obj = (StgClosure*)Sp[offset+1];
 523             ASSERT(get_itbl(obj)->type == BCO);
 524             goto run_BCO_return_unboxed;
 525
 526         default:
 527         {
 528             // Can't handle this return address; yield to scheduler
 529             INTERP_TICK(it_retto_other);
 530             IF_DEBUG(interpreter,
 531                      debugBelch("returning to unknown frame -- yielding to sched\n");
 532                      printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
 533                 );
 534             RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
 535         }
 536         }
 537     }
 538     // not reached.
 539
 540
 541     // -------------------------------------------------------------------------
 542     // Application...
 543
 544 do_apply:
 545     ASSERT(obj == UNTAG_CLOSURE(tagged_obj));
 546     // we have a function to apply (obj), and n arguments taking up m
 547     // words on the stack.  The info table (stg_ap_pp_info or whatever)
 548     // is on top of the arguments on the stack.
 549     {
 550         switch (get_itbl(obj)->type) {
 551
 552         case PAP: {
 553             StgPAP *pap;
 554             nat i, arity;
 555
 556             pap = (StgPAP *)obj;
 557
 558             // we only cope with PAPs whose function is a BCO
 559             if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) {
 560                 goto defer_apply_to_sched;
 561             }
 562
 563             // Stack check: we're about to unpack the PAP onto the
 564             // stack.  The (+1) is for the (arity < n) case, where we
 565             // also need space for an extra info pointer.
 566             if (Sp - (pap->n_args + 1) < SpLim) {
 567                 Sp -= 2;
 568                 Sp[1] = (W_)tagged_obj;
 569                 Sp[0] = (W_)&stg_enter_info;
 570                 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
 571             }
 572
 573             Sp++;
 574             arity = pap->arity;
 575             ASSERT(arity > 0);
 576             if (arity < n) {
 577                 // n must be greater than 1, and the only kinds of
 578                 // application we support with more than one argument
 579                 // are all pointers...
 580                 //
 581                 // Shuffle the args for this function down, and put
 582                 // the appropriate info table in the gap.
 583                 for (i = 0; i < arity; i++) {
 584                     Sp[(int)i-1] = Sp[i];
 585                     // ^^^^^ careful, i-1 might be negative, but i in unsigned
 586                 }
 587                 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
 588                 Sp--;
 589                 // unpack the PAP's arguments onto the stack
 590                 Sp -= pap->n_args;
 591                 for (i = 0; i < pap->n_args; i++) {
 592                     Sp[i] = (W_)pap->payload[i];
 593                 }
 594                 obj = UNTAG_CLOSURE(pap->fun);
 595                 goto run_BCO_fun;
 596             }
 597             else if (arity == n) {
 598                 Sp -= pap->n_args;
 599                 for (i = 0; i < pap->n_args; i++) {
 600                     Sp[i] = (W_)pap->payload[i];
 601                 }
 602                 obj = UNTAG_CLOSURE(pap->fun);
 603                 goto run_BCO_fun;
 604             }
 605             else /* arity > n */ {
 606                 // build a new PAP and return it.
 607                 StgPAP *new_pap;
 608                 new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m));
 609                 SET_HDR(new_pap,&stg_PAP_info,CCCS);
 610                 new_pap->arity = pap->arity - n;
 611                 new_pap->n_args = pap->n_args + m;
 612                 new_pap->fun = pap->fun;
 613                 for (i = 0; i < pap->n_args; i++) {
 614                     new_pap->payload[i] = pap->payload[i];
 615                 }
 616                 for (i = 0; i < m; i++) {
 617                     new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
 618                 }
 619                 tagged_obj = (StgClosure *)new_pap;
 620                 Sp += m;
 621                 goto do_return;
 622             }
 623         }
 624
 625         case BCO: {
 626             nat arity, i;
 627
 628             Sp++;
 629             arity = ((StgBCO *)obj)->arity;
 630             ASSERT(arity > 0);
 631             if (arity < n) {
 632                 // n must be greater than 1, and the only kinds of
 633                 // application we support with more than one argument
 634                 // are all pointers...
 635                 //
 636                 // Shuffle the args for this function down, and put
 637                 // the appropriate info table in the gap.
 638                 for (i = 0; i < arity; i++) {
 639                     Sp[(int)i-1] = Sp[i];
 640                     // ^^^^^ careful, i-1 might be negative, but i in unsigned
 641                 }
 642                 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
 643                 Sp--;
 644                 goto run_BCO_fun;
 645             }
 646             else if (arity == n) {
 647                 goto run_BCO_fun;
 648             }
 649             else /* arity > n */ {
 650                 // build a PAP and return it.
 651                 StgPAP *pap;
 652                 nat i;
 653                 pap = (StgPAP *)allocate(cap, PAP_sizeW(m));
 654                 SET_HDR(pap, &stg_PAP_info,CCCS);
 655                 pap->arity = arity - n;
 656                 pap->fun = obj;
 657                 pap->n_args = m;
 658                 for (i = 0; i < m; i++) {
 659                     pap->payload[i] = (StgClosure *)Sp[i];
 660                 }
 661                 tagged_obj = (StgClosure *)pap;
 662                 Sp += m;
 663                 goto do_return;
 664             }
 665         }
 666
 667         // No point in us applying machine-code functions
 668         default:
 669         defer_apply_to_sched:
 670             Sp -= 2;
 671             Sp[1] = (W_)tagged_obj;
 672             Sp[0] = (W_)&stg_enter_info;
 673             RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
 674     }
 675
 676     // ------------------------------------------------------------------------
 677     // Ok, we now have a bco (obj), and its arguments are all on the
 678     // stack.  We can start executing the byte codes.
 679     //
 680     // The stack is in one of two states.  First, if this BCO is a
 681     // function:
 682     //
 683     //    |     ....      |
 684     //    +---------------+
 685     //    |     arg2      |
 686     //    +---------------+
 687     //    |     arg1      |
 688     //    +---------------+
 689     //
 690     // Second, if this BCO is a continuation:
 691     //
 692     //    |     ....      |
 693     //    +---------------+
 694     //    |     fv2       |
 695     //    +---------------+
 696     //    |     fv1       |
 697     //    +---------------+
 698     //    |     BCO       |
 699     //    +---------------+
 700     //    | stg_ctoi_ret_ |
 701     //    +---------------+
 702     //    |    retval     |
 703     //    +---------------+
 704     //
 705     // where retval is the value being returned to this continuation.
 706     // In the event of a stack check, heap check, or context switch,
 707     // we need to leave the stack in a sane state so the garbage
 708     // collector can find all the pointers.
 709     //
 710     //  (1) BCO is a function:  the BCO's bitmap describes the
 711     //      pointerhood of the arguments.
 712     //
 713     //  (2) BCO is a continuation: BCO's bitmap describes the
 714     //      pointerhood of the free variables.
 715     //
 716     // Sadly we have three different kinds of stack/heap/cswitch check
 717     // to do:
 718
 719
 720 run_BCO_return:
 721     // Heap check
 722     if (doYouWantToGC(cap)) {
 723         Sp--; Sp[0] = (W_)&stg_enter_info;
 724         RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
 725     }
 726     // Stack checks aren't necessary at return points, the stack use
 727     // is aggregated into the enclosing function entry point.
 728
 729     goto run_BCO;
 730
 731 run_BCO_return_unboxed:
 732     // Heap check
 733     if (doYouWantToGC(cap)) {
 734         RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
 735     }
 736     // Stack checks aren't necessary at return points, the stack use
 737     // is aggregated into the enclosing function entry point.
 738
 739     goto run_BCO;
 740
 741 run_BCO_fun:
 742     IF_DEBUG(sanity,
 743              Sp -= 2;
 744              Sp[1] = (W_)obj;
 745              Sp[0] = (W_)&stg_apply_interp_info;
 746              checkStackChunk(Sp,SpLim);
 747              Sp += 2;
 748         );
 749
 750     // Heap check
 751     if (doYouWantToGC(cap)) {
 752         Sp -= 2;
 753         Sp[1] = (W_)obj;
 754         Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
 755         RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
 756     }
 757
 758     // Stack check
 759     if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
 760         Sp -= 2;
 761         Sp[1] = (W_)obj;
 762         Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
 763         RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
 764     }
 765
 766     goto run_BCO;
 767
 768     // Now, actually interpret the BCO... (no returning to the
 769     // scheduler again until the stack is in an orderly state).
 770 run_BCO:
 771     INTERP_TICK(it_BCO_entries);
 772     {
 773         register int       bciPtr = 0; /* instruction pointer */
 774         register StgWord16 bci;
 775         register StgBCO*   bco        = (StgBCO*)obj;
 776         register StgWord16* instrs    = (StgWord16*)(bco->instrs->payload);
 777         register StgWord*  literals   = (StgWord*)(&bco->literals->payload[0]);
 778         register StgPtr*   ptrs       = (StgPtr*)(&bco->ptrs->payload[0]);
 779         int bcoSize;
 780     bcoSize = BCO_NEXT_WORD;
 781         IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
 782
 783 #ifdef INTERP_STATS
 784         it_lastopc = 0; /* no opcode */
 785 #endif
 786
 787     nextInsn:
 788         ASSERT(bciPtr < bcoSize);
 789         IF_DEBUG(interpreter,
 790                  //if (do_print_stack) {
 791                  //debugBelch("\n-- BEGIN stack\n");
 792                  //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
 793                  //debugBelch("-- END stack\n\n");
 794                  //}
 795                  debugBelch("Sp = %p   pc = %d      ", Sp, bciPtr);
 796                  disInstr(bco,bciPtr);
 797                  if (0) { int i;
 798                  debugBelch("\n");
 799                  for (i = 8; i >= 0; i--) {
 800                      debugBelch("%d  %p\n", i, (StgPtr)(*(Sp+i)));
 801                  }
 802                  debugBelch("\n");
 803                  }
 804                  //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
 805             );
 806
 807
 808         INTERP_TICK(it_insns);
 809
 810 #ifdef INTERP_STATS
 811         ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
 812         it_ofreq[ (int)instrs[bciPtr] ] ++;
 813         it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
 814         it_lastopc = (int)instrs[bciPtr];
 815 #endif
 816
 817         bci = BCO_NEXT;
 818     /* We use the high 8 bits for flags, only the highest of which is
 819      * currently allocated */
 820     ASSERT((bci & 0xFF00) == (bci & 0x8000));
 821
 822     switch (bci & 0xFF) {
 823
 824         /* check for a breakpoint on the beginning of a let binding */
 825         case bci_BRK_FUN:
 826         {
 827             int arg1_brk_array, arg2_array_index, arg3_freeVars;
 828             StgArrWords *breakPoints;
 829             int returning_from_break;     // are we resuming execution from a breakpoint?
 830                                           //  if yes, then don't break this time around
 831             StgClosure *ioAction;         // the io action to run at a breakpoint
 832
 833             StgAP_STACK *new_aps;         // a closure to save the top stack frame on the heap
 834             int i;
 835             int size_words;
 836
 837             arg1_brk_array      = BCO_NEXT;  // 1st arg of break instruction
 838             arg2_array_index    = BCO_NEXT;  // 2nd arg of break instruction
 839             arg3_freeVars       = BCO_NEXT;  // 3rd arg of break instruction
 840
 841             // check if we are returning from a breakpoint - this info
 842             // is stored in the flags field of the current TSO
 843             returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
 844
 845             // if we are returning from a break then skip this section
 846             // and continue executing
 847             if (!returning_from_break)
 848             {
 849                breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
 850
 851                // stop the current thread if either the
 852                // "rts_stop_next_breakpoint" flag is true OR if the
 853                // breakpoint flag for this particular expression is
 854                // true
 855                if (rts_stop_next_breakpoint == rtsTrue ||
 856                    breakPoints->payload[arg2_array_index] == rtsTrue)
 857                {
 858                   // make sure we don't automatically stop at the
 859                   // next breakpoint
 860                   rts_stop_next_breakpoint = rtsFalse;
 861
 862                   // allocate memory for a new AP_STACK, enough to
 863                   // store the top stack frame plus an
 864                   // stg_apply_interp_info pointer and a pointer to
 865                   // the BCO
 866                   size_words = BCO_BITMAP_SIZE(obj) + 2;
 867                   new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
 868                   SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
 869                   new_aps->size = size_words;
 870                   new_aps->fun = &stg_dummy_ret_closure;
 871
 872                   // fill in the payload of the AP_STACK
 873                   new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
 874                   new_aps->payload[1] = (StgClosure *)obj;
 875
 876                   // copy the contents of the top stack frame into the AP_STACK
 877                   for (i = 2; i < size_words; i++)
 878                   {
 879                      new_aps->payload[i] = (StgClosure *)Sp[i-2];
 880                   }
 881
 882                   // prepare the stack so that we can call the
 883                   // rts_breakpoint_io_action and ensure that the stack is
 884                   // in a reasonable state for the GC and so that
 885                   // execution of this BCO can continue when we resume
 886                   ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
 887                   Sp -= 8;
 888                   Sp[7] = (W_)obj;
 889                   Sp[6] = (W_)&stg_apply_interp_info;
 890                   Sp[5] = (W_)new_aps;                 // the AP_STACK
 891                   Sp[4] = (W_)BCO_PTR(arg3_freeVars);  // the info about local vars of the breakpoint
 892                   Sp[3] = (W_)False_closure;            // True <=> a breakpoint
 893                   Sp[2] = (W_)&stg_ap_pppv_info;
 894                   Sp[1] = (W_)ioAction;                // apply the IO action to its two arguments above
 895                   Sp[0] = (W_)&stg_enter_info;         // get ready to run the IO action
 896                   // set the flag in the TSO to say that we are now
 897                   // stopping at a breakpoint so that when we resume
 898                   // we don't stop on the same breakpoint that we
 899                   // already stopped at just now
 900                   cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
 901
 902                   // stop this thread and return to the scheduler -
 903                   // eventually we will come back and the IO action on
 904                   // the top of the stack will be executed
 905                   RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
 906                }
 907             }
 908             // record that this thread is not stopped at a breakpoint anymore
 909             cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
 910
 911             // continue normal execution of the byte code instructions
 912             goto nextInsn;
 913         }
 914
 915         case bci_STKCHECK: {
 916             // Explicit stack check at the beginning of a function
 917             // *only* (stack checks in case alternatives are
 918             // propagated to the enclosing function).
 919             StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
 920             if (Sp - stk_words_reqd < SpLim) {
 921                 Sp -= 2;
 922                 Sp[1] = (W_)obj;
 923                 Sp[0] = (W_)&stg_apply_interp_info;
 924                 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
 925             } else {
 926                 goto nextInsn;
 927             }
 928         }
 929
 930         case bci_PUSH_L: {
 931             int o1 = BCO_NEXT;
 932             Sp[-1] = Sp[o1];
 933             Sp--;
 934             goto nextInsn;
 935         }
 936
 937         case bci_PUSH_LL: {
 938             int o1 = BCO_NEXT;
 939             int o2 = BCO_NEXT;
 940             Sp[-1] = Sp[o1];
 941             Sp[-2] = Sp[o2];
 942             Sp -= 2;
 943             goto nextInsn;
 944         }
 945
 946         case bci_PUSH_LLL: {
 947             int o1 = BCO_NEXT;
 948             int o2 = BCO_NEXT;
 949             int o3 = BCO_NEXT;
 950             Sp[-1] = Sp[o1];
 951             Sp[-2] = Sp[o2];
 952             Sp[-3] = Sp[o3];
 953             Sp -= 3;
 954             goto nextInsn;
 955         }
 956
 957         case bci_PUSH_G: {
 958             int o1 = BCO_NEXT;
 959             Sp[-1] = BCO_PTR(o1);
 960             Sp -= 1;
 961             goto nextInsn;
 962         }
 963
 964         case bci_PUSH_ALTS: {
 965             int o_bco  = BCO_NEXT;
 966             Sp[-2] = (W_)&stg_ctoi_R1p_info;
 967             Sp[-1] = BCO_PTR(o_bco);
 968             Sp -= 2;
 969             goto nextInsn;
 970         }
 971
 972         case bci_PUSH_ALTS_P: {
 973             int o_bco  = BCO_NEXT;
 974             Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
 975             Sp[-1] = BCO_PTR(o_bco);
 976             Sp -= 2;
 977             goto nextInsn;
 978         }
 979
 980         case bci_PUSH_ALTS_N: {
 981             int o_bco  = BCO_NEXT;
 982             Sp[-2] = (W_)&stg_ctoi_R1n_info;
 983             Sp[-1] = BCO_PTR(o_bco);
 984             Sp -= 2;
 985             goto nextInsn;
 986         }
 987
 988         case bci_PUSH_ALTS_F: {
 989             int o_bco  = BCO_NEXT;
 990             Sp[-2] = (W_)&stg_ctoi_F1_info;
 991             Sp[-1] = BCO_PTR(o_bco);
 992             Sp -= 2;
 993             goto nextInsn;
 994         }
 995
 996         case bci_PUSH_ALTS_D: {
 997             int o_bco  = BCO_NEXT;
 998             Sp[-2] = (W_)&stg_ctoi_D1_info;
 999             Sp[-1] = BCO_PTR(o_bco);
1000             Sp -= 2;
1001             goto nextInsn;
1002         }
1003
1004         case bci_PUSH_ALTS_L: {
1005             int o_bco  = BCO_NEXT;
1006             Sp[-2] = (W_)&stg_ctoi_L1_info;
1007             Sp[-1] = BCO_PTR(o_bco);
1008             Sp -= 2;
1009             goto nextInsn;
1010         }
1011
1012         case bci_PUSH_ALTS_V: {
1013             int o_bco  = BCO_NEXT;
1014             Sp[-2] = (W_)&stg_ctoi_V_info;
1015             Sp[-1] = BCO_PTR(o_bco);
1016             Sp -= 2;
1017             goto nextInsn;
1018         }
1019
1020         case bci_PUSH_APPLY_N:
1021             Sp--; Sp[0] = (W_)&stg_ap_n_info;
1022             goto nextInsn;
1023         case bci_PUSH_APPLY_V:
1024             Sp--; Sp[0] = (W_)&stg_ap_v_info;
1025             goto nextInsn;
1026         case bci_PUSH_APPLY_F:
1027             Sp--; Sp[0] = (W_)&stg_ap_f_info;
1028             goto nextInsn;
1029         case bci_PUSH_APPLY_D:
1030             Sp--; Sp[0] = (W_)&stg_ap_d_info;
1031             goto nextInsn;
1032         case bci_PUSH_APPLY_L:
1033             Sp--; Sp[0] = (W_)&stg_ap_l_info;
1034             goto nextInsn;
1035         case bci_PUSH_APPLY_P:
1036             Sp--; Sp[0] = (W_)&stg_ap_p_info;
1037             goto nextInsn;
1038         case bci_PUSH_APPLY_PP:
1039             Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1040             goto nextInsn;
1041         case bci_PUSH_APPLY_PPP:
1042             Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1043             goto nextInsn;
1044         case bci_PUSH_APPLY_PPPP:
1045             Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1046             goto nextInsn;
1047         case bci_PUSH_APPLY_PPPPP:
1048             Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1049             goto nextInsn;
1050         case bci_PUSH_APPLY_PPPPPP:
1051             Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1052             goto nextInsn;
1053
1054         case bci_PUSH_UBX: {
1055             int i;
1056             int o_lits = BCO_NEXT;
1057             int n_words = BCO_NEXT;
1058             Sp -= n_words;
1059             for (i = 0; i < n_words; i++) {
1060                 Sp[i] = (W_)BCO_LIT(o_lits+i);
1061             }
1062             goto nextInsn;
1063         }
1064
1065         case bci_SLIDE: {
1066             int n  = BCO_NEXT;
1067             int by = BCO_NEXT;
1068             /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1069             while(--n >= 0) {
1070                 Sp[n+by] = Sp[n];
1071             }
1072             Sp += by;
1073             INTERP_TICK(it_slides);
1074             goto nextInsn;
1075         }
1076
1077         case bci_ALLOC_AP: {
1078             StgAP* ap;
1079             int n_payload = BCO_NEXT;
1080             ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1081             Sp[-1] = (W_)ap;
1082             ap->n_args = n_payload;
1083             SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
1084             Sp --;
1085             goto nextInsn;
1086         }
1087
1088         case bci_ALLOC_AP_NOUPD: {
1089             StgAP* ap;
1090             int n_payload = BCO_NEXT;
1091             ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1092             Sp[-1] = (W_)ap;
1093             ap->n_args = n_payload;
1094             SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
1095             Sp --;
1096             goto nextInsn;
1097         }
1098
1099         case bci_ALLOC_PAP: {
1100             StgPAP* pap;
1101             int arity = BCO_NEXT;
1102             int n_payload = BCO_NEXT;
1103             pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload));
1104             Sp[-1] = (W_)pap;
1105             pap->n_args = n_payload;
1106             pap->arity = arity;
1107             SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
1108             Sp --;
1109             goto nextInsn;
1110         }
1111
1112         case bci_MKAP: {
1113             int i;
1114             int stkoff = BCO_NEXT;
1115             int n_payload = BCO_NEXT;
1116             StgAP* ap = (StgAP*)Sp[stkoff];
1117             ASSERT((int)ap->n_args == n_payload);
1118             ap->fun = (StgClosure*)Sp[0];
1119
1120             // The function should be a BCO, and its bitmap should
1121             // cover the payload of the AP correctly.
1122             ASSERT(get_itbl(ap->fun)->type == BCO
1123                    && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1124
1125             for (i = 0; i < n_payload; i++)
1126                 ap->payload[i] = (StgClosure*)Sp[i+1];
1127             Sp += n_payload+1;
1128             IF_DEBUG(interpreter,
1129                      debugBelch("\tBuilt ");
1130                      printObj((StgClosure*)ap);
1131                 );
1132             goto nextInsn;
1133         }
1134
1135         case bci_MKPAP: {
1136             int i;
1137             int stkoff = BCO_NEXT;
1138             int n_payload = BCO_NEXT;
1139             StgPAP* pap = (StgPAP*)Sp[stkoff];
1140             ASSERT((int)pap->n_args == n_payload);
1141             pap->fun = (StgClosure*)Sp[0];
1142
1143             // The function should be a BCO
1144             ASSERT(get_itbl(pap->fun)->type == BCO);
1145
1146             for (i = 0; i < n_payload; i++)
1147                 pap->payload[i] = (StgClosure*)Sp[i+1];
1148             Sp += n_payload+1;
1149             IF_DEBUG(interpreter,
1150                      debugBelch("\tBuilt ");
1151                      printObj((StgClosure*)pap);
1152                 );
1153             goto nextInsn;
1154         }
1155
1156         case bci_UNPACK: {
1157             /* Unpack N ptr words from t.o.s constructor */
1158             int i;
1159             int n_words = BCO_NEXT;
1160             StgClosure* con = (StgClosure*)Sp[0];
1161             Sp -= n_words;
1162             for (i = 0; i < n_words; i++) {
1163                 Sp[i] = (W_)con->payload[i];
1164             }
1165             goto nextInsn;
1166         }
1167
1168         case bci_PACK: {
1169             int i;
1170             int o_itbl         = BCO_NEXT;
1171             int n_words        = BCO_NEXT;
1172             StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
1173             int request        = CONSTR_sizeW( itbl->layout.payload.ptrs,
1174                                                itbl->layout.payload.nptrs );
1175             StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
1176             ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1177             SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
1178             for (i = 0; i < n_words; i++) {
1179                 con->payload[i] = (StgClosure*)Sp[i];
1180             }
1181             Sp += n_words;
1182             Sp --;
1183             Sp[0] = (W_)con;
1184             IF_DEBUG(interpreter,
1185                      debugBelch("\tBuilt ");
1186                      printObj((StgClosure*)con);
1187                 );
1188             goto nextInsn;
1189         }
1190
1191         case bci_TESTLT_P: {
1192             unsigned int discr  = BCO_NEXT;
1193             int failto = BCO_GET_LARGE_ARG;
1194             StgClosure* con = (StgClosure*)Sp[0];
1195             if (GET_TAG(con) >= discr) {
1196                 bciPtr = failto;
1197             }
1198             goto nextInsn;
1199         }
1200
1201         case bci_TESTEQ_P: {
1202             unsigned int discr  = BCO_NEXT;
1203             int failto = BCO_GET_LARGE_ARG;
1204             StgClosure* con = (StgClosure*)Sp[0];
1205             if (GET_TAG(con) != discr) {
1206                 bciPtr = failto;
1207             }
1208             goto nextInsn;
1209         }
1210
1211         case bci_TESTLT_I: {
1212             // There should be an Int at Sp[1], and an info table at Sp[0].
1213             int discr   = BCO_NEXT;
1214             int failto  = BCO_GET_LARGE_ARG;
1215             I_ stackInt = (I_)Sp[1];
1216             if (stackInt >= (I_)BCO_LIT(discr))
1217                 bciPtr = failto;
1218             goto nextInsn;
1219         }
1220
1221         case bci_TESTEQ_I: {
1222             // There should be an Int at Sp[1], and an info table at Sp[0].
1223             int discr   = BCO_NEXT;
1224             int failto  = BCO_GET_LARGE_ARG;
1225             I_ stackInt = (I_)Sp[1];
1226             if (stackInt != (I_)BCO_LIT(discr)) {
1227                 bciPtr = failto;
1228             }
1229             goto nextInsn;
1230         }
1231
1232         case bci_TESTLT_W: {
1233             // There should be an Int at Sp[1], and an info table at Sp[0].
1234             int discr   = BCO_NEXT;
1235             int failto  = BCO_GET_LARGE_ARG;
1236             W_ stackWord = (W_)Sp[1];
1237             if (stackWord >= (W_)BCO_LIT(discr))
1238                 bciPtr = failto;
1239             goto nextInsn;
1240         }
1241
1242         case bci_TESTEQ_W: {
1243             // There should be an Int at Sp[1], and an info table at Sp[0].
1244             int discr   = BCO_NEXT;
1245             int failto  = BCO_GET_LARGE_ARG;
1246             W_ stackWord = (W_)Sp[1];
1247             if (stackWord != (W_)BCO_LIT(discr)) {
1248                 bciPtr = failto;
1249             }
1250             goto nextInsn;
1251         }
1252
1253         case bci_TESTLT_D: {
1254             // There should be a Double at Sp[1], and an info table at Sp[0].
1255             int discr   = BCO_NEXT;
1256             int failto  = BCO_GET_LARGE_ARG;
1257             StgDouble stackDbl, discrDbl;
1258             stackDbl = PK_DBL( & Sp[1] );
1259             discrDbl = PK_DBL( & BCO_LIT(discr) );
1260             if (stackDbl >= discrDbl) {
1261                 bciPtr = failto;
1262             }
1263             goto nextInsn;
1264         }
1265
1266         case bci_TESTEQ_D: {
1267             // There should be a Double at Sp[1], and an info table at Sp[0].
1268             int discr   = BCO_NEXT;
1269             int failto  = BCO_GET_LARGE_ARG;
1270             StgDouble stackDbl, discrDbl;
1271             stackDbl = PK_DBL( & Sp[1] );
1272             discrDbl = PK_DBL( & BCO_LIT(discr) );
1273             if (stackDbl != discrDbl) {
1274                 bciPtr = failto;
1275             }
1276             goto nextInsn;
1277         }
1278
1279         case bci_TESTLT_F: {
1280             // There should be a Float at Sp[1], and an info table at Sp[0].
1281             int discr   = BCO_NEXT;
1282             int failto  = BCO_GET_LARGE_ARG;
1283             StgFloat stackFlt, discrFlt;
1284             stackFlt = PK_FLT( & Sp[1] );
1285             discrFlt = PK_FLT( & BCO_LIT(discr) );
1286             if (stackFlt >= discrFlt) {
1287                 bciPtr = failto;
1288             }
1289             goto nextInsn;
1290         }
1291
1292         case bci_TESTEQ_F: {
1293             // There should be a Float at Sp[1], and an info table at Sp[0].
1294             int discr   = BCO_NEXT;
1295             int failto  = BCO_GET_LARGE_ARG;
1296             StgFloat stackFlt, discrFlt;
1297             stackFlt = PK_FLT( & Sp[1] );
1298             discrFlt = PK_FLT( & BCO_LIT(discr) );
1299             if (stackFlt != discrFlt) {
1300                 bciPtr = failto;
1301             }
1302             goto nextInsn;
1303         }
1304
1305         // Control-flow ish things
1306         case bci_ENTER:
1307             // Context-switch check.  We put it here to ensure that
1308             // the interpreter has done at least *some* work before
1309             // context switching: sometimes the scheduler can invoke
1310             // the interpreter with context_switch == 1, particularly
1311             // if the -C0 flag has been given on the cmd line.
1312             if (cap->r.rHpLim == NULL) {
1313                 Sp--; Sp[0] = (W_)&stg_enter_info;
1314                 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1315             }
1316             goto eval;
1317
1318         case bci_RETURN:
1319             tagged_obj = (StgClosure *)Sp[0];
1320             Sp++;
1321             goto do_return;
1322
1323         case bci_RETURN_P:
1324             Sp--;
1325             Sp[0] = (W_)&stg_gc_unpt_r1_info;
1326             goto do_return_unboxed;
1327         case bci_RETURN_N:
1328             Sp--;
1329             Sp[0] = (W_)&stg_gc_unbx_r1_info;
1330             goto do_return_unboxed;
1331         case bci_RETURN_F:
1332             Sp--;
1333             Sp[0] = (W_)&stg_gc_f1_info;
1334             goto do_return_unboxed;
1335         case bci_RETURN_D:
1336             Sp--;
1337             Sp[0] = (W_)&stg_gc_d1_info;
1338             goto do_return_unboxed;
1339         case bci_RETURN_L:
1340             Sp--;
1341             Sp[0] = (W_)&stg_gc_l1_info;
1342             goto do_return_unboxed;
1343         case bci_RETURN_V:
1344             Sp--;
1345             Sp[0] = (W_)&stg_gc_void_info;
1346             goto do_return_unboxed;
1347
1348         case bci_SWIZZLE: {
1349             int stkoff = BCO_NEXT;
1350             signed short n = (signed short)(BCO_NEXT);
1351             Sp[stkoff] += (W_)n;
1352             goto nextInsn;
1353         }
1354
1355         case bci_CCALL: {
1356             void *tok;
1357             int stk_offset            = BCO_NEXT;
1358             int o_itbl                = BCO_NEXT;
1359             void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1360             int ret_dyn_size =
1361                 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1362                 + sizeofW(StgRetDyn);
1363
1364             /* the stack looks like this:
1365
1366                |             |  <- Sp + stk_offset
1367                +-------------+
1368                |             |
1369                |    args     |
1370                |             |  <- Sp + ret_size + 1
1371                +-------------+
1372                |    C fun    |  <- Sp + ret_size
1373                +-------------+
1374                |     ret     |  <- Sp
1375                +-------------+
1376
1377                ret is a placeholder for the return address, and may be
1378                up to 2 words.
1379
1380                We need to copy the args out of the TSO, because when
1381                we call suspendThread() we no longer own the TSO stack,
1382                and it may move at any time - indeed suspendThread()
1383                itself may do stack squeezing and move our args.
1384                So we make a copy of the argument block.
1385             */
1386
1387 #define ROUND_UP_WDS(p)  ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1388
1389             ffi_cif *cif = (ffi_cif *)marshall_fn;
1390             nat nargs = cif->nargs;
1391             nat ret_size;
1392             nat i;
1393             StgPtr p;
1394             W_ ret[2];                  // max needed
1395             W_ *arguments[stk_offset];  // max needed
1396             void *argptrs[nargs];
1397             void (*fn)(void);
1398
1399             if (cif->rtype->type == FFI_TYPE_VOID) {
1400                 // necessary because cif->rtype->size == 1 for void,
1401                 // but the bytecode generator has not pushed a
1402                 // placeholder in this case.
1403                 ret_size = 0;
1404             } else {
1405                 ret_size = ROUND_UP_WDS(cif->rtype->size);
1406             }
1407
1408             memcpy(arguments, Sp+ret_size+1,
1409                    sizeof(W_) * (stk_offset-1-ret_size));
1410
1411             // libffi expects the args as an array of pointers to
1412             // values, so we have to construct this array before making
1413             // the call.
1414             p = (StgPtr)arguments;
1415             for (i = 0; i < nargs; i++) {
1416                 argptrs[i] = (void *)p;
1417                 // get the size from the cif
1418                 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1419             }
1420
1421             // this is the function we're going to call
1422             fn = (void(*)(void))Sp[ret_size];
1423
1424             // Restore the Haskell thread's current value of errno
1425             errno = cap->r.rCurrentTSO->saved_errno;
1426
1427             // There are a bunch of non-ptr words on the stack (the
1428             // ccall args, the ccall fun address and space for the
1429             // result), which we need to cover with an info table
1430             // since we might GC during this call.
1431             //
1432             // We know how many (non-ptr) words there are before the
1433             // next valid stack frame: it is the stk_offset arg to the
1434             // CCALL instruction.   So we build a RET_DYN stack frame
1435             // on the stack frame to describe this chunk of stack.
1436             //
1437             Sp -= ret_dyn_size;
1438             ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset);
1439             ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1440
1441             // save obj (pointer to the current BCO), since this
1442             // might move during the call.  We use the R1 slot in the
1443             // RET_DYN frame for this, hence R1_PTR above.
1444             ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
1445
1446             SAVE_STACK_POINTERS;
1447             tok = suspendThread(&cap->r);
1448
1449             // We already made a copy of the arguments above.
1450             ffi_call(cif, fn, ret, argptrs);
1451
1452             // And restart the thread again, popping the RET_DYN frame.
1453             cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
1454             LOAD_STACK_POINTERS;
1455
1456             // Re-load the pointer to the BCO from the RET_DYN frame,
1457             // it might have moved during the call.  Also reload the
1458             // pointers to the components of the BCO.
1459             obj        = ((StgRetDyn *)Sp)->payload[0];
1460             bco        = (StgBCO*)obj;
1461             instrs     = (StgWord16*)(bco->instrs->payload);
1462             literals   = (StgWord*)(&bco->literals->payload[0]);
1463             ptrs       = (StgPtr*)(&bco->ptrs->payload[0]);
1464
1465             Sp += ret_dyn_size;
1466
1467             // Save the Haskell thread's current value of errno
1468             cap->r.rCurrentTSO->saved_errno = errno;
1469
1470             // Copy the return value back to the TSO stack.  It is at
1471             // most 2 words large, and resides at arguments[0].
1472             memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1473
1474             goto nextInsn;
1475         }
1476
1477         case bci_JMP: {
1478             /* BCO_NEXT modifies bciPtr, so be conservative. */
1479             int nextpc = BCO_GET_LARGE_ARG;
1480             bciPtr     = nextpc;
1481             goto nextInsn;
1482         }
1483
1484         case bci_CASEFAIL:
1485             barf("interpretBCO: hit a CASEFAIL");
1486
1487             // Errors
1488         default:
1489             barf("interpretBCO: unknown or unimplemented opcode %d",
1490                  (int)(bci & 0xFF));
1491
1492         } /* switch on opcode */
1493     }
1494     }
1495
1496     barf("interpretBCO: fell off end of the interpreter");
1497 }