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