ghc/interpreter/optimise.c

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