ghc/rts/Interpreter.c

   1 /* -----------------------------------------------------------------------------
   2  * Bytecode interpreter
   3  *
   4  * Copyright (c) The GHC Team, 1994-2002.
   5  * ---------------------------------------------------------------------------*/
   6
   7 #if !defined(SMP)
   8 #include "PosixSource.h"
   9 #else
  10 /* Hack and slash.. */
  11 #include "Stg.h"
  12 #endif
  13 #include "Rts.h"
  14 #include "RtsAPI.h"
  15 #include "RtsUtils.h"
  16 #include "Closures.h"
  17 #include "TSO.h"
  18 #include "Schedule.h"
  19 #include "RtsFlags.h"
  20 #include "Storage.h"
  21 #include "Updates.h"
  22 #include "Sanity.h"
  23
  24 #include "Bytecodes.h"
  25 #include "Printer.h"
  26 #include "Disassembler.h"
  27 #include "Interpreter.h"
  28
  29
  30 /* --------------------------------------------------------------------------
  31  * The bytecode interpreter
  32  * ------------------------------------------------------------------------*/
  33
  34 /* Gather stats about entry, opcode, opcode-pair frequencies.  For
  35    tuning the interpreter. */
  36
  37 /* #define INTERP_STATS */
  38
  39
  40 /* Sp points to the lowest live word on the stack. */
  41
  42 #define BCO_NEXT      instrs[bciPtr++]
  43 #define BCO_PTR(n)    (W_)ptrs[n]
  44 #define BCO_LIT(n)    (W_)literals[n]
  45 #define BCO_ITBL(n)   itbls[n]
  46
  47 #define LOAD_STACK_POINTERS                                     \
  48     Sp = cap->r.rCurrentTSO->sp;                                \
  49     /* We don't change this ... */                              \
  50     SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
  51
  52 #define SAVE_STACK_POINTERS                     \
  53     cap->r.rCurrentTSO->sp = Sp
  54
  55 #define RETURN_TO_SCHEDULER(todo,retcode)       \
  56    SAVE_STACK_POINTERS;                         \
  57    cap->r.rCurrentTSO->what_next = (todo);      \
  58    return (retcode);
  59
  60
  61 static inline StgPtr
  62 allocate_UPD (int n_words)
  63 {
  64    return allocate(stg_max(sizeofW(StgHeader)+MIN_UPD_SIZE, n_words));
  65 }
  66
  67 static inline StgPtr
  68 allocate_NONUPD (int n_words)
  69 {
  70     return allocate(stg_max(sizeofW(StgHeader)+MIN_NONUPD_SIZE, n_words));
  71 }
  72
  73
  74 #ifdef INTERP_STATS
  75
  76 /* Hacky stats, for tuning the interpreter ... */
  77 int it_unknown_entries[N_CLOSURE_TYPES];
  78 int it_total_unknown_entries;
  79 int it_total_entries;
  80
  81 int it_retto_BCO;
  82 int it_retto_UPDATE;
  83 int it_retto_other;
  84
  85 int it_slides;
  86 int it_insns;
  87 int it_BCO_entries;
  88
  89 int it_ofreq[27];
  90 int it_oofreq[27][27];
  91 int it_lastopc;
  92
  93 #define INTERP_TICK(n) (n)++
  94
  95 void interp_startup ( void )
  96 {
  97    int i, j;
  98    it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
  99    it_total_entries = it_total_unknown_entries = 0;
 100    for (i = 0; i < N_CLOSURE_TYPES; i++)
 101       it_unknown_entries[i] = 0;
 102    it_slides = it_insns = it_BCO_entries = 0;
 103    for (i = 0; i < 27; i++) it_ofreq[i] = 0;
 104    for (i = 0; i < 27; i++)
 105      for (j = 0; j < 27; j++)
 106         it_oofreq[i][j] = 0;
 107    it_lastopc = 0;
 108 }
 109
 110 void interp_shutdown ( void )
 111 {
 112    int i, j, k, o_max, i_max, j_max;
 113    fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
 114                    it_retto_BCO + it_retto_UPDATE + it_retto_other,
 115                    it_retto_BCO, it_retto_UPDATE, it_retto_other );
 116    fprintf(stderr, "%d total entries, %d unknown entries \n",
 117                    it_total_entries, it_total_unknown_entries);
 118    for (i = 0; i < N_CLOSURE_TYPES; i++) {
 119      if (it_unknown_entries[i] == 0) continue;
 120      fprintf(stderr, "   type %2d: unknown entries (%4.1f%%) == %d\n",
 121              i, 100.0 * ((double)it_unknown_entries[i]) /
 122                         ((double)it_total_unknown_entries),
 123              it_unknown_entries[i]);
 124    }
 125    fprintf(stderr, "%d insns, %d slides, %d BCO_entries\n",
 126                    it_insns, it_slides, it_BCO_entries);
 127    for (i = 0; i < 27; i++)
 128       fprintf(stderr, "opcode %2d got %d\n", i, it_ofreq[i] );
 129
 130    for (k = 1; k < 20; k++) {
 131       o_max = 0;
 132       i_max = j_max = 0;
 133       for (i = 0; i < 27; i++) {
 134          for (j = 0; j < 27; j++) {
 135             if (it_oofreq[i][j] > o_max) {
 136                o_max = it_oofreq[i][j];
 137                i_max = i; j_max = j;
 138             }
 139          }
 140       }
 141
 142       fprintf ( stderr, "%d:  count (%4.1f%%) %6d   is %d then %d\n",
 143                 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
 144                    i_max, j_max );
 145       it_oofreq[i_max][j_max] = 0;
 146
 147    }
 148 }
 149
 150 #else // !INTERP_STATS
 151
 152 #define INTERP_TICK(n) /* nothing */
 153
 154 #endif
 155
 156 static StgWord app_ptrs_itbl[] = {
 157     (W_)&stg_ap_p_info,
 158     (W_)&stg_ap_pp_info,
 159     (W_)&stg_ap_ppp_info,
 160     (W_)&stg_ap_pppp_info,
 161     (W_)&stg_ap_ppppp_info,
 162     (W_)&stg_ap_pppppp_info,
 163     (W_)&stg_ap_ppppppp_info
 164 };
 165
 166 StgThreadReturnCode
 167 interpretBCO (Capability* cap)
 168 {
 169     // Use of register here is primarily to make it clear to compilers
 170     // that these entities are non-aliasable.
 171     register StgPtr       Sp;    // local state -- stack pointer
 172     register StgPtr       SpLim; // local state -- stack lim pointer
 173     register StgClosure*  obj;
 174     nat n, m;
 175
 176     LOAD_STACK_POINTERS;
 177
 178     // ------------------------------------------------------------------------
 179     // Case 1:
 180     //
 181     //       We have a closure to evaluate.  Stack looks like:
 182     //
 183     //          |   XXXX_info   |
 184     //          +---------------+
 185     //       Sp |      -------------------> closure
 186     //          +---------------+
 187     //
 188     if (Sp[0] == (W_)&stg_enter_info) {
 189         Sp++;
 190         goto eval;
 191     }
 192
 193     // ------------------------------------------------------------------------
 194     // Case 2:
 195     //
 196     //       We have a BCO application to perform.  Stack looks like:
 197     //
 198     //          |     ....      |
 199     //          +---------------+
 200     //          |     arg1      |
 201     //          +---------------+
 202     //          |     BCO       |
 203     //          +---------------+
 204     //       Sp |   RET_BCO     |
 205     //          +---------------+
 206     //
 207     else if (Sp[0] == (W_)&stg_apply_interp_info) {
 208         obj = (StgClosure *)Sp[1];
 209         Sp += 2;
 210         goto run_BCO_fun;
 211     }
 212
 213     // ------------------------------------------------------------------------
 214     // Case 3:
 215     //
 216     //       We have an unboxed value to return.  See comment before
 217     //       do_return_unboxed, below.
 218     //
 219     else {
 220         goto do_return_unboxed;
 221     }
 222
 223     // Evaluate the object on top of the stack.
 224 eval:
 225     obj = (StgClosure*)Sp[0]; Sp++;
 226
 227 eval_obj:
 228     INTERP_TICK(it_total_evals);
 229
 230     IF_DEBUG(interpreter,
 231              fprintf(stderr,
 232              "\n---------------------------------------------------------------\n");
 233              fprintf(stderr,"Evaluating: "); printObj(obj);
 234              fprintf(stderr,"Sp = %p\n", Sp);
 235              fprintf(stderr, "\n" );
 236
 237              printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
 238              fprintf(stderr, "\n\n");
 239             );
 240
 241     IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
 242
 243     switch ( get_itbl(obj)->type ) {
 244
 245     case IND:
 246     case IND_OLDGEN:
 247     case IND_PERM:
 248     case IND_OLDGEN_PERM:
 249     case IND_STATIC:
 250     {
 251         obj = ((StgInd*)obj)->indirectee;
 252         goto eval_obj;
 253     }
 254
 255     case CONSTR:
 256     case CONSTR_1_0:
 257     case CONSTR_0_1:
 258     case CONSTR_2_0:
 259     case CONSTR_1_1:
 260     case CONSTR_0_2:
 261     case CONSTR_INTLIKE:
 262     case CONSTR_CHARLIKE:
 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                  fprintf(stderr, "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(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              fprintf(stderr,
 348              "\n---------------------------------------------------------------\n");
 349              fprintf(stderr,"Returning: "); printObj(obj);
 350              fprintf(stderr,"Sp = %p\n", Sp);
 351              fprintf(stderr, "\n" );
 352              printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
 353              fprintf(stderr, "\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         if (info == (StgInfoTable *)&stg_ap_ppppppp_info) {
 399             n = 7; m = 7; 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                  fprintf(stderr, "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(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                      fprintf(stderr, "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(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 arity, i;
 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[i-1] = Sp[i];
 534                 }
 535                 Sp[arity-1] = app_ptrs_itbl[n-arity-1];
 536                 Sp--;
 537                 // unpack the PAP's arguments onto the stack
 538                 Sp -= pap->n_args;
 539                 for (i = 0; i < pap->n_args; i++) {
 540                     Sp[i] = (W_)pap->payload[i];
 541                 }
 542                 obj = pap->fun;
 543                 goto run_BCO_fun;
 544             }
 545             else if (arity == n) {
 546                 Sp -= pap->n_args;
 547                 for (i = 0; i < pap->n_args; i++) {
 548                     Sp[i] = (W_)pap->payload[i];
 549                 }
 550                 obj = pap->fun;
 551                 goto run_BCO_fun;
 552             }
 553             else /* arity > n */ {
 554                 // build a new PAP and return it.
 555                 StgPAP *new_pap;
 556                 nat size;
 557                 size = PAP_sizeW(pap->n_args + m);
 558                 new_pap = (StgPAP *)allocate(size);
 559                 SET_HDR(new_pap,&stg_PAP_info,CCCS);
 560                 new_pap->arity = pap->arity - n;
 561                 new_pap->n_args = pap->n_args + m;
 562                 new_pap->fun = pap->fun;
 563                 for (i = 0; i < pap->n_args; i++) {
 564                     new_pap->payload[i] = pap->payload[i];
 565                 }
 566                 for (i = 0; i < m; i++) {
 567                     new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
 568                 }
 569                 obj = (StgClosure *)new_pap;
 570                 Sp += m;
 571                 goto do_return;
 572             }
 573         }
 574
 575         case BCO: {
 576             nat arity, i;
 577
 578             Sp++;
 579             arity = ((StgBCO *)obj)->arity;
 580             ASSERT(arity > 0);
 581             if (arity < n) {
 582                 // n must be greater than 1, and the only kinds of
 583                 // application we support with more than one argument
 584                 // are all pointers...
 585                 //
 586                 // Shuffle the args for this function down, and put
 587                 // the appropriate info table in the gap.
 588                 for (i = 0; i < arity; i++) {
 589                     Sp[i-1] = Sp[i];
 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 size, i;
 602                 size = PAP_sizeW(m);
 603                 pap = (StgPAP *)allocate(size);
 604                 SET_HDR(pap, &stg_PAP_info,CCCS);
 605                 pap->arity = arity - n;
 606                 pap->fun = obj;
 607                 pap->n_args = m;
 608                 for (i = 0; i < m; i++) {
 609                     pap->payload[i] = (StgClosure *)Sp[i];
 610                 }
 611                 obj = (StgClosure *)pap;
 612                 Sp += m;
 613                 goto do_return;
 614             }
 615         }
 616
 617         // No point in us applying machine-code functions
 618         default:
 619         defer_apply_to_sched:
 620             Sp -= 2;
 621             Sp[1] = (W_)obj;
 622             Sp[0] = (W_)&stg_enter_info;
 623             RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding);
 624     }
 625
 626     // ------------------------------------------------------------------------
 627     // Ok, we now have a bco (obj), and its arguments are all on the
 628     // stack.  We can start executing the byte codes.
 629     //
 630     // The stack is in one of two states.  First, if this BCO is a
 631     // function:
 632     //
 633     //    |     ....      |
 634     //    +---------------+
 635     //    |     arg2      |
 636     //    +---------------+
 637     //    |     arg1      |
 638     //    +---------------+
 639     //
 640     // Second, if this BCO is a continuation:
 641     //
 642     //    |     ....      |
 643     //    +---------------+
 644     //    |     fv2       |
 645     //    +---------------+
 646     //    |     fv1       |
 647     //    +---------------+
 648     //    |     BCO       |
 649     //    +---------------+
 650     //    | stg_ctoi_ret_ |
 651     //    +---------------+
 652     //    |    retval     |
 653     //    +---------------+
 654     //
 655     // where retval is the value being returned to this continuation.
 656     // In the event of a stack check, heap check, or context switch,
 657     // we need to leave the stack in a sane state so the garbage
 658     // collector can find all the pointers.
 659     //
 660     //  (1) BCO is a function:  the BCO's bitmap describes the
 661     //      pointerhood of the arguments.
 662     //
 663     //  (2) BCO is a continuation: BCO's bitmap describes the
 664     //      pointerhood of the free variables.
 665     //
 666     // Sadly we have three different kinds of stack/heap/cswitch check
 667     // to do:
 668
 669 run_BCO_return:
 670     // Heap check
 671     if (doYouWantToGC()) {
 672         Sp--; Sp[0] = (W_)&stg_enter_info;
 673         RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
 674     }
 675     // Stack checks aren't necessary at return points, the stack use
 676     // is aggregated into the enclosing function entry point.
 677     goto run_BCO;
 678
 679 run_BCO_return_unboxed:
 680     // Heap check
 681     if (doYouWantToGC()) {
 682         RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
 683     }
 684     // Stack checks aren't necessary at return points, the stack use
 685     // is aggregated into the enclosing function entry point.
 686     goto run_BCO;
 687
 688 run_BCO_fun:
 689     IF_DEBUG(sanity,
 690              Sp -= 2;
 691              Sp[1] = (W_)obj;
 692              Sp[0] = (W_)&stg_apply_interp_info;
 693              checkStackChunk(Sp,SpLim);
 694              Sp += 2;
 695         );
 696
 697     // Heap check
 698     if (doYouWantToGC()) {
 699         Sp -= 2;
 700         Sp[1] = (W_)obj;
 701         Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
 702         RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
 703     }
 704
 705     // Stack check
 706     if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
 707         Sp -= 2;
 708         Sp[1] = (W_)obj;
 709         Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
 710         RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
 711     }
 712     goto run_BCO;
 713
 714     // Now, actually interpret the BCO... (no returning to the
 715     // scheduler again until the stack is in an orderly state).
 716 run_BCO:
 717     INTERP_TICK(it_BCO_entries);
 718     {
 719         register int       bciPtr     = 1; /* instruction pointer */
 720         register StgBCO*   bco        = (StgBCO*)obj;
 721         register StgWord16* instrs    = (StgWord16*)(bco->instrs->payload);
 722         register StgWord*  literals   = (StgWord*)(&bco->literals->payload[0]);
 723         register StgPtr*   ptrs       = (StgPtr*)(&bco->ptrs->payload[0]);
 724         register StgInfoTable** itbls = (StgInfoTable**)
 725             (&bco->itbls->payload[0]);
 726
 727 #ifdef INTERP_STATS
 728         it_lastopc = 0; /* no opcode */
 729 #endif
 730
 731     nextInsn:
 732         ASSERT(bciPtr <= instrs[0]);
 733         IF_DEBUG(interpreter,
 734                  //if (do_print_stack) {
 735                  //fprintf(stderr, "\n-- BEGIN stack\n");
 736                  //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
 737                  //fprintf(stderr, "-- END stack\n\n");
 738                  //}
 739                  fprintf(stderr,"Sp = %p   pc = %d      ", Sp, bciPtr);
 740                  disInstr(bco,bciPtr);
 741                  if (0) { int i;
 742                  fprintf(stderr,"\n");
 743                  for (i = 8; i >= 0; i--) {
 744                      fprintf(stderr, "%d  %p\n", i, (StgPtr)(*(Sp+i)));
 745                  }
 746                  fprintf(stderr,"\n");
 747                  }
 748                  //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
 749             );
 750
 751         INTERP_TICK(it_insns);
 752
 753 #ifdef INTERP_STATS
 754         ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
 755         it_ofreq[ (int)instrs[bciPtr] ] ++;
 756         it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
 757         it_lastopc = (int)instrs[bciPtr];
 758 #endif
 759
 760         switch (BCO_NEXT) {
 761
 762         case bci_STKCHECK: {
 763             // Explicit stack check at the beginning of a function
 764             // *only* (stack checks in case alternatives are
 765             // propagated to the enclosing function).
 766             int stk_words_reqd = BCO_NEXT + 1;
 767             if (Sp - stk_words_reqd < SpLim) {
 768                 Sp -= 2;
 769                 Sp[1] = (W_)obj;
 770                 Sp[0] = (W_)&stg_apply_interp_info;
 771                 RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
 772             } else {
 773                 goto nextInsn;
 774             }
 775         }
 776
 777         case bci_PUSH_L: {
 778             int o1 = BCO_NEXT;
 779             Sp[-1] = Sp[o1];
 780             Sp--;
 781             goto nextInsn;
 782         }
 783
 784         case bci_PUSH_LL: {
 785             int o1 = BCO_NEXT;
 786             int o2 = BCO_NEXT;
 787             Sp[-1] = Sp[o1];
 788             Sp[-2] = Sp[o2];
 789             Sp -= 2;
 790             goto nextInsn;
 791         }
 792
 793         case bci_PUSH_LLL: {
 794             int o1 = BCO_NEXT;
 795             int o2 = BCO_NEXT;
 796             int o3 = BCO_NEXT;
 797             Sp[-1] = Sp[o1];
 798             Sp[-2] = Sp[o2];
 799             Sp[-3] = Sp[o3];
 800             Sp -= 3;
 801             goto nextInsn;
 802         }
 803
 804         case bci_PUSH_G: {
 805             int o1 = BCO_NEXT;
 806             Sp[-1] = BCO_PTR(o1);
 807             Sp -= 1;
 808             goto nextInsn;
 809         }
 810
 811         case bci_PUSH_ALTS: {
 812             int o_bco  = BCO_NEXT;
 813             Sp[-2] = (W_)&stg_ctoi_ret_R1p_info;
 814             Sp[-1] = BCO_PTR(o_bco);
 815             Sp -= 2;
 816             goto nextInsn;
 817         }
 818
 819         case bci_PUSH_ALTS_P: {
 820             int o_bco  = BCO_NEXT;
 821             Sp[-2] = (W_)&stg_ctoi_ret_R1unpt_info;
 822             Sp[-1] = BCO_PTR(o_bco);
 823             Sp -= 2;
 824             goto nextInsn;
 825         }
 826
 827         case bci_PUSH_ALTS_N: {
 828             int o_bco  = BCO_NEXT;
 829             Sp[-2] = (W_)&stg_ctoi_ret_R1n_info;
 830             Sp[-1] = BCO_PTR(o_bco);
 831             Sp -= 2;
 832             goto nextInsn;
 833         }
 834
 835         case bci_PUSH_ALTS_F: {
 836             int o_bco  = BCO_NEXT;
 837             Sp[-2] = (W_)&stg_ctoi_ret_F1_info;
 838             Sp[-1] = BCO_PTR(o_bco);
 839             Sp -= 2;
 840             goto nextInsn;
 841         }
 842
 843         case bci_PUSH_ALTS_D: {
 844             int o_bco  = BCO_NEXT;
 845             Sp[-2] = (W_)&stg_ctoi_ret_D1_info;
 846             Sp[-1] = BCO_PTR(o_bco);
 847             Sp -= 2;
 848             goto nextInsn;
 849         }
 850
 851         case bci_PUSH_ALTS_L: {
 852             int o_bco  = BCO_NEXT;
 853             Sp[-2] = (W_)&stg_ctoi_ret_L1_info;
 854             Sp[-1] = BCO_PTR(o_bco);
 855             Sp -= 2;
 856             goto nextInsn;
 857         }
 858
 859         case bci_PUSH_ALTS_V: {
 860             int o_bco  = BCO_NEXT;
 861             Sp[-2] = (W_)&stg_ctoi_ret_V_info;
 862             Sp[-1] = BCO_PTR(o_bco);
 863             Sp -= 2;
 864             goto nextInsn;
 865         }
 866
 867         case bci_PUSH_APPLY_N:
 868             Sp--; Sp[0] = (W_)&stg_ap_n_info;
 869             goto nextInsn;
 870         case bci_PUSH_APPLY_V:
 871             Sp--; Sp[0] = (W_)&stg_ap_v_info;
 872             goto nextInsn;
 873         case bci_PUSH_APPLY_F:
 874             Sp--; Sp[0] = (W_)&stg_ap_f_info;
 875             goto nextInsn;
 876         case bci_PUSH_APPLY_D:
 877             Sp--; Sp[0] = (W_)&stg_ap_d_info;
 878             goto nextInsn;
 879         case bci_PUSH_APPLY_L:
 880             Sp--; Sp[0] = (W_)&stg_ap_l_info;
 881             goto nextInsn;
 882         case bci_PUSH_APPLY_P:
 883             Sp--; Sp[0] = (W_)&stg_ap_p_info;
 884             goto nextInsn;
 885         case bci_PUSH_APPLY_PP:
 886             Sp--; Sp[0] = (W_)&stg_ap_pp_info;
 887             goto nextInsn;
 888         case bci_PUSH_APPLY_PPP:
 889             Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
 890             goto nextInsn;
 891         case bci_PUSH_APPLY_PPPP:
 892             Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
 893             goto nextInsn;
 894         case bci_PUSH_APPLY_PPPPP:
 895             Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
 896             goto nextInsn;
 897         case bci_PUSH_APPLY_PPPPPP:
 898             Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
 899             goto nextInsn;
 900         case bci_PUSH_APPLY_PPPPPPP:
 901             Sp--; Sp[0] = (W_)&stg_ap_ppppppp_info;
 902             goto nextInsn;
 903
 904         case bci_PUSH_UBX: {
 905             int i;
 906             int o_lits = BCO_NEXT;
 907             int n_words = BCO_NEXT;
 908             Sp -= n_words;
 909             for (i = 0; i < n_words; i++) {
 910                 Sp[i] = BCO_LIT(o_lits+i);
 911             }
 912             goto nextInsn;
 913         }
 914
 915         case bci_SLIDE: {
 916             int n  = BCO_NEXT;
 917             int by = BCO_NEXT;
 918             /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
 919             while(--n >= 0) {
 920                 Sp[n+by] = Sp[n];
 921             }
 922             Sp += by;
 923             INTERP_TICK(it_slides);
 924             goto nextInsn;
 925         }
 926
 927         case bci_ALLOC_AP: {
 928             StgAP* ap;
 929             int n_payload = BCO_NEXT;
 930             int request   = PAP_sizeW(n_payload);
 931             ap = (StgAP*)allocate_UPD(request);
 932             Sp[-1] = (W_)ap;
 933             ap->n_args = n_payload;
 934             SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
 935             Sp --;
 936             goto nextInsn;
 937         }
 938
 939         case bci_ALLOC_PAP: {
 940             StgPAP* pap;
 941             int arity = BCO_NEXT;
 942             int n_payload = BCO_NEXT;
 943             int request   = PAP_sizeW(n_payload);
 944             pap = (StgPAP*)allocate_NONUPD(request);
 945             Sp[-1] = (W_)pap;
 946             pap->n_args = n_payload;
 947             pap->arity = arity;
 948             SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
 949             Sp --;
 950             goto nextInsn;
 951         }
 952
 953         case bci_MKAP: {
 954             int i;
 955             int stkoff = BCO_NEXT;
 956             int n_payload = BCO_NEXT;
 957             StgAP* ap = (StgAP*)Sp[stkoff];
 958             ASSERT((int)ap->n_args == n_payload);
 959             ap->fun = (StgClosure*)Sp[0];
 960
 961             // The function should be a BCO, and its bitmap should
 962             // cover the payload of the AP correctly.
 963             ASSERT(get_itbl(ap->fun)->type == BCO
 964                    && (get_itbl(ap)->type == PAP ||
 965                        BCO_BITMAP_SIZE(ap->fun) == ap->n_args));
 966
 967             for (i = 0; i < n_payload; i++)
 968                 ap->payload[i] = (StgClosure*)Sp[i+1];
 969             Sp += n_payload+1;
 970             IF_DEBUG(interpreter,
 971                      fprintf(stderr,"\tBuilt ");
 972                      printObj((StgClosure*)ap);
 973                 );
 974             goto nextInsn;
 975         }
 976
 977         case bci_UNPACK: {
 978             /* Unpack N ptr words from t.o.s constructor */
 979             int i;
 980             int n_words = BCO_NEXT;
 981             StgClosure* con = (StgClosure*)Sp[0];
 982             Sp -= n_words;
 983             for (i = 0; i < n_words; i++) {
 984                 Sp[i] = (W_)con->payload[i];
 985             }
 986             goto nextInsn;
 987         }
 988
 989         case bci_PACK: {
 990             int i;
 991             int o_itbl         = BCO_NEXT;
 992             int n_words        = BCO_NEXT;
 993             StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
 994             int request        = CONSTR_sizeW( itbl->layout.payload.ptrs,
 995                                                itbl->layout.payload.nptrs );
 996             StgClosure* con = (StgClosure*)allocate_NONUPD(request);
 997             ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
 998             SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
 999             for (i = 0; i < n_words; i++) {
1000                 con->payload[i] = (StgClosure*)Sp[i];
1001             }
1002             Sp += n_words;
1003             Sp --;
1004             Sp[0] = (W_)con;
1005             IF_DEBUG(interpreter,
1006                      fprintf(stderr,"\tBuilt ");
1007                      printObj((StgClosure*)con);
1008                 );
1009             goto nextInsn;
1010         }
1011
1012         case bci_TESTLT_P: {
1013             int discr  = BCO_NEXT;
1014             int failto = BCO_NEXT;
1015             StgClosure* con = (StgClosure*)Sp[0];
1016             if (constrTag(con) >= discr) {
1017                 bciPtr = failto;
1018             }
1019             goto nextInsn;
1020         }
1021
1022         case bci_TESTEQ_P: {
1023             int discr  = BCO_NEXT;
1024             int failto = BCO_NEXT;
1025             StgClosure* con = (StgClosure*)Sp[0];
1026             if (constrTag(con) != discr) {
1027                 bciPtr = failto;
1028             }
1029             goto nextInsn;
1030         }
1031
1032         case bci_TESTLT_I: {
1033             // There should be an Int at Sp[1], and an info table at Sp[0].
1034             int discr   = BCO_NEXT;
1035             int failto  = BCO_NEXT;
1036             I_ stackInt = (I_)Sp[1];
1037             if (stackInt >= (I_)BCO_LIT(discr))
1038                 bciPtr = failto;
1039             goto nextInsn;
1040         }
1041
1042         case bci_TESTEQ_I: {
1043             // There should be an Int at Sp[1], and an info table at Sp[0].
1044             int discr   = BCO_NEXT;
1045             int failto  = BCO_NEXT;
1046             I_ stackInt = (I_)Sp[1];
1047             if (stackInt != (I_)BCO_LIT(discr)) {
1048                 bciPtr = failto;
1049             }
1050             goto nextInsn;
1051         }
1052
1053         case bci_TESTLT_D: {
1054             // There should be a Double at Sp[1], and an info table at Sp[0].
1055             int discr   = BCO_NEXT;
1056             int failto  = BCO_NEXT;
1057             StgDouble stackDbl, discrDbl;
1058             stackDbl = PK_DBL( & Sp[1] );
1059             discrDbl = PK_DBL( & BCO_LIT(discr) );
1060             if (stackDbl >= discrDbl) {
1061                 bciPtr = failto;
1062             }
1063             goto nextInsn;
1064         }
1065
1066         case bci_TESTEQ_D: {
1067             // There should be a Double at Sp[1], and an info table at Sp[0].
1068             int discr   = BCO_NEXT;
1069             int failto  = BCO_NEXT;
1070             StgDouble stackDbl, discrDbl;
1071             stackDbl = PK_DBL( & Sp[1] );
1072             discrDbl = PK_DBL( & BCO_LIT(discr) );
1073             if (stackDbl != discrDbl) {
1074                 bciPtr = failto;
1075             }
1076             goto nextInsn;
1077         }
1078
1079         case bci_TESTLT_F: {
1080             // There should be a Float at Sp[1], and an info table at Sp[0].
1081             int discr   = BCO_NEXT;
1082             int failto  = BCO_NEXT;
1083             StgFloat stackFlt, discrFlt;
1084             stackFlt = PK_FLT( & Sp[1] );
1085             discrFlt = PK_FLT( & BCO_LIT(discr) );
1086             if (stackFlt >= discrFlt) {
1087                 bciPtr = failto;
1088             }
1089             goto nextInsn;
1090         }
1091
1092         case bci_TESTEQ_F: {
1093             // There should be a Float at Sp[1], and an info table at Sp[0].
1094             int discr   = BCO_NEXT;
1095             int failto  = BCO_NEXT;
1096             StgFloat stackFlt, discrFlt;
1097             stackFlt = PK_FLT( & Sp[1] );
1098             discrFlt = PK_FLT( & BCO_LIT(discr) );
1099             if (stackFlt != discrFlt) {
1100                 bciPtr = failto;
1101             }
1102             goto nextInsn;
1103         }
1104
1105         // Control-flow ish things
1106         case bci_ENTER:
1107             // Context-switch check.  We put it here to ensure that
1108             // the interpreter has done at least *some* work before
1109             // context switching: sometimes the scheduler can invoke
1110             // the interpreter with context_switch == 1, particularly
1111             // if the -C0 flag has been given on the cmd line.
1112             if (context_switch) {
1113                 Sp--; Sp[0] = (W_)&stg_enter_info;
1114                 RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
1115             }
1116             goto eval;
1117
1118         case bci_RETURN:
1119             obj = (StgClosure *)Sp[0];
1120             Sp++;
1121             goto do_return;
1122
1123         case bci_RETURN_P:
1124             Sp--;
1125             Sp[0] = (W_)&stg_gc_unpt_r1_info;
1126             goto do_return_unboxed;
1127         case bci_RETURN_N:
1128             Sp--;
1129             Sp[0] = (W_)&stg_gc_unbx_r1_info;
1130             goto do_return_unboxed;
1131         case bci_RETURN_F:
1132             Sp--;
1133             Sp[0] = (W_)&stg_gc_f1_info;
1134             goto do_return_unboxed;
1135         case bci_RETURN_D:
1136             Sp--;
1137             Sp[0] = (W_)&stg_gc_d1_info;
1138             goto do_return_unboxed;
1139         case bci_RETURN_L:
1140             Sp--;
1141             Sp[0] = (W_)&stg_gc_l1_info;
1142             goto do_return_unboxed;
1143         case bci_RETURN_V:
1144             Sp--;
1145             Sp[0] = (W_)&stg_gc_void_info;
1146             goto do_return_unboxed;
1147
1148         case bci_SWIZZLE: {
1149             int stkoff = BCO_NEXT;
1150             signed short n = (signed short)(BCO_NEXT);
1151             Sp[stkoff] += (W_)n;
1152             goto nextInsn;
1153         }
1154
1155         case bci_CCALL: {
1156             StgInt tok;
1157             int stk_offset            = BCO_NEXT;
1158             int o_itbl                = BCO_NEXT;
1159             void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
1160             int ret_dyn_size =
1161                 RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
1162                 + sizeofW(StgRetDyn);
1163
1164 #ifdef RTS_SUPPORTS_THREADS
1165             // Threaded RTS:
1166             // Arguments on the TSO stack are not good, because garbage
1167             // collection might move the TSO as soon as we call
1168             // suspendThread below.
1169
1170             W_ arguments[stk_offset];
1171
1172             memcpy(arguments, Sp, sizeof(W_) * stk_offset);
1173 #endif
1174
1175             // There are a bunch of non-ptr words on the stack (the
1176             // ccall args, the ccall fun address and space for the
1177             // result), which we need to cover with an info table
1178             // since we might GC during this call.
1179             //
1180             // We know how many (non-ptr) words there are before the
1181             // next valid stack frame: it is the stk_offset arg to the
1182             // CCALL instruction.   So we build a RET_DYN stack frame
1183             // on the stack frame to describe this chunk of stack.
1184             //
1185             Sp -= ret_dyn_size;
1186             ((StgRetDyn *)Sp)->liveness = ALL_NON_PTRS | N_NONPTRS(stk_offset);
1187             ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
1188
1189             SAVE_STACK_POINTERS;
1190             tok = suspendThread(&cap->r,rtsFalse);
1191
1192 #ifndef RTS_SUPPORTS_THREADS
1193             // Careful:
1194             // suspendThread might have shifted the stack
1195             // around (stack squeezing), so we have to grab the real
1196             // Sp out of the TSO to find the ccall args again.
1197
1198             marshall_fn ( (void*)(cap->r.rCurrentTSO->sp + ret_dyn_size) );
1199 #else
1200             // Threaded RTS:
1201             // We already made a malloced copy of the arguments above.
1202
1203             marshall_fn ( arguments );
1204 #endif
1205
1206             // And restart the thread again, popping the RET_DYN frame.
1207             cap = (Capability *)((void *)resumeThread(tok,rtsFalse) - sizeof(StgFunTable));
1208             LOAD_STACK_POINTERS;
1209             Sp += ret_dyn_size;
1210
1211 #ifdef RTS_SUPPORTS_THREADS
1212             // Threaded RTS:
1213             // Copy the "arguments", which might include a return value,
1214             // back to the TSO stack. It would of course be enough to
1215             // just copy the return value, but we don't know the offset.
1216             memcpy(Sp, arguments, sizeof(W_) * stk_offset);
1217 #endif
1218
1219             goto nextInsn;
1220         }
1221
1222         case bci_JMP: {
1223             /* BCO_NEXT modifies bciPtr, so be conservative. */
1224             int nextpc = BCO_NEXT;
1225             bciPtr     = nextpc;
1226             goto nextInsn;
1227         }
1228
1229         case bci_CASEFAIL:
1230             barf("interpretBCO: hit a CASEFAIL");
1231
1232             // Errors
1233         default:
1234             barf("interpretBCO: unknown or unimplemented opcode");
1235
1236         } /* switch on opcode */
1237     }
1238     }
1239
1240     barf("interpretBCO: fell off end of the interpreter");
1241 }