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