ghc/rts/Interpreter.c

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