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 = 0; /* 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         int bcoSize;
 773     bcoSize = BCO_NEXT_WORD;
 774         IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
 775
 776 #ifdef INTERP_STATS
 777         it_lastopc = 0; /* no opcode */
 778 #endif
 779
 780     nextInsn:
 781         ASSERT(bciPtr < bcoSize);
 782         IF_DEBUG(interpreter,
 783                  //if (do_print_stack) {
 784                  //debugBelch("\n-- BEGIN stack\n");
 785                  //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
 786                  //debugBelch("-- END stack\n\n");
 787                  //}
 788                  debugBelch("Sp = %p   pc = %d      ", Sp, bciPtr);
 789                  disInstr(bco,bciPtr);
 790                  if (0) { int i;
 791                  debugBelch("\n");
 792                  for (i = 8; i >= 0; i--) {
 793                      debugBelch("%d  %p\n", i, (StgPtr)(*(Sp+i)));
 794                  }
 795                  debugBelch("\n");
 796                  }
 797                  //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
 798             );
 799
 800
 801         INTERP_TICK(it_insns);
 802
 803 #ifdef INTERP_STATS
 804         ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
 805         it_ofreq[ (int)instrs[bciPtr] ] ++;
 806         it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
 807         it_lastopc = (int)instrs[bciPtr];
 808 #endif
 809
 810         bci = BCO_NEXT;
 811     /* We use the high 8 bits for flags, only the highest of which is
 812      * currently allocated */
 813     ASSERT((bci & 0xFF00) == (bci & 0x8000));
 814
 815     switch (bci & 0xFF) {
 816
 817         /* check for a breakpoint on the beginning of a let binding */
 818         case bci_BRK_FUN:
 819         {
 820             int arg1_brk_array, arg2_array_index, arg3_freeVars;
 821             StgArrWords *breakPoints;
 822             int returning_from_break;     // are we resuming execution from a breakpoint?
 823                                           //  if yes, then don't break this time around
 824             StgClosure *ioAction;         // the io action to run at a breakpoint
 825
 826             StgAP_STACK *new_aps;         // a closure to save the top stack frame on the heap
 827             int i;
 828             int size_words;
 829
 830             arg1_brk_array      = BCO_NEXT;  // 1st arg of break instruction
 831             arg2_array_index    = BCO_NEXT;  // 2nd arg of break instruction
 832             arg3_freeVars       = BCO_NEXT;  // 3rd arg of break instruction
 833
 834             // check if we are returning from a breakpoint - this info
 835             // is stored in the flags field of the current TSO
 836             returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
 837
 838             // if we are returning from a break then skip this section
 839             // and continue executing
 840             if (!returning_from_break)
 841             {
 842                breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
 843
 844                // stop the current thread if either the
 845                // "rts_stop_next_breakpoint" flag is true OR if the
 846                // breakpoint flag for this particular expression is
 847                // true
 848                if (rts_stop_next_breakpoint == rtsTrue ||
 849                    breakPoints->payload[arg2_array_index] == rtsTrue)
 850                {
 851                   // make sure we don't automatically stop at the
 852                   // next breakpoint
 853                   rts_stop_next_breakpoint = rtsFalse;
 854
 855                   // allocate memory for a new AP_STACK, enough to
 856                   // store the top stack frame plus an
 857                   // stg_apply_interp_info pointer and a pointer to
 858                   // the BCO
 859                   size_words = BCO_BITMAP_SIZE(obj) + 2;
 860                   new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words));
 861                   SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
 862                   new_aps->size = size_words;
 863                   new_aps->fun = &stg_dummy_ret_closure;
 864
 865                   // fill in the payload of the AP_STACK
 866                   new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
 867                   new_aps->payload[1] = (StgClosure *)obj;
 868
 869                   // copy the contents of the top stack frame into the AP_STACK
 870                   for (i = 2; i < size_words; i++)
 871                   {
 872                      new_aps->payload[i] = (StgClosure *)Sp[i-2];
 873                   }
 874
 875                   // prepare the stack so that we can call the
 876                   // rts_breakpoint_io_action and ensure that the stack is
 877                   // in a reasonable state for the GC and so that
 878                   // execution of this BCO can continue when we resume
 879                   ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
 880                   Sp -= 9;
 881                   Sp[8] = (W_)obj;
 882                   Sp[7] = (W_)&stg_apply_interp_info;
 883                   Sp[6] = (W_)&stg_noforceIO_info;     // see [unreg] below
 884                   Sp[5] = (W_)new_aps;                 // the AP_STACK
 885                   Sp[4] = (W_)BCO_PTR(arg3_freeVars);  // the info about local vars of the breakpoint
 886                   Sp[3] = (W_)False_closure;            // True <=> a breakpoint
 887                   Sp[2] = (W_)&stg_ap_pppv_info;
 888                   Sp[1] = (W_)ioAction;                // apply the IO action to its two arguments above
 889                   Sp[0] = (W_)&stg_enter_info;         // get ready to run the IO action
 890                   // Note [unreg]: in unregisterised mode, the return
 891                   // convention for IO is different.  The
 892                   // stg_noForceIO_info stack frame is necessary to
 893                   // account for this difference.
 894
 895                   // set the flag in the TSO to say that we are now
 896                   // stopping at a breakpoint so that when we resume
 897                   // we don't stop on the same breakpoint that we
 898                   // already stopped at just now
 899                   cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
 900
 901                   // stop this thread and return to the scheduler -
 902                   // eventually we will come back and the IO action on
 903                   // the top of the stack will be executed
 904                   RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
 905                }
 906             }
 907             // record that this thread is not stopped at a breakpoint anymore
 908             cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
 909
 910             // continue normal execution of the byte code instructions
 911             goto nextInsn;
 912         }
 913
 914         case bci_STKCHECK: {
 915             // Explicit stack check at the beginning of a function
 916             // *only* (stack checks in case alternatives are
 917             // propagated to the enclosing function).
 918             StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
 919             if (Sp - stk_words_reqd < SpLim) {
 920                 Sp -= 2;
 921                 Sp[1] = (W_)obj;
 922                 Sp[0] = (W_)&stg_apply_interp_info;
 923                 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
 924             } else {
 925                 goto nextInsn;
 926             }
 927         }
 928
 929         case bci_PUSH_L: {
 930             int o1 = BCO_NEXT;
 931             Sp[-1] = Sp[o1];
 932             Sp--;
 933             goto nextInsn;
 934         }
 935
 936         case bci_PUSH_LL: {
 937             int o1 = BCO_NEXT;
 938             int o2 = BCO_NEXT;
 939             Sp[-1] = Sp[o1];
 940             Sp[-2] = Sp[o2];
 941             Sp -= 2;
 942             goto nextInsn;
 943         }
 944
 945         case bci_PUSH_LLL: {
 946             int o1 = BCO_NEXT;
 947             int o2 = BCO_NEXT;
 948             int o3 = BCO_NEXT;
 949             Sp[-1] = Sp[o1];
 950             Sp[-2] = Sp[o2];
 951             Sp[-3] = Sp[o3];
 952             Sp -= 3;
 953             goto nextInsn;
 954         }
 955
 956         case bci_PUSH_G: {
 957             int o1 = BCO_NEXT;
 958             Sp[-1] = BCO_PTR(o1);
 959             Sp -= 1;
 960             goto nextInsn;
 961         }
 962
 963         case bci_PUSH_ALTS: {
 964             int o_bco  = BCO_NEXT;
 965             Sp[-2] = (W_)&stg_ctoi_R1p_info;
 966             Sp[-1] = BCO_PTR(o_bco);
 967             Sp -= 2;
 968             goto nextInsn;
 969         }
 970
 971         case bci_PUSH_ALTS_P: {
 972             int o_bco  = BCO_NEXT;
 973             Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
 974             Sp[-1] = BCO_PTR(o_bco);
 975             Sp -= 2;
 976             goto nextInsn;
 977         }
 978
 979         case bci_PUSH_ALTS_N: {
 980             int o_bco  = BCO_NEXT;
 981             Sp[-2] = (W_)&stg_ctoi_R1n_info;
 982             Sp[-1] = BCO_PTR(o_bco);
 983             Sp -= 2;
 984             goto nextInsn;
 985         }
 986
 987         case bci_PUSH_ALTS_F: {
 988             int o_bco  = BCO_NEXT;
 989             Sp[-2] = (W_)&stg_ctoi_F1_info;
 990             Sp[-1] = BCO_PTR(o_bco);
 991             Sp -= 2;
 992             goto nextInsn;
 993         }
 994
 995         case bci_PUSH_ALTS_D: {
 996             int o_bco  = BCO_NEXT;
 997             Sp[-2] = (W_)&stg_ctoi_D1_info;
 998             Sp[-1] = BCO_PTR(o_bco);
 999             Sp -= 2;
1000             goto nextInsn;
1001         }
1002
1003         case bci_PUSH_ALTS_L: {
1004             int o_bco  = BCO_NEXT;
1005             Sp[-2] = (W_)&stg_ctoi_L1_info;
1006             Sp[-1] = BCO_PTR(o_bco);
1007             Sp -= 2;
1008             goto nextInsn;
1009         }
1010
1011         case bci_PUSH_ALTS_V: {
1012             int o_bco  = BCO_NEXT;
1013             Sp[-2] = (W_)&stg_ctoi_V_info;
1014             Sp[-1] = BCO_PTR(o_bco);
1015             Sp -= 2;
1016             goto nextInsn;
1017         }
1018
1019         case bci_PUSH_APPLY_N:
1020             Sp--; Sp[0] = (W_)&stg_ap_n_info;
1021             goto nextInsn;
1022         case bci_PUSH_APPLY_V:
1023             Sp--; Sp[0] = (W_)&stg_ap_v_info;
1024             goto nextInsn;
1025         case bci_PUSH_APPLY_F:
1026             Sp--; Sp[0] = (W_)&stg_ap_f_info;
1027             goto nextInsn;
1028         case bci_PUSH_APPLY_D:
1029             Sp--; Sp[0] = (W_)&stg_ap_d_info;
1030             goto nextInsn;
1031         case bci_PUSH_APPLY_L:
1032             Sp--; Sp[0] = (W_)&stg_ap_l_info;
1033             goto nextInsn;
1034         case bci_PUSH_APPLY_P:
1035             Sp--; Sp[0] = (W_)&stg_ap_p_info;
1036             goto nextInsn;
1037         case bci_PUSH_APPLY_PP:
1038             Sp--; Sp[0] = (W_)&stg_ap_pp_info;
1039             goto nextInsn;
1040         case bci_PUSH_APPLY_PPP:
1041             Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
1042             goto nextInsn;
1043         case bci_PUSH_APPLY_PPPP:
1044             Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
1045             goto nextInsn;
1046         case bci_PUSH_APPLY_PPPPP:
1047             Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
1048             goto nextInsn;
1049         case bci_PUSH_APPLY_PPPPPP:
1050             Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
1051             goto nextInsn;
1052
1053         case bci_PUSH_UBX: {
1054             int i;
1055             int o_lits = BCO_NEXT;
1056             int n_words = BCO_NEXT;
1057             Sp -= n_words;
1058             for (i = 0; i < n_words; i++) {
1059                 Sp[i] = (W_)BCO_LIT(o_lits+i);
1060             }
1061             goto nextInsn;
1062         }
1063
1064         case bci_SLIDE: {
1065             int n  = BCO_NEXT;
1066             int by = BCO_NEXT;
1067             /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
1068             while(--n >= 0) {
1069                 Sp[n+by] = Sp[n];
1070             }
1071             Sp += by;
1072             INTERP_TICK(it_slides);
1073             goto nextInsn;
1074         }
1075
1076         case bci_ALLOC_AP: {
1077             StgAP* ap;
1078             int n_payload = BCO_NEXT;
1079             ap = (StgAP*)allocate(AP_sizeW(n_payload));
1080             Sp[-1] = (W_)ap;
1081             ap->n_args = n_payload;
1082             SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
1083             Sp --;
1084             goto nextInsn;
1085         }
1086
1087         case bci_ALLOC_AP_NOUPD: {
1088             StgAP* ap;
1089             int n_payload = BCO_NEXT;
1090             ap = (StgAP*)allocate(AP_sizeW(n_payload));
1091             Sp[-1] = (W_)ap;
1092             ap->n_args = n_payload;
1093             SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
1094             Sp --;
1095             goto nextInsn;
1096         }
1097
1098         case bci_ALLOC_PAP: {
1099             StgPAP* pap;
1100             int arity = BCO_NEXT;
1101             int n_payload = BCO_NEXT;
1102             pap = (StgPAP*)allocate(PAP_sizeW(n_payload));
1103             Sp[-1] = (W_)pap;
1104             pap->n_args = n_payload;
1105             pap->arity = arity;
1106             SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
1107             Sp --;
1108             goto nextInsn;
1109         }
1110
1111         case bci_MKAP: {
1112             int i;
1113             int stkoff = BCO_NEXT;
1114             int n_payload = BCO_NEXT;
1115             StgAP* ap = (StgAP*)Sp[stkoff];
1116             ASSERT((int)ap->n_args == n_payload);
1117             ap->fun = (StgClosure*)Sp[0];
1118
1119             // The function should be a BCO, and its bitmap should
1120             // cover the payload of the AP correctly.
1121             ASSERT(get_itbl(ap->fun)->type == BCO
1122                    && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
1123
1124             for (i = 0; i < n_payload; i++)
1125                 ap->payload[i] = (StgClosure*)Sp[i+1];
1126             Sp += n_payload+1;
1127             IF_DEBUG(interpreter,
1128                      debugBelch("\tBuilt ");
1129                      printObj((StgClosure*)ap);
1130                 );
1131             goto nextInsn;
1132         }
1133
1134         case bci_MKPAP: {
1135             int i;
1136             int stkoff = BCO_NEXT;
1137             int n_payload = BCO_NEXT;
1138             StgPAP* pap = (StgPAP*)Sp[stkoff];
1139             ASSERT((int)pap->n_args == n_payload);
1140             pap->fun = (StgClosure*)Sp[0];
1141
1142             // The function should be a BCO
1143             ASSERT(get_itbl(pap->fun)->type == BCO);
1144
1145             for (i = 0; i < n_payload; i++)
1146                 pap->payload[i] = (StgClosure*)Sp[i+1];
1147             Sp += n_payload+1;
1148             IF_DEBUG(interpreter,
1149                      debugBelch("\tBuilt ");
1150                      printObj((StgClosure*)pap);
1151                 );
1152             goto nextInsn;
1153         }
1154
1155         case bci_UNPACK: {
1156             /* Unpack N ptr words from t.o.s constructor */
1157             int i;
1158             int n_words = BCO_NEXT;
1159             StgClosure* con = (StgClosure*)Sp[0];
1160             Sp -= n_words;
1161             for (i = 0; i < n_words; i++) {
1162                 Sp[i] = (W_)con->payload[i];
1163             }
1164             goto nextInsn;
1165         }
1166
1167         case bci_PACK: {
1168             int i;
1169             int o_itbl         = BCO_NEXT;
1170             int n_words        = BCO_NEXT;
1171             StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
1172             int request        = CONSTR_sizeW( itbl->layout.payload.ptrs,
1173                                                itbl->layout.payload.nptrs );
1174             StgClosure* con = (StgClosure*)allocate_NONUPD(request);
1175             ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
1176             SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
1177             for (i = 0; i < n_words; i++) {
1178                 con->payload[i] = (StgClosure*)Sp[i];
1179             }
1180             Sp += n_words;
1181             Sp --;
1182             Sp[0] = (W_)con;
1183             IF_DEBUG(interpreter,
1184                      debugBelch("\tBuilt ");
1185                      printObj((StgClosure*)con);
1186                 );
1187             goto nextInsn;
1188         }
1189
1190         case bci_TESTLT_P: {
1191             unsigned int discr  = BCO_NEXT;
1192             int failto = BCO_GET_LARGE_ARG;
1193             StgClosure* con = (StgClosure*)Sp[0];
1194             if (GET_TAG(con) >= discr) {
1195                 bciPtr = failto;
1196             }
1197             goto nextInsn;
1198         }
1199
1200         case bci_TESTEQ_P: {
1201             unsigned int discr  = BCO_NEXT;
1202             int failto = BCO_GET_LARGE_ARG;
1203             StgClosure* con = (StgClosure*)Sp[0];
1204             if (GET_TAG(con) != discr) {
1205                 bciPtr = failto;
1206             }
1207             goto nextInsn;
1208         }
1209
1210         case bci_TESTLT_I: {
1211             // There should be an Int at Sp[1], and an info table at Sp[0].
1212             int discr   = BCO_NEXT;
1213             int failto  = BCO_GET_LARGE_ARG;
1214             I_ stackInt = (I_)Sp[1];
1215             if (stackInt >= (I_)BCO_LIT(discr))
1216                 bciPtr = failto;
1217             goto nextInsn;
1218         }
1219
1220         case bci_TESTEQ_I: {
1221             // There should be an Int at Sp[1], and an info table at Sp[0].
1222             int discr   = BCO_NEXT;
1223             int failto  = BCO_GET_LARGE_ARG;
1224             I_ stackInt = (I_)Sp[1];
1225             if (stackInt != (I_)BCO_LIT(discr)) {
1226                 bciPtr = failto;
1227             }
1228             goto nextInsn;
1229         }
1230
1231         case bci_TESTLT_D: {
1232             // There should be a Double at Sp[1], and an info table at Sp[0].
1233             int discr   = BCO_NEXT;
1234             int failto  = BCO_GET_LARGE_ARG;
1235             StgDouble stackDbl, discrDbl;
1236             stackDbl = PK_DBL( & Sp[1] );
1237             discrDbl = PK_DBL( & BCO_LIT(discr) );
1238             if (stackDbl >= discrDbl) {
1239                 bciPtr = failto;
1240             }
1241             goto nextInsn;
1242         }
1243
1244         case bci_TESTEQ_D: {
1245             // There should be a Double at Sp[1], and an info table at Sp[0].
1246             int discr   = BCO_NEXT;
1247             int failto  = BCO_GET_LARGE_ARG;
1248             StgDouble stackDbl, discrDbl;
1249             stackDbl = PK_DBL( & Sp[1] );
1250             discrDbl = PK_DBL( & BCO_LIT(discr) );
1251             if (stackDbl != discrDbl) {
1252                 bciPtr = failto;
1253             }
1254             goto nextInsn;
1255         }
1256
1257         case bci_TESTLT_F: {
1258             // There should be a Float at Sp[1], and an info table at Sp[0].
1259             int discr   = BCO_NEXT;
1260             int failto  = BCO_GET_LARGE_ARG;
1261             StgFloat stackFlt, discrFlt;
1262             stackFlt = PK_FLT( & Sp[1] );
1263             discrFlt = PK_FLT( & BCO_LIT(discr) );
1264             if (stackFlt >= discrFlt) {
1265                 bciPtr = failto;
1266             }
1267             goto nextInsn;
1268         }
1269
1270         case bci_TESTEQ_F: {
1271             // There should be a Float at Sp[1], and an info table at Sp[0].
1272             int discr   = BCO_NEXT;
1273             int failto  = BCO_GET_LARGE_ARG;
1274             StgFloat stackFlt, discrFlt;
1275             stackFlt = PK_FLT( & Sp[1] );
1276             discrFlt = PK_FLT( & BCO_LIT(discr) );
1277             if (stackFlt != discrFlt) {
1278                 bciPtr = failto;
1279             }
1280             goto nextInsn;
1281         }
1282
1283         // Control-flow ish things
1284         case bci_ENTER:
1285             // Context-switch check.  We put it here to ensure that
1286             // the interpreter has done at least *some* work before
1287             // context switching: sometimes the scheduler can invoke
1288             // the interpreter with context_switch == 1, particularly
1289             // if the -C0 flag has been given on the cmd line.
1290             if (cap->r.rHpLim == NULL) {
1291                 Sp--; Sp[0] = (W_)&stg_enter_info;
1292                 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1293             }
1294             goto eval;
1295
1296         case bci_RETURN:
1297             tagged_obj = (StgClosure *)Sp[0];
1298             Sp++;
1299             goto do_return;
1300
1301         case bci_RETURN_P:
1302             Sp--;
1303             Sp[0] = (W_)&stg_gc_unpt_r1_info;
1304             goto do_return_unboxed;
1305         case bci_RETURN_N:
1306             Sp--;
1307             Sp[0] = (W_)&stg_gc_unbx_r1_info;
1308             goto do_return_unboxed;
1309         case bci_RETURN_F:
1310             Sp--;
1311             Sp[0] = (W_)&stg_gc_f1_info;
1312             goto do_return_unboxed;
1313         case bci_RETURN_D:
1314             Sp--;
1315             Sp[0] = (W_)&stg_gc_d1_info;
1316             goto do_return_unboxed;
1317         case bci_RETURN_L:
1318             Sp--;
1319             Sp[0] = (W_)&stg_gc_l1_info;
1320             goto do_return_unboxed;
1321         case bci_RETURN_V:
1322             Sp--;
1323             Sp[0] = (W_)&stg_gc_void_info;
1324             goto do_return_unboxed;
1325
1326         case bci_SWIZZLE: {
1327             int stkoff = BCO_NEXT;
1328             signed short n = (signed short)(BCO_NEXT);
1329             Sp[stkoff] += (W_)n;
1330             goto nextInsn;
1331         }
1332
1333         case bci_CCALL: {
1334             void *tok;
1335             int stk_offset            = BCO_NEXT;
1336             int o_itbl                = BCO_NEXT;
1337             void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1338             int ret_dyn_size =
1339                 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1340                 + sizeofW(StgRetDyn);
1341
1342             /* the stack looks like this:
1343
1344                |             |  <- Sp + stk_offset
1345                +-------------+
1346                |             |
1347                |    args     |
1348                |             |  <- Sp + ret_size + 1
1349                +-------------+
1350                |    C fun    |  <- Sp + ret_size
1351                +-------------+
1352                |     ret     |  <- Sp
1353                +-------------+
1354
1355                ret is a placeholder for the return address, and may be
1356                up to 2 words.
1357
1358                We need to copy the args out of the TSO, because when
1359                we call suspendThread() we no longer own the TSO stack,
1360                and it may move at any time - indeed suspendThread()
1361                itself may do stack squeezing and move our args.
1362                So we make a copy of the argument block.
1363             */
1364
1365 #define ROUND_UP_WDS(p)  ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
1366
1367             ffi_cif *cif = (ffi_cif *)marshall_fn;
1368             nat nargs = cif->nargs;
1369             nat ret_size;
1370             nat i;
1371             StgPtr p;
1372             W_ ret[2];                  // max needed
1373             W_ *arguments[stk_offset];  // max needed
1374             void *argptrs[nargs];
1375             void (*fn)(void);
1376
1377             if (cif->rtype->type == FFI_TYPE_VOID) {
1378                 // necessary because cif->rtype->size == 1 for void,
1379                 // but the bytecode generator has not pushed a
1380                 // placeholder in this case.
1381                 ret_size = 0;
1382             } else {
1383                 ret_size = ROUND_UP_WDS(cif->rtype->size);
1384             }
1385
1386             memcpy(arguments, Sp+ret_size+1,
1387                    sizeof(W_) * (stk_offset-1-ret_size));
1388
1389             // libffi expects the args as an array of pointers to
1390             // values, so we have to construct this array before making
1391             // the call.
1392             p = (StgPtr)arguments;
1393             for (i = 0; i < nargs; i++) {
1394                 argptrs[i] = (void *)p;
1395                 // get the size from the cif
1396                 p += ROUND_UP_WDS(cif->arg_types[i]->size);
1397             }
1398
1399             // this is the function we're going to call
1400             fn = (void(*)(void))Sp[ret_size];
1401
1402             // Restore the Haskell thread's current value of errno
1403             errno = cap->r.rCurrentTSO->saved_errno;
1404
1405             // There are a bunch of non-ptr words on the stack (the
1406             // ccall args, the ccall fun address and space for the
1407             // result), which we need to cover with an info table
1408             // since we might GC during this call.
1409             //
1410             // We know how many (non-ptr) words there are before the
1411             // next valid stack frame: it is the stk_offset arg to the
1412             // CCALL instruction.   So we build a RET_DYN stack frame
1413             // on the stack frame to describe this chunk of stack.
1414             //
1415             Sp -= ret_dyn_size;
1416             ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset);
1417             ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1418
1419             // save obj (pointer to the current BCO), since this
1420             // might move during the call.  We use the R1 slot in the
1421             // RET_DYN frame for this, hence R1_PTR above.
1422             ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
1423
1424             SAVE_STACK_POINTERS;
1425             tok = suspendThread(&cap->r);
1426
1427             // We already made a copy of the arguments above.
1428             ffi_call(cif, fn, ret, argptrs);
1429
1430             // And restart the thread again, popping the RET_DYN frame.
1431             cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
1432             LOAD_STACK_POINTERS;
1433
1434             // Re-load the pointer to the BCO from the RET_DYN frame,
1435             // it might have moved during the call.  Also reload the
1436             // pointers to the components of the BCO.
1437             obj        = ((StgRetDyn *)Sp)->payload[0];
1438             bco        = (StgBCO*)obj;
1439             instrs     = (StgWord16*)(bco->instrs->payload);
1440             literals   = (StgWord*)(&bco->literals->payload[0]);
1441             ptrs       = (StgPtr*)(&bco->ptrs->payload[0]);
1442
1443             Sp += ret_dyn_size;
1444
1445             // Save the Haskell thread's current value of errno
1446             cap->r.rCurrentTSO->saved_errno = errno;
1447
1448             // Copy the return value back to the TSO stack.  It is at
1449             // most 2 words large, and resides at arguments[0].
1450             memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
1451
1452             goto nextInsn;
1453         }
1454
1455         case bci_JMP: {
1456             /* BCO_NEXT modifies bciPtr, so be conservative. */
1457             int nextpc = BCO_GET_LARGE_ARG;
1458             bciPtr     = nextpc;
1459             goto nextInsn;
1460         }
1461
1462         case bci_CASEFAIL:
1463             barf("interpretBCO: hit a CASEFAIL");
1464
1465             // Errors
1466         default:
1467             barf("interpretBCO: unknown or unimplemented opcode %d",
1468                  (int)(bci & 0xFF));
1469
1470         } /* switch on opcode */
1471     }
1472     }
1473
1474     barf("interpretBCO: fell off end of the interpreter");
1475 }