ghc/rts/Interpreter.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * Bytecode evaluator
   4  *
   5  * Copyright (c) 1994-2000.
   6  *
   7  * $RCSfile: Interpreter.c,v $
   8  * $Revision: 1.28 $
   9  * $Date: 2001/08/09 11:19:16 $
  10  * ---------------------------------------------------------------------------*/
  11
  12 #include "Rts.h"
  13 #include "RtsAPI.h"
  14 #include "RtsUtils.h"
  15 #include "Closures.h"
  16 #include "TSO.h"
  17 #include "Schedule.h"
  18 #include "RtsFlags.h"
  19 #include "Storage.h"
  20 #include "Updates.h"
  21
  22 #include "Bytecodes.h"
  23 #include "Printer.h"
  24 #include "Disassembler.h"
  25 #include "Interpreter.h"
  26
  27
  28 /* --------------------------------------------------------------------------
  29  * The new bytecode interpreter
  30  * ------------------------------------------------------------------------*/
  31
  32 /* The interpreter can be compiled so it just interprets BCOs and
  33    hands literally everything else to the scheduler.  This gives a
  34    "reference interpreter" which is correct but slow -- useful for
  35    debugging.  By default, we handle certain closures specially so as
  36    to dramatically cut down on the number of deferrals to the
  37    scheduler.  Ie normally you don't want REFERENCE_INTERPRETER to be
  38    defined. */
  39
  40 #define REFERENCE_INTERPRETER
  41
  42 /* Gather stats about entry, opcode, opcode-pair frequencies.  For
  43    tuning the interpreter. */
  44
  45 /* #define INTERP_STATS */
  46
  47
  48
  49 /* iSp points to the lowest live word on the stack. */
  50
  51 #define StackWord(n)  iSp[n]
  52 #define BCO_NEXT      instrs[bciPtr++]
  53 #define BCO_PTR(n)    (W_)ptrs[n]
  54 #define BCO_LIT(n)    (W_)literals[n]
  55 #define BCO_ITBL(n)   itbls[n]
  56
  57 #define LOAD_STACK_POINTERS          \
  58     iSp = cap->rCurrentTSO->sp;      \
  59     iSu = cap->rCurrentTSO->su;      \
  60     /* We don't change this ... */   \
  61     iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
  62
  63
  64 #define SAVE_STACK_POINTERS          \
  65     cap->rCurrentTSO->sp = iSp;      \
  66     cap->rCurrentTSO->su = iSu;
  67
  68 #define RETURN(retcode)              \
  69    SAVE_STACK_POINTERS; return retcode;
  70
  71
  72 static __inline__ StgPtr allocate_UPD ( int n_words )
  73 {
  74    if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE)
  75       n_words = MIN_UPD_SIZE + sizeofW(StgHeader);
  76    return allocate(n_words);
  77 }
  78
  79 static __inline__ StgPtr allocate_NONUPD ( int n_words )
  80 {
  81    if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
  82       n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader);
  83    return allocate(n_words);
  84 }
  85
  86
  87 #ifdef INTERP_STATS
  88 /* Hacky stats, for tuning the interpreter ... */
  89 int it_unknown_entries[N_CLOSURE_TYPES];
  90 int it_total_unknown_entries;
  91 int it_total_entries;
  92
  93 int it_retto_BCO;
  94 int it_retto_UPDATE;
  95 int it_retto_other;
  96
  97 int it_slides;
  98 int it_insns;
  99 int it_BCO_entries;
 100
 101 int it_ofreq[27];
 102 int it_oofreq[27][27];
 103 int it_lastopc;
 104
 105 void interp_startup ( void )
 106 {
 107    int i, j;
 108    it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
 109    it_total_entries = it_total_unknown_entries = 0;
 110    for (i = 0; i < N_CLOSURE_TYPES; i++)
 111       it_unknown_entries[i] = 0;
 112    it_slides = it_insns = it_BCO_entries = 0;
 113    for (i = 0; i < 27; i++) it_ofreq[i] = 0;
 114    for (i = 0; i < 27; i++)
 115      for (j = 0; j < 27; j++)
 116         it_oofreq[i][j] = 0;
 117    it_lastopc = 0;
 118 }
 119
 120 void interp_shutdown ( void )
 121 {
 122    int i, j, k, o_max, i_max, j_max;
 123    fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
 124                    it_retto_BCO + it_retto_UPDATE + it_retto_other,
 125                    it_retto_BCO, it_retto_UPDATE, it_retto_other );
 126    fprintf(stderr, "%d total entries, %d unknown entries \n",
 127                    it_total_entries, it_total_unknown_entries);
 128    for (i = 0; i < N_CLOSURE_TYPES; i++) {
 129      if (it_unknown_entries[i] == 0) continue;
 130      fprintf(stderr, "   type %2d: unknown entries (%4.1f%%) == %d\n",
 131              i, 100.0 * ((double)it_unknown_entries[i]) /
 132                         ((double)it_total_unknown_entries),
 133              it_unknown_entries[i]);
 134    }
 135    fprintf(stderr, "%d insns, %d slides, %d BCO_entries\n",
 136                    it_insns, it_slides, it_BCO_entries);
 137    for (i = 0; i < 27; i++)
 138       fprintf(stderr, "opcode %2d got %d\n", i, it_ofreq[i] );
 139
 140    for (k = 1; k < 20; k++) {
 141       o_max = 0;
 142       i_max = j_max = 0;
 143       for (i = 0; i < 27; i++) {
 144          for (j = 0; j < 27; j++) {
 145             if (it_oofreq[i][j] > o_max) {
 146                o_max = it_oofreq[i][j];
 147                i_max = i; j_max = j;
 148             }
 149          }
 150       }
 151
 152       fprintf ( stderr, "%d:  count (%4.1f%%) %6d   is %d then %d\n",
 153                 k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
 154                    i_max, j_max );
 155       it_oofreq[i_max][j_max] = 0;
 156
 157    }
 158 }
 159 #endif
 160
 161
 162 StgThreadReturnCode interpretBCO ( Capability* cap )
 163 {
 164    /* On entry, the closure to interpret is on the top of the
 165       stack. */
 166
 167    /* Use of register here is primarily to make it clear to compilers
 168       that these entities are non-aliasable.
 169    */
 170     register W_*              iSp;    /* local state -- stack pointer */
 171     register StgUpdateFrame*  iSu;    /* local state -- frame pointer */
 172     register StgPtr           iSpLim; /* local state -- stack lim pointer */
 173     register StgClosure*      obj;
 174
 175     LOAD_STACK_POINTERS;
 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           /* Context-switch check */
 388           if (context_switch) {
 389              iSp--;
 390              StackWord(0) = (W_)obj;
 391              cap->rCurrentTSO->what_next = ThreadEnterInterp;
 392              RETURN(ThreadYielding);
 393           }
 394
 395
 396 #         ifdef INTERP_STATS
 397           it_lastopc = 0; /* no opcode */
 398 #         endif
 399
 400           nextInsn:
 401
 402           ASSERT(bciPtr <= instrs[0]);
 403           IF_DEBUG(evaluator,
 404                    //if (do_print_stack) {
 405                    //fprintf(stderr, "\n-- BEGIN stack\n");
 406                    //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
 407                    //fprintf(stderr, "-- END stack\n\n");
 408                    //}
 409                    do_print_stack = 1;
 410                    fprintf(stderr,"iSp = %p   iSu = %p   pc = %d      ", iSp, iSu, bciPtr);
 411                    disInstr(bco,bciPtr);
 412                     if (0) { int i;
 413                              fprintf(stderr,"\n");
 414                              for (i = 8; i >= 0; i--)
 415                                 fprintf(stderr, "%d  %p\n", i, (StgPtr)(*(iSp+i)));
 416                              fprintf(stderr,"\n");
 417                            }
 418                     //if (do_print_stack) checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu);
 419                   );
 420
 421 #         ifdef INTERP_STATS
 422           it_insns++;
 423           ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
 424           it_ofreq[ (int)instrs[bciPtr] ] ++;
 425           it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
 426           it_lastopc = (int)instrs[bciPtr];
 427 #         endif
 428
 429           switch (BCO_NEXT) {
 430
 431               case bci_STKCHECK: {
 432                 /* An explicit stack check; we hope these will be
 433                    rare. */
 434                 int stk_words_reqd = BCO_NEXT + 1;
 435                 if (iSp - stk_words_reqd < iSpLim) {
 436                    iSp--;
 437                    StackWord(0) = (W_)obj;
 438                    cap->rCurrentTSO->what_next = ThreadEnterInterp;
 439                    RETURN(StackOverflow);
 440                 }
 441                 goto nextInsn;
 442               }
 443               case bci_ARGCHECK: {
 444                  int i;
 445                  StgPAP* pap;
 446                  int arg_words_reqd = BCO_NEXT;
 447                  int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
 448                  if (arg_words_avail >= arg_words_reqd) goto nextInsn;
 449
 450 #                ifndef REFERENCE_INTERPRETER
 451
 452                  /* Optimisation: if there are no args avail and the
 453                     t-o-s is an update frame, do the update, and
 454                     re-enter the object. */
 455                  if (arg_words_avail == 0
 456                     && get_itbl(iSu)->type == UPDATE_FRAME) {
 457                     UPD_IND(iSu->updatee, obj);
 458                     iSu = iSu->link;
 459                     iSp += sizeofW(StgUpdateFrame);
 460                     goto nextEnter_obj_BCO;
 461                  }
 462
 463 #                endif /* ndef REFERENCE_INTERPRETER */
 464
 465                  /* Handle arg check failure.  General case: copy the
 466                     spare args into a PAP frame. */
 467                  pap = (StgPAP*)allocate_UPD(PAP_sizeW(arg_words_avail));
 468                  SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
 469                  pap->n_args = arg_words_avail;
 470                  pap->fun = obj;
 471                  for (i = 0; i < arg_words_avail; i++)
 472                     pap->payload[i] = (StgClosure*)StackWord(i);
 473
 474                  /* Push on the stack and defer to the scheduler. */
 475                  iSp = (StgPtr)iSu;
 476                  iSp --;
 477                  StackWord(0) = (W_)pap;
 478                  IF_DEBUG(evaluator,
 479                           fprintf(stderr,"\tBuilt ");
 480                           printObj((StgClosure*)pap);
 481                          );
 482                  cap->rCurrentTSO->what_next = ThreadEnterGHC;
 483                  RETURN(ThreadYielding);
 484               }
 485               case bci_PUSH_L: {
 486                  int o1 = BCO_NEXT;
 487                  ASSERT((W_*)iSp+o1 < (W_*)iSu);
 488                  StackWord(-1) = StackWord(o1);
 489                  iSp--;
 490                  do_print_stack = 0;
 491                  goto nextInsn;
 492               }
 493               case bci_PUSH_LL: {
 494                  int o1 = BCO_NEXT;
 495                  int o2 = BCO_NEXT;
 496                  ASSERT((W_*)iSp+o1 < (W_*)iSu);
 497                  ASSERT((W_*)iSp+o2 < (W_*)iSu);
 498                  StackWord(-1) = StackWord(o1);
 499                  StackWord(-2) = StackWord(o2);
 500                  iSp -= 2;
 501                  goto nextInsn;
 502               }
 503               case bci_PUSH_LLL: {
 504                  int o1 = BCO_NEXT;
 505                  int o2 = BCO_NEXT;
 506                  int o3 = BCO_NEXT;
 507                  ASSERT((W_*)iSp+o1 < (W_*)iSu);
 508                  ASSERT((W_*)iSp+o2 < (W_*)iSu);
 509                  ASSERT((W_*)iSp+o3 < (W_*)iSu);
 510                  StackWord(-1) = StackWord(o1);
 511                  StackWord(-2) = StackWord(o2);
 512                  StackWord(-3) = StackWord(o3);
 513                  iSp -= 3;
 514                  goto nextInsn;
 515               }
 516               case bci_PUSH_G: {
 517                  int o1 = BCO_NEXT;
 518                  StackWord(-1) = BCO_PTR(o1);
 519                  iSp -= 1;
 520                  goto nextInsn;
 521               }
 522               case bci_PUSH_AS: {
 523                  int o_bco  = BCO_NEXT;
 524                  int o_itbl = BCO_NEXT;
 525                  StackWord(-2) = BCO_LIT(o_itbl);
 526                  StackWord(-1) = BCO_PTR(o_bco);
 527                  iSp -= 2;
 528                  goto nextInsn;
 529               }
 530               case bci_PUSH_UBX: {
 531                  int i;
 532                  int o_lits = BCO_NEXT;
 533                  int n_words = BCO_NEXT;
 534                  iSp -= n_words;
 535                  for (i = 0; i < n_words; i++)
 536                     StackWord(i) = BCO_LIT(o_lits+i);
 537                  do_print_stack = 0;
 538                  goto nextInsn;
 539               }
 540               case bci_PUSH_TAG: {
 541                  W_ tag = (W_)(BCO_NEXT);
 542                  StackWord(-1) = tag;
 543                  iSp --;
 544                  goto nextInsn;
 545               }
 546               case bci_SLIDE: {
 547                  int n  = BCO_NEXT;
 548                  int by = BCO_NEXT;
 549                  ASSERT((W_*)iSp+n+by <= (W_*)iSu);
 550                  /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
 551                  while(--n >= 0) {
 552                     StackWord(n+by) = StackWord(n);
 553                  }
 554                  iSp += by;
 555 #                ifdef INTERP_STATS
 556                  it_slides++;
 557 #                endif
 558                  goto nextInsn;
 559               }
 560               case bci_ALLOC: {
 561                  StgAP_UPD* ap;
 562                  int n_payload = BCO_NEXT - 1;
 563                  int request   = AP_sizeW(n_payload);
 564                  ap = (StgAP_UPD*)allocate_UPD(request);
 565                  StackWord(-1) = (W_)ap;
 566                  ap->n_args = n_payload;
 567                  SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM/*ToDo*/)
 568                  iSp --;
 569                  goto nextInsn;
 570               }
 571               case bci_MKAP: {
 572                  int i;
 573                  int stkoff = BCO_NEXT;
 574                  int n_payload = BCO_NEXT - 1;
 575                  StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
 576                  ASSERT((int)ap->n_args == n_payload);
 577                  ap->fun = (StgClosure*)StackWord(0);
 578                  for (i = 0; i < n_payload; i++)
 579                     ap->payload[i] = (StgClosure*)StackWord(i+1);
 580                  iSp += n_payload+1;
 581                  IF_DEBUG(evaluator,
 582                           fprintf(stderr,"\tBuilt ");
 583                           printObj((StgClosure*)ap);
 584                          );
 585                  goto nextInsn;
 586               }
 587               case bci_UNPACK: {
 588                  /* Unpack N ptr words from t.o.s constructor */
 589                  /* The common case ! */
 590                  int i;
 591                  int n_words = BCO_NEXT;
 592                  StgClosure* con = (StgClosure*)StackWord(0);
 593                  iSp -= n_words;
 594                  for (i = 0; i < n_words; i++)
 595                     StackWord(i) = (W_)con->payload[i];
 596                  goto nextInsn;
 597               }
 598               case bci_UPK_TAG: {
 599                  /* Unpack N (non-ptr) words from offset M in the
 600                     constructor K words down the stack, and then push
 601                     N as a tag, on top of it.  Slow but general; we
 602                     hope it will be the rare case. */
 603                  int i;
 604                  int n_words = BCO_NEXT;
 605                  int con_off = BCO_NEXT;
 606                  int stk_off = BCO_NEXT;
 607                  StgClosure* con = (StgClosure*)StackWord(stk_off);
 608                  iSp -= n_words;
 609                  for (i = 0; i < n_words; i++)
 610                     StackWord(i) = (W_)con->payload[con_off + i];
 611                  iSp --;
 612                  StackWord(0) = n_words;
 613                  goto nextInsn;
 614               }
 615               case bci_PACK: {
 616                  int i;
 617                  int o_itbl         = BCO_NEXT;
 618                  int n_words        = BCO_NEXT;
 619                  StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
 620                  int request        = CONSTR_sizeW( itbl->layout.payload.ptrs,
 621                                                     itbl->layout.payload.nptrs );
 622                  StgClosure* con = (StgClosure*)allocate_NONUPD(request);
 623                  ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
 624                  SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
 625                  for (i = 0; i < n_words; i++)
 626                     con->payload[i] = (StgClosure*)StackWord(i);
 627                  iSp += n_words;
 628                  iSp --;
 629                  StackWord(0) = (W_)con;
 630                  IF_DEBUG(evaluator,
 631                           fprintf(stderr,"\tBuilt ");
 632                           printObj((StgClosure*)con);
 633                          );
 634                  goto nextInsn;
 635               }
 636               case bci_TESTLT_P: {
 637                  int discr  = BCO_NEXT;
 638                  int failto = BCO_NEXT;
 639                  StgClosure* con = (StgClosure*)StackWord(0);
 640                  if (constrTag(con) >= discr)
 641                     bciPtr = failto;
 642                  goto nextInsn;
 643               }
 644               case bci_TESTEQ_P: {
 645                  int discr  = BCO_NEXT;
 646                  int failto = BCO_NEXT;
 647                  StgClosure* con = (StgClosure*)StackWord(0);
 648                  if (constrTag(con) != discr)
 649                     bciPtr = failto;
 650                  goto nextInsn;
 651               }
 652               case bci_TESTLT_I: {
 653                  /* The top thing on the stack should be a tagged int. */
 654                  int discr   = BCO_NEXT;
 655                  int failto  = BCO_NEXT;
 656                  I_ stackInt = (I_)StackWord(1);
 657                  ASSERT(1 == StackWord(0));
 658                  if (stackInt >= (I_)BCO_LIT(discr))
 659                     bciPtr = failto;
 660                  goto nextInsn;
 661               }
 662               case bci_TESTEQ_I: {
 663                  /* The top thing on the stack should be a tagged int. */
 664                  int discr   = BCO_NEXT;
 665                  int failto  = BCO_NEXT;
 666                  I_ stackInt = (I_)StackWord(1);
 667                  ASSERT(1 == StackWord(0));
 668                  if (stackInt != (I_)BCO_LIT(discr))
 669                     bciPtr = failto;
 670                  goto nextInsn;
 671               }
 672               case bci_TESTLT_D: {
 673                  /* The top thing on the stack should be a tagged double. */
 674                  int discr   = BCO_NEXT;
 675                  int failto  = BCO_NEXT;
 676                  StgDouble stackDbl, discrDbl;
 677                  ASSERT(sizeofW(StgDouble) == StackWord(0));
 678                  stackDbl = PK_DBL( & StackWord(1) );
 679                  discrDbl = PK_DBL( & BCO_LIT(discr) );
 680                  if (stackDbl >= discrDbl)
 681                     bciPtr = failto;
 682                  goto nextInsn;
 683               }
 684               case bci_TESTEQ_D: {
 685                  /* The top thing on the stack should be a tagged double. */
 686                  int discr   = BCO_NEXT;
 687                  int failto  = BCO_NEXT;
 688                  StgDouble stackDbl, discrDbl;
 689                  ASSERT(sizeofW(StgDouble) == StackWord(0));
 690                  stackDbl = PK_DBL( & StackWord(1) );
 691                  discrDbl = PK_DBL( & BCO_LIT(discr) );
 692                  if (stackDbl != discrDbl)
 693                     bciPtr = failto;
 694                  goto nextInsn;
 695               }
 696               case bci_TESTLT_F: {
 697                  /* The top thing on the stack should be a tagged float. */
 698                  int discr   = BCO_NEXT;
 699                  int failto  = BCO_NEXT;
 700                  StgFloat stackFlt, discrFlt;
 701                  ASSERT(sizeofW(StgFloat) == StackWord(0));
 702                  stackFlt = PK_FLT( & StackWord(1) );
 703                  discrFlt = PK_FLT( & BCO_LIT(discr) );
 704                  if (stackFlt >= discrFlt)
 705                     bciPtr = failto;
 706                  goto nextInsn;
 707               }
 708               case bci_TESTEQ_F: {
 709                  /* The top thing on the stack should be a tagged float. */
 710                  int discr   = BCO_NEXT;
 711                  int failto  = BCO_NEXT;
 712                  StgFloat stackFlt, discrFlt;
 713                  ASSERT(sizeofW(StgFloat) == StackWord(0));
 714                  stackFlt = PK_FLT( & StackWord(1) );
 715                  discrFlt = PK_FLT( & BCO_LIT(discr) );
 716                  if (stackFlt != discrFlt)
 717                     bciPtr = failto;
 718                  goto nextInsn;
 719               }
 720
 721               /* Control-flow ish things */
 722               case bci_ENTER: {
 723                  goto nextEnter;
 724               }
 725               case bci_RETURN: {
 726                  /* Figure out whether returning to interpreted or
 727                     compiled code. */
 728                  int           o_itoc_itbl = BCO_NEXT;
 729                  int           tag         = StackWord(0);
 730                  StgInfoTable* ret_itbl    = (StgInfoTable*)StackWord(tag +1);
 731                  ASSERT(tag <= 2); /* say ... */
 732                  if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
 733                      || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
 734                      || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
 735                      || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info
 736                      || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_V_info) {
 737                      /* Returning to interpreted code.  Interpret the BCO
 738                         immediately underneath the itbl. */
 739                      StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
 740                      iSp --;
 741                      StackWord(0) = (W_)ret_bco;
 742                      goto nextEnter;
 743                  } else {
 744                      /* Returning (unboxed value) to compiled code.
 745                         Replace tag with a suitable itbl and ask the
 746                         scheduler to run it.  The itbl code will copy
 747                         the TOS value into R1/F1/D1 and do a standard
 748                         compiled-code return. */
 749                      StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
 750                      if (magic_itbl != NULL) {
 751                         StackWord(0) = (W_)magic_itbl;
 752                         cap->rCurrentTSO->what_next = ThreadRunGHC;
 753                         RETURN(ThreadYielding);
 754                      } else {
 755                         /* Special case -- returning a VoidRep to
 756                            compiled code.  T.O.S is the VoidRep tag,
 757                            and underneath is the return itbl.  Zap the
 758                            tag and enter the itbl. */
 759                         ASSERT(StackWord(0) == (W_)NULL);
 760                         iSp ++;
 761                         cap->rCurrentTSO->what_next = ThreadRunGHC;
 762                         RETURN(ThreadYielding);
 763                      }
 764                  }
 765               }
 766               case bci_SWIZZLE: {
 767                  int stkoff = BCO_NEXT;
 768                  signed short n = (signed short)(BCO_NEXT);
 769                  StackWord(stkoff) += (W_)n;
 770                  goto nextInsn;
 771               }
 772               case bci_CCALL: {
 773                  StgInt tok;
 774                  int o_itbl                = BCO_NEXT;
 775                  void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
 776                  SAVE_STACK_POINTERS;
 777                  tok = suspendThread(cap);
 778                  marshall_fn ( (void*)(& StackWord(0) ) );
 779                  cap = resumeThread(tok);
 780                  LOAD_STACK_POINTERS;
 781                  goto nextInsn;
 782               }
 783               case bci_JMP: {
 784                  /* BCO_NEXT modifies bciPtr, so be conservative. */
 785                  int nextpc = BCO_NEXT;
 786                  bciPtr     = nextpc;
 787                  goto nextInsn;
 788               }
 789               case bci_CASEFAIL:
 790                  barf("interpretBCO: hit a CASEFAIL");
 791
 792               /* Errors */
 793               default:
 794                  barf("interpretBCO: unknown or unimplemented opcode");
 795
 796           } /* switch on opcode */
 797
 798           barf("interpretBCO: fell off end of insn loop");
 799
 800        }
 801        /* ---------------------------------------------------- */
 802        /* End of the bytecode interpreter                      */
 803        /* ---------------------------------------------------- */
 804
 805        defer_to_sched:
 806        default: {
 807 #         ifdef INTERP_STATS
 808           { int j = get_itbl(obj)->type;
 809             ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
 810             it_unknown_entries[j]++;
 811             it_total_unknown_entries++;
 812           }
 813 #         endif
 814
 815           /* Can't handle this object; yield to sched. */
 816           IF_DEBUG(evaluator,
 817                    fprintf(stderr, "entering unknown closure -- yielding to sched\n");
 818                    printObj(obj);
 819                   );
 820           iSp--; StackWord(0) = (W_)obj;
 821           cap->rCurrentTSO->what_next = ThreadEnterGHC;
 822           RETURN(ThreadYielding);
 823        }
 824     } /* switch on object kind */
 825
 826     barf("fallen off end of object-type switch in interpretBCO()");
 827 }