2 /* --------------------------------------------------------------------------
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
9 * $RCSfile: optimise.c,v $
11 * $Date: 1999/04/27 10:06:57 $
12 * ------------------------------------------------------------------------*/
20 #include "Assembler.h"
22 /* #define DEBUG_OPTIMISE */
24 /* --------------------------------------------------------------------------
26 * ------------------------------------------------------------------------*/
28 Int nLoopBreakersInlined;
37 Int nLetrecGroupsDropped;
39 Int nCaseDefaultsDropped;
41 Int nLetsFloatedOutOfFn;
42 Int nLetsFloatedIntoCase;
43 Int nCasesFloatedOutOfFn;
53 static void local optimiseTopBind( StgVar v );
62 /* Exactly like whatIs except it avoids a fn call for STG tags */
63 #define whatIsStg(xx) ((isPair(xx) ? (isTag(fst(xx)) ? fst(xx) : AP) : whatIs(xx)))
66 /* --------------------------------------------------------------------------
67 * Transformation stats
68 * ------------------------------------------------------------------------*/
70 void initOptStats ( void )
72 nLoopBreakersInlined = 0;
81 nLetrecGroupsDropped = 0;
83 nCaseDefaultsDropped = 0;
85 nLetsFloatedOutOfFn = 0;
86 nLetsFloatedIntoCase = 0;
87 nCasesFloatedOutOfFn = 0;
93 void printOptStats ( FILE* f )
95 fflush(stdout); fflush(stderr); fflush(f);
97 fprintf(f, "Inlining: topvar %-5d letvar %-5d"
98 " loopbrkr %-5d betaredn %-5d\n",
99 nTopvarsInlined, nLetvarsInlined, nLoopBreakersInlined,
101 fprintf(f, "Case-of-: let %-5d case %-5d"
102 " con %-5d case# %-5d\n",
103 nCaseOfLet, nCaseOfCase, nCaseOfCon, nCaseOfPrimCase );
104 fprintf(f, "Dropped: letbind %-5d letgroup %-5d"
106 nLetBindsDropped, nLetrecGroupsDropped, nCaseDefaultsDropped );
107 fprintf(f, "Merges: lambda %-5d app %-5d\n",
108 nLambdasMerged, nAppsMerged );
109 fprintf(f, "Fn-float: let %-5d case %-5d\n",
110 nLetsFloatedOutOfFn, nCasesFloatedOutOfFn );
111 fprintf(f, "Misc: case-outer %-5d let-into-case %-5d\n",
112 nCaseOfOuter, nLetsFloatedIntoCase );
113 fprintf(f, "total size: in %-5d out %-5d\n",
114 nTotSizeIn, nTotSizeOut );
119 /* --------------------------------------------------------------------------
120 * How big is this STG tree (viz (primarily), do I want to inline it?)
121 * ------------------------------------------------------------------------*/
123 Int stgSize_list ( List es )
126 for (; nonNull(es); es=tl(es)) n += stgSize(hd(es));
130 Int stgSize ( StgExpr e )
135 if (isNull(e)) return 0;
137 switch(whatIsStg(e)) {
141 for (xs = stgLetBinds(e); nonNull(xs);xs=tl(xs))
142 n += stgSize(stgVarBody(hd(xs)));
143 n += stgSize(stgLetBody(e));
146 n += stgSize(stgLambdaBody(e));
149 n += stgSize_list(stgCaseAlts(e));
150 n += stgSize(stgCaseScrut(e));
153 n += stgSize_list(stgPrimCaseAlts(e));
154 n += stgSize(stgPrimCaseScrut(e));
157 n += stgSize_list(stgAppArgs(e));
158 n += stgSize(stgAppFun(e));
161 n += stgSize_list(stgPrimArgs(e));
162 n += stgSize(stgPrimOp(e));
165 n += stgSize_list(stgConArgs(e));
166 n += stgSize(stgConCon(e));
169 n = stgSize(stgDefaultBody(e));
172 n = stgSize(stgCaseAltBody(e));
175 n = stgSize(stgPrimAltBody(e));
187 fprintf(stderr, "sizeStg: unknown stuff %d\n",whatIsStg(e));
194 /* --------------------------------------------------------------------------
195 * Stacks of pairs of collectable things. Used to implement associations.
196 * cloneStg() uses its stack to map old var names to new ones.
197 * ------------------------------------------------------------------------*/
200 #define SP_NOT_IN_USE (-123456789)
203 struct { Cell pfst; Cell psnd; }
207 static StgPair pairClone[M_PAIRS];
209 void markPairs ( void )
212 if (spClone != SP_NOT_IN_USE) {
213 for (i = 0; i <= spClone; i++) {
214 mark(pairClone[i].pfst);
215 mark(pairClone[i].psnd);
220 void pushClone ( Cell a, Cell b )
223 if (spClone >= M_PAIRS) internal("pushClone -- M_PAIRS too small");
224 pairClone[spClone].pfst = a;
225 pairClone[spClone].psnd = b;
228 void dropClone ( void )
230 if (spClone < 0) internal("dropClone");
234 Cell findClone ( Cell x )
237 for (i = spClone; i >= 0; i--)
238 if (pairClone[i].pfst == x)
239 return pairClone[i].psnd;
244 /* --------------------------------------------------------------------------
245 * Cloning of STG trees
246 * ------------------------------------------------------------------------*/
248 /* Clone v to create a new var. Works for both StgVar and StgPrimVar. */
249 StgVar cloneStgVar ( StgVar v )
251 return ap(STGVAR,triple(stgVarBody(v),stgVarRep(v),NIL));
255 /* For each StgVar in origVars, make a new one with cloneStgVar,
256 and push the (old,new) pair on the clone pair stack. Returns
257 the list of new vars.
259 List cloneStg_addVars ( List origVars )
262 while (nonNull(origVars)) {
263 StgVar newv = cloneStgVar(hd(origVars));
264 pushClone ( hd(origVars), newv );
265 newVars = cons(newv,newVars);
266 origVars = tl(origVars);
268 newVars = rev(newVars);
273 void cloneStg_dropVars ( List vs )
275 for (; nonNull(vs); vs=tl(vs))
280 /* Print the clone pair stack. Just for debugging purposes. */
281 void ppCloneEnv ( char* s )
284 fflush(stdout);fflush(stderr);
285 printf ( "\nenv-%s\n", s );
286 for (i = 0; i <= spClone; i++) {
288 ppStgExpr(pairClone[i].pfst);
289 ppStgExpr(pairClone[i].psnd);
292 printf ( "vne-%s\n", s );
296 StgExpr cloneStg ( StgExpr e )
302 switch(whatIsStg(e)) {
305 if (nonNull(newv)) return newv; else return e;
307 newvs = cloneStg_addVars ( stgLetBinds(e) );
308 for (xs = newvs; nonNull(xs);xs=tl(xs))
309 stgVarBody(hd(xs)) = cloneStg(stgVarBody(hd(xs)));
310 t = mkStgLet(newvs,cloneStg(stgLetBody(e)));
311 cloneStg_dropVars ( stgLetBinds(e) );
314 newvs = cloneStg_addVars ( stgLambdaArgs(e) );
315 t = mkStgLambda(newvs, cloneStg(stgLambdaBody(e)));
316 cloneStg_dropVars ( stgLambdaArgs(e) );
319 xs = dupList(stgCaseAlts(e));
320 mapOver(cloneStg,xs);
321 return mkStgCase(cloneStg(stgCaseScrut(e)),xs);
323 xs = dupList(stgPrimCaseAlts(e));
324 mapOver(cloneStg,xs);
325 return mkStgPrimCase(cloneStg(stgPrimCaseScrut(e)),xs);
327 xs = dupList(stgAppArgs(e));
328 mapOver(cloneStg,xs);
329 return mkStgApp(cloneStg(stgAppFun(e)),xs);
331 xs = dupList(stgPrimArgs(e));
332 mapOver(cloneStg,xs);
333 return mkStgPrim(cloneStg(stgPrimOp(e)),xs);
335 xs = dupList(stgConArgs(e));
336 mapOver(cloneStg,xs);
337 return mkStgCon(cloneStg(stgConCon(e)),xs);
339 newv = cloneStgVar(stgDefaultVar(e));
340 pushClone ( stgDefaultVar(e), newv );
341 t = mkStgDefault(newv,cloneStg(stgDefaultBody(e)));
345 newvs = cloneStg_addVars ( stgCaseAltVars(e) );
346 t = mkStgCaseAlt(stgCaseAltCon(e),newvs,
347 cloneStg(stgCaseAltBody(e)));
348 cloneStg_dropVars ( stgCaseAltVars(e) );
351 newvs = cloneStg_addVars ( stgPrimAltVars(e) );
352 t = mkStgPrimAlt(newvs, cloneStg(stgPrimAltBody(e)));
353 cloneStg_dropVars ( stgPrimAltVars(e) );
365 fprintf(stderr, "cloneStg: unknown stuff %d\n",whatIsStg(e));
371 /* Main entry point. Checks against re-entrant use. */
372 StgExpr cloneStgTop ( StgExpr e )
375 if (spClone != SP_NOT_IN_USE)
376 internal("cloneStgTop");
378 res = cloneStg ( e );
379 assert(spClone == -1);
380 spClone = SP_NOT_IN_USE;
386 /* --------------------------------------------------------------------------
387 * Sets of StgVars, used by the strongly-connected-components machinery.
388 * Represented as an array of variables. The vars
389 * must be in strictly nondecreasing order. Each value may appear
390 * more than once, so as to make deletion relatively cheap.
392 * After a garbage collection happens, the values may have changed,
393 * so the array will need to be sorted.
395 * Using a binary search, membership costs O(log N). Union and
396 * intersection cost O(N + M). Deletion of a single element costs
397 * O(N) in the worst case, although if it happens infrequently
398 * compared to the other ops, it should asymptotically approach O(1).
399 * ------------------------------------------------------------------------*/
401 #define M_VAR_SETS 4000
402 #define MIN_VAR_SET_SIZE 4
403 #define M_UNION_TMP 20000
415 typedef Int StgVarSet;
417 StgVarSetRec varSet[M_VAR_SETS];
420 Cell union_tmp[M_UNION_TMP];
422 #if 0 /* unused since unnecessary */
423 /* Shellsort set elems to restore representation invariants */
424 static Int shellCells_incs[10]
425 = { 1, 4, 13, 40, 121, 364, 1093, 3280, 9841, 29524 };
426 static void shellCells ( Cell* a, Int lo, Int hi )
431 N = hi - lo + 1; if (N < 2) return;
433 while (hp < 10 && shellCells_incs[hp] < N) hp++; hp--;
435 for (; hp >= 0; hp--) {
436 h = shellCells_incs[hp];
443 a[j] = a[j-h]; j = j - h;
444 if (j <= (lo + h - 1)) break;
452 /* check that representation invariant still holds */
453 static void checkCells ( Cell* a, Int lo, Int hi )
456 for (i = lo; i < hi; i++)
458 internal("checkCells");
462 /* Mark set contents for GC */
463 void markStgVarSets ( void )
466 for (i = 0; i < M_VAR_SETS; i++)
468 for (j = 0; j < varSet[i].used; j++)
469 mark(varSet[i].vs[j]);
473 /* Check representation invariants after GC */
474 void checkStgVarSets ( void )
477 for (i = 0; i < M_VAR_SETS; i++)
479 checkCells ( varSet[i].vs, 0, varSet[i].used-1 );
483 /* Allocate a set of a given size */
484 StgVarSet allocStgVarSet ( Int size )
487 if (varSet_nextfree == -1)
488 internal("allocStgVarSet -- run out of var sets");
490 varSet_nextfree = varSet[i].nextfree;
491 varSet[i].inUse = TRUE;
492 j = MIN_VAR_SET_SIZE;
493 while (j <= size) j *= 2;
496 varSet[i].vs = malloc(j * sizeof(StgVar) );
498 internal("allocStgVarSet -- can't malloc memory");
504 /* resize (upwards) */
505 void resizeStgVarSet ( StgVarSet s, Int size )
510 Int j = MIN_VAR_SET_SIZE;
511 while (j <= size) j *= 2;
512 if (j < varSet[s].size) return;
514 tmp2 = malloc( j * sizeof(StgVar) );
515 if (!tmp2) internal("resizeStgVarSet -- can't malloc memory");
517 for (i = 0; i < varSet[s].used; i++)
523 /* Deallocation ... */
524 void freeStgVarSet ( StgVarSet s )
526 if (s < 0 || s >= M_VAR_SETS ||
527 !varSet[s].inUse || !varSet[s].vs)
528 internal("freeStgVarSet");
530 varSet[s].inUse = FALSE;
532 varSet[s].nextfree = varSet_nextfree;
539 void initStgVarSets ( void )
542 for (i = M_VAR_SETS-1; i >= 0; i--) {
543 varSet[i].inUse = FALSE;
545 varSet[i].nextfree = i+1;
547 varSet[M_VAR_SETS-1].nextfree = -1;
549 varSet_nfree = M_VAR_SETS;
553 /* Find a var using binary search */
554 Int findInStgVarSet ( StgVarSet s, StgVar v )
558 hi = varSet[s].used-1;
560 if (lo > hi) return -1;
562 if (varSet[s].vs[mid] == v) return mid;
563 if (varSet[s].vs[mid] < v) lo = mid+1; else hi = mid-1;
568 Bool elemStgVarSet ( StgVarSet s, StgVar v )
570 return findInStgVarSet(s,v) != -1;
573 void ppSet ( StgVarSet s )
576 fprintf(stderr, "{ ");
577 for (i = 0; i < varSet[s].used; i++)
578 fprintf(stderr, "%d ", varSet[s].vs[i] );
579 fprintf(stderr, "}\n" );
583 void deleteFromStgVarSet ( StgVarSet s, StgVar v )
586 i = findInStgVarSet(s,v);
588 j = varSet[s].used-1;
589 for (; i < j; i++) varSet[s].vs[i] = varSet[s].vs[i+1];
594 void singletonStgVarSet ( StgVarSet s, StgVar v )
601 void emptyStgVarSet ( StgVarSet s )
607 void copyStgVarSets ( StgVarSet dst, StgVarSet src )
610 varSet[dst].used = varSet[src].used;
611 for (i = 0; i < varSet[dst].used; i++)
612 varSet[dst].vs[i] = varSet[src].vs[i];
616 Int sizeofVarSet ( StgVarSet s )
618 return varSet[s].used;
622 void unionStgVarSets ( StgVarSet dst, StgVarSet src )
625 Int pd, ps, i, res_used, tmp_used, dst_used, src_used;
630 dst_vs = varSet[dst].vs;
632 /* fast track a common (~ 50%) case */
633 if (varSet[src].used == 1) {
634 v1 = varSet[src].vs[0];
635 pd = findInStgVarSet(dst,v1);
636 if (pd != -1) return;
637 if (varSet[dst].used < varSet[dst].size) {
638 i = varSet[dst].used;
639 while (i > 0 && dst_vs[i-1] > v1) {
640 dst_vs[i] = dst_vs[i-1];
649 res_used = varSet[dst].used + varSet[src].used;
650 if (res_used > M_UNION_TMP)
651 internal("unionStgVarSets -- M_UNION_TMP too small");
653 resizeStgVarSet(dst,res_used);
654 dst_vs = varSet[dst].vs;
655 src_vs = varSet[src].vs;
658 dst_used = varSet[dst].used;
659 src_used = varSet[src].used;
661 /* merge the two sets into tmp */
663 while (pd < dst_used || ps < src_used) {
665 tmp_vs[tmp_used++] = src_vs[ps++];
668 tmp_vs[tmp_used++] = dst_vs[pd++];
670 StgVar vald = dst_vs[pd];
671 StgVar vals = src_vs[ps];
673 tmp_vs[tmp_used++] = vald, pd++;
676 tmp_vs[tmp_used++] = vals, ps++;
678 tmp_vs[tmp_used++] = vals, ps++, pd++;
682 /* copy setTmp back to dst */
683 varSet[dst].used = tmp_used;
684 for (i = 0; i < tmp_used; i++) {
685 dst_vs[i] = tmp_vs[i];
691 /* --------------------------------------------------------------------------
692 * Strongly-connected-components machinery for STG let bindings.
693 * Arranges let bindings in minimal mutually recursive groups, and
694 * then throws away any groups not referred to in the body of the let.
696 * How it works: does a bottom-up sweep of the tree. Each call returns
697 * the set of variables free in the tree. All nodes except LETREC are
700 * When 'let v1=e1 .. vn=en in e' is encountered:
701 * -- recursively make a call on e. This returns fvs(e) and scc-ifies
703 * -- do recursive calls for e1 .. en too, giving fvs(e1) ... fvs(en).
705 * Then, using fvs(e1) ... fvs(en), the dependancy graph for v1 ... vn
706 * can be cheaply computed. Using that, compute the strong components
707 * and rearrange the let binding accordingly.
708 * Finally, for each of the strong components, we can use fvs(en) to
709 * cheaply determine if the component is used in the body of the let,
710 * and if not, it can be omitted.
712 * oaScc destructively modifies the tree -- when it gets to a let --
713 * we need to pass the address of the expression to scc, not the
714 * (more usual) heap index of it.
716 * The main requirement of this algorithm is an efficient implementation
717 * of sets of variables. Because there is no name shadowing in these
718 * trees, either mentioned-sets or free-sets would be ok, although
719 * free sets are presumably smaller.
720 * ------------------------------------------------------------------------*/
723 #define SCC stgScc /* make scc algorithm for StgVars */
724 #define LOWLINK stgLowlink
725 #define DEPENDS(t) thd3(t)
726 #define SETDEPENDS(c,v) thd3(c)=v
734 StgVarSet oaScc ( StgExpr* e_orig )
738 StgVarSet e_fvs, s1, s2;
739 List bs, bs2, bs3, bsFinal, augs, augsL;
741 bs=bs2=bs3=bsFinal=augs=augsL=e_fvs=s1=s2=e=NIL;
746 //fprintf(stderr,"\n==================\n");
747 //ppStgExpr(*e_orig);
748 //fprintf(stderr,"\n\n");fflush(stderr);fflush(stdout);
751 switch(whatIsStg(e)) {
753 /* first, recurse into the let body */
754 e_fvs = oaScc(&stgLetBody(*e_orig));
756 /* Make bs :: [StgVar] and e :: Stgexpr. */
760 /* make augs :: [(StgVar,fvs(bindee),NIL)] */
762 for (; nonNull(bs); bs=tl(bs)) {
763 StgVarSet fvs_bindee = oaScc(&stgVarBody(hd(bs)));
764 augs = cons( triple(hd(bs),mkInt(fvs_bindee),NIL), augs );
767 bs2=bs3=bsFinal=augsL=s1=s2=NIL;
769 /* In each of the triples in aug, replace the NIL field with
770 a list of the let-bound vars appearing in the bindee.
771 ie, construct the adjacency list for the graph.
773 augs :: [(StgVar,fvs(bindee),[pointers-back-to-this-list-of-pairs])]
775 for (bs=augs;nonNull(bs);bs=tl(bs)) {
777 for (bs2=augs;nonNull(bs2);bs2=tl(bs2))
778 if (elemStgVarSet( intOf(snd3(hd(bs))), fst3(hd(bs2)) ))
779 augsL = cons(hd(bs2),augsL);
780 thd3(hd(bs)) = augsL;
783 bs2=bs3=bsFinal=augsL=s1=s2=NIL;
786 augs becomes :: [[(StgVar,fvs(bindee),aux_info_field)]] */
789 /* work backwards through augs, reconstructing the expression,
790 dumping any unused groups as you go.
793 for (augs=rev(augs); nonNull(augs); augs=tl(augs)) {
795 for (augsL=hd(augs);nonNull(augsL); augsL=tl(augsL))
796 bs2 = cons(fst3(hd(augsL)),bs2);
798 for (bs3=bs2;nonNull(bs3);bs3=tl(bs3))
799 if (elemStgVarSet(e_fvs,hd(bs3))) { grpUsed=TRUE; break; }
801 //e = mkStgLet(bs2,e);
802 bsFinal = dupOnto(bs2,bsFinal);
803 for (augsL=hd(augs);nonNull(augsL);augsL=tl(augsL)) {
804 unionStgVarSets(e_fvs, intOf(snd3(hd(augsL))) );
805 freeStgVarSet(intOf(snd3(hd(augsL))));
808 nLetrecGroupsDropped++;
809 for (augsL=hd(augs);nonNull(augsL);augsL=tl(augsL)) {
810 freeStgVarSet(intOf(snd3(hd(augsL))));
815 *e_orig = mkStgLet(bsFinal,e);
819 s1 = oaScc(&stgLambdaBody(e));
820 for (bs=stgLambdaArgs(e);nonNull(bs);bs=tl(bs))
821 deleteFromStgVarSet(s1,hd(bs));
824 s1 = oaScc(&stgCaseScrut(e));
825 for (bs=stgCaseAlts(e);nonNull(bs);bs=tl(bs)) {
827 unionStgVarSets(s1,s2);
832 s1 = oaScc(&stgPrimCaseScrut(e));
833 for (bs=stgPrimCaseAlts(e);nonNull(bs);bs=tl(bs)) {
835 unionStgVarSets(s1,s2);
840 s1 = oaScc(&stgAppFun(e));
841 for (bs=stgAppArgs(e);nonNull(bs);bs=tl(bs)) {
843 unionStgVarSets(s1,s2);
848 s1 = oaScc(&stgPrimOp(e));
849 for (bs=stgPrimArgs(e);nonNull(bs);bs=tl(bs)) {
851 unionStgVarSets(s1,s2);
856 s1 = allocStgVarSet(0);
857 for (bs=stgPrimArgs(e);nonNull(bs);bs=tl(bs)) {
859 unionStgVarSets(s1,s2);
864 s1 = oaScc(&stgCaseAltBody(e));
865 for (bs=stgCaseAltVars(e);nonNull(bs);bs=tl(bs))
866 deleteFromStgVarSet(s1,hd(bs));
869 s1 = oaScc(&stgDefaultBody(e));
870 deleteFromStgVarSet(s1,stgDefaultVar(e));
873 s1 = oaScc(&stgPrimAltBody(e));
874 for (bs=stgPrimAltVars(e);nonNull(bs);bs=tl(bs))
875 deleteFromStgVarSet(s1,hd(bs));
878 s1 = allocStgVarSet(1);
879 singletonStgVarSet(s1,e);
888 return allocStgVarSet(0);
891 fprintf(stderr, "oaScc: unknown stuff %d\n",whatIsStg(e));
898 /* --------------------------------------------------------------------------
899 * Occurrence analyser. Marks each let-bound var with the number of times
900 * it is used, or some number >= OCC_IN_LAMBDA if it is used inside a lambda.
902 * Firstly, oaPre traverses the tree, attaching a mutable INT cell to each
903 * let bound var, and NIL-ing the counts on all other vars.
905 * Then oaCount traveses the tree. Because variables are represented by
906 * pointers in the heap, we can just increment the count field of each
907 * variable we see. However, to deal with lambdas, the Hugs stack holds
908 * all let-bound variables currently in scope, and the uppermost portion
909 * of the stack, stack(spBase .. sp) inclusive, denotes the variables
910 * introduced into scope since the nearest enclosing lambda. When a
911 * let-bound var is seen, we search stack(spBase .. sp). If it appears
912 * there, no lambda exists between the binding site and this usage of the
913 * var, so we can safely increment its use. Otherwise, we must set it to
916 * When passing a lambda, spBase is set to sp+1, so as to effectively
917 * empty the set of vars-bound-since-the-latest-lambda.
919 * Because oaPre pre-annotates the tree with mutable INT cells, oaCount
920 * doesn't allocate any heap at all.
921 * ------------------------------------------------------------------------*/
926 #define OCC_IN_LAMBDA 50 /* any number > 1 will do */
927 #define nullCount(vv) stgVarInfo(vv)=NIL
928 #define nullCounts(vvs) { List tt=(vvs);for(;nonNull(tt);tt=tl(tt)) nullCount(hd(tt));}
932 void oaPre ( StgExpr e )
935 switch(whatIsStg(e)) {
937 for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
938 stgVarInfo(hd(bs)) = mkInt(0);
939 for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
940 oaPre(stgVarBody(hd(bs)));
941 oaPre(stgLetBody(e));
944 nullCounts(stgLambdaArgs(e));
945 oaPre(stgLambdaBody(e));
948 oaPre(stgCaseScrut(e));
949 mapProc(oaPre,stgCaseAlts(e));
952 oaPre(stgPrimCaseScrut(e));
953 mapProc(oaPre,stgPrimCaseAlts(e));
957 mapProc(oaPre,stgAppArgs(e));
960 mapProc(oaPre,stgPrimArgs(e));
963 mapProc(oaPre,stgConArgs(e));
966 nullCounts(stgCaseAltVars(e));
967 oaPre(stgCaseAltBody(e));
970 nullCount(stgDefaultVar(e));
971 oaPre(stgDefaultBody(e));
974 nullCounts(stgPrimAltVars(e));
975 oaPre(stgPrimAltBody(e));
987 fprintf(stderr, "oaPre: unknown stuff %d\n",whatIsStg(e));
994 -- the stack is always the set of let-bound vars currently
995 in scope. viz, stack(0 .. sp) inclusive.
996 -- spBase is always >= 0 and <= sp.
997 stack(spBase .. sp) inclusive will be the let vars bound
998 since the nearest enclosing lambda. When entering a lambda,
999 we set spBase=sp+1 so as record this fact, and restore spBase
1002 void oaCount ( StgExpr e )
1007 switch(whatIsStg(e)) {
1009 for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
1011 for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
1012 oaCount(stgVarBody(hd(bs)));
1013 oaCount(stgLetBody(e));
1014 for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
1018 spBase_saved = spBase;
1020 oaCount(stgLambdaBody(e));
1021 spBase = spBase_saved;
1024 oaCount(stgCaseScrut(e));
1025 mapProc(oaCount,stgCaseAlts(e));
1028 oaCount(stgPrimCaseScrut(e));
1029 mapProc(oaCount,stgPrimCaseAlts(e));
1032 oaCount(stgAppFun(e));
1033 mapProc(oaCount,stgAppArgs(e));
1036 mapProc(oaCount,stgPrimArgs(e));
1039 mapProc(oaCount,stgConArgs(e));
1042 nullCounts(stgCaseAltVars(e));
1043 oaCount(stgCaseAltBody(e));
1046 nullCount(stgDefaultVar(e));
1047 oaCount(stgDefaultBody(e));
1050 nullCounts(stgPrimAltVars(e));
1051 oaCount(stgPrimAltBody(e));
1054 if (isInt(stgVarInfo(e))) {
1057 for (i = sp; i >= spBase; i--)
1058 if (stack(i) == e) { j = i; break; };
1060 stgVarInfo(e) = mkInt(OCC_IN_LAMBDA); else
1061 stgVarInfo(e) = mkInt(1 + intOf(stgVarInfo(e)));
1073 fprintf(stderr, "oaCount: unknown stuff %d\n",whatIsStg(e));
1078 void stgTopSanity ( char*, StgVar );
1080 /* Top level entry point for the occurrence analyser. */
1081 void oaTop ( StgVar v )
1083 assert (varSet_nfree == M_VAR_SETS);
1084 freeStgVarSet(oaScc(&stgVarBody(v)));
1085 assert (varSet_nfree == M_VAR_SETS);
1086 oaPre(stgVarBody(v));
1087 clearStack(); spBase = 0;
1088 oaCount(stgVarBody(v));
1089 assert(stackEmpty());
1090 stgTopSanity("oaTop",stgVarBody(v));
1094 /* --------------------------------------------------------------------------
1095 * Transformation machinery proper
1096 * ------------------------------------------------------------------------*/
1098 #define streq(aa,bb) (strcmp((aa),(bb))==0)
1099 /* Return TRUE if the non-default alts in the given list are exhaustive.
1100 If in doubt, return FALSE.
1102 Bool stgAltsExhaustive ( List alts )
1110 while (nonNull(alts) && isDefaultAlt(hd(alts))) alts=tl(alts);
1114 con = stgCaseAltCon(hd(alts));
1115 /* special case: dictionary constructor */
1116 if (strncmp("Make.",textToStr(name(con).text),5)==0)
1118 /* special case: constructor boxing an unboxed value. */
1119 if (isBoxingCon(con))
1121 /* some other special cases which are not boxingCons */
1122 s = textToStr(name(con).text);
1123 if (streq(s,"Integer#")
1125 || streq(s,"PrimMutableArray#")
1126 || streq(s,"PrimMutableByteArray#")
1127 || streq(s,"PrimByteArray#")
1128 || streq(s,"PrimArray#")
1131 if (strcmp("Ref#",textToStr(name(con).text))==0)
1133 /* special case: Tuples */
1134 if (isTuple(con) || (isName(con) && con==nameUnit))
1136 if (isNull(name(con).parent)) internal("stgAltsExhaustive(1)");
1137 t = name(con).parent;
1139 if (tycon(t).what != DATATYPE) internal("stgAltsExhaustive(2)");
1140 nDefnCons = length(cs);
1141 for (; nonNull(alts0);alts0=tl(alts0)) {
1142 if (isDefaultAlt(hd(alts0))) continue;
1146 return nDefnCons == 0;
1151 /* If in doubt, return FALSE.
1153 Bool isManifestCon ( StgExpr e )
1156 switch (whatIsStg(e)) {
1157 case STGCON: return TRUE;
1158 case LETREC: return isManifestCon(stgLetBody(e));
1159 case CASE: if (length(stgCaseAlts(e))==1) {
1160 if (isDefaultAlt(hd(stgCaseAlts(e))))
1161 altB = stgDefaultBody(hd(stgCaseAlts(e))); else
1162 altB = stgCaseAltBody(hd(stgCaseAlts(e)));
1163 return isManifestCon(altB);
1167 default: return FALSE;
1172 /* Like isManifestCon, but doesn't give up at non-singular cases */
1173 Bool constructsCon ( StgExpr e )
1176 switch (whatIsStg(e)) {
1177 case STGCON: return TRUE;
1178 case LETREC: return constructsCon(stgLetBody(e));
1179 case CASE: for (as = stgCaseAlts(e); nonNull(as); as=tl(as))
1180 if (!constructsCon(hd(as))) return FALSE;
1182 case PRIMCASE: for (as = stgPrimCaseAlts(e); nonNull(as); as=tl(as))
1183 if (!constructsCon(hd(as))) return FALSE;
1185 case CASEALT: return constructsCon(stgCaseAltBody(e));
1186 case DEEFALT: return constructsCon(stgDefaultBody(e));
1187 case PRIMALT: return constructsCon(stgPrimAltBody(e));
1188 default: return FALSE;
1193 /* Inline v in the special case where expr is
1194 case v of C a1 ... an -> E
1195 and v's bindee returns a product constructed with C.
1196 and v does not appear in E
1197 and v does not appear in letDefs (ie, this expr isn't
1198 part of the definition of v.
1200 void tryLoopbreakerHack ( List letDefs, StgExpr expr )
1203 StgExpr scrut, ee, v_bindee;
1206 assert (whatIsStg(expr)==CASE);
1207 alts = stgCaseAlts(expr);
1208 scrut = stgCaseScrut(expr);
1209 if (whatIsStg(scrut) != STGVAR || isNull(stgVarBody(scrut))) return;
1210 if (length(alts) != 1 || isDefaultAlt(hd(alts))) return;
1211 if (!stgAltsExhaustive(alts)) return;
1213 ee = stgCaseAltBody(alt);
1214 if (nonNull(cellIsMember(scrut,letDefs))) return;
1216 v_bindee = stgVarBody(scrut);
1217 if (!isManifestCon(v_bindee)) return;
1219 stgCaseScrut(expr) = cloneStgTop(v_bindee);
1220 nLoopBreakersInlined++;
1224 /* Traverse a tree. Replace let-bound vars marked as used-once
1225 by their definitions. Replace references to top-level
1226 values marked inlineMe with their bodies. Carry around a list
1227 of let-bound variables whose definitions we are currently in
1228 so as to know not to inline let-bound vars in their own
1231 StgExpr copyIn ( List letDefs, InlineCtx ctx, StgExpr e )
1235 switch(whatIsStg(e)) {
1236 // these are the only two interesting cases
1238 assert(isPtr(stgVarInfo(e)) || isNull(stgVarInfo(e)) ||
1239 isInt(stgVarInfo(e)));
1240 if (isInt(stgVarInfo(e)) && intOf(stgVarInfo(e))==1) {
1242 return cloneStgTop(stgVarBody(e));
1246 // if we're not inlining top vars on this round, do nothing
1247 if (!copyInTopvar) return e;
1248 // if it doesn't want to be inlined, do nothing
1249 if (!name(e).inlineMe) return e;
1250 // we decline to inline dictionary builders inside other builders
1251 if (inDBuilder && name(e).isDBuilder) {
1252 //fprintf(stderr, "decline to inline dbuilder %s\n", textToStr(name(e).text));
1255 // in fact, only inline dict builders into a case scrutinee
1256 if (name(e).isDBuilder && ctx != CTX_SCRUT)
1260 assert( stgSize(stgVarBody(name(e).stgVar)) == name(e).stgSize );
1263 // only inline large dict builders if it returns a manifest con
1264 if (name(e).isDBuilder &&
1265 name(e).stgSize > 180 &&
1266 !isManifestCon(stgVarBody(name(e).stgVar)))
1269 // if it's huge, don't inline into a boring place
1270 if (ctx != CTX_SCRUT &&
1271 name(e).stgSize > 270)
1276 return cloneStgTop(stgVarBody(name(e).stgVar));
1278 // the rest are a boring recursive traversal of the tree
1280 stgLetBody(e) = copyIn(letDefs,CTX_OTHER,stgLetBody(e));
1281 letDefs = dupOnto(stgLetBinds(e),letDefs);
1282 for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
1283 stgVarBody(hd(bs)) = copyIn(letDefs,CTX_OTHER,stgVarBody(hd(bs)));
1286 stgLambdaBody(e) = copyIn(letDefs,CTX_OTHER,stgLambdaBody(e));
1289 stgCaseScrut(e) = copyIn(letDefs,CTX_SCRUT,stgCaseScrut(e));
1290 map2Over(copyIn,letDefs,CTX_OTHER,stgCaseAlts(e));
1291 if (copyInTopvar) tryLoopbreakerHack(letDefs,e);
1294 stgPrimCaseScrut(e) = copyIn(letDefs,CTX_OTHER,stgPrimCaseScrut(e));
1295 map2Over(copyIn,letDefs,CTX_OTHER,stgPrimCaseAlts(e));
1298 stgAppFun(e) = copyIn(letDefs,CTX_OTHER,stgAppFun(e));
1301 stgCaseAltBody(e) = copyIn(letDefs,CTX_OTHER,stgCaseAltBody(e));
1304 stgDefaultBody(e) = copyIn(letDefs,CTX_OTHER,stgDefaultBody(e));
1307 stgPrimAltBody(e) = copyIn(letDefs,CTX_OTHER,stgPrimAltBody(e));
1318 fprintf(stderr, "copyIn: unknown stuff %d\n",whatIsStg(e));
1330 /* case (C a1 ... an) of
1335 e with v1/a1 ... vn/an
1337 StgExpr doCaseOfCon ( StgExpr expr, Bool* done )
1342 List alts, altvs, as, sub;
1345 alts = stgCaseAlts(expr);
1346 scrut = stgCaseScrut(expr);
1348 apC = stgConCon(scrut);
1351 for (alts = stgCaseAlts(expr); nonNull(alts); alts=tl(alts))
1352 if (!isDefaultAlt(hd(alts)) && stgCaseAltCon(hd(alts)) == apC) {
1357 if (isNull(theAlt)) return expr;
1358 altvs = stgCaseAltVars(theAlt);
1359 e = stgCaseAltBody(theAlt);
1360 as = stgConArgs(scrut);
1362 if (length(as)!=length(altvs)) return expr;
1365 while (nonNull(altvs)) {
1366 sub = cons(pair(hd(altvs),hd(as)),sub);
1372 return zubstExpr(sub,e);
1376 /* case (let binds in e) of alts
1378 let binds in case e of alts
1380 StgExpr doCaseOfLet ( StgExpr expr, Bool* done )
1385 letexpr = stgCaseScrut(expr);
1386 e = stgLetBody(letexpr);
1387 binds = stgLetBinds(letexpr);
1388 alts = stgCaseAlts(expr);
1391 return mkStgLet(binds,mkStgCase(e,alts));
1396 /* case (case e of p1 -> e1 ... pn -> en) of
1402 p1 -> case e1 of q1 -> h1 ... qk -> hk
1404 pn -> case en of q1 -> h1 ... qk -> kl
1406 StgExpr doCaseOfCase ( StgExpr expr )
1408 StgExpr innercase, e, tmpcase, protocase;
1409 List ps_n_es, qs_n_hs, newAlts;
1410 StgCaseAlt newAlt, p_n_e;
1414 innercase = stgCaseScrut(expr);
1415 e = stgCaseScrut(innercase);
1416 ps_n_es = stgCaseAlts(innercase);
1417 qs_n_hs = stgCaseAlts(expr);
1419 /* protocase = case (hole-to-fill-in) of q1 -> h1 ... qk -> hk */
1420 protocase = mkStgCase( mkInt(0), qs_n_hs);
1423 for (;nonNull(ps_n_es);ps_n_es = tl(ps_n_es)) {
1424 tmpcase = cloneStgTop(protocase);
1425 p_n_e = hd(ps_n_es);
1426 if (isDefaultAlt(p_n_e)) {
1427 stgCaseScrut(tmpcase) = stgDefaultBody(p_n_e);
1428 newAlt = mkStgDefault(stgDefaultVar(p_n_e), tmpcase);
1430 stgCaseScrut(tmpcase) = stgCaseAltBody(p_n_e);
1431 newAlt = mkStgCaseAlt(stgCaseAltCon(p_n_e),stgCaseAltVars(p_n_e),tmpcase);
1433 newAlts = cons(newAlt,newAlts);
1435 newAlts = rev(newAlts);
1437 mkStgCase(e, newAlts);
1442 /* case (case# e of p1 -> e1 ... pn -> en) of
1448 p1 -> case e1 of q1 -> h1 ... qk -> hk
1450 pn -> case en of q1 -> h1 ... qk -> kl
1452 StgExpr doCaseOfPrimCase ( StgExpr expr )
1454 StgExpr innercase, e, tmpcase, protocase;
1455 List ps_n_es, qs_n_hs, newAlts;
1456 StgCaseAlt newAlt, p_n_e;
1460 innercase = stgCaseScrut(expr);
1461 e = stgPrimCaseScrut(innercase);
1462 ps_n_es = stgPrimCaseAlts(innercase);
1463 qs_n_hs = stgCaseAlts(expr);
1465 /* protocase = case (hole-to-fill-in) of q1 -> h1 ... qk -> hk */
1466 protocase = mkStgCase( mkInt(0), qs_n_hs);
1469 for (;nonNull(ps_n_es);ps_n_es = tl(ps_n_es)) {
1470 tmpcase = cloneStgTop(protocase);
1471 p_n_e = hd(ps_n_es);
1472 stgPrimCaseScrut(tmpcase) = stgPrimAltBody(p_n_e);
1473 newAlt = mkStgPrimAlt(stgPrimAltVars(p_n_e),tmpcase);
1474 newAlts = cons(newAlt,newAlts);
1476 newAlts = rev(newAlts);
1478 mkStgPrimCase(e, newAlts);
1482 Bool isStgCaseWithSingleNonDefaultAlt ( StgExpr e )
1485 whatIsStg(e)==CASE &&
1486 length(stgCaseAlts(e))==1 &&
1487 !isDefaultAlt(hd(stgCaseAlts(e)));
1491 /* Do simplifications on an Stg tree. Invariant is that the
1492 input and output trees should have no name shadowing.
1498 -- dump individual let-bindings with usage counts of zero
1500 -- dump let-binding groups for which none of the bound vars
1501 occur in the let body
1503 -- (\v1 ... vn -> e) a1 ... am
1505 -- the usual beta reduction. There are no constraints on n and m, so
1506 the result can be a lambda term (if n > m), or an application of e
1507 to the unused args (if n < m).
1510 Scheme is: bottom-up traversal of the tree. First simplify child
1511 trees. Then try to do local transformations. If a local transformation
1512 succeeds, jump to the local-transformation code for whatever node
1513 is produced -- so as to try and maximise the amount of work which
1514 happens on each call to simplify.
1516 StgExpr simplify ( List caseEnv, StgExpr e )
1523 switch(whatIsStg(e)) {
1531 /* first dump dead binds, so as not to waste effort simplifying them */
1533 for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
1534 if (!isInt(stgVarInfo(hd(bs))) ||
1535 intOf(stgVarInfo(hd(bs))) > 0) {
1536 bs2=cons(hd(bs),bs2);
1540 if (isNull(bs2)) { e = stgLetBody(e); goto restart; };
1541 stgLetBinds(e) = rev(bs2);
1543 for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
1544 stgVarBody(hd(bs)) = simplify(caseEnv,stgVarBody(hd(bs)));
1545 stgLetBody(e) = simplify(caseEnv,stgLetBody(e));
1547 /* Merge let ... in let ... in e. Grouping lets together
1548 sometimes reduces the number of iterations needed.
1549 oaScc should do this anyway, but this just to make sure.
1551 while (whatIsStg(stgLetBody(e))==LETREC) {
1552 stgLetBinds(e) = dupOnto(stgLetBinds(stgLetBody(e)),stgLetBinds(e));
1553 stgLetBody(e) = stgLetBody(stgLetBody(e));
1557 /* let binds in case v-not-in-binds of singleAlt -> expr
1559 case v-not-in-binds of singleAlt -> let binds in expr
1561 if (isStgCaseWithSingleNonDefaultAlt(stgLetBody(e)) &&
1562 whatIsStg(stgCaseScrut(stgLetBody(e)))==STGVAR &&
1563 isNull(cellIsMember(stgCaseScrut(stgLetBody(e)),stgLetBinds(e)))) {
1564 StgVar v = stgCaseScrut(stgLetBody(e));
1565 StgCaseAlt a = hd(stgCaseAlts(stgLetBody(e)));
1566 nLetsFloatedIntoCase++;
1573 mkStgLet(stgLetBinds(e),stgCaseAltBody(a))
1577 assert(whatIsStg(e)==CASE);
1584 stgLambdaBody(e) = simplify(caseEnv,stgLambdaBody(e));
1587 while (whatIsStg(stgLambdaBody(e))==LAMBDA) {
1589 stgLambdaArgs(e) = appendOnto(stgLambdaArgs(e),
1590 stgLambdaArgs(stgLambdaBody(e)));
1591 stgLambdaBody(e) = stgLambdaBody(stgLambdaBody(e));
1597 stgCaseScrut(e) = simplify(caseEnv,stgCaseScrut(e));
1598 if (isStgCaseWithSingleNonDefaultAlt(e) &&
1599 (whatIsStg(stgCaseScrut(e))==STGVAR ||
1600 whatIsStg(stgCaseScrut(e))==NAME)) {
1601 List caseEnv2 = cons(
1602 pair(stgCaseScrut(e),stgCaseAltVars(hd(stgCaseAlts(e)))),
1605 map1Over(simplify,caseEnv2,stgCaseAlts(e));
1607 map1Over(simplify,caseEnv,stgCaseAlts(e));
1611 /* zap redundant default alternatives */
1612 if (stgAltsExhaustive(stgCaseAlts(e))) {
1613 Bool droppedDef = FALSE;
1615 for (bs = dupList(stgCaseAlts(e));nonNull(bs);bs=tl(bs))
1616 if (!isDefaultAlt(hd(bs))) {
1617 bs2=cons(hd(bs),bs2);
1622 stgCaseAlts(e) = bs2;
1623 if (droppedDef) nCaseDefaultsDropped++;
1626 switch (whatIsStg(stgCaseScrut(e))) {
1628 /* attempt case-of-case */
1629 n = length(stgCaseAlts(e));
1632 (stgSize(e)-stgSize(stgCaseScrut(e))) < 100 &&
1633 constructsCon(stgCaseScrut(e)))
1635 e = doCaseOfCase(e);
1636 assert(whatIsStg(e)==CASE);
1641 /* attempt case-of-case# */
1642 n = length(stgCaseAlts(e));
1645 (stgSize(e)-stgSize(stgCaseScrut(e))) < 100 &&
1646 constructsCon(stgCaseScrut(e)))
1648 e = doCaseOfPrimCase(e);
1649 assert(whatIsStg(e)==PRIMCASE);
1650 goto primcase_local;
1654 /* attempt case-of-let */
1655 e = doCaseOfLet(e,&done);
1656 if (done) { assert(whatIsStg(e)==LETREC); goto let_local; };
1659 /* attempt case-of-constructor */
1660 e = doCaseOfCon(e,&done);
1661 /* we don't know what the result is, so can't jump to local */
1665 /* attempt to remove case on something already cased on */
1666 List outervs, innervs, sub;
1668 if (!isStgCaseWithSingleNonDefaultAlt(e)) break;
1669 lookupResult = cellAssoc(stgCaseScrut(e),caseEnv);
1670 if (isNull(lookupResult)) break;
1671 outervs = snd(lookupResult);
1674 innervs = stgCaseAltVars(hd(stgCaseAlts(e)));
1675 for (; nonNull(outervs) && nonNull(innervs);
1676 outervs=tl(outervs), innervs=tl(innervs))
1677 sub = cons(pair(hd(innervs),hd(outervs)),sub);
1678 assert (isNull(outervs) && isNull(innervs));
1679 return zubstExpr(sub, stgCaseAltBody(hd(stgCaseAlts(e))));
1686 stgCaseAltBody(e) = simplify(caseEnv,stgCaseAltBody(e));
1689 stgDefaultBody(e) = simplify(caseEnv,stgDefaultBody(e));
1692 stgPrimAltBody(e) = simplify(caseEnv,stgPrimAltBody(e));
1695 stgPrimCaseScrut(e) = simplify(caseEnv,stgPrimCaseScrut(e));
1696 map1Over(simplify,caseEnv,stgPrimCaseAlts(e));
1705 stgAppFun(e) = simplify(caseEnv,stgAppFun(e));
1706 map1Over(simplify,caseEnv,stgAppArgs(e));
1709 args = stgAppArgs(e);
1711 switch (whatIsStg(fun)) {
1714 stgAppArgs(e) = appendOnto(stgAppArgs(fun),args);
1715 stgAppFun(e) = stgAppFun(fun);
1718 /* (let binds in f) args ==> let binds in (f args) */
1719 nLetsFloatedOutOfFn++;
1720 e = mkStgLet(stgLetBinds(fun),mkStgApp(stgLetBody(fun),args));
1721 assert(whatIsStg(e)==LETREC);
1725 if (length(stgCaseAlts(fun))==1 &&
1726 !isDefaultAlt(hd(stgCaseAlts(fun)))) {
1727 StgCaseAlt theAlt = hd(stgCaseAlts(fun));
1728 /* (case e of alt -> f) args ==> case e of alt -> f args */
1731 singleton(mkStgCaseAlt(stgCaseAltCon(theAlt),
1732 stgCaseAltVars(theAlt),
1733 mkStgApp(stgCaseAltBody(theAlt),args))
1736 nCasesFloatedOutOfFn++;
1737 assert(whatIsStg(e)==CASE);
1743 formals = stgLambdaArgs(fun);
1744 while (nonNull(formals) && nonNull(args)) {
1745 sub = cons(pair(hd(formals),hd(args)),sub);
1746 formals = tl(formals);
1749 subd_body = zubstExpr(sub,stgLambdaBody(fun));
1752 assert(isNull(formals) || isNull(args));
1753 if (isNull(formals) && isNull(args)) {
1754 /* fn and args match exactly */
1759 if (isNull(formals) && nonNull(args)) {
1760 /* more args than we could deal with. Build a new Ap. */
1761 e = mkStgApp(subd_body,args);
1765 if (nonNull(formals) && isNull(args)) {
1766 /* partial application. We get a new Lambda */
1767 e = mkStgLambda(formals,subd_body);
1788 fprintf(stderr, "simplify: unknown stuff %d\n",whatIsStg(e));
1799 /* Restore STG representation invariants broken by simplify.
1800 -- Let-bind any constructor applications which appear
1801 anywhere other than a let.
1802 -- Let-bind non-atomic case scrutinees (ToDo).
1804 StgExpr restoreStg ( StgExpr e )
1809 if (isNull(e)) return e;
1811 switch(whatIsStg(e)) {
1813 for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs)) {
1814 if (whatIsStg(stgVarBody(hd(bs))) == STGCON) {
1818 if (whatIsStg(stgVarBody(hd(bs))) == LAMBDA) {
1819 stgLambdaBody(stgVarBody(hd(bs)))
1820 = restoreStg(stgLambdaBody(stgVarBody(hd(bs))));
1823 stgVarBody(hd(bs)) = restoreStg(stgVarBody(hd(bs)));
1826 stgLetBody(e) = restoreStg(stgLetBody(e));
1829 /* note that the check in LETREC above ensures we won't
1830 get here for legitimate (let-bound) lambdas. */
1831 stgLambdaBody(e) = restoreStg(stgLambdaBody(e));
1832 newv = mkStgVar(e,NIL);
1833 e = mkStgLet(singleton(newv),newv);
1836 stgCaseScrut(e) = restoreStg(stgCaseScrut(e));
1837 mapOver(restoreStg,stgCaseAlts(e));
1838 if (!isAtomic(stgCaseScrut(e))) {
1839 newv = mkStgVar(stgCaseScrut(e),NIL);
1840 return mkStgLet(singleton(newv),mkStgCase(newv,stgCaseAlts(e)));
1844 stgPrimCaseScrut(e) = restoreStg(stgPrimCaseScrut(e));
1845 mapOver(restoreStg,stgPrimCaseAlts(e));
1848 stgAppFun(e) = restoreStg(stgAppFun(e));
1849 mapOver(restoreStg,stgAppArgs(e)); /* probably incorrect */
1850 if (!isAtomic(stgAppFun(e))) {
1851 newv = mkStgVar(stgAppFun(e),NIL);
1852 e = mkStgLet(singleton(newv),mkStgApp(newv,stgAppArgs(e)));
1856 mapOver(restoreStg,stgPrimArgs(e));
1859 /* note that the check in LETREC above ensures we won't
1860 get here for legitimate constructor applications. */
1861 mapOver(restoreStg,stgConArgs(e));
1862 newv = mkStgVar(e,NIL);
1863 return mkStgLet(singleton(newv),newv);
1866 stgCaseAltBody(e) = restoreStg(stgCaseAltBody(e));
1867 if (whatIsStg(stgCaseAltBody(e))==LAMBDA) {
1868 newv = mkStgVar(stgCaseAltBody(e),NIL);
1869 stgCaseAltBody(e) = mkStgLet(singleton(newv),newv);
1873 stgDefaultBody(e) = restoreStg(stgDefaultBody(e));
1874 if (whatIsStg(stgDefaultBody(e))==LAMBDA) {
1875 newv = mkStgVar(stgDefaultBody(e),NIL);
1876 stgDefaultBody(e) = mkStgLet(singleton(newv),newv);
1880 stgPrimAltBody(e) = restoreStg(stgPrimAltBody(e));
1891 fprintf(stderr, "restoreStg: unknown stuff %d\n",whatIsStg(e));
1900 StgExpr restoreStgTop ( StgExpr e )
1902 if (whatIs(e)==LAMBDA)
1903 stgLambdaBody(e) = restoreStg(stgLambdaBody(e)); else
1909 void simplTopRefs ( StgExpr e )
1913 switch(whatIsStg(e)) {
1914 /* the only interesting case */
1916 if (name(e).inlineMe && !name(e).simplified) {
1917 /* printf("\n((%d)) request for %s\n",rDepth, textToStr(name(e).text)); */
1918 name(e).simplified = TRUE;
1919 optimiseTopBind(name(e).stgVar);
1920 /* printf("((%d)) done for %s\n",rDepth, textToStr(name(e).text)); */
1924 simplTopRefs(stgLetBody(e));
1925 for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
1926 simplTopRefs(stgVarBody(hd(bs)));
1929 simplTopRefs(stgLambdaBody(e));
1932 simplTopRefs(stgCaseScrut(e));
1933 mapProc(simplTopRefs,stgCaseAlts(e));
1936 simplTopRefs(stgPrimCaseScrut(e));
1937 mapProc(simplTopRefs,stgPrimCaseAlts(e));
1940 simplTopRefs(stgAppFun(e));
1941 mapProc(simplTopRefs,stgAppArgs(e));
1944 mapProc(simplTopRefs,stgConArgs(e));
1947 simplTopRefs(stgPrimOp(e));
1948 mapProc(simplTopRefs,stgPrimArgs(e));
1951 simplTopRefs(stgCaseAltBody(e));
1954 simplTopRefs(stgDefaultBody(e));
1957 simplTopRefs(stgPrimAltBody(e));
1969 fprintf(stderr, "simplTopRefs: unknown stuff %d\n",whatIsStg(e));
1978 char* maybeName ( StgVar v )
1980 Name n = nameFromStgVar(v);
1981 if (isNull(n)) return "(unknown)";
1982 return textToStr(name(n).text);
1986 /* --------------------------------------------------------------------------
1987 * Sanity checking (weak :-(
1988 * ------------------------------------------------------------------------*/
1992 int stgSanity_checkStack ( StgVar v )
1996 for (i = 0; i <= sp; i++)
1997 if (stack(i)==v) j++;
2001 void stgSanity_dropVar ( StgVar v )
2006 void stgSanity_pushVar ( StgVar v )
2008 if (stgSanity_checkStack(v) != 0) stgError = TRUE;
2013 void stgSanity ( StgExpr e )
2017 switch(whatIsStg(e)) {
2019 mapProc(stgSanity_pushVar,stgLetBinds(e));
2020 stgSanity(stgLetBody(e));
2021 for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
2022 stgSanity(stgVarBody(hd(bs)));
2023 mapProc(stgSanity_dropVar,stgLetBinds(e));
2026 mapProc(stgSanity_pushVar,stgLambdaArgs(e));
2027 stgSanity(stgLambdaBody(e));
2028 mapProc(stgSanity_dropVar,stgLambdaArgs(e));
2031 stgSanity(stgCaseScrut(e));
2032 mapProc(stgSanity,stgCaseAlts(e));
2035 stgSanity(stgPrimCaseScrut(e));
2036 mapProc(stgSanity,stgPrimCaseAlts(e));
2039 stgSanity(stgAppFun(e));
2040 mapProc(stgSanity,stgAppArgs(e));
2043 stgSanity(stgConCon(e));
2044 mapProc(stgSanity,stgConArgs(e));
2047 stgSanity(stgPrimOp(e));
2048 mapProc(stgSanity,stgPrimArgs(e));
2051 mapProc(stgSanity_pushVar,stgCaseAltVars(e));
2052 stgSanity(stgCaseAltBody(e));
2053 mapProc(stgSanity_dropVar,stgCaseAltVars(e));
2056 stgSanity_pushVar(stgDefaultVar(e));
2057 stgSanity(stgDefaultBody(e));
2058 stgSanity_dropVar(stgDefaultVar(e));
2061 mapProc(stgSanity_pushVar,stgPrimAltVars(e));
2062 stgSanity(stgPrimAltBody(e));
2063 mapProc(stgSanity_dropVar,stgPrimAltVars(e));
2066 if (stgSanity_checkStack(e) == 1) break;
2067 if (nonNull(nameFromStgVar(e))) return;
2078 fprintf(stderr, "stgSanity: unknown stuff %d\n",whatIsStg(e));
2088 void stgTopSanity ( char* caller, StgExpr e )
2097 fprintf(stderr, "\n\nstgTopSanity (caller = %s):\n\n", caller );
2105 /* Check if e is in a form which the code generator can deal with.
2106 * stgexpr-ness is what we need to enforce. The extended version,
2107 * expr, may only occur as the rhs of a let binding.
2109 * stgexpr ::= case atom of alts
2110 * | case# primop{atom*} of primalts
2111 * | let v_i = expr_i in stgexpr
2118 * alt ::= con vars -> stgexpr (primalt and default similarly)
2120 * atom ::= var | int | char etc (unboxed, that is)
2122 Bool isStgExpr ( StgExpr e );
2123 Bool isStgFullExpr ( StgExpr e );
2125 Bool isStgExpr ( StgExpr e )
2128 switch (whatIs(e)) {
2133 for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
2134 if (!isStgFullExpr(stgVarBody(hd(bs))))
2136 return isStgExpr(stgLetBody(e));
2138 for (bs=stgCaseAlts(e); nonNull(bs); bs=tl(bs))
2139 if (!isStgExpr(hd(bs))) return FALSE;
2140 return isAtomic(stgCaseScrut(e));
2142 for (bs=stgPrimCaseAlts(e); nonNull(bs); bs=tl(bs))
2143 if (!isStgExpr(hd(bs))) return FALSE;
2144 if (isAtomic(stgPrimCaseScrut(e))) return TRUE;
2145 if (whatIs(stgPrimCaseScrut(e))==STGPRIM)
2146 return isStgExpr(stgPrimCaseScrut(e));
2152 for (bs=stgAppArgs(e); nonNull(bs); bs=tl(bs))
2153 if (!isAtomic(hd(bs))) return FALSE;
2154 if (isStgVar(stgAppFun(e)) || isName(stgAppFun(e))) return TRUE;
2157 for (bs=stgPrimArgs(e); nonNull(bs); bs=tl(bs))
2158 if (!isAtomic(hd(bs))) return FALSE;
2159 if (isName(stgPrimOp(e))) return TRUE;
2162 return isStgExpr(stgCaseAltBody(e));
2164 return isStgExpr(stgDefaultBody(e));
2166 return isStgExpr(stgPrimAltBody(e));
2173 Bool isStgFullExpr ( StgExpr e )
2176 switch (whatIs(e)) {
2178 return isStgExpr(stgLambdaBody(e));
2180 for (bs=stgConArgs(e); nonNull(bs); bs=tl(bs))
2181 if (!isAtomic(hd(bs))) return FALSE;
2182 if (isName(stgConCon(e)) || isTuple(stgConCon(e)))
2186 return isStgExpr(e);
2191 /* --------------------------------------------------------------------------
2193 * ------------------------------------------------------------------------*/
2195 /* Set ddumpSimpl to TRUE if you want to see simplified code. */
2196 static Bool ddumpSimpl = FALSE;
2198 /* Leave this one alone ... */
2202 static void local optimiseTopBind( StgVar v )
2204 Bool ppPrel = FALSE;
2207 Int oldSize, newSize;
2210 /* printf( "[[%d]] looking at %s\n", rDepth, maybeName(v)); */
2211 assert(whatIsStg(v)==STGVAR);
2214 if (nonNull(stgVarBody(v))) simplTopRefs(stgVarBody(v));
2218 //me= 0&& 0==strcmp("tcUnify",maybeName(v));
2219 me= 0&& 0==strcmp("ttt",maybeName(v));
2221 nTotSizeIn += stgSize(stgVarBody(v));
2223 printf( "%28s: in %4d ", maybeName(v),stgSize(stgVarBody(v)));
2228 naam = nameFromStgVar(v);
2229 if (nonNull(naam) && name(naam).isDBuilder) inDBuilder = TRUE;
2232 if (nonNull(naam)) {
2233 assert(name(naam).stgSize == stgSize(stgVarBody(name(naam).stgVar)));
2238 fflush(stdout); fflush(stderr);
2239 fprintf ( stderr, "{{%d}}-----------------------------\n", -v );fflush(stderr);
2240 printStg ( stderr, v );
2241 fprintf(stderr, "\n" );
2244 stgTopSanity ( "initial", stgVarBody(v));
2246 if (nonNull(stgVarBody(v))) {
2249 for (n = 0; n < 8; n++) { // originally 7
2250 if (noisy) printf("%4d", stgSize(stgVarBody(v)));
2251 copyInTopvar = TRUE;
2252 stgTopSanity ( "outer-1", stgVarBody(v));
2254 stgTopSanity ( "outer-2", stgVarBody(v));
2255 stgVarBody(v) = copyIn ( NIL, CTX_OTHER, stgVarBody(v) );
2256 stgTopSanity ( "outer-3", stgVarBody(v));
2257 stgVarBody(v) = simplify ( NIL, stgVarBody(v) );
2258 stgTopSanity ( "outer-4", stgVarBody(v));
2260 for (m = 0; m < 3; m++) { // oprignally 3
2261 if (noisy) printf(".");
2263 copyInTopvar = FALSE;
2264 stgTopSanity ( "inner-1", stgVarBody(v));
2266 stgTopSanity ( "inner-2", stgVarBody(v));
2267 stgVarBody(v) = copyIn ( NIL, CTX_OTHER, stgVarBody(v) );
2268 stgTopSanity ( "inner-3", stgVarBody(v));
2269 stgVarBody(v) = simplify ( NIL, stgVarBody(v) );
2272 fprintf(stderr,"\n-%d- - - - - - - - - - - - - -\n", n+1);
2273 printStg ( stderr,v );
2275 stgTopSanity ( "inner-post", stgVarBody(v));
2280 fprintf(stderr,"\n-%d-=-=-=-=-=-=-=-=-=-=-=-=-=-\n", n+1);
2281 printStg ( stderr,v );
2284 stgTopSanity ( "outer-post", stgVarBody(v));
2286 newSize = stgSize ( stgVarBody(v) );
2287 if (newSize == oldSize) break;
2290 n++; for (; n < 8; n++) for (m = 0; m <= 3+3; m++) if (noisy) printf ( " " );
2291 if (noisy) printf(" --> %4d\n", stgSize(stgVarBody(v)) );
2292 stgVarBody(v) = restoreStgTop ( stgVarBody(v) );
2294 if (nonNull(naam)) {
2295 assert(name(naam).stgVar == v);
2296 name(naam).stgSize = stgSize(stgVarBody(v));
2301 if (!isStgFullExpr(stgVarBody(v))) {
2302 fprintf(stderr, "\n\nrestoreStg failed!\n\n" );
2303 printStg(stderr, v);
2304 fprintf(stderr, "\n" );
2310 nTotSizeOut += stgSize(stgVarBody(v));
2313 fprintf(stderr,"\n=============================\n");
2314 printStg ( stderr,v );
2315 fprintf(stderr, "\n\n" );
2322 void optimiseTopBinds ( List bs )
2328 noisy = ddumpSimpl && (lastModule() != modulePrelude);
2331 if (noisy) printf("\n");
2334 for (t = bs; nonNull(t); t=tl(t)) {
2335 n = nameFromStgVar(hd(t));
2336 if (isNull(n) || !name(n).simplified) {
2338 optimiseTopBind(hd(t));
2342 if (noisy) printOptStats ( stderr );
2347 /* --------------------------------------------------------------------------
2348 * Optimiser control:
2349 * ------------------------------------------------------------------------*/
2351 Void optimiser(what)
2356 case RESET : spClone = SP_NOT_IN_USE;
2361 case MARK : markPairs();
2366 case GCDONE : checkStgVarSets();
2371 /*-------------------------------------------------------------------------*/