ghc/rts/Interpreter.c

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