rts/Interpreter.c

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