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