ghc/rts/Interpreter.c

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