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