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