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