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