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