ghc/interpreter/optimise.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Optimiser
   4  *
   5  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   6  * All rights reserved. See NOTICE for details and conditions of use etc...
   7  * Hugs version 1.4, December 1997
   8  *
   9  * $RCSfile: optimise.c,v $
  10  * $Revision: 1.6 $
  11  * $Date: 1999/07/06 15:24:39 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "backend.h"
  17 #include "connect.h"
  18 #include "errors.h"
  19 #include "link.h"
  20 #include "Assembler.h"
  21
  22 /* #define DEBUG_OPTIMISE */
  23
  24 extern void print ( Cell, Int );
  25
  26 /* --------------------------------------------------------------------------
  27  * Local functions
  28  * ------------------------------------------------------------------------*/
  29
  30 Int nLoopBreakersInlined;
  31 Int nLetvarsInlined;
  32 Int nTopvarsInlined;
  33 Int nCaseOfLet;
  34 Int nCaseOfCase;
  35 Int nCaseOfPrimCase;
  36 Int nCaseOfCon;
  37 Int nCaseOfOuter;
  38 Int nLetBindsDropped;
  39 Int nLetrecGroupsDropped;
  40 Int nLambdasMerged;
  41 Int nCaseDefaultsDropped;
  42 Int nAppsMerged;
  43 Int nLetsFloatedOutOfFn;
  44 Int nLetsFloatedIntoCase;
  45 Int nCasesFloatedOutOfFn;
  46 Int nBetaReductions;
  47
  48 Int nTotSizeIn;
  49 Int nTotSizeOut;
  50
  51 Int  rDepth;
  52 Bool copyInTopvar;
  53 Bool inDBuilder;
  54
  55 static void local optimiseTopBind( StgVar v );
  56
  57 typedef
  58    enum {
  59       CTX_SCRUT,
  60       CTX_OTHER
  61    }
  62    InlineCtx;
  63
  64 /* Exactly like whatIs except it avoids a fn call for STG tags */
  65 #define whatIsStg(xx) ((isPair(xx) ? (isTag(fst(xx)) ? fst(xx) : AP) : whatIs(xx)))
  66
  67
  68 /* --------------------------------------------------------------------------
  69  * Transformation stats
  70  * ------------------------------------------------------------------------*/
  71
  72 void initOptStats ( void )
  73 {
  74    nLoopBreakersInlined  = 0;
  75    nLetvarsInlined       = 0;
  76    nTopvarsInlined       = 0;
  77    nCaseOfLet            = 0;
  78    nCaseOfCase           = 0;
  79    nCaseOfPrimCase       = 0;
  80    nCaseOfCon            = 0;
  81    nCaseOfOuter          = 0;
  82    nLetBindsDropped      = 0;
  83    nLetrecGroupsDropped  = 0;
  84    nLambdasMerged        = 0;
  85    nCaseDefaultsDropped  = 0;
  86    nAppsMerged           = 0;
  87    nLetsFloatedOutOfFn   = 0;
  88    nLetsFloatedIntoCase  = 0;
  89    nCasesFloatedOutOfFn  = 0;
  90    nBetaReductions       = 0;
  91    nTotSizeIn            = 0;
  92    nTotSizeOut           = 0;
  93 }
  94
  95 void printOptStats ( FILE* f )
  96 {
  97    fflush(stdout); fflush(stderr); fflush(f);
  98    fprintf(f, "\n\n" );
  99    fprintf(f, "Inlining:     topvar %-5d        letvar %-5d"
 100               "      loopbrkr %-5d      betaredn %-5d\n",
 101               nTopvarsInlined, nLetvarsInlined, nLoopBreakersInlined,
 102               nBetaReductions );
 103    fprintf(f, "Case-of-:        let %-5d          case %-5d"
 104               "           con %-5d         case# %-5d\n",
 105               nCaseOfLet, nCaseOfCase, nCaseOfCon, nCaseOfPrimCase );
 106    fprintf(f, "Dropped:     letbind %-5d      letgroup %-5d"
 107               "       default %-5d\n",
 108               nLetBindsDropped, nLetrecGroupsDropped, nCaseDefaultsDropped );
 109    fprintf(f, "Merges:       lambda %-5d           app %-5d\n",
 110               nLambdasMerged, nAppsMerged  );
 111    fprintf(f, "Fn-float:        let %-5d          case %-5d\n",
 112               nLetsFloatedOutOfFn, nCasesFloatedOutOfFn );
 113    fprintf(f, "Misc:     case-outer %-5d let-into-case %-5d\n",
 114               nCaseOfOuter, nLetsFloatedIntoCase );
 115    fprintf(f, "total size:       in %-5d           out %-5d\n",
 116               nTotSizeIn, nTotSizeOut );
 117    fprintf(f, "\n" );
 118 }
 119
 120
 121 /* --------------------------------------------------------------------------
 122  * How big is this STG tree (viz (primarily), do I want to inline it?)
 123  * ------------------------------------------------------------------------*/
 124
 125 Int stgSize_list ( List es )
 126 {
 127    Int n = 0;
 128    for (; nonNull(es); es=tl(es)) n += stgSize(hd(es));
 129    return n;
 130 }
 131
 132 Int stgSize ( StgExpr e )
 133 {
 134    List xs;
 135    Int n = 1;
 136
 137    if (isNull(e)) return 0;
 138
 139    switch(whatIsStg(e)) {
 140       case STGVAR:
 141          break;
 142       case LETREC:
 143          for (xs = stgLetBinds(e); nonNull(xs);xs=tl(xs))
 144             n += stgSize(stgVarBody(hd(xs)));
 145          n += stgSize(stgLetBody(e));
 146          break;
 147       case LAMBDA:
 148          n += stgSize(stgLambdaBody(e));
 149          break;
 150       case CASE:
 151          n += stgSize_list(stgCaseAlts(e));
 152          n += stgSize(stgCaseScrut(e));
 153          break;
 154       case PRIMCASE:
 155          n += stgSize_list(stgPrimCaseAlts(e));
 156          n += stgSize(stgPrimCaseScrut(e));
 157          break;
 158       case STGAPP:
 159          n += stgSize_list(stgAppArgs(e));
 160          n += stgSize(stgAppFun(e));
 161          break;
 162       case STGPRIM:
 163          n += stgSize_list(stgPrimArgs(e));
 164          n += stgSize(stgPrimOp(e));
 165          break;
 166       case STGCON:
 167          n += stgSize_list(stgConArgs(e));
 168          n += stgSize(stgConCon(e));
 169          break;
 170       case DEEFALT:
 171          n  = stgSize(stgDefaultBody(e));
 172          break;
 173       case CASEALT:
 174          n  = stgSize(stgCaseAltBody(e));
 175          break;
 176       case PRIMALT:
 177          n  = stgSize(stgPrimAltBody(e));
 178          break;
 179       case INTCELL:
 180       case STRCELL:
 181       case PTRCELL:
 182       case CHARCELL:
 183       case FLOATCELL:
 184       case BIGCELL:
 185       case NAME:
 186       case TUPLE:
 187          break;
 188       default:
 189          fprintf(stderr, "sizeStg: unknown stuff %d\n",whatIsStg(e));
 190          assert(0);
 191    }
 192    return n;
 193 }
 194
 195
 196 /* --------------------------------------------------------------------------
 197  * Stacks of pairs of collectable things.  Used to implement associations.
 198  * cloneStg() uses its stack to map old var names to new ones.
 199  * ------------------------------------------------------------------------*/
 200
 201 #define M_PAIRS 400
 202 #define SP_NOT_IN_USE (-123456789)
 203
 204 typedef
 205    struct { Cell pfst; Cell psnd; }
 206    StgPair;
 207
 208 static Int     spClone;
 209 static StgPair pairClone[M_PAIRS];
 210
 211 void markPairs ( void )
 212 {
 213    Int i;
 214    if (spClone != SP_NOT_IN_USE) {
 215       for (i = 0; i <= spClone; i++) {
 216          mark(pairClone[i].pfst);
 217          mark(pairClone[i].psnd);
 218       }
 219    }
 220 }
 221
 222 void pushClone ( Cell a, Cell b )
 223 {
 224    spClone++;
 225    if (spClone >= M_PAIRS) internal("pushClone -- M_PAIRS too small");
 226    pairClone[spClone].pfst = a;
 227    pairClone[spClone].psnd = b;
 228 }
 229
 230 void dropClone ( void )
 231 {
 232    if (spClone < 0) internal("dropClone");
 233    spClone--;
 234 }
 235
 236 Cell findClone ( Cell x )
 237 {
 238    Int i;
 239    for (i = spClone; i >= 0; i--)
 240       if (pairClone[i].pfst == x)
 241          return pairClone[i].psnd;
 242    return NIL;
 243 }
 244
 245
 246 /* --------------------------------------------------------------------------
 247  * Cloning of STG trees
 248  * ------------------------------------------------------------------------*/
 249
 250 /* Clone v to create a new var.  Works for both StgVar and StgPrimVar. */
 251 StgVar cloneStgVar ( StgVar v )
 252 {
 253   return ap(STGVAR,triple(stgVarBody(v),stgVarRep(v),NIL));
 254 }
 255
 256
 257 /* For each StgVar in origVars, make a new one with cloneStgVar,
 258    and push the (old,new) pair on the clone pair stack.  Returns
 259    the list of new vars.
 260 */
 261 List cloneStg_addVars ( List origVars )
 262 {
 263    List newVars = NIL;
 264    while (nonNull(origVars)) {
 265       StgVar newv = cloneStgVar(hd(origVars));
 266       pushClone ( hd(origVars), newv );
 267       newVars    = cons(newv,newVars);
 268       origVars   = tl(origVars);
 269    }
 270    newVars = rev(newVars);
 271    return newVars;
 272 }
 273
 274
 275 void cloneStg_dropVars ( List vs )
 276 {
 277    for (; nonNull(vs); vs=tl(vs))
 278       dropClone();
 279 }
 280
 281
 282 /* Print the clone pair stack.  Just for debugging purposes. */
 283 void ppCloneEnv ( char* s )
 284 {
 285    Int i;
 286    fflush(stdout);fflush(stderr);
 287    printf ( "\nenv-%s\n", s );
 288    for (i = 0; i <= spClone; i++) {
 289       printf ( "\t" );
 290       ppStgExpr(pairClone[i].pfst);
 291       ppStgExpr(pairClone[i].psnd);
 292       printf ( "\n" );
 293    };
 294    printf ( "vne-%s\n", s );
 295 }
 296
 297
 298 StgExpr cloneStg ( StgExpr e )
 299 {
 300    List xs, newvs;
 301    StgVar newv;
 302    StgExpr t;
 303
 304    switch(whatIsStg(e)) {
 305       case STGVAR:
 306          newv = findClone(e);
 307          if (nonNull(newv)) return newv; else return e;
 308       case LETREC:
 309          newvs = cloneStg_addVars ( stgLetBinds(e) );
 310          for (xs = newvs; nonNull(xs);xs=tl(xs))
 311             stgVarBody(hd(xs)) = cloneStg(stgVarBody(hd(xs)));
 312          t = mkStgLet(newvs,cloneStg(stgLetBody(e)));
 313          cloneStg_dropVars ( stgLetBinds(e) );
 314          return t;
 315       case LAMBDA:
 316          newvs = cloneStg_addVars ( stgLambdaArgs(e) );
 317          t = mkStgLambda(newvs, cloneStg(stgLambdaBody(e)));
 318          cloneStg_dropVars ( stgLambdaArgs(e) );
 319          return t;
 320       case CASE:
 321          xs = dupList(stgCaseAlts(e));
 322          mapOver(cloneStg,xs);
 323          return mkStgCase(cloneStg(stgCaseScrut(e)),xs);
 324       case PRIMCASE:
 325          xs = dupList(stgPrimCaseAlts(e));
 326          mapOver(cloneStg,xs);
 327          return mkStgPrimCase(cloneStg(stgPrimCaseScrut(e)),xs);
 328       case STGAPP:
 329          xs = dupList(stgAppArgs(e));
 330          mapOver(cloneStg,xs);
 331          return mkStgApp(cloneStg(stgAppFun(e)),xs);
 332       case STGPRIM:
 333          xs = dupList(stgPrimArgs(e));
 334          mapOver(cloneStg,xs);
 335          return mkStgPrim(cloneStg(stgPrimOp(e)),xs);
 336       case STGCON:
 337          xs = dupList(stgConArgs(e));
 338          mapOver(cloneStg,xs);
 339          return mkStgCon(cloneStg(stgConCon(e)),xs);
 340       case DEEFALT:
 341          newv = cloneStgVar(stgDefaultVar(e));
 342          pushClone ( stgDefaultVar(e), newv );
 343          t = mkStgDefault(newv,cloneStg(stgDefaultBody(e)));
 344          dropClone();
 345          return t;
 346       case CASEALT:
 347          newvs = cloneStg_addVars ( stgCaseAltVars(e) );
 348          t = mkStgCaseAlt(stgCaseAltCon(e),newvs,
 349                           cloneStg(stgCaseAltBody(e)));
 350          cloneStg_dropVars ( stgCaseAltVars(e) );
 351          return t;
 352       case PRIMALT:
 353          newvs = cloneStg_addVars ( stgPrimAltVars(e) );
 354          t = mkStgPrimAlt(newvs, cloneStg(stgPrimAltBody(e)));
 355          cloneStg_dropVars ( stgPrimAltVars(e) );
 356          return t;
 357       case INTCELL:
 358       case STRCELL:
 359       case PTRCELL:
 360       case BIGCELL:
 361       case CHARCELL:
 362       case FLOATCELL:
 363       case NAME:
 364       case TUPLE:
 365          return e;
 366       default:
 367          fprintf(stderr, "cloneStg: unknown stuff %d\n",whatIsStg(e));
 368          assert(0);
 369    }
 370 }
 371
 372
 373 /* Main entry point.  Checks against re-entrant use. */
 374 StgExpr cloneStgTop ( StgExpr e )
 375 {
 376    StgExpr res;
 377    if (spClone != SP_NOT_IN_USE)
 378       internal("cloneStgTop");
 379    spClone = -1;
 380    res = cloneStg ( e );
 381    assert(spClone == -1);
 382    spClone = SP_NOT_IN_USE;
 383    return res;
 384 }
 385
 386
 387
 388 /* --------------------------------------------------------------------------
 389  * Sets of StgVars, used by the strongly-connected-components machinery.
 390  * Represented as an array of variables.  The vars
 391  * must be in strictly nondecreasing order.  Each value may appear
 392  * more than once, so as to make deletion relatively cheap.
 393
 394  * After a garbage collection happens, the values may have changed,
 395  * so the array will need to be sorted.
 396
 397  * Using a binary search, membership costs O(log N).  Union and
 398  * intersection cost O(N + M).  Deletion of a single element costs
 399  * O(N) in the worst case, although if it happens infrequently
 400  * compared to the other ops, it should asymptotically approach O(1).
 401  * ------------------------------------------------------------------------*/
 402
 403 #define M_VAR_SETS 4000
 404 #define MIN_VAR_SET_SIZE 4
 405 #define M_UNION_TMP 20000
 406
 407 typedef
 408    struct {
 409       Int   nextfree;
 410       Bool  inUse;
 411       Int   size;
 412       Int   used;
 413       Cell* vs;
 414    }
 415    StgVarSetRec;
 416
 417 typedef Int StgVarSet;
 418
 419 StgVarSetRec varSet[M_VAR_SETS];
 420 Int varSet_nfree;
 421 Int varSet_nextfree;
 422 Cell union_tmp[M_UNION_TMP];
 423
 424 #if 0 /* unused since unnecessary */
 425 /* Shellsort set elems to restore representation invariants */
 426 static Int shellCells_incs[10]
 427    = { 1, 4, 13, 40, 121, 364, 1093, 3280, 9841, 29524 };
 428 static void shellCells ( Cell* a, Int lo, Int hi )
 429 {
 430    Int i, j, h, N, hp;
 431    Cell v;
 432
 433    N = hi - lo + 1; if (N < 2) return;
 434    hp = 0;
 435    while (hp < 10 && shellCells_incs[hp] < N) hp++; hp--;
 436
 437    for (; hp >= 0; hp--) {
 438       h = shellCells_incs[hp];
 439       i = lo + h;
 440       while (1) {
 441          if (i > hi) break;
 442          v = a[i];
 443          j = i;
 444          while (a[j-h] > v) {
 445             a[j] = a[j-h]; j = j - h;
 446             if (j <= (lo + h - 1)) break;
 447          }
 448          a[j] = v; i++;
 449       }
 450    }
 451 }
 452 #endif
 453
 454 /* check that representation invariant still holds */
 455 static void checkCells ( Cell* a, Int lo, Int hi )
 456 {
 457    Int i;
 458    for (i = lo; i < hi; i++)
 459       if (a[i] > a[i+1])
 460          internal("checkCells");
 461 }
 462
 463
 464 /* Mark set contents for GC */
 465 void markStgVarSets ( void )
 466 {
 467    Int i, j;
 468    for (i = 0; i < M_VAR_SETS; i++)
 469       if (varSet[i].inUse)
 470          for (j = 0; j < varSet[i].used; j++)
 471             mark(varSet[i].vs[j]);
 472 }
 473
 474
 475 /* Check representation invariants after GC */
 476 void checkStgVarSets ( void )
 477 {
 478    Int i;
 479    for (i = 0; i < M_VAR_SETS; i++)
 480       if (varSet[i].inUse)
 481          checkCells ( varSet[i].vs, 0, varSet[i].used-1 );
 482 }
 483
 484
 485 /* Allocate a set of a given size */
 486 StgVarSet allocStgVarSet ( Int size )
 487 {
 488    Int i, j;
 489    if (varSet_nextfree == -1)
 490       internal("allocStgVarSet -- run out of var sets");
 491    i = varSet_nextfree;
 492    varSet_nextfree = varSet[i].nextfree;
 493    varSet[i].inUse = TRUE;
 494    j = MIN_VAR_SET_SIZE;
 495    while (j <= size) j *= 2;
 496    varSet[i].used = 0;
 497    varSet[i].size = j;
 498    varSet[i].vs = malloc(j * sizeof(StgVar) );
 499    if (!varSet[i].vs)
 500       internal("allocStgVarSet -- can't malloc memory");
 501    varSet_nfree--;
 502    return i;
 503 }
 504
 505
 506 /* resize (upwards) */
 507 void resizeStgVarSet ( StgVarSet s, Int size )
 508 {
 509    Cell* tmp;
 510    Cell* tmp2;
 511    Int i;
 512    Int j = MIN_VAR_SET_SIZE;
 513    while (j <= size) j *= 2;
 514    if (j < varSet[s].size) return;
 515    tmp = varSet[s].vs;
 516    tmp2 = malloc( j * sizeof(StgVar) );
 517    if (!tmp2) internal("resizeStgVarSet -- can't malloc memory");
 518    varSet[s].vs = tmp2;
 519    for (i = 0; i < varSet[s].used; i++)
 520       tmp2[i] = tmp[i];
 521    free(tmp);
 522 }
 523
 524
 525 /* Deallocation ... */
 526 void freeStgVarSet ( StgVarSet s )
 527 {
 528    if (s < 0 || s >= M_VAR_SETS ||
 529        !varSet[s].inUse || !varSet[s].vs)
 530       internal("freeStgVarSet");
 531    free(varSet[s].vs);
 532    varSet[s].inUse = FALSE;
 533    varSet[s].vs = NULL;
 534    varSet[s].nextfree = varSet_nextfree;
 535    varSet_nextfree = s;
 536    varSet_nfree++;
 537 }
 538
 539
 540 /* Initialisation */
 541 void initStgVarSets ( void )
 542 {
 543    Int i;
 544    for (i = M_VAR_SETS-1; i >= 0; i--) {
 545       varSet[i].inUse = FALSE;
 546       varSet[i].vs = NULL;
 547       varSet[i].nextfree = i+1;
 548    }
 549    varSet[M_VAR_SETS-1].nextfree = -1;
 550    varSet_nextfree = 0;
 551    varSet_nfree = M_VAR_SETS;
 552 }
 553
 554
 555 /* Find a var using binary search */
 556 Int findInStgVarSet ( StgVarSet s, StgVar v )
 557 {
 558    Int lo, mid, hi;
 559    lo = 0;
 560    hi = varSet[s].used-1;
 561    while (1) {
 562       if (lo > hi) return -1;
 563       mid = (hi+lo)/2;
 564       if (varSet[s].vs[mid] == v) return mid;
 565       if (varSet[s].vs[mid] < v) lo = mid+1; else hi = mid-1;
 566    }
 567 }
 568
 569
 570 Bool elemStgVarSet ( StgVarSet s, StgVar v )
 571 {
 572    return findInStgVarSet(s,v) != -1;
 573 }
 574
 575 void ppSet ( StgVarSet s )
 576 {
 577    Int i;
 578    fprintf(stderr, "{ ");
 579    for (i = 0; i < varSet[s].used; i++)
 580       fprintf(stderr, "%d ", varSet[s].vs[i] );
 581    fprintf(stderr, "}\n" );
 582 }
 583
 584
 585 void deleteFromStgVarSet ( StgVarSet s, StgVar v )
 586 {
 587    Int i, j;
 588    i = findInStgVarSet(s,v);
 589    if (i == -1) return;
 590    j = varSet[s].used-1;
 591    for (; i < j; i++) varSet[s].vs[i] = varSet[s].vs[i+1];
 592    varSet[s].used--;
 593 }
 594
 595
 596 void singletonStgVarSet ( StgVarSet s, StgVar v )
 597 {
 598    varSet[s].used  = 1;
 599    varSet[s].vs[0] = v;
 600 }
 601
 602
 603 void emptyStgVarSet ( StgVarSet s )
 604 {
 605    varSet[s].used = 0;
 606 }
 607
 608
 609 void copyStgVarSets ( StgVarSet dst, StgVarSet src )
 610 {
 611    Int i;
 612    varSet[dst].used = varSet[src].used;
 613    for (i = 0; i < varSet[dst].used; i++)
 614       varSet[dst].vs[i] = varSet[src].vs[i];
 615 }
 616
 617
 618 Int sizeofVarSet ( StgVarSet s )
 619 {
 620    return varSet[s].used;
 621 }
 622
 623
 624 void unionStgVarSets ( StgVarSet dst, StgVarSet src )
 625 {
 626    StgVar v1;
 627    Int pd, ps, i, res_used, tmp_used, dst_used, src_used;
 628    StgVar* dst_vs;
 629    StgVar* src_vs;
 630    StgVar* tmp_vs;
 631
 632    dst_vs = varSet[dst].vs;
 633
 634    /* fast track a common (~ 50%) case */
 635    if (varSet[src].used == 1) {
 636       v1 = varSet[src].vs[0];
 637       pd = findInStgVarSet(dst,v1);
 638       if (pd != -1) return;
 639       if (varSet[dst].used < varSet[dst].size) {
 640          i = varSet[dst].used;
 641          while (i > 0 && dst_vs[i-1] > v1) {
 642             dst_vs[i] = dst_vs[i-1];
 643             i--;
 644          }
 645          dst_vs[i] = v1;
 646          varSet[dst].used++;
 647          return;
 648       }
 649    }
 650
 651    res_used = varSet[dst].used + varSet[src].used;
 652    if (res_used > M_UNION_TMP)
 653       internal("unionStgVarSets -- M_UNION_TMP too small");
 654
 655    resizeStgVarSet(dst,res_used);
 656    dst_vs = varSet[dst].vs;
 657    src_vs = varSet[src].vs;
 658    tmp_vs = union_tmp;
 659    tmp_used = 0;
 660    dst_used = varSet[dst].used;
 661    src_used = varSet[src].used;
 662
 663    /* merge the two sets into tmp */
 664    pd = ps = 0;
 665    while (pd < dst_used || ps < src_used) {
 666       if (pd == dst_used)
 667          tmp_vs[tmp_used++] = src_vs[ps++];
 668       else
 669       if (ps == src_used)
 670          tmp_vs[tmp_used++] = dst_vs[pd++];
 671       else {
 672          StgVar vald = dst_vs[pd];
 673          StgVar vals = src_vs[ps];
 674          if (vald < vals)
 675             tmp_vs[tmp_used++] = vald, pd++;
 676          else
 677          if (vald > vals)
 678             tmp_vs[tmp_used++] = vals, ps++;
 679          else
 680             tmp_vs[tmp_used++] = vals, ps++, pd++;
 681       }
 682    }
 683
 684    /* copy setTmp back to dst */
 685    varSet[dst].used = tmp_used;
 686    for (i = 0; i < tmp_used; i++) {
 687       dst_vs[i] = tmp_vs[i];
 688    }
 689 }
 690
 691
 692
 693 /* --------------------------------------------------------------------------
 694  * Strongly-connected-components machinery for STG let bindings.
 695  * Arranges let bindings in minimal mutually recursive groups, and
 696  * then throws away any groups not referred to in the body of the let.
 697  *
 698  * How it works: does a bottom-up sweep of the tree.  Each call returns
 699  * the set of variables free in the tree.  All nodes except LETREC are
 700  * boring.
 701  *
 702  * When 'let v1=e1 .. vn=en in e' is encountered:
 703  * -- recursively make a call on e.  This returns fvs(e) and scc-ifies
 704  *    inside e as well.
 705  * -- do recursive calls for e1 .. en too, giving fvs(e1) ... fvs(en).
 706  *
 707  * Then, using fvs(e1) ... fvs(en), the dependancy graph for v1 ... vn
 708  * can be cheaply computed.  Using that, compute the strong components
 709  * and rearrange the let binding accordingly.
 710  * Finally, for each of the strong components, we can use fvs(en) to
 711  * cheaply determine if the component is used in the body of the let,
 712  * and if not, it can be omitted.
 713  *
 714  * oaScc destructively modifies the tree -- when it gets to a let --
 715  * we need to pass the address of the expression to scc, not the
 716  * (more usual) heap index of it.
 717  *
 718  * The main requirement of this algorithm is an efficient implementation
 719  * of sets of variables.  Because there is no name shadowing in these
 720  * trees, either mentioned-sets or free-sets would be ok, although
 721  * free sets are presumably smaller.
 722  * ------------------------------------------------------------------------*/
 723
 724
 725 #define  SCC             stgScc          /* make scc algorithm for StgVars */
 726 #define  LOWLINK         stgLowlink
 727 #define  DEPENDS(t)      thd3(t)
 728 #define  SETDEPENDS(c,v) thd3(c)=v
 729 #include "scc.c"
 730 #undef   SETDEPENDS
 731 #undef   DEPENDS
 732 #undef   LOWLINK
 733 #undef   SCC
 734
 735
 736 StgVarSet oaScc ( StgExpr* e_orig )
 737 {
 738    Bool grpUsed;
 739    StgExpr e;
 740    StgVarSet e_fvs, s1, s2;
 741    List bs, bs2, bs3, bsFinal, augs, augsL;
 742
 743    bs=bs2=bs3=bsFinal=augs=augsL=e_fvs=s1=s2=e=NIL;
 744    grpUsed=FALSE;
 745
 746    e = *e_orig;
 747
 748    //fprintf(stderr,"\n==================\n");
 749    //ppStgExpr(*e_orig);
 750    //fprintf(stderr,"\n\n");fflush(stderr);fflush(stdout);
 751
 752
 753    switch(whatIsStg(e)) {
 754       case LETREC:
 755          /* first, recurse into the let body */
 756          e_fvs = oaScc(&stgLetBody(*e_orig));
 757
 758          /* Make bs :: [StgVar] and e :: Stgexpr. */
 759          bs = stgLetBinds(e);
 760          e  = stgLetBody(e);
 761
 762          /* make augs :: [(StgVar,fvs(bindee),NIL)] */
 763          augs = NIL;
 764          for (; nonNull(bs); bs=tl(bs)) {
 765             StgVarSet fvs_bindee = oaScc(&stgVarBody(hd(bs)));
 766             augs = cons( triple(hd(bs),mkInt(fvs_bindee),NIL), augs );
 767          }
 768
 769          bs2=bs3=bsFinal=augsL=s1=s2=NIL;
 770
 771          /* In each of the triples in aug, replace the NIL field with
 772             a list of the let-bound vars appearing in the bindee.
 773             ie, construct the adjacency list for the graph.
 774             giving
 775             augs :: [(StgVar,fvs(bindee),[pointers-back-to-this-list-of-pairs])]
 776          */
 777          for (bs=augs;nonNull(bs);bs=tl(bs)) {
 778             augsL = NIL;
 779             for (bs2=augs;nonNull(bs2);bs2=tl(bs2))
 780                if (elemStgVarSet( intOf(snd3(hd(bs))), fst3(hd(bs2)) ))
 781                   augsL = cons(hd(bs2),augsL);
 782             thd3(hd(bs)) = augsL;
 783          }
 784
 785          bs2=bs3=bsFinal=augsL=s1=s2=NIL;
 786
 787          /* Do the Biz.
 788             augs becomes :: [[(StgVar,fvs(bindee),aux_info_field)]] */
 789          augs = stgScc(augs);
 790
 791          /* work backwards through augs, reconstructing the expression,
 792             dumping any unused groups as you go.
 793          */
 794          bsFinal = NIL;
 795          for (augs=rev(augs); nonNull(augs); augs=tl(augs)) {
 796             bs2 = NIL;
 797             for (augsL=hd(augs);nonNull(augsL); augsL=tl(augsL))
 798                bs2 = cons(fst3(hd(augsL)),bs2);
 799             grpUsed = FALSE;
 800             for (bs3=bs2;nonNull(bs3);bs3=tl(bs3))
 801                if (elemStgVarSet(e_fvs,hd(bs3))) { grpUsed=TRUE; break; }
 802             if (grpUsed) {
 803                //e = mkStgLet(bs2,e);
 804                bsFinal = dupOnto(bs2,bsFinal);
 805                for (augsL=hd(augs);nonNull(augsL);augsL=tl(augsL)) {
 806                   unionStgVarSets(e_fvs, intOf(snd3(hd(augsL))) );
 807                   freeStgVarSet(intOf(snd3(hd(augsL))));
 808                }
 809             } else {
 810                nLetrecGroupsDropped++;
 811                for (augsL=hd(augs);nonNull(augsL);augsL=tl(augsL)) {
 812                   freeStgVarSet(intOf(snd3(hd(augsL))));
 813                }
 814             }
 815          }
 816          //*e_orig = e;
 817          *e_orig = mkStgLet(bsFinal,e);
 818          return e_fvs;
 819
 820       case LAMBDA:
 821          s1 = oaScc(&stgLambdaBody(e));
 822          for (bs=stgLambdaArgs(e);nonNull(bs);bs=tl(bs))
 823             deleteFromStgVarSet(s1,hd(bs));
 824          return s1;
 825       case CASE:
 826          s1 = oaScc(&stgCaseScrut(e));
 827          for (bs=stgCaseAlts(e);nonNull(bs);bs=tl(bs)) {
 828             s2 = oaScc(&hd(bs));
 829             unionStgVarSets(s1,s2);
 830             freeStgVarSet(s2);
 831          }
 832          return s1;
 833       case PRIMCASE:
 834          s1 = oaScc(&stgPrimCaseScrut(e));
 835          for (bs=stgPrimCaseAlts(e);nonNull(bs);bs=tl(bs)) {
 836             s2 = oaScc(&hd(bs));
 837             unionStgVarSets(s1,s2);
 838             freeStgVarSet(s2);
 839          }
 840          return s1;
 841       case STGAPP:
 842          s1 = oaScc(&stgAppFun(e));
 843          for (bs=stgAppArgs(e);nonNull(bs);bs=tl(bs)) {
 844             s2 = oaScc(&hd(bs));
 845             unionStgVarSets(s1,s2);
 846             freeStgVarSet(s2);
 847          }
 848          return s1;
 849       case STGPRIM:
 850          s1 = oaScc(&stgPrimOp(e));
 851          for (bs=stgPrimArgs(e);nonNull(bs);bs=tl(bs)) {
 852             s2 = oaScc(&hd(bs));
 853             unionStgVarSets(s1,s2);
 854             freeStgVarSet(s2);
 855          }
 856          return s1;
 857       case STGCON:
 858          s1 = allocStgVarSet(0);
 859          for (bs=stgPrimArgs(e);nonNull(bs);bs=tl(bs)) {
 860             s2 = oaScc(&hd(bs));
 861             unionStgVarSets(s1,s2);
 862             freeStgVarSet(s2);
 863          }
 864          return s1;
 865       case CASEALT:
 866          s1 = oaScc(&stgCaseAltBody(e));
 867          for (bs=stgCaseAltVars(e);nonNull(bs);bs=tl(bs))
 868             deleteFromStgVarSet(s1,hd(bs));
 869          return s1;
 870       case DEEFALT:
 871          s1 = oaScc(&stgDefaultBody(e));
 872          deleteFromStgVarSet(s1,stgDefaultVar(e));
 873          return s1;
 874       case PRIMALT:
 875          s1 = oaScc(&stgPrimAltBody(e));
 876          for (bs=stgPrimAltVars(e);nonNull(bs);bs=tl(bs))
 877             deleteFromStgVarSet(s1,hd(bs));
 878          return s1;
 879       case STGVAR:
 880          s1 = allocStgVarSet(1);
 881          singletonStgVarSet(s1,e);
 882          return s1;
 883       case NAME:
 884       case INTCELL:
 885       case STRCELL:
 886       case PTRCELL:
 887       case BIGCELL:
 888       case CHARCELL:
 889       case FLOATCELL:
 890          return allocStgVarSet(0);
 891          break;
 892       default:
 893          fprintf(stderr, "oaScc: unknown stuff %d\n",whatIsStg(e));
 894          assert(0);
 895    }
 896 }
 897
 898
 899
 900 /* --------------------------------------------------------------------------
 901  * Occurrence analyser.  Marks each let-bound var with the number of times
 902  * it is used, or some number >= OCC_IN_LAMBDA if it is used inside a lambda.
 903  *
 904  * Firstly, oaPre traverses the tree, attaching a mutable INT cell to each
 905  * let bound var, and NIL-ing the counts on all other vars.
 906  *
 907  * Then oaCount traveses the tree.  Because variables are represented by
 908  * pointers in the heap, we can just increment the count field of each
 909  * variable we see.  However, to deal with lambdas, the Hugs stack holds
 910  * all let-bound variables currently in scope, and the uppermost portion
 911  * of the stack, stack(spBase .. sp) inclusive, denotes the variables
 912  * introduced into scope since the nearest enclosing lambda.  When a
 913  * let-bound var is seen, we search stack(spBase .. sp).  If it appears
 914  * there, no lambda exists between the binding site and this usage of the
 915  * var, so we can safely increment its use.  Otherwise, we must set it to
 916  * OCC_IN_LAMBDA.
 917  *
 918  * When passing a lambda, spBase is set to sp+1, so as to effectively
 919  * empty the set of vars-bound-since-the-latest-lambda.
 920  *
 921  * Because oaPre pre-annotates the tree with mutable INT cells, oaCount
 922  * doesn't allocate any heap at all.
 923  * ------------------------------------------------------------------------*/
 924
 925 static int spBase;
 926
 927
 928 #define OCC_IN_LAMBDA 50  /* any number > 1 will do */
 929 #define nullCount(vv) stgVarInfo(vv)=NIL
 930 #define nullCounts(vvs) { List tt=(vvs);for(;nonNull(tt);tt=tl(tt)) nullCount(hd(tt));}
 931
 932
 933
 934 void oaPre ( StgExpr e )
 935 {
 936    List bs;
 937    switch(whatIsStg(e)) {
 938       case LETREC:
 939          for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
 940             stgVarInfo(hd(bs)) = mkInt(0);
 941          for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
 942             oaPre(stgVarBody(hd(bs)));
 943          oaPre(stgLetBody(e));
 944          break;
 945       case LAMBDA:
 946          nullCounts(stgLambdaArgs(e));
 947          oaPre(stgLambdaBody(e));
 948          break;
 949       case CASE:
 950          oaPre(stgCaseScrut(e));
 951          mapProc(oaPre,stgCaseAlts(e));
 952          break;
 953       case PRIMCASE:
 954          oaPre(stgPrimCaseScrut(e));
 955          mapProc(oaPre,stgPrimCaseAlts(e));
 956          break;
 957       case STGAPP:
 958          oaPre(stgAppFun(e));
 959          mapProc(oaPre,stgAppArgs(e));
 960          break;
 961       case STGPRIM:
 962          mapProc(oaPre,stgPrimArgs(e));
 963          break;
 964       case STGCON:
 965          mapProc(oaPre,stgConArgs(e));
 966          break;
 967       case CASEALT:
 968          nullCounts(stgCaseAltVars(e));
 969          oaPre(stgCaseAltBody(e));
 970          break;
 971       case DEEFALT:
 972          nullCount(stgDefaultVar(e));
 973          oaPre(stgDefaultBody(e));
 974          break;
 975       case PRIMALT:
 976          nullCounts(stgPrimAltVars(e));
 977          oaPre(stgPrimAltBody(e));
 978          break;
 979       case STGVAR:
 980       case NAME:
 981       case INTCELL:
 982       case STRCELL:
 983       case PTRCELL:
 984       case BIGCELL:
 985       case CHARCELL:
 986       case FLOATCELL:
 987          break;
 988       default:
 989          fprintf(stderr, "oaPre: unknown stuff %d\n",whatIsStg(e));
 990          assert(0);
 991    }
 992 }
 993
 994
 995 /* In oaCount:
 996    -- the stack is always the set of let-bound vars currently
 997       in scope.  viz, stack(0 .. sp) inclusive.
 998    -- spBase is always >= 0 and <= sp.
 999       stack(spBase .. sp) inclusive will be the let vars bound
1000       since the nearest enclosing lambda.  When entering a lambda,
1001       we set spBase=sp+1 so as record this fact, and restore spBase
1002       afterwards.
1003 */
1004 void oaCount ( StgExpr e )
1005 {
1006    List bs;
1007    Int  spBase_saved;
1008
1009    switch(whatIsStg(e)) {
1010       case LETREC:
1011          for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
1012             push(hd(bs));
1013          for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
1014             oaCount(stgVarBody(hd(bs)));
1015          oaCount(stgLetBody(e));
1016          for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
1017             drop();
1018          break;
1019       case LAMBDA:
1020          spBase_saved = spBase;
1021          spBase = sp+1;
1022          oaCount(stgLambdaBody(e));
1023          spBase = spBase_saved;
1024          break;
1025       case CASE:
1026          oaCount(stgCaseScrut(e));
1027          mapProc(oaCount,stgCaseAlts(e));
1028          break;
1029       case PRIMCASE:
1030          oaCount(stgPrimCaseScrut(e));
1031          mapProc(oaCount,stgPrimCaseAlts(e));
1032          break;
1033       case STGAPP:
1034          oaCount(stgAppFun(e));
1035          mapProc(oaCount,stgAppArgs(e));
1036          break;
1037       case STGPRIM:
1038          mapProc(oaCount,stgPrimArgs(e));
1039          break;
1040       case STGCON:
1041          mapProc(oaCount,stgConArgs(e));
1042          break;
1043       case CASEALT:
1044          nullCounts(stgCaseAltVars(e));
1045          oaCount(stgCaseAltBody(e));
1046          break;
1047       case DEEFALT:
1048          nullCount(stgDefaultVar(e));
1049          oaCount(stgDefaultBody(e));
1050          break;
1051       case PRIMALT:
1052          nullCounts(stgPrimAltVars(e));
1053          oaCount(stgPrimAltBody(e));
1054          break;
1055       case STGVAR:
1056          if (isInt(stgVarInfo(e))) {
1057             Int i, j;
1058             j = -1;
1059             for (i = sp; i >= spBase; i--)
1060                if (stack(i) == e) { j = i; break; };
1061             if (j == -1)
1062                stgVarInfo(e) = mkInt(OCC_IN_LAMBDA); else
1063                stgVarInfo(e) = mkInt(1 + intOf(stgVarInfo(e)));
1064          }
1065          break;
1066       case NAME:
1067       case INTCELL:
1068       case STRCELL:
1069       case PTRCELL:
1070       case BIGCELL:
1071       case CHARCELL:
1072       case FLOATCELL:
1073          break;
1074       default:
1075          fprintf(stderr, "oaCount: unknown stuff %d\n",whatIsStg(e));
1076          assert(0);
1077    }
1078 }
1079
1080 void stgTopSanity ( char*, StgVar );
1081
1082 /* Top level entry point for the occurrence analyser. */
1083 void oaTop ( StgVar v )
1084 {
1085    assert (varSet_nfree == M_VAR_SETS);
1086    freeStgVarSet(oaScc(&stgVarBody(v)));
1087    assert (varSet_nfree == M_VAR_SETS);
1088    oaPre(stgVarBody(v));
1089    clearStack(); spBase = 0;
1090    oaCount(stgVarBody(v));
1091    assert(stackEmpty());
1092    stgTopSanity("oaTop",stgVarBody(v));
1093 }
1094
1095
1096 /* --------------------------------------------------------------------------
1097  * Transformation machinery proper
1098  * ------------------------------------------------------------------------*/
1099
1100 #define streq(aa,bb) (strcmp((aa),(bb))==0)
1101 /* Return TRUE if the non-default alts in the given list are exhaustive.
1102    If in doubt, return FALSE.
1103 */
1104 Bool stgAltsExhaustive ( List alts )
1105 {
1106    Int   nDefnCons;
1107    Name  con;
1108    Tycon t;
1109    List  cs;
1110    char* s;
1111    List  alts0 = alts;
1112    while (nonNull(alts) && isDefaultAlt(hd(alts))) alts=tl(alts);
1113    if (isNull(alts)) {
1114       return FALSE;
1115    } else {
1116       con = stgCaseAltCon(hd(alts));
1117       /* special case: dictionary constructor */
1118       if (strncmp("Make.",textToStr(name(con).text),5)==0)
1119          return TRUE;
1120       /* special case: constructor boxing an unboxed value. */
1121       if (isBoxingCon(con))
1122          return TRUE;
1123       /* some other special cases which are not boxingCons */
1124       s = textToStr(name(con).text);
1125       if (streq(s,"Integer#")
1126           || streq(s,"Ref#")
1127           || streq(s,"PrimMutableArray#")
1128           || streq(s,"PrimMutableByteArray#")
1129           || streq(s,"PrimByteArray#")
1130           || streq(s,"PrimArray#")
1131          )
1132          return TRUE;
1133       if (strcmp("Ref#",textToStr(name(con).text))==0)
1134          return TRUE;
1135       /* special case: Tuples */
1136       if (isTuple(con) || (isName(con) && con==nameUnit))
1137          return TRUE;
1138       if (isNull(name(con).parent)) internal("stgAltsExhaustive(1)");
1139       t = name(con).parent;
1140       cs = tycon(t).defn;
1141       if (tycon(t).what != DATATYPE) internal("stgAltsExhaustive(2)");
1142       nDefnCons = length(cs);
1143       for (; nonNull(alts0);alts0=tl(alts0)) {
1144          if (isDefaultAlt(hd(alts0))) continue;
1145          nDefnCons--;
1146       }
1147    }
1148    return nDefnCons == 0;
1149 }
1150 #undef streq
1151
1152
1153 /* If in doubt, return FALSE.
1154 */
1155 Bool isManifestCon ( StgExpr e )
1156 {
1157    StgExpr altB;
1158    switch (whatIsStg(e)) {
1159       case STGCON: return TRUE;
1160       case LETREC: return isManifestCon(stgLetBody(e));
1161       case CASE:   if (length(stgCaseAlts(e))==1) {
1162                       if (isDefaultAlt(hd(stgCaseAlts(e))))
1163                          altB = stgDefaultBody(hd(stgCaseAlts(e))); else
1164                          altB = stgCaseAltBody(hd(stgCaseAlts(e)));
1165                          return isManifestCon(altB);
1166                    } else {
1167                       return FALSE;
1168                    }
1169       default:     return FALSE;
1170    }
1171 }
1172
1173
1174 /* Like isManifestCon, but doesn't give up at non-singular cases */
1175 Bool constructsCon ( StgExpr e )
1176 {
1177    List    as;
1178    switch (whatIsStg(e)) {
1179       case STGCON:   return TRUE;
1180       case LETREC:   return constructsCon(stgLetBody(e));
1181       case CASE:     for (as = stgCaseAlts(e); nonNull(as); as=tl(as))
1182                         if (!constructsCon(hd(as))) return FALSE;
1183                      return TRUE;
1184       case PRIMCASE: for (as = stgPrimCaseAlts(e); nonNull(as); as=tl(as))
1185                         if (!constructsCon(hd(as))) return FALSE;
1186                      return TRUE;
1187       case CASEALT:  return constructsCon(stgCaseAltBody(e));
1188       case DEEFALT:  return constructsCon(stgDefaultBody(e));
1189       case PRIMALT:  return constructsCon(stgPrimAltBody(e));
1190       default:       return FALSE;
1191    }
1192 }
1193
1194
1195 /* Inline v in the special case where expr is
1196    case v of C a1 ... an -> E
1197    and v's bindee returns a product constructed with C.
1198    and v does not appear in E
1199    and v does not appear in letDefs (ie, this expr isn't
1200        part of the definition of v.
1201 */
1202 void tryLoopbreakerHack ( List letDefs, StgExpr expr )
1203 {
1204    List       alts;
1205    StgExpr    scrut, ee, v_bindee;
1206    StgCaseAlt alt;
1207
1208    assert (whatIsStg(expr)==CASE);
1209    alts      = stgCaseAlts(expr);
1210    scrut     = stgCaseScrut(expr);
1211    if (whatIsStg(scrut) != STGVAR || isNull(stgVarBody(scrut))) return;
1212    if (length(alts) != 1 || isDefaultAlt(hd(alts))) return;
1213    if (!stgAltsExhaustive(alts)) return;
1214    alt       = hd(alts);
1215    ee        = stgCaseAltBody(alt);
1216    if (nonNull(cellIsMember(scrut,letDefs))) return;
1217
1218    v_bindee  = stgVarBody(scrut);
1219    if (!isManifestCon(v_bindee)) return;
1220
1221    stgCaseScrut(expr) = cloneStgTop(v_bindee);
1222    nLoopBreakersInlined++;
1223 }
1224
1225
1226 /* Traverse a tree.  Replace let-bound vars marked as used-once
1227    by their definitions.  Replace references to top-level
1228    values marked inlineMe with their bodies.  Carry around a list
1229    of let-bound variables whose definitions we are currently in
1230    so as to know not to inline let-bound vars in their own
1231    definitions.
1232 */
1233 StgExpr copyIn ( List letDefs, InlineCtx ctx, StgExpr e )
1234 {
1235    List bs;
1236
1237    switch(whatIsStg(e)) {
1238       // these are the only two interesting cases
1239       case STGVAR:
1240          assert(isPtr(stgVarInfo(e)) || isNull(stgVarInfo(e)) ||
1241                 isInt(stgVarInfo(e)));
1242          if (isInt(stgVarInfo(e)) && intOf(stgVarInfo(e))==1) {
1243             nLetvarsInlined++;
1244             return cloneStgTop(stgVarBody(e));
1245          } else
1246             return e;
1247       case NAME:
1248          // if we're not inlining top vars on this round, do nothing
1249          if (!copyInTopvar) return e;
1250          // if it doesn't want to be inlined, do nothing
1251          if (!name(e).inlineMe) return e;
1252          // we decline to inline dictionary builders inside other builders
1253          if (inDBuilder && name(e).isDBuilder) {
1254            //fprintf(stderr, "decline to inline dbuilder %s\n", textToStr(name(e).text));
1255             return e;
1256          }
1257          // in fact, only inline dict builders into a case scrutinee
1258          if (name(e).isDBuilder && ctx != CTX_SCRUT)
1259             return e;
1260
1261 #if DEBUG_OPTIMISE
1262 assert( stgSize(stgVarBody(name(e).stgVar)) == name(e).stgSize );
1263 #endif
1264
1265          // only inline large dict builders if it returns a manifest con
1266          if (name(e).isDBuilder &&
1267              name(e).stgSize > 180 &&
1268              !isManifestCon(stgVarBody(name(e).stgVar)))
1269             return e;
1270 #if 0
1271          // if it's huge, don't inline into a boring place
1272          if (ctx != CTX_SCRUT &&
1273              name(e).stgSize > 270)
1274             return e;
1275 #endif
1276
1277          nTopvarsInlined++;
1278          return cloneStgTop(stgVarBody(name(e).stgVar));
1279
1280       // the rest are a boring recursive traversal of the tree
1281       case LETREC:
1282          stgLetBody(e) = copyIn(letDefs,CTX_OTHER,stgLetBody(e));
1283          letDefs = dupOnto(stgLetBinds(e),letDefs);
1284          for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
1285             stgVarBody(hd(bs)) = copyIn(letDefs,CTX_OTHER,stgVarBody(hd(bs)));
1286          break;
1287       case LAMBDA:
1288          stgLambdaBody(e) = copyIn(letDefs,CTX_OTHER,stgLambdaBody(e));
1289          break;
1290       case CASE:
1291          stgCaseScrut(e) = copyIn(letDefs,CTX_SCRUT,stgCaseScrut(e));
1292          map2Over(copyIn,letDefs,CTX_OTHER,stgCaseAlts(e));
1293          if (copyInTopvar) tryLoopbreakerHack(letDefs,e);
1294          break;
1295       case PRIMCASE:
1296          stgPrimCaseScrut(e) = copyIn(letDefs,CTX_OTHER,stgPrimCaseScrut(e));
1297          map2Over(copyIn,letDefs,CTX_OTHER,stgPrimCaseAlts(e));
1298          break;
1299       case STGAPP:
1300          stgAppFun(e) = copyIn(letDefs,CTX_OTHER,stgAppFun(e));
1301          break;
1302       case CASEALT:
1303          stgCaseAltBody(e) = copyIn(letDefs,CTX_OTHER,stgCaseAltBody(e));
1304          break;
1305       case DEEFALT:
1306          stgDefaultBody(e) = copyIn(letDefs,CTX_OTHER,stgDefaultBody(e));
1307          break;
1308       case PRIMALT:
1309          stgPrimAltBody(e) = copyIn(letDefs,CTX_OTHER,stgPrimAltBody(e));
1310          break;
1311       case STGPRIM:
1312       case STGCON:
1313       case INTCELL:
1314       case STRCELL:
1315       case PTRCELL:
1316       case CHARCELL:
1317       case FLOATCELL:
1318          break;
1319       default:
1320          fprintf(stderr, "copyIn: unknown stuff %d\n",whatIsStg(e));
1321          ppStgExpr(e);
1322          printf("\n");
1323          print(e,1000);
1324          printf("\n");
1325          assert(0);
1326    }
1327    return e;
1328 }
1329
1330
1331
1332 /* case (C a1 ... an) of
1333       B ...       -> ...
1334       C v1 ... vn -> e
1335       D ...       -> ...
1336    ==>
1337    e with v1/a1 ... vn/an
1338 */
1339 StgExpr doCaseOfCon ( StgExpr expr, Bool* done )
1340 {
1341    StgExpr    scrut, e;
1342    StgVar     apC;
1343    StgCaseAlt theAlt;
1344    List       alts, altvs, as, sub;
1345
1346    *done  = FALSE;
1347    alts   = stgCaseAlts(expr);
1348    scrut  = stgCaseScrut(expr);
1349
1350    apC    = stgConCon(scrut);
1351
1352    theAlt = NIL;
1353    for (alts = stgCaseAlts(expr); nonNull(alts); alts=tl(alts))
1354       if (!isDefaultAlt(hd(alts)) && stgCaseAltCon(hd(alts)) == apC) {
1355          theAlt = hd(alts);
1356          break;
1357       }
1358
1359    if (isNull(theAlt)) return expr;
1360    altvs  = stgCaseAltVars(theAlt);
1361    e      = stgCaseAltBody(theAlt);
1362    as     = stgConArgs(scrut);
1363
1364    if (length(as)!=length(altvs)) return expr;
1365
1366    sub = NIL;
1367    while (nonNull(altvs)) {
1368       sub   = cons(pair(hd(altvs),hd(as)),sub);
1369       as    = tl(as);
1370       altvs = tl(altvs);
1371    }
1372    nCaseOfCon++;
1373    *done = TRUE;
1374    return zubstExpr(sub,e);
1375 }
1376
1377
1378 /* case (let binds in e) of alts
1379    ===>
1380    let binds in case e of alts
1381 */
1382 StgExpr doCaseOfLet ( StgExpr expr, Bool* done )
1383 {
1384    StgExpr letexpr, e;
1385    List    binds, alts;
1386
1387    letexpr = stgCaseScrut(expr);
1388    e       = stgLetBody(letexpr);
1389    binds   = stgLetBinds(letexpr);
1390    alts    = stgCaseAlts(expr);
1391    nCaseOfLet++;
1392    *done   = TRUE;
1393    return mkStgLet(binds,mkStgCase(e,alts));
1394 }
1395
1396
1397
1398 /* case (case e of p1 -> e1 ... pn -> en) of
1399       q1 -> h1
1400       ...
1401       qk -> hk
1402    ===>
1403    case e of
1404       p1 -> case e1 of q1 -> h1 ... qk -> hk
1405       ...
1406       pn -> case en of q1 -> h1 ... qk -> kl
1407 */
1408 StgExpr doCaseOfCase ( StgExpr expr )
1409 {
1410    StgExpr innercase, e, tmpcase, protocase;
1411    List ps_n_es, qs_n_hs, newAlts;
1412    StgCaseAlt newAlt, p_n_e;
1413
1414    nCaseOfCase++;
1415
1416    innercase = stgCaseScrut(expr);
1417    e = stgCaseScrut(innercase);
1418    ps_n_es = stgCaseAlts(innercase);
1419    qs_n_hs = stgCaseAlts(expr);
1420
1421    /* protocase = case (hole-to-fill-in) of q1 -> h1 ... qk -> hk */
1422    protocase = mkStgCase( mkInt(0), qs_n_hs);
1423
1424    newAlts = NIL;
1425    for (;nonNull(ps_n_es);ps_n_es = tl(ps_n_es)) {
1426       tmpcase = cloneStgTop(protocase);
1427       p_n_e = hd(ps_n_es);
1428       if (isDefaultAlt(p_n_e)) {
1429          stgCaseScrut(tmpcase) = stgDefaultBody(p_n_e);
1430          newAlt = mkStgDefault(stgDefaultVar(p_n_e), tmpcase);
1431       } else {
1432          stgCaseScrut(tmpcase) = stgCaseAltBody(p_n_e);
1433          newAlt = mkStgCaseAlt(stgCaseAltCon(p_n_e),stgCaseAltVars(p_n_e),tmpcase);
1434       }
1435       newAlts = cons(newAlt,newAlts);
1436    }
1437    newAlts = rev(newAlts);
1438    return
1439       mkStgCase(e, newAlts);
1440 }
1441
1442
1443
1444 /* case (case# e of p1 -> e1 ... pn -> en) of
1445       q1 -> h1
1446       ...
1447       qk -> hk
1448    ===>
1449    case# e of
1450       p1 -> case e1 of q1 -> h1 ... qk -> hk
1451       ...
1452       pn -> case en of q1 -> h1 ... qk -> kl
1453 */
1454 StgExpr doCaseOfPrimCase ( StgExpr expr )
1455 {
1456    StgExpr innercase, e, tmpcase, protocase;
1457    List ps_n_es, qs_n_hs, newAlts;
1458    StgCaseAlt newAlt, p_n_e;
1459
1460    nCaseOfPrimCase++;
1461
1462    innercase = stgCaseScrut(expr);
1463    e = stgPrimCaseScrut(innercase);
1464    ps_n_es = stgPrimCaseAlts(innercase);
1465    qs_n_hs = stgCaseAlts(expr);
1466
1467    /* protocase = case (hole-to-fill-in) of q1 -> h1 ... qk -> hk */
1468    protocase = mkStgCase( mkInt(0), qs_n_hs);
1469
1470    newAlts = NIL;
1471    for (;nonNull(ps_n_es);ps_n_es = tl(ps_n_es)) {
1472       tmpcase = cloneStgTop(protocase);
1473       p_n_e = hd(ps_n_es);
1474       stgPrimCaseScrut(tmpcase) = stgPrimAltBody(p_n_e);
1475       newAlt = mkStgPrimAlt(stgPrimAltVars(p_n_e),tmpcase);
1476       newAlts = cons(newAlt,newAlts);
1477    }
1478    newAlts = rev(newAlts);
1479    return
1480       mkStgPrimCase(e, newAlts);
1481 }
1482
1483
1484 Bool isStgCaseWithSingleNonDefaultAlt ( StgExpr e )
1485 {
1486    return
1487       whatIsStg(e)==CASE &&
1488       length(stgCaseAlts(e))==1 &&
1489       !isDefaultAlt(hd(stgCaseAlts(e)));
1490 }
1491
1492
1493 /* Do simplifications on an Stg tree.  Invariant is that the
1494    input and output trees should have no name shadowing.
1495
1496    -- let { } in e
1497       ===>
1498       e
1499
1500    -- dump individual let-bindings with usage counts of zero
1501
1502    -- dump let-binding groups for which none of the bound vars
1503       occur in the let body
1504
1505    -- (\v1 ... vn -> e) a1 ... am
1506       ===>
1507       -- the usual beta reduction.  There are no constraints on n and m, so
1508          the result can be a lambda term (if n > m), or an application of e
1509          to the unused args (if n < m).
1510
1511
1512   Scheme is: bottom-up traversal of the tree.  First simplify child
1513   trees.  Then try to do local transformations.  If a local transformation
1514   succeeds, jump to the local-transformation code for whatever node
1515   is produced -- so as to try and maximise the amount of work which
1516   happens on each call to simplify.
1517 */
1518 StgExpr simplify ( List caseEnv, StgExpr e )
1519 {
1520    List bs, bs2;
1521    Bool done;
1522    Int  n;
1523
1524    restart:
1525    switch(whatIsStg(e)) {
1526       case STGVAR:
1527          return e;
1528       case NAME:
1529          return e;
1530
1531       case LETREC:
1532
1533          /* first dump dead binds, so as not to waste effort simplifying them */
1534          bs2=NIL;
1535          for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
1536             if (!isInt(stgVarInfo(hd(bs))) ||
1537                 intOf(stgVarInfo(hd(bs))) > 0) {
1538                bs2=cons(hd(bs),bs2);
1539             } else {
1540                nLetBindsDropped++;
1541             }
1542          if (isNull(bs2)) { e = stgLetBody(e); goto restart; };
1543          stgLetBinds(e) = rev(bs2);
1544
1545          for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
1546             stgVarBody(hd(bs)) = simplify(caseEnv,stgVarBody(hd(bs)));
1547          stgLetBody(e) = simplify(caseEnv,stgLetBody(e));
1548
1549          /* Merge let ... in let ... in e.  Grouping lets together
1550             sometimes reduces the number of iterations needed.
1551             oaScc should do this anyway, but this just to make sure.
1552          */
1553          while (whatIsStg(stgLetBody(e))==LETREC) {
1554             stgLetBinds(e) = dupOnto(stgLetBinds(stgLetBody(e)),stgLetBinds(e));
1555             stgLetBody(e) = stgLetBody(stgLetBody(e));
1556          }
1557
1558          let_local:
1559          /* let binds in case v-not-in-binds of singleAlt -> expr
1560             ===>
1561             case v-not-in-binds of singleAlt -> let binds in expr
1562          */
1563          if (isStgCaseWithSingleNonDefaultAlt(stgLetBody(e)) &&
1564              whatIsStg(stgCaseScrut(stgLetBody(e)))==STGVAR &&
1565              isNull(cellIsMember(stgCaseScrut(stgLetBody(e)),stgLetBinds(e)))) {
1566             StgVar     v = stgCaseScrut(stgLetBody(e));
1567             StgCaseAlt a = hd(stgCaseAlts(stgLetBody(e)));
1568             nLetsFloatedIntoCase++;
1569             e = mkStgCase(
1570                    v,
1571                    singleton(
1572                       mkStgCaseAlt(
1573                          stgCaseAltCon(a),
1574                          stgCaseAltVars(a),
1575                          mkStgLet(stgLetBinds(e),stgCaseAltBody(a))
1576                       )
1577                    )
1578                 );
1579             assert(whatIsStg(e)==CASE);
1580             goto case_local;
1581          }
1582
1583          break;
1584
1585       case LAMBDA:
1586          stgLambdaBody(e) = simplify(caseEnv,stgLambdaBody(e));
1587
1588          /* lambda_local: */
1589          while (whatIsStg(stgLambdaBody(e))==LAMBDA) {
1590             nLambdasMerged++;
1591             stgLambdaArgs(e) = appendOnto(stgLambdaArgs(e),
1592                                           stgLambdaArgs(stgLambdaBody(e)));
1593             stgLambdaBody(e) = stgLambdaBody(stgLambdaBody(e));
1594          }
1595          break;
1596
1597
1598       case CASE:
1599          stgCaseScrut(e) = simplify(caseEnv,stgCaseScrut(e));
1600          if (isStgCaseWithSingleNonDefaultAlt(e) &&
1601              (whatIsStg(stgCaseScrut(e))==STGVAR ||
1602               whatIsStg(stgCaseScrut(e))==NAME)) {
1603             List caseEnv2 = cons(
1604                                pair(stgCaseScrut(e),stgCaseAltVars(hd(stgCaseAlts(e)))),
1605                                caseEnv
1606                             );
1607             map1Over(simplify,caseEnv2,stgCaseAlts(e));
1608          } else {
1609             map1Over(simplify,caseEnv,stgCaseAlts(e));
1610          }
1611
1612          case_local:
1613          /* zap redundant default alternatives */
1614          if (stgAltsExhaustive(stgCaseAlts(e))) {
1615             Bool droppedDef = FALSE;
1616             bs2 = NIL;
1617             for (bs = dupList(stgCaseAlts(e));nonNull(bs);bs=tl(bs))
1618                if (!isDefaultAlt(hd(bs))) {
1619                   bs2=cons(hd(bs),bs2);
1620                } else {
1621                   droppedDef = TRUE;
1622                }
1623             bs2 = rev(bs2);
1624             stgCaseAlts(e) = bs2;
1625             if (droppedDef) nCaseDefaultsDropped++;
1626          }
1627
1628          switch (whatIsStg(stgCaseScrut(e))) {
1629             case CASE:
1630                /* attempt case-of-case */
1631                n = length(stgCaseAlts(e));
1632                if (n==1 ||
1633                            (n <= 3 &&
1634                             (stgSize(e)-stgSize(stgCaseScrut(e))) < 100 &&
1635                             constructsCon(stgCaseScrut(e)))
1636                   ) {
1637                   e = doCaseOfCase(e);
1638                   assert(whatIsStg(e)==CASE);
1639                   goto case_local;
1640                }
1641                break;
1642             case PRIMCASE:
1643                /* attempt case-of-case# */
1644                n = length(stgCaseAlts(e));
1645                if (n==1 ||
1646                            (n <= 3 &&
1647                             (stgSize(e)-stgSize(stgCaseScrut(e))) < 100 &&
1648                             constructsCon(stgCaseScrut(e)))
1649                   ) {
1650                   e = doCaseOfPrimCase(e);
1651                   assert(whatIsStg(e)==PRIMCASE);
1652                   goto primcase_local;
1653                }
1654                break;
1655             case LETREC:
1656                /* attempt case-of-let */
1657                e = doCaseOfLet(e,&done);
1658                if (done) { assert(whatIsStg(e)==LETREC); goto let_local; };
1659                break;
1660             case STGCON:
1661                /* attempt case-of-constructor */
1662                e = doCaseOfCon(e,&done);
1663                /* we don't know what the result is, so can't jump to local */
1664                break;
1665             case NAME:
1666             case STGVAR: {
1667                /* attempt to remove case on something already cased on */
1668                List outervs, innervs, sub;
1669                Cell lookupResult;
1670                if (!isStgCaseWithSingleNonDefaultAlt(e)) break;
1671                lookupResult = cellAssoc(stgCaseScrut(e),caseEnv);
1672                if (isNull(lookupResult)) break;
1673                outervs = snd(lookupResult);
1674                nCaseOfOuter++;
1675                sub = NIL;
1676                innervs = stgCaseAltVars(hd(stgCaseAlts(e)));
1677                for (; nonNull(outervs) && nonNull(innervs);
1678                       outervs=tl(outervs), innervs=tl(innervs))
1679                   sub = cons(pair(hd(innervs),hd(outervs)),sub);
1680                assert (isNull(outervs) && isNull(innervs));
1681                return zubstExpr(sub, stgCaseAltBody(hd(stgCaseAlts(e))));
1682                }
1683             default:
1684                break;
1685          }
1686          break;
1687       case CASEALT:
1688          stgCaseAltBody(e) = simplify(caseEnv,stgCaseAltBody(e));
1689          break;
1690       case DEEFALT:
1691          stgDefaultBody(e) = simplify(caseEnv,stgDefaultBody(e));
1692          break;
1693       case PRIMALT:
1694          stgPrimAltBody(e) = simplify(caseEnv,stgPrimAltBody(e));
1695          break;
1696       case PRIMCASE:
1697          stgPrimCaseScrut(e) = simplify(caseEnv,stgPrimCaseScrut(e));
1698          map1Over(simplify,caseEnv,stgPrimCaseAlts(e));
1699          primcase_local:
1700          break;
1701       case STGAPP: {
1702          List    sub, formals;
1703          StgExpr subd_body;
1704          StgExpr fun;
1705          List    args;
1706
1707          stgAppFun(e) = simplify(caseEnv,stgAppFun(e));
1708          map1Over(simplify,caseEnv,stgAppArgs(e));
1709
1710          fun  = stgAppFun(e);
1711          args = stgAppArgs(e);
1712
1713          switch (whatIsStg(fun)) {
1714             case STGAPP:
1715                nAppsMerged++;
1716                stgAppArgs(e) = appendOnto(stgAppArgs(fun),args);
1717                stgAppFun(e) = stgAppFun(fun);
1718                break;
1719             case LETREC:
1720                /* (let binds in f) args  ==> let binds in (f args) */
1721                nLetsFloatedOutOfFn++;
1722                e = mkStgLet(stgLetBinds(fun),mkStgApp(stgLetBody(fun),args));
1723                assert(whatIsStg(e)==LETREC);
1724                goto let_local;
1725                break;
1726             case CASE:
1727                if (length(stgCaseAlts(fun))==1 &&
1728                    !isDefaultAlt(hd(stgCaseAlts(fun)))) {
1729                   StgCaseAlt theAlt = hd(stgCaseAlts(fun));
1730                   /* (case e of alt -> f) args  ==> case e of alt -> f args */
1731                   e = mkStgCase(
1732                          stgCaseScrut(fun),
1733                          singleton(mkStgCaseAlt(stgCaseAltCon(theAlt),
1734                                                 stgCaseAltVars(theAlt),
1735                                                  mkStgApp(stgCaseAltBody(theAlt),args))
1736                          )
1737                       );
1738                   nCasesFloatedOutOfFn++;
1739                   assert(whatIsStg(e)==CASE);
1740                   goto case_local;
1741                }
1742                break;
1743             case LAMBDA: {
1744                sub      = NIL;
1745                formals  = stgLambdaArgs(fun);
1746                while (nonNull(formals) && nonNull(args)) {
1747                   sub     = cons(pair(hd(formals),hd(args)),sub);
1748                   formals = tl(formals);
1749                   args    = tl(args);
1750                }
1751                subd_body = zubstExpr(sub,stgLambdaBody(fun));
1752
1753                nBetaReductions++;
1754                assert(isNull(formals) || isNull(args));
1755                if (isNull(formals) && isNull(args)) {
1756                   /* fn and args match exactly */
1757                   e = subd_body;
1758                   return e;
1759                }
1760                else
1761                if (isNull(formals) && nonNull(args)) {
1762                   /* more args than we could deal with.  Build a new Ap. */
1763                   e = mkStgApp(subd_body,args);
1764                   return e;
1765                }
1766                else
1767                if (nonNull(formals) && isNull(args)) {
1768                   /* partial application.  We get a new Lambda */
1769                   e = mkStgLambda(formals,subd_body);
1770                   return e;
1771                }
1772                }
1773                break;
1774             default:
1775                break;
1776          }
1777          }
1778          break;
1779       case STGPRIM:
1780          break;
1781       case STGCON:
1782          break;
1783       case INTCELL:
1784       case STRCELL:
1785       case PTRCELL:
1786       case CHARCELL:
1787       case FLOATCELL:
1788          break;
1789       default:
1790          fprintf(stderr, "simplify: unknown stuff %d\n",whatIsStg(e));
1791          ppStgExpr(e);
1792          printf("\n");
1793          print(e,1000);
1794          printf("\n");
1795          assert(0);
1796    }
1797    return e;
1798 }
1799
1800
1801 /* Restore STG representation invariants broken by simplify.
1802    -- Let-bind any constructor applications which appear
1803       anywhere other than a let.
1804    -- Let-bind non-atomic case scrutinees (ToDo).
1805 */
1806 StgExpr restoreStg ( StgExpr e )
1807 {
1808    List bs;
1809    StgVar newv;
1810
1811    if (isNull(e)) return e;
1812
1813    switch(whatIsStg(e)) {
1814       case LETREC:
1815          for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs)) {
1816             if (whatIsStg(stgVarBody(hd(bs))) == STGCON) {
1817               /* do nothing */
1818             }
1819             else
1820             if (whatIsStg(stgVarBody(hd(bs))) == LAMBDA) {
1821                stgLambdaBody(stgVarBody(hd(bs)))
1822                   = restoreStg(stgLambdaBody(stgVarBody(hd(bs))));
1823             }
1824             else {
1825                stgVarBody(hd(bs)) = restoreStg(stgVarBody(hd(bs)));
1826             }
1827          }
1828          stgLetBody(e) = restoreStg(stgLetBody(e));
1829          break;
1830       case LAMBDA:
1831          /* note that the check in LETREC above ensures we won't
1832             get here for legitimate (let-bound) lambdas. */
1833          stgLambdaBody(e) = restoreStg(stgLambdaBody(e));
1834          newv = mkStgVar(e,NIL);
1835          e = mkStgLet(singleton(newv),newv);
1836          break;
1837       case CASE:
1838          stgCaseScrut(e) = restoreStg(stgCaseScrut(e));
1839          mapOver(restoreStg,stgCaseAlts(e));
1840          if (!isAtomic(stgCaseScrut(e))) {
1841             newv = mkStgVar(stgCaseScrut(e),NIL);
1842             return mkStgLet(singleton(newv),mkStgCase(newv,stgCaseAlts(e)));
1843          }
1844          break;
1845       case PRIMCASE:
1846          stgPrimCaseScrut(e) = restoreStg(stgPrimCaseScrut(e));
1847          mapOver(restoreStg,stgPrimCaseAlts(e));
1848          break;
1849       case STGAPP:
1850          stgAppFun(e) = restoreStg(stgAppFun(e));
1851          mapOver(restoreStg,stgAppArgs(e)); /* probably incorrect */
1852          if (!isAtomic(stgAppFun(e))) {
1853             newv = mkStgVar(stgAppFun(e),NIL);
1854             e = mkStgLet(singleton(newv),mkStgApp(newv,stgAppArgs(e)));
1855          }
1856          break;
1857       case STGPRIM:
1858          mapOver(restoreStg,stgPrimArgs(e));
1859          break;
1860       case STGCON:
1861          /* note that the check in LETREC above ensures we won't
1862             get here for legitimate constructor applications. */
1863          mapOver(restoreStg,stgConArgs(e));
1864          newv = mkStgVar(e,NIL);
1865          return mkStgLet(singleton(newv),newv);
1866          break;
1867       case CASEALT:
1868          stgCaseAltBody(e) = restoreStg(stgCaseAltBody(e));
1869          if (whatIsStg(stgCaseAltBody(e))==LAMBDA) {
1870             newv = mkStgVar(stgCaseAltBody(e),NIL);
1871             stgCaseAltBody(e) = mkStgLet(singleton(newv),newv);
1872          }
1873          break;
1874       case DEEFALT:
1875          stgDefaultBody(e) = restoreStg(stgDefaultBody(e));
1876          if (whatIsStg(stgDefaultBody(e))==LAMBDA) {
1877             newv = mkStgVar(stgDefaultBody(e),NIL);
1878             stgDefaultBody(e) = mkStgLet(singleton(newv),newv);
1879          }
1880          break;
1881       case PRIMALT:
1882          stgPrimAltBody(e) = restoreStg(stgPrimAltBody(e));
1883          break;
1884       case STGVAR:
1885       case NAME:
1886       case INTCELL:
1887       case STRCELL:
1888       case PTRCELL:
1889       case CHARCELL:
1890       case FLOATCELL:
1891          break;
1892       default:
1893          fprintf(stderr, "restoreStg: unknown stuff %d\n",whatIsStg(e));
1894          ppStgExpr(e);
1895          printf("\n");
1896          assert(0);
1897    }
1898    return e;
1899 }
1900
1901
1902 StgExpr restoreStgTop ( StgExpr e )
1903 {
1904    if (whatIs(e)==LAMBDA)
1905       stgLambdaBody(e) = restoreStg(stgLambdaBody(e)); else
1906       e = restoreStg(e);
1907    return e;
1908 }
1909
1910
1911 void simplTopRefs ( StgExpr e )
1912 {
1913    List bs;
1914
1915    switch(whatIsStg(e)) {
1916      /* the only interesting case */
1917       case NAME:
1918          if (name(e).inlineMe && !name(e).simplified) {
1919             /* printf("\n((%d)) request for %s\n",rDepth, textToStr(name(e).text)); */
1920             name(e).simplified = TRUE;
1921             optimiseTopBind(name(e).stgVar);
1922             /* printf("((%d)) done    for %s\n",rDepth, textToStr(name(e).text)); */
1923          }
1924          break;
1925       case LETREC:
1926          simplTopRefs(stgLetBody(e));
1927          for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
1928             simplTopRefs(stgVarBody(hd(bs)));
1929          break;
1930       case LAMBDA:
1931          simplTopRefs(stgLambdaBody(e));
1932          break;
1933       case CASE:
1934          simplTopRefs(stgCaseScrut(e));
1935          mapProc(simplTopRefs,stgCaseAlts(e));
1936          break;
1937       case PRIMCASE:
1938          simplTopRefs(stgPrimCaseScrut(e));
1939          mapProc(simplTopRefs,stgPrimCaseAlts(e));
1940          break;
1941       case STGAPP:
1942          simplTopRefs(stgAppFun(e));
1943          mapProc(simplTopRefs,stgAppArgs(e));
1944          break;
1945       case STGCON:
1946          mapProc(simplTopRefs,stgConArgs(e));
1947          break;
1948       case STGPRIM:
1949          simplTopRefs(stgPrimOp(e));
1950          mapProc(simplTopRefs,stgPrimArgs(e));
1951          break;
1952       case CASEALT:
1953          simplTopRefs(stgCaseAltBody(e));
1954          break;
1955       case DEEFALT:
1956          simplTopRefs(stgDefaultBody(e));
1957          break;
1958       case PRIMALT:
1959          simplTopRefs(stgPrimAltBody(e));
1960          break;
1961       case INTCELL:
1962       case STRCELL:
1963       case PTRCELL:
1964       case BIGCELL:
1965       case CHARCELL:
1966       case FLOATCELL:
1967       case TUPLE:
1968       case STGVAR:
1969          break;
1970       default:
1971          fprintf(stderr, "simplTopRefs: unknown stuff %d\n",whatIsStg(e));
1972          ppStgExpr(e);
1973          printf("\n");
1974          print(e,1000);
1975          printf("\n");
1976          assert(0);
1977    }
1978 }
1979
1980 char* maybeName ( StgVar v )
1981 {
1982    Name n = nameFromStgVar(v);
1983    if (isNull(n)) return "(unknown)";
1984    return textToStr(name(n).text);
1985 }
1986
1987
1988 /* --------------------------------------------------------------------------
1989  * Sanity checking (weak :-(
1990  * ------------------------------------------------------------------------*/
1991
1992 Bool stgError;
1993
1994 int stgSanity_checkStack ( StgVar v )
1995 {
1996    int i, j;
1997    j = 0;
1998    for (i = 0; i <= sp; i++)
1999       if (stack(i)==v) j++;
2000    return j;
2001 }
2002
2003 void stgSanity_dropVar ( StgVar v )
2004 {
2005    drop();
2006 }
2007
2008 void stgSanity_pushVar ( StgVar v )
2009 {
2010    if (stgSanity_checkStack(v) != 0) stgError = TRUE;
2011    push(v);
2012 }
2013
2014
2015 void stgSanity ( StgExpr e )
2016 {
2017    List bs;
2018
2019    switch(whatIsStg(e)) {
2020       case LETREC:
2021          mapProc(stgSanity_pushVar,stgLetBinds(e));
2022          stgSanity(stgLetBody(e));
2023          for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
2024              stgSanity(stgVarBody(hd(bs)));
2025          mapProc(stgSanity_dropVar,stgLetBinds(e));
2026          break;
2027       case LAMBDA:
2028          mapProc(stgSanity_pushVar,stgLambdaArgs(e));
2029          stgSanity(stgLambdaBody(e));
2030          mapProc(stgSanity_dropVar,stgLambdaArgs(e));
2031          break;
2032       case CASE:
2033          stgSanity(stgCaseScrut(e));
2034          mapProc(stgSanity,stgCaseAlts(e));
2035          break;
2036       case PRIMCASE:
2037          stgSanity(stgPrimCaseScrut(e));
2038          mapProc(stgSanity,stgPrimCaseAlts(e));
2039          break;
2040       case STGAPP:
2041          stgSanity(stgAppFun(e));
2042          mapProc(stgSanity,stgAppArgs(e));
2043          break;
2044       case STGCON:
2045          stgSanity(stgConCon(e));
2046          mapProc(stgSanity,stgConArgs(e));
2047          break;
2048       case STGPRIM:
2049          stgSanity(stgPrimOp(e));
2050          mapProc(stgSanity,stgPrimArgs(e));
2051          break;
2052       case CASEALT:
2053          mapProc(stgSanity_pushVar,stgCaseAltVars(e));
2054          stgSanity(stgCaseAltBody(e));
2055          mapProc(stgSanity_dropVar,stgCaseAltVars(e));
2056          break;
2057       case DEEFALT:
2058          stgSanity_pushVar(stgDefaultVar(e));
2059          stgSanity(stgDefaultBody(e));
2060          stgSanity_dropVar(stgDefaultVar(e));
2061          break;
2062       case PRIMALT:
2063          mapProc(stgSanity_pushVar,stgPrimAltVars(e));
2064          stgSanity(stgPrimAltBody(e));
2065          mapProc(stgSanity_dropVar,stgPrimAltVars(e));
2066          break;
2067       case STGVAR:
2068          if (stgSanity_checkStack(e) == 1) break;
2069          if (nonNull(nameFromStgVar(e))) return;
2070          break;
2071       case NAME:
2072       case INTCELL:
2073       case STRCELL:
2074       case PTRCELL:
2075       case CHARCELL:
2076       case FLOATCELL:
2077       case TUPLE:
2078          break;
2079       default:
2080          fprintf(stderr, "stgSanity: unknown stuff %d\n",whatIsStg(e));
2081          ppStgExpr(e);
2082          printf("\n");
2083          print(e,1000);
2084          printf("\n");
2085          assert(0);
2086    }
2087 }
2088
2089
2090 void stgTopSanity ( char* caller, StgExpr e )
2091 {
2092 return;
2093    clearStack();
2094    assert(sp == -1);
2095    stgError = FALSE;
2096    stgSanity(e);
2097    assert(sp == -1);
2098    if (stgError) {
2099       fprintf(stderr, "\n\nstgTopSanity (caller = %s):\n\n", caller );
2100       ppStgExpr ( e );
2101       printf( "\n\n" );
2102       assert(0);
2103    }
2104 }
2105
2106
2107 /* Check if e is in a form which the code generator can deal with.
2108  * stgexpr-ness is what we need to enforce.  The extended version,
2109  * expr, may only occur as the rhs of a let binding.
2110  *
2111  * stgexpr ::= case atom of alts
2112  *           | case# primop{atom*} of primalts
2113  *           | let v_i = expr_i in stgexpr
2114  *           | var{atom*}
2115  *
2116  * expr ::= stgexpr
2117  *        | \v_i -> stgexpr
2118  *        | con{atoms}
2119  *
2120  *  alt ::= con vars -> stgexpr      (primalt and default similarly)
2121  *
2122  * atom ::= var | int | char etc     (unboxed, that is)
2123  */
2124 Bool isStgExpr     ( StgExpr e );
2125 Bool isStgFullExpr ( StgExpr e );
2126
2127 Bool isStgExpr ( StgExpr e )
2128 {
2129    List bs;
2130    switch (whatIs(e)) {
2131       case LAMBDA:
2132       case STGCON:
2133          return FALSE;
2134       case LETREC:
2135          for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
2136             if (!isStgFullExpr(stgVarBody(hd(bs))))
2137                return FALSE;
2138          return isStgExpr(stgLetBody(e));
2139       case CASE:
2140          for (bs=stgCaseAlts(e); nonNull(bs); bs=tl(bs))
2141             if (!isStgExpr(hd(bs))) return FALSE;
2142          return isAtomic(stgCaseScrut(e));
2143       case PRIMCASE:
2144          for (bs=stgPrimCaseAlts(e); nonNull(bs); bs=tl(bs))
2145             if (!isStgExpr(hd(bs))) return FALSE;
2146          if (isAtomic(stgPrimCaseScrut(e))) return TRUE;
2147          if (whatIs(stgPrimCaseScrut(e))==STGPRIM)
2148             return isStgExpr(stgPrimCaseScrut(e));
2149          return FALSE;
2150       case STGVAR:
2151       case NAME:
2152          return TRUE;
2153       case STGAPP:
2154          for (bs=stgAppArgs(e); nonNull(bs); bs=tl(bs))
2155             if (!isAtomic(hd(bs))) return FALSE;
2156          if (isStgVar(stgAppFun(e)) || isName(stgAppFun(e))) return TRUE;
2157          return FALSE;
2158       case STGPRIM:
2159          for (bs=stgPrimArgs(e); nonNull(bs); bs=tl(bs))
2160             if (!isAtomic(hd(bs))) return FALSE;
2161          if (isName(stgPrimOp(e))) return TRUE;
2162          return FALSE;
2163       case CASEALT:
2164          return isStgExpr(stgCaseAltBody(e));
2165       case DEEFALT:
2166          return isStgExpr(stgDefaultBody(e));
2167       case PRIMALT:
2168          return isStgExpr(stgPrimAltBody(e));
2169       default:
2170          return FALSE;
2171    }
2172 }
2173
2174
2175 Bool isStgFullExpr ( StgExpr e )
2176 {
2177    List bs;
2178    switch (whatIs(e)) {
2179       case LAMBDA:
2180          return isStgExpr(stgLambdaBody(e));
2181       case STGCON:
2182          for (bs=stgConArgs(e); nonNull(bs); bs=tl(bs))
2183             if (!isAtomic(hd(bs))) return FALSE;
2184          if (isName(stgConCon(e)) || isTuple(stgConCon(e)))
2185             return TRUE;
2186          return FALSE;
2187       default:
2188          return isStgExpr(e);
2189    }
2190 }
2191
2192
2193 /* --------------------------------------------------------------------------
2194  * Top level calls
2195  * ------------------------------------------------------------------------*/
2196
2197 /* Set ddumpSimpl to TRUE if you want to see simplified code. */
2198 static Bool ddumpSimpl = FALSE;
2199
2200 /* Leave this one alone ... */
2201 static Bool noisy;
2202
2203
2204 static void local optimiseTopBind( StgVar v )
2205 {
2206   /* Bool ppPrel = FALSE; */
2207    Int  n, m;
2208    Name naam;
2209    Int  oldSize, newSize;
2210    Bool me;
2211
2212    /* printf( "[[%d]] looking at %s\n", rDepth, maybeName(v)); */
2213    assert(whatIsStg(v)==STGVAR);
2214
2215    rDepth++;
2216    if (nonNull(stgVarBody(v))) simplTopRefs(stgVarBody(v));
2217    rDepth--;
2218
2219    /* debugging ... */
2220    //me= 0&& 0==strcmp("tcUnify",maybeName(v));
2221    me= 0&& 0==strcmp("ttt",maybeName(v));
2222
2223    nTotSizeIn += stgSize(stgVarBody(v));
2224    if (noisy) {
2225       printf( "%28s: in %4d    ", maybeName(v),stgSize(stgVarBody(v)));
2226       fflush(stdout);
2227    }
2228
2229    inDBuilder = FALSE;
2230    naam = nameFromStgVar(v);
2231    if (nonNull(naam) && name(naam).isDBuilder) inDBuilder = TRUE;
2232
2233 #if DEBUG_OPTIMISE
2234    if (nonNull(naam)) {
2235       assert(name(naam).stgSize == stgSize(stgVarBody(name(naam).stgVar)));
2236    }
2237 #endif
2238
2239    if (me) {
2240       fflush(stdout); fflush(stderr);
2241       fprintf ( stderr, "{{%d}}-----------------------------\n", -v );fflush(stderr);
2242       printStg ( stderr, v );
2243       fprintf(stderr, "\n" );
2244    }
2245
2246    stgTopSanity ( "initial", stgVarBody(v));
2247
2248    if (nonNull(stgVarBody(v))) {
2249       oldSize = -1;
2250
2251       for (n = 0; n < 8; n++) { // originally 7
2252          if (noisy) printf("%4d", stgSize(stgVarBody(v)));
2253          copyInTopvar = TRUE;
2254          stgTopSanity ( "outer-1", stgVarBody(v));
2255          oaTop ( v );
2256          stgTopSanity ( "outer-2", stgVarBody(v));
2257          stgVarBody(v) = copyIn ( NIL, CTX_OTHER, stgVarBody(v) );
2258          stgTopSanity ( "outer-3", stgVarBody(v));
2259          stgVarBody(v) = simplify ( NIL, stgVarBody(v) );
2260          stgTopSanity ( "outer-4", stgVarBody(v));
2261
2262          for (m = 0; m < 3; m++) { // oprignally 3
2263             if (noisy) printf(".");
2264             fflush(stdout);
2265             copyInTopvar = FALSE;
2266             stgTopSanity ( "inner-1", stgVarBody(v));
2267             oaTop ( v );
2268             stgTopSanity ( "inner-2", stgVarBody(v));
2269             stgVarBody(v) = copyIn ( NIL, CTX_OTHER, stgVarBody(v) );
2270             stgTopSanity ( "inner-3", stgVarBody(v));
2271             stgVarBody(v) = simplify ( NIL, stgVarBody(v) );
2272
2273             if (me && 0) {
2274                fprintf(stderr,"\n-%d- - - - - - - - - - - - - -\n", n+1);
2275                printStg ( stderr,v );
2276             }
2277             stgTopSanity ( "inner-post", stgVarBody(v));
2278
2279          }
2280
2281          if (me && 1) {
2282             fprintf(stderr,"\n-%d-=-=-=-=-=-=-=-=-=-=-=-=-=-\n", n+1);
2283             printStg ( stderr,v );
2284          }
2285
2286          stgTopSanity ( "outer-post", stgVarBody(v));
2287
2288          newSize = stgSize ( stgVarBody(v) );
2289          if (newSize == oldSize) break;
2290          oldSize = newSize;
2291       }
2292       n++; for (; n < 8; n++) for (m = 0; m <= 3+3; m++) if (noisy) printf ( " " );
2293       if (noisy) printf(" --> %4d\n", stgSize(stgVarBody(v)) );
2294       stgVarBody(v) = restoreStgTop ( stgVarBody(v) );
2295
2296       if (nonNull(naam)) {
2297          assert(name(naam).stgVar == v);
2298          name(naam).stgSize = stgSize(stgVarBody(v));
2299       }
2300
2301 #if DEBUG_OPTIMISE
2302       /* debugging ... */
2303       if (!isStgFullExpr(stgVarBody(v))) {
2304          fprintf(stderr, "\n\nrestoreStg failed!\n\n" );
2305          printStg(stderr, v);
2306          fprintf(stderr, "\n" );
2307          exit(1);
2308       }
2309 #endif
2310    }
2311
2312    nTotSizeOut += stgSize(stgVarBody(v));
2313
2314    if (me) {
2315       fprintf(stderr,"\n=============================\n");
2316       printStg ( stderr,v );
2317       fprintf(stderr, "\n\n" );
2318       fflush(stderr);
2319       if (me) exit(1);
2320    }
2321 }
2322
2323
2324 void optimiseTopBinds ( List bs )
2325 {
2326    List t;
2327    Name n;
2328    Target ta = 0;
2329
2330    noisy = ddumpSimpl && (lastModule() != modulePrelude);
2331
2332    optimiser(RESET);
2333    if (noisy) printf("\n");
2334    initOptStats();
2335
2336    for (t = bs; nonNull(t); t=tl(t)) {
2337       n = nameFromStgVar(hd(t));
2338       if (isNull(n) || !name(n).simplified) {
2339          rDepth = 0;
2340          optimiseTopBind(hd(t));
2341       }
2342       soFar(ta++);
2343    }
2344    if (noisy) printOptStats ( stderr );
2345    optimiser(RESET);
2346 }
2347
2348
2349 /* --------------------------------------------------------------------------
2350  * Optimiser control:
2351  * ------------------------------------------------------------------------*/
2352
2353 Void optimiser(what)
2354 Int what; {
2355
2356     switch (what) {
2357         case INSTALL :
2358         case RESET   : spClone = SP_NOT_IN_USE;
2359                        initStgVarSets();
2360                        daSccs = NIL;
2361                        break;
2362
2363         case MARK    : markPairs();
2364                        markStgVarSets();
2365                        mark(daSccs);
2366                        break;
2367
2368         case GCDONE  : checkStgVarSets();
2369                        break;
2370     }
2371 }
2372
2373 /*-------------------------------------------------------------------------*/