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