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