ghc/rts/Interpreter.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * Bytecode evaluator
   4  *
   5  * Copyright (c) 1994-2000.
   6  *
   7  * $RCSfile: Interpreter.c,v $
   8  * $Revision: 1.22 $
   9  * $Date: 2001/05/21 16:34:22 $
  10  * ---------------------------------------------------------------------------*/
  11
  12 #include "Rts.h"
  13 #include "RtsAPI.h"
  14 #include "RtsUtils.h"
  15 #include "Closures.h"
  16 #include "TSO.h"
  17 #include "Schedule.h"
  18 #include "RtsFlags.h"
  19 #include "Storage.h"
  20 #include "Updates.h"
  21
  22 #include "Bytecodes.h"
  23 #include "Printer.h"
  24 #include "Disassembler.h"
  25 #include "Interpreter.h"
  26
  27
  28 /* --------------------------------------------------------------------------
  29  * The new bytecode interpreter
  30  * ------------------------------------------------------------------------*/
  31
  32 /* The interpreter can be compiled so it just interprets BCOs and
  33    hands literally everything else to the scheduler.  This gives a
  34    "reference interpreter" which is correct but slow -- useful for
  35    debugging.  By default, we handle certain closures specially so as
  36    to dramatically cut down on the number of deferrals to the
  37    scheduler.  Ie normally you don't want REFERENCE_INTERPRETER to be
  38    defined. */
  39
  40 /* #define REFERENCE_INTERPRETER */
  41
  42 /* Gather stats about entry, opcode, opcode-pair frequencies.  For
  43    tuning the interpreter. */
  44
  45 /* #define INTERP_STATS */
  46
  47
  48
  49 /* iSp points to the lowest live word on the stack. */
  50
  51 #define StackWord(n)  iSp[n]
  52 #define BCO_NEXT      instrs[bciPtr++]
  53 #define BCO_PTR(n)    (W_)ptrs[n]
  54 #define BCO_LIT(n)    (W_)literals[n]
  55 #define BCO_ITBL(n)   itbls[n]
  56
  57 #define LOAD_STACK_POINTERS \
  58     iSp = cap->rCurrentTSO->sp; iSu = cap->rCurrentTSO->su;
  59
  60 #define SAVE_STACK_POINTERS \
  61     cap->rCurrentTSO->sp = iSp; cap->rCurrentTSO->su = iSu;
  62
  63 #define RETURN(retcode) \
  64    SAVE_STACK_POINTERS; return retcode;
  65
  66
  67 static __inline__ StgPtr allocate_UPD ( int n_words )
  68 {
  69    if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE)
  70       n_words = MIN_UPD_SIZE + sizeofW(StgHeader);
  71    return allocate(n_words);
  72 }
  73
  74 static __inline__ StgPtr allocate_NONUPD ( int n_words )
  75 {
  76    if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
  77       n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader);
  78    return allocate(n_words);
  79 }
  80
  81
  82 #ifdef INTERP_STATS
  83 /* Hacky stats, for tuning the interpreter ... */
  84 int it_unknown_entries[N_CLOSURE_TYPES];
  85 int it_total_unknown_entries;
  86 int it_total_entries;
  87
  88 int it_retto_BCO;
  89 int it_retto_UPDATE;
  90 int it_retto_other;
  91
  92 int it_slides;
  93 int it_insns;
  94 int it_BCO_entries;
  95
  96 int it_ofreq[27];
  97 int it_oofreq[27][27];
  98 int it_lastopc;
  99
 100 void interp_startup ( void )
 101 {
 102    int i, j;
 103    it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
 104    it_total_entries = it_total_unknown_entries = 0;
 105    for (i = 0; i < N_CLOSURE_TYPES; i++)
 106       it_unknown_entries[i] = 0;
 107    it_slides = it_insns = it_BCO_entries = 0;
 108    for (i = 0; i < 27; i++) it_ofreq[i] = 0;
 109    for (i = 0; i < 27; i++)
 110      for (j = 0; j < 27; j++)
 111         it_oofreq[i][j] = 0;
 112    it_lastopc = 0;
 113 }
 114
 115 void interp_shutdown ( void )
 116 {
 117    int i, j, k, o_max, i_max, j_max;
 118    fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ???)\n",
 119                    it_retto_BCO + it_retto_UPDATE + it_retto_other,
 120                    it_retto_BCO, it_retto_UPDATE, it_retto_other );
 121    fprintf(stderr, "%d total entries, %d unknown entries \n",
 122                    it_total_entries, it_total_unknown_entries);
 123    for (i = 0; i < N_CLOSURE_TYPES; i++) {
 124      if (it_unknown_entries[i] == 0) continue;
 125      fprintf(stderr, "   type %2d: unknown entries (%4.1f%%) == %d\n",
 126              i, 100.0 * ((double)it_unknown_entries[i]) /
 127                         ((double)it_total_unknown_entries),
 128              it_unknown_entries[i]);
 129    }
 130    fprintf(stderr, "%d insns, %d slides, %d BCO_entries\n",
 131                    it_insns, it_slides, it_BCO_entries);
 132    for (i = 0; i < 27; i++)
 133       fprintf(stderr, "opcode %2d got %d\n", i, it_ofreq[i] );
 134
 135    for (k = 1; k < 20; k++) {
 136       o_max = 0;
 137       i_max = j_max = 0;
 138       for (i = 0; i < 27; i++) {
 139          for (j = 0; j < 27; j++) {
 140             if (it_oofreq[i][j] > o_max) {
 141                o_max = it_oofreq[i][j];
 142                i_max = i; j_max = j;
 143             }
 144          }
 145       }
 146
 147       fprintf ( stderr, "%d:  count (%4.1f%%) %6d   is %d then %d\n",
 148                 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
 149                    i_max, j_max );
 150       it_oofreq[i_max][j_max] = 0;
 151
 152    }
 153 }
 154 #endif
 155
 156
 157 StgThreadReturnCode interpretBCO ( Capability* cap )
 158 {
 159    /* On entry, the closure to interpret is on the top of the
 160       stack. */
 161
 162    /* Use of register here is primarily to make it clear to compilers
 163       that these entities are non-aliasable.
 164    */
 165     register W_*              iSp;    /* local state -- stack pointer */
 166     register StgUpdateFrame*  iSu;    /* local state -- frame pointer */
 167     register StgPtr           iSpLim; /* local state -- stack lim pointer */
 168     register StgClosure*      obj;
 169
 170     LOAD_STACK_POINTERS;
 171
 172     /* We don't change this ... */
 173     iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
 174
 175     /* Main object-entering loop.  Object to be entered is on top of
 176        stack. */
 177     nextEnter:
 178
 179     obj = (StgClosure*)StackWord(0); iSp++;
 180
 181     nextEnter_obj:
 182
 183 #   ifdef INTERP_STATS
 184     it_total_entries++;
 185 #   endif
 186
 187     IF_DEBUG(evaluator,
 188              fprintf(stderr,
 189              "\n---------------------------------------------------------------\n");
 190              fprintf(stderr,"Entering: "); printObj(obj);
 191              fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu);
 192              fprintf(stderr, "\n" );
 193
 194              //      checkSanity(1);
 195              //             iSp--; StackWord(0) = obj;
 196              //             checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
 197              //             iSp++;
 198
 199              printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
 200              fprintf(stderr, "\n\n");
 201             );
 202
 203
 204
 205     switch ( get_itbl(obj)->type ) {
 206
 207        case INVALID_OBJECT:
 208                barf("Invalid object %p",(StgPtr)obj);
 209
 210 #      ifndef REFERENCE_INTERPRETER
 211
 212        case IND:
 213        case IND_OLDGEN:
 214        case IND_PERM:
 215        case IND_OLDGEN_PERM:
 216        case IND_STATIC:
 217        {
 218           obj = ((StgInd*)obj)->indirectee;
 219           goto nextEnter_obj;
 220        }
 221
 222        case CONSTR:
 223        case CONSTR_1_0:
 224        case CONSTR_0_1:
 225        case CONSTR_2_0:
 226        case CONSTR_1_1:
 227        case CONSTR_0_2:
 228        case CONSTR_INTLIKE:
 229        case CONSTR_CHARLIKE:
 230        case CONSTR_STATIC:
 231        case CONSTR_NOCAF_STATIC:
 232        nextEnter_obj_CONSTR:
 233        {
 234           StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(0);
 235           if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info) {
 236 #            ifdef INTERP_STATS
 237              it_retto_BCO++;
 238 #            endif
 239              /* Returning this constr to a BCO.  Push the constr on
 240                 the stack and enter the return continuation BCO, which
 241                 is immediately underneath ret_itbl. */
 242              StackWord(-1) = (W_)obj;
 243              obj = (StgClosure*)StackWord(1);
 244              iSp --;
 245              if (get_itbl(obj)->type == BCO)
 246                 goto nextEnter_obj_BCO; /* fast-track common case */
 247              else
 248                 goto nextEnter_obj; /* a safe fallback */
 249           } else
 250           if (ret_itbl == (StgInfoTable*)&stg_upd_frame_info) {
 251 #            ifdef INTERP_STATS
 252              it_retto_UPDATE++;
 253 #            endif
 254              /* Returning this constr to an update frame.  Do the
 255                 update and re-enter the constr. */
 256              ASSERT((W_*)iSu == iSp);
 257              UPD_IND(iSu->updatee, obj);
 258              iSu = iSu->link;
 259              iSp += sizeofW(StgUpdateFrame);
 260              goto nextEnter_obj_CONSTR;
 261           }
 262 #         ifdef INTERP_STATS
 263           else it_retto_other++;
 264 #         endif
 265           goto defer_to_sched;
 266        }
 267
 268        case AP_UPD:
 269        /* Copied from stg_AP_UPD_entry. */
 270        {
 271           nat i, words;
 272           StgAP_UPD *ap = (StgAP_UPD*)obj;
 273           words = ap->n_args;
 274
 275           /* Stack check.  If a stack overflow might occur, don't enter
 276              the closure; let the scheduler handle it instead. */
 277           if (iSp - (words+sizeofW(StgUpdateFrame)) < iSpLim)
 278              goto defer_to_sched;
 279
 280           /* Ok; we're safe.  Party on.  Push an update frame. */
 281           iSp -= sizeofW(StgUpdateFrame);
 282           {
 283               StgUpdateFrame *__frame;
 284               __frame = (StgUpdateFrame *)iSp;
 285               SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
 286               __frame->link = iSu;
 287               __frame->updatee = (StgClosure *)(ap);
 288               iSu = __frame;
 289           }
 290
 291           /* Reload the stack */
 292           iSp -= words;
 293           for (i=0; i < words; i++) StackWord(i) = (W_)ap->payload[i];
 294
 295           obj = (StgClosure*)ap->fun;
 296           goto nextEnter_obj;
 297        }
 298
 299        case PAP:
 300        /* Copied from stg_PAP_entry. */
 301        {
 302           nat     words, i;
 303           StgPAP* pap = (StgPAP *)obj;
 304
 305           /*
 306            * remove any update frames on the top of the stack, by just
 307            * performing the update here.
 308            */
 309           while ((W_)iSu - (W_)iSp == 0) {
 310
 311              switch (get_itbl(iSu)->type) {
 312
 313              case UPDATE_FRAME:
 314                 /* We're sitting on top of an update frame, so let's
 315                    do the business. */
 316                 UPD_IND(iSu->updatee, pap);
 317                 iSu = iSu->link;
 318                 iSp += sizeofW(StgUpdateFrame);
 319                 continue;
 320
 321              case SEQ_FRAME:
 322                 /* Too complicated ... adopt the Usual Solution. */
 323                 /* fprintf(stderr, "!!! SEQ frame in PAP update\n"); */
 324                 goto defer_to_sched;
 325
 326              case CATCH_FRAME:
 327                 /* can't happen, see stg_update_PAP */
 328                 barf("interpretBCO: PAP_entry: CATCH_FRAME");
 329
 330              default:
 331                 barf("interpretBCO: PAP_entry: strange activation record");
 332              }
 333           }
 334
 335           words = pap->n_args;
 336
 337           /* Stack check.  If a stack overflow might occur, don't enter
 338              the closure; let the scheduler handle it instead. */
 339           if (iSp - words < iSpLim)
 340              goto defer_to_sched;
 341
 342           /* Ok; safe. */
 343           iSp -= words;
 344           for (i=0; i < words; i++) StackWord(i) = (W_)pap->payload[i];
 345
 346           obj = (StgClosure*)pap->fun;
 347           goto nextEnter_obj;
 348        }
 349
 350 #      endif /* ndef REFERENCE_INTERPRETER */
 351
 352        case BCO:
 353        /* ---------------------------------------------------- */
 354        /* Start of the bytecode interpreter                    */
 355        /* ---------------------------------------------------- */
 356        nextEnter_obj_BCO:
 357 #      ifdef INTERP_STATS
 358        it_BCO_entries++;
 359 #      endif
 360        {
 361           int do_print_stack = 1;
 362           register int       bciPtr     = 1; /* instruction pointer */
 363           register StgBCO*   bco        = (StgBCO*)obj;
 364           register UShort*   instrs     = (UShort*)(&bco->instrs->payload[0]);
 365           register StgWord*  literals   = (StgWord*)(&bco->literals->payload[0]);
 366           register StgPtr*   ptrs       = (StgPtr*)(&bco->ptrs->payload[0]);
 367           register StgInfoTable** itbls = (StgInfoTable**)
 368                                              (&bco->itbls->payload[0]);
 369
 370           /* Heap check */
 371           if (doYouWantToGC()) {
 372              iSp--; StackWord(0) = (W_)bco;
 373              cap->rCurrentTSO->what_next = ThreadEnterInterp;
 374              RETURN(HeapOverflow);
 375           }
 376
 377           /* "Standard" stack check */
 378           if (iSp - (INTERP_STACK_CHECK_THRESH+1) < iSpLim) {
 379              iSp--;
 380              StackWord(0) = (W_)obj;
 381              cap->rCurrentTSO->what_next = ThreadEnterInterp;
 382              RETURN(StackOverflow);
 383           }
 384
 385           /* Context-switch check */
 386           if (context_switch) {
 387              iSp--;
 388              StackWord(0) = (W_)obj;
 389              cap->rCurrentTSO->what_next = ThreadEnterInterp;
 390              RETURN(ThreadYielding);
 391           }
 392
 393
 394 #         ifdef INTERP_STATS
 395           it_lastopc = 0; /* no opcode */
 396 #         endif
 397
 398           nextInsn:
 399
 400           ASSERT(bciPtr <= instrs[0]);
 401           IF_DEBUG(evaluator,
 402                    //if (do_print_stack) {
 403                    //fprintf(stderr, "\n-- BEGIN stack\n");
 404                    //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
 405                    //fprintf(stderr, "-- END stack\n\n");
 406                    //}
 407                    do_print_stack = 1;
 408                    fprintf(stderr,"iSp = %p   iSu = %p   pc = %d      ", iSp, iSu, bciPtr);
 409                    disInstr(bco,bciPtr);
 410                     if (0) { int i;
 411                              fprintf(stderr,"\n");
 412                              for (i = 8; i >= 0; i--)
 413                                 fprintf(stderr, "%d  %p\n", i, (StgPtr)(*(iSp+i)));
 414                              fprintf(stderr,"\n");
 415                            }
 416                     //if (do_print_stack) checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
 417                   );
 418
 419 #         ifdef INTERP_STATS
 420           it_insns++;
 421           ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
 422           it_ofreq[ (int)instrs[bciPtr] ] ++;
 423           it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
 424           it_lastopc = (int)instrs[bciPtr];
 425 #         endif
 426
 427           switch (BCO_NEXT) {
 428
 429               case bci_STKCHECK: {
 430                 /* An explicit stack check; we hope these will be
 431                    rare. */
 432                 int stk_words_reqd = BCO_NEXT + 1;
 433                 if (iSp - stk_words_reqd < iSpLim) {
 434                    iSp--;
 435                    StackWord(0) = (W_)obj;
 436                    cap->rCurrentTSO->what_next = ThreadEnterInterp;
 437                    RETURN(StackOverflow);
 438                 }
 439                 goto nextInsn;
 440               }
 441               case bci_ARGCHECK: {
 442                  int i;
 443                  StgPAP* pap;
 444                  int arg_words_reqd = BCO_NEXT;
 445                  int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
 446                  if (arg_words_avail >= arg_words_reqd) goto nextInsn;
 447
 448 #                ifndef REFERENCE_INTERPRETER
 449
 450                  /* Optimisation: if there are no args avail and the
 451                     t-o-s is an update frame, do the update, and
 452                     re-enter the object. */
 453                  if (arg_words_avail == 0
 454                     && get_itbl(iSu)->type == UPDATE_FRAME) {
 455                     UPD_IND(iSu->updatee, obj);
 456                     iSu = iSu->link;
 457                     iSp += sizeofW(StgUpdateFrame);
 458                     goto nextEnter_obj_BCO;
 459                  }
 460
 461 #                endif /* ndef REFERENCE_INTERPRETER */
 462
 463                  /* Handle arg check failure.  General case: copy the
 464                     spare args into a PAP frame. */
 465                  pap = (StgPAP*)allocate_UPD(PAP_sizeW(arg_words_avail));
 466                  SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
 467                  pap->n_args = arg_words_avail;
 468                  pap->fun = obj;
 469                  for (i = 0; i < arg_words_avail; i++)
 470                     pap->payload[i] = (StgClosure*)StackWord(i);
 471
 472                  /* Push on the stack and defer to the scheduler. */
 473                  iSp = (StgPtr)iSu;
 474                  iSp --;
 475                  StackWord(0) = (W_)pap;
 476                  IF_DEBUG(evaluator,
 477                           fprintf(stderr,"\tBuilt ");
 478                           printObj((StgClosure*)pap);
 479                          );
 480                  cap->rCurrentTSO->what_next = ThreadEnterGHC;
 481                  RETURN(ThreadYielding);
 482               }
 483               case bci_PUSH_L: {
 484                  int o1 = BCO_NEXT;
 485                  ASSERT((W_*)iSp+o1 < (W_*)iSu);
 486                  StackWord(-1) = StackWord(o1);
 487                  iSp--;
 488                  do_print_stack = 0;
 489                  goto nextInsn;
 490               }
 491               case bci_PUSH_LL: {
 492                  int o1 = BCO_NEXT;
 493                  int o2 = BCO_NEXT;
 494                  ASSERT((W_*)iSp+o1 < (W_*)iSu);
 495                  ASSERT((W_*)iSp+o2 < (W_*)iSu);
 496                  StackWord(-1) = StackWord(o1);
 497                  StackWord(-2) = StackWord(o2);
 498                  iSp -= 2;
 499                  goto nextInsn;
 500               }
 501               case bci_PUSH_LLL: {
 502                  int o1 = BCO_NEXT;
 503                  int o2 = BCO_NEXT;
 504                  int o3 = BCO_NEXT;
 505                  ASSERT((W_*)iSp+o1 < (W_*)iSu);
 506                  ASSERT((W_*)iSp+o2 < (W_*)iSu);
 507                  ASSERT((W_*)iSp+o3 < (W_*)iSu);
 508                  StackWord(-1) = StackWord(o1);
 509                  StackWord(-2) = StackWord(o2);
 510                  StackWord(-3) = StackWord(o3);
 511                  iSp -= 3;
 512                  goto nextInsn;
 513               }
 514               case bci_PUSH_G: {
 515                  int o1 = BCO_NEXT;
 516                  StackWord(-1) = BCO_PTR(o1);
 517                  iSp -= 1;
 518                  goto nextInsn;
 519               }
 520               case bci_PUSH_AS: {
 521                  int o_bco  = BCO_NEXT;
 522                  int o_itbl = BCO_NEXT;
 523                  StackWord(-2) = BCO_LIT(o_itbl);
 524                  StackWord(-1) = BCO_PTR(o_bco);
 525                  iSp -= 2;
 526                  goto nextInsn;
 527               }
 528               case bci_PUSH_UBX: {
 529                  int i;
 530                  int o_lits = BCO_NEXT;
 531                  int n_words = BCO_NEXT;
 532                  iSp -= n_words;
 533                  for (i = 0; i < n_words; i++)
 534                     StackWord(i) = BCO_LIT(o_lits+i);
 535                  do_print_stack = 0;
 536                  goto nextInsn;
 537               }
 538               case bci_PUSH_TAG: {
 539                  W_ tag = (W_)(BCO_NEXT);
 540                  StackWord(-1) = tag;
 541                  iSp --;
 542                  goto nextInsn;
 543               }
 544               case bci_SLIDE: {
 545                  int n  = BCO_NEXT;
 546                  int by = BCO_NEXT;
 547                  ASSERT((W_*)iSp+n+by <= (W_*)iSu);
 548                  /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
 549                  while(--n >= 0) {
 550                     StackWord(n+by) = StackWord(n);
 551                  }
 552                  iSp += by;
 553 #                ifdef INTERP_STATS
 554                  it_slides++;
 555 #                endif
 556                  goto nextInsn;
 557               }
 558               case bci_ALLOC: {
 559                  StgAP_UPD* ap;
 560                  int n_payload = BCO_NEXT - 1;
 561                  int request   = AP_sizeW(n_payload);
 562                  ap = (StgAP_UPD*)allocate_UPD(request);
 563                  StackWord(-1) = (W_)ap;
 564                  ap->n_args = n_payload;
 565                  SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM/*ToDo*/)
 566                  iSp --;
 567                  goto nextInsn;
 568               }
 569               case bci_MKAP: {
 570                  int i;
 571                  int stkoff = BCO_NEXT;
 572                  int n_payload = BCO_NEXT - 1;
 573                  StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
 574                  ASSERT((int)ap->n_args == n_payload);
 575                  ap->fun = (StgClosure*)StackWord(0);
 576                  for (i = 0; i < n_payload; i++)
 577                     ap->payload[i] = (StgClosure*)StackWord(i+1);
 578                  iSp += n_payload+1;
 579                  IF_DEBUG(evaluator,
 580                           fprintf(stderr,"\tBuilt ");
 581                           printObj((StgClosure*)ap);
 582                          );
 583                  goto nextInsn;
 584               }
 585               case bci_UNPACK: {
 586                  /* Unpack N ptr words from t.o.s constructor */
 587                  /* The common case ! */
 588                  int i;
 589                  int n_words = BCO_NEXT;
 590                  StgClosure* con = (StgClosure*)StackWord(0);
 591                  iSp -= n_words;
 592                  for (i = 0; i < n_words; i++)
 593                     StackWord(i) = (W_)con->payload[i];
 594                  goto nextInsn;
 595               }
 596               case bci_UPK_TAG: {
 597                  /* Unpack N (non-ptr) words from offset M in the
 598                     constructor K words down the stack, and then push
 599                     N as a tag, on top of it.  Slow but general; we
 600                     hope it will be the rare case. */
 601                  int i;
 602                  int n_words = BCO_NEXT;
 603                  int con_off = BCO_NEXT;
 604                  int stk_off = BCO_NEXT;
 605                  StgClosure* con = (StgClosure*)StackWord(stk_off);
 606                  iSp -= n_words;
 607                  for (i = 0; i < n_words; i++)
 608                     StackWord(i) = (W_)con->payload[con_off + i];
 609                  iSp --;
 610                  StackWord(0) = n_words;
 611                  goto nextInsn;
 612               }
 613               case bci_PACK: {
 614                  int i;
 615                  int o_itbl         = BCO_NEXT;
 616                  int n_words        = BCO_NEXT;
 617                  StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
 618                  int request        = CONSTR_sizeW( itbl->layout.payload.ptrs,
 619                                                     itbl->layout.payload.nptrs );
 620                  StgClosure* con = (StgClosure*)allocate_NONUPD(request);
 621                  ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
 622                  SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
 623                  for (i = 0; i < n_words; i++)
 624                     con->payload[i] = (StgClosure*)StackWord(i);
 625                  iSp += n_words;
 626                  iSp --;
 627                  StackWord(0) = (W_)con;
 628                  IF_DEBUG(evaluator,
 629                           fprintf(stderr,"\tBuilt ");
 630                           printObj((StgClosure*)con);
 631                          );
 632                  goto nextInsn;
 633               }
 634               case bci_TESTLT_P: {
 635                  int discr  = BCO_NEXT;
 636                  int failto = BCO_NEXT;
 637                  StgClosure* con = (StgClosure*)StackWord(0);
 638                  if (constrTag(con) >= discr)
 639                     bciPtr = failto;
 640                  goto nextInsn;
 641               }
 642               case bci_TESTEQ_P: {
 643                  int discr  = BCO_NEXT;
 644                  int failto = BCO_NEXT;
 645                  StgClosure* con = (StgClosure*)StackWord(0);
 646                  if (constrTag(con) != discr)
 647                     bciPtr = failto;
 648                  goto nextInsn;
 649               }
 650               case bci_TESTLT_I: {
 651                  /* The top thing on the stack should be a tagged int. */
 652                  int discr   = BCO_NEXT;
 653                  int failto  = BCO_NEXT;
 654                  I_ stackInt = (I_)StackWord(1);
 655                  ASSERT(1 == StackWord(0));
 656                  if (stackInt >= (I_)BCO_LIT(discr))
 657                     bciPtr = failto;
 658                  goto nextInsn;
 659               }
 660               case bci_TESTEQ_I: {
 661                  /* The top thing on the stack should be a tagged int. */
 662                  int discr   = BCO_NEXT;
 663                  int failto  = BCO_NEXT;
 664                  I_ stackInt = (I_)StackWord(1);
 665                  ASSERT(1 == StackWord(0));
 666                  if (stackInt != (I_)BCO_LIT(discr))
 667                     bciPtr = failto;
 668                  goto nextInsn;
 669               }
 670               case bci_TESTLT_D: {
 671                  /* The top thing on the stack should be a tagged double. */
 672                  int discr   = BCO_NEXT;
 673                  int failto  = BCO_NEXT;
 674                  StgDouble stackDbl, discrDbl;
 675                  ASSERT(sizeofW(StgDouble) == StackWord(0));
 676                  stackDbl = PK_DBL( & StackWord(1) );
 677                  discrDbl = PK_DBL( & BCO_LIT(discr) );
 678                  if (stackDbl >= discrDbl)
 679                     bciPtr = failto;
 680                  goto nextInsn;
 681               }
 682               case bci_TESTEQ_D: {
 683                  /* The top thing on the stack should be a tagged double. */
 684                  int discr   = BCO_NEXT;
 685                  int failto  = BCO_NEXT;
 686                  StgDouble stackDbl, discrDbl;
 687                  ASSERT(sizeofW(StgDouble) == StackWord(0));
 688                  stackDbl = PK_DBL( & StackWord(1) );
 689                  discrDbl = PK_DBL( & BCO_LIT(discr) );
 690                  if (stackDbl != discrDbl)
 691                     bciPtr = failto;
 692                  goto nextInsn;
 693               }
 694               case bci_TESTLT_F: {
 695                  /* The top thing on the stack should be a tagged float. */
 696                  int discr   = BCO_NEXT;
 697                  int failto  = BCO_NEXT;
 698                  StgFloat stackFlt, discrFlt;
 699                  ASSERT(sizeofW(StgFloat) == StackWord(0));
 700                  stackFlt = PK_FLT( & StackWord(1) );
 701                  discrFlt = PK_FLT( & BCO_LIT(discr) );
 702                  if (stackFlt >= discrFlt)
 703                     bciPtr = failto;
 704                  goto nextInsn;
 705               }
 706               case bci_TESTEQ_F: {
 707                  /* The top thing on the stack should be a tagged float. */
 708                  int discr   = BCO_NEXT;
 709                  int failto  = BCO_NEXT;
 710                  StgFloat stackFlt, discrFlt;
 711                  ASSERT(sizeofW(StgFloat) == StackWord(0));
 712                  stackFlt = PK_FLT( & StackWord(1) );
 713                  discrFlt = PK_FLT( & BCO_LIT(discr) );
 714                  if (stackFlt != discrFlt)
 715                     bciPtr = failto;
 716                  goto nextInsn;
 717               }
 718
 719               /* Control-flow ish things */
 720               case bci_ENTER: {
 721                  goto nextEnter;
 722               }
 723               case bci_RETURN: {
 724                  /* Figure out whether returning to interpreted or
 725                     compiled code. */
 726                  int           o_itoc_itbl = BCO_NEXT;
 727                  int           tag         = StackWord(0);
 728                  StgInfoTable* ret_itbl    = (StgInfoTable*)StackWord(tag +1);
 729                  ASSERT(tag <= 2); /* say ... */
 730                  if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
 731                      || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
 732                      || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
 733                      || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info
 734                      || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_V_info) {
 735                      /* Returning to interpreted code.  Interpret the BCO
 736                         immediately underneath the itbl. */
 737                      StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
 738                      iSp --;
 739                      StackWord(0) = (W_)ret_bco;
 740                      goto nextEnter;
 741                  } else {
 742                      /* Returning (unboxed value) to compiled code.
 743                         Replace tag with a suitable itbl and ask the
 744                         scheduler to run it.  The itbl code will copy
 745                         the TOS value into R1/F1/D1 and do a standard
 746                         compiled-code return. */
 747                      StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
 748                      if (magic_itbl != NULL) {
 749                         StackWord(0) = (W_)magic_itbl;
 750                         cap->rCurrentTSO->what_next = ThreadRunGHC;
 751                         RETURN(ThreadYielding);
 752                      } else {
 753                         /* Special case -- returning a VoidRep to
 754                            compiled code.  T.O.S is the VoidRep tag,
 755                            and underneath is the return itbl.  Zap the
 756                            tag and enter the itbl. */
 757                         ASSERT(StackWord(0) == (W_)NULL);
 758                         iSp ++;
 759                         cap->rCurrentTSO->what_next = ThreadRunGHC;
 760                         RETURN(ThreadYielding);
 761                      }
 762                  }
 763               }
 764
 765               case bci_JMP: {
 766                  /* BCO_NEXT modifies bciPtr, so be conservative. */
 767                  int nextpc = BCO_NEXT;
 768                  bciPtr     = nextpc;
 769                  goto nextInsn;
 770               }
 771               case bci_CASEFAIL:
 772                  barf("interpretBCO: hit a CASEFAIL");
 773
 774               /* Errors */
 775               default:
 776                  barf("interpretBCO: unknown or unimplemented opcode");
 777
 778           } /* switch on opcode */
 779
 780           barf("interpretBCO: fell off end of insn loop");
 781
 782        }
 783        /* ---------------------------------------------------- */
 784        /* End of the bytecode interpreter                      */
 785        /* ---------------------------------------------------- */
 786
 787        defer_to_sched:
 788        default: {
 789 #         ifdef INTERP_STATS
 790           { int j = get_itbl(obj)->type;
 791             ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
 792             it_unknown_entries[j]++;
 793             it_total_unknown_entries++;
 794           }
 795 #         endif
 796
 797           /* Can't handle this object; yield to sched. */
 798           IF_DEBUG(evaluator,
 799                    fprintf(stderr, "entering unknown closure -- yielding to sched\n");
 800                    printObj(obj);
 801                   );
 802           iSp--; StackWord(0) = (W_)obj;
 803           cap->rCurrentTSO->what_next = ThreadEnterGHC;
 804           RETURN(ThreadYielding);
 805        }
 806     } /* switch on object kind */
 807
 808     barf("fallen off end of object-type switch in interpretBCO()");
 809 }