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/07/06 15:24:39 $
12 * ------------------------------------------------------------------------*/
20 #include "Assembler.h"
22 /* #define DEBUG_OPTIMISE */
24 extern void print ( Cell, Int );
26 /* --------------------------------------------------------------------------
28 * ------------------------------------------------------------------------*/
30 Int nLoopBreakersInlined;
39 Int nLetrecGroupsDropped;
41 Int nCaseDefaultsDropped;
43 Int nLetsFloatedOutOfFn;
44 Int nLetsFloatedIntoCase;
45 Int nCasesFloatedOutOfFn;
55 static void local optimiseTopBind( StgVar v );
64 /* Exactly like whatIs except it avoids a fn call for STG tags */
65 #define whatIsStg(xx) ((isPair(xx) ? (isTag(fst(xx)) ? fst(xx) : AP) : whatIs(xx)))
68 /* --------------------------------------------------------------------------
69 * Transformation stats
70 * ------------------------------------------------------------------------*/
72 void initOptStats ( void )
74 nLoopBreakersInlined = 0;
83 nLetrecGroupsDropped = 0;
85 nCaseDefaultsDropped = 0;
87 nLetsFloatedOutOfFn = 0;
88 nLetsFloatedIntoCase = 0;
89 nCasesFloatedOutOfFn = 0;
95 void printOptStats ( FILE* f )
97 fflush(stdout); fflush(stderr); fflush(f);
99 fprintf(f, "Inlining: topvar %-5d letvar %-5d"
100 " loopbrkr %-5d betaredn %-5d\n",
101 nTopvarsInlined, nLetvarsInlined, nLoopBreakersInlined,
103 fprintf(f, "Case-of-: let %-5d case %-5d"
104 " con %-5d case# %-5d\n",
105 nCaseOfLet, nCaseOfCase, nCaseOfCon, nCaseOfPrimCase );
106 fprintf(f, "Dropped: letbind %-5d letgroup %-5d"
108 nLetBindsDropped, nLetrecGroupsDropped, nCaseDefaultsDropped );
109 fprintf(f, "Merges: lambda %-5d app %-5d\n",
110 nLambdasMerged, nAppsMerged );
111 fprintf(f, "Fn-float: let %-5d case %-5d\n",
112 nLetsFloatedOutOfFn, nCasesFloatedOutOfFn );
113 fprintf(f, "Misc: case-outer %-5d let-into-case %-5d\n",
114 nCaseOfOuter, nLetsFloatedIntoCase );
115 fprintf(f, "total size: in %-5d out %-5d\n",
116 nTotSizeIn, nTotSizeOut );
121 /* --------------------------------------------------------------------------
122 * How big is this STG tree (viz (primarily), do I want to inline it?)
123 * ------------------------------------------------------------------------*/
125 Int stgSize_list ( List es )
128 for (; nonNull(es); es=tl(es)) n += stgSize(hd(es));
132 Int stgSize ( StgExpr e )
137 if (isNull(e)) return 0;
139 switch(whatIsStg(e)) {
143 for (xs = stgLetBinds(e); nonNull(xs);xs=tl(xs))
144 n += stgSize(stgVarBody(hd(xs)));
145 n += stgSize(stgLetBody(e));
148 n += stgSize(stgLambdaBody(e));
151 n += stgSize_list(stgCaseAlts(e));
152 n += stgSize(stgCaseScrut(e));
155 n += stgSize_list(stgPrimCaseAlts(e));
156 n += stgSize(stgPrimCaseScrut(e));
159 n += stgSize_list(stgAppArgs(e));
160 n += stgSize(stgAppFun(e));
163 n += stgSize_list(stgPrimArgs(e));
164 n += stgSize(stgPrimOp(e));
167 n += stgSize_list(stgConArgs(e));
168 n += stgSize(stgConCon(e));
171 n = stgSize(stgDefaultBody(e));
174 n = stgSize(stgCaseAltBody(e));
177 n = stgSize(stgPrimAltBody(e));
189 fprintf(stderr, "sizeStg: unknown stuff %d\n",whatIsStg(e));
196 /* --------------------------------------------------------------------------
197 * Stacks of pairs of collectable things. Used to implement associations.
198 * cloneStg() uses its stack to map old var names to new ones.
199 * ------------------------------------------------------------------------*/
202 #define SP_NOT_IN_USE (-123456789)
205 struct { Cell pfst; Cell psnd; }
209 static StgPair pairClone[M_PAIRS];
211 void markPairs ( void )
214 if (spClone != SP_NOT_IN_USE) {
215 for (i = 0; i <= spClone; i++) {
216 mark(pairClone[i].pfst);
217 mark(pairClone[i].psnd);
222 void pushClone ( Cell a, Cell b )
225 if (spClone >= M_PAIRS) internal("pushClone -- M_PAIRS too small");
226 pairClone[spClone].pfst = a;
227 pairClone[spClone].psnd = b;
230 void dropClone ( void )
232 if (spClone < 0) internal("dropClone");
236 Cell findClone ( Cell x )
239 for (i = spClone; i >= 0; i--)
240 if (pairClone[i].pfst == x)
241 return pairClone[i].psnd;
246 /* --------------------------------------------------------------------------
247 * Cloning of STG trees
248 * ------------------------------------------------------------------------*/
250 /* Clone v to create a new var. Works for both StgVar and StgPrimVar. */
251 StgVar cloneStgVar ( StgVar v )
253 return ap(STGVAR,triple(stgVarBody(v),stgVarRep(v),NIL));
257 /* For each StgVar in origVars, make a new one with cloneStgVar,
258 and push the (old,new) pair on the clone pair stack. Returns
259 the list of new vars.
261 List cloneStg_addVars ( List origVars )
264 while (nonNull(origVars)) {
265 StgVar newv = cloneStgVar(hd(origVars));
266 pushClone ( hd(origVars), newv );
267 newVars = cons(newv,newVars);
268 origVars = tl(origVars);
270 newVars = rev(newVars);
275 void cloneStg_dropVars ( List vs )
277 for (; nonNull(vs); vs=tl(vs))
282 /* Print the clone pair stack. Just for debugging purposes. */
283 void ppCloneEnv ( char* s )
286 fflush(stdout);fflush(stderr);
287 printf ( "\nenv-%s\n", s );
288 for (i = 0; i <= spClone; i++) {
290 ppStgExpr(pairClone[i].pfst);
291 ppStgExpr(pairClone[i].psnd);
294 printf ( "vne-%s\n", s );
298 StgExpr cloneStg ( StgExpr e )
304 switch(whatIsStg(e)) {
307 if (nonNull(newv)) return newv; else return e;
309 newvs = cloneStg_addVars ( stgLetBinds(e) );
310 for (xs = newvs; nonNull(xs);xs=tl(xs))
311 stgVarBody(hd(xs)) = cloneStg(stgVarBody(hd(xs)));
312 t = mkStgLet(newvs,cloneStg(stgLetBody(e)));
313 cloneStg_dropVars ( stgLetBinds(e) );
316 newvs = cloneStg_addVars ( stgLambdaArgs(e) );
317 t = mkStgLambda(newvs, cloneStg(stgLambdaBody(e)));
318 cloneStg_dropVars ( stgLambdaArgs(e) );
321 xs = dupList(stgCaseAlts(e));
322 mapOver(cloneStg,xs);
323 return mkStgCase(cloneStg(stgCaseScrut(e)),xs);
325 xs = dupList(stgPrimCaseAlts(e));
326 mapOver(cloneStg,xs);
327 return mkStgPrimCase(cloneStg(stgPrimCaseScrut(e)),xs);
329 xs = dupList(stgAppArgs(e));
330 mapOver(cloneStg,xs);
331 return mkStgApp(cloneStg(stgAppFun(e)),xs);
333 xs = dupList(stgPrimArgs(e));
334 mapOver(cloneStg,xs);
335 return mkStgPrim(cloneStg(stgPrimOp(e)),xs);
337 xs = dupList(stgConArgs(e));
338 mapOver(cloneStg,xs);
339 return mkStgCon(cloneStg(stgConCon(e)),xs);
341 newv = cloneStgVar(stgDefaultVar(e));
342 pushClone ( stgDefaultVar(e), newv );
343 t = mkStgDefault(newv,cloneStg(stgDefaultBody(e)));
347 newvs = cloneStg_addVars ( stgCaseAltVars(e) );
348 t = mkStgCaseAlt(stgCaseAltCon(e),newvs,
349 cloneStg(stgCaseAltBody(e)));
350 cloneStg_dropVars ( stgCaseAltVars(e) );
353 newvs = cloneStg_addVars ( stgPrimAltVars(e) );
354 t = mkStgPrimAlt(newvs, cloneStg(stgPrimAltBody(e)));
355 cloneStg_dropVars ( stgPrimAltVars(e) );
367 fprintf(stderr, "cloneStg: unknown stuff %d\n",whatIsStg(e));
373 /* Main entry point. Checks against re-entrant use. */
374 StgExpr cloneStgTop ( StgExpr e )
377 if (spClone != SP_NOT_IN_USE)
378 internal("cloneStgTop");
380 res = cloneStg ( e );
381 assert(spClone == -1);
382 spClone = SP_NOT_IN_USE;
388 /* --------------------------------------------------------------------------
389 * Sets of StgVars, used by the strongly-connected-components machinery.
390 * Represented as an array of variables. The vars
391 * must be in strictly nondecreasing order. Each value may appear
392 * more than once, so as to make deletion relatively cheap.
394 * After a garbage collection happens, the values may have changed,
395 * so the array will need to be sorted.
397 * Using a binary search, membership costs O(log N). Union and
398 * intersection cost O(N + M). Deletion of a single element costs
399 * O(N) in the worst case, although if it happens infrequently
400 * compared to the other ops, it should asymptotically approach O(1).
401 * ------------------------------------------------------------------------*/
403 #define M_VAR_SETS 4000
404 #define MIN_VAR_SET_SIZE 4
405 #define M_UNION_TMP 20000
417 typedef Int StgVarSet;
419 StgVarSetRec varSet[M_VAR_SETS];
422 Cell union_tmp[M_UNION_TMP];
424 #if 0 /* unused since unnecessary */
425 /* Shellsort set elems to restore representation invariants */
426 static Int shellCells_incs[10]
427 = { 1, 4, 13, 40, 121, 364, 1093, 3280, 9841, 29524 };
428 static void shellCells ( Cell* a, Int lo, Int hi )
433 N = hi - lo + 1; if (N < 2) return;
435 while (hp < 10 && shellCells_incs[hp] < N) hp++; hp--;
437 for (; hp >= 0; hp--) {
438 h = shellCells_incs[hp];
445 a[j] = a[j-h]; j = j - h;
446 if (j <= (lo + h - 1)) break;
454 /* check that representation invariant still holds */
455 static void checkCells ( Cell* a, Int lo, Int hi )
458 for (i = lo; i < hi; i++)
460 internal("checkCells");
464 /* Mark set contents for GC */
465 void markStgVarSets ( void )
468 for (i = 0; i < M_VAR_SETS; i++)
470 for (j = 0; j < varSet[i].used; j++)
471 mark(varSet[i].vs[j]);
475 /* Check representation invariants after GC */
476 void checkStgVarSets ( void )
479 for (i = 0; i < M_VAR_SETS; i++)
481 checkCells ( varSet[i].vs, 0, varSet[i].used-1 );
485 /* Allocate a set of a given size */
486 StgVarSet allocStgVarSet ( Int size )
489 if (varSet_nextfree == -1)
490 internal("allocStgVarSet -- run out of var sets");
492 varSet_nextfree = varSet[i].nextfree;
493 varSet[i].inUse = TRUE;
494 j = MIN_VAR_SET_SIZE;
495 while (j <= size) j *= 2;
498 varSet[i].vs = malloc(j * sizeof(StgVar) );
500 internal("allocStgVarSet -- can't malloc memory");
506 /* resize (upwards) */
507 void resizeStgVarSet ( StgVarSet s, Int size )
512 Int j = MIN_VAR_SET_SIZE;
513 while (j <= size) j *= 2;
514 if (j < varSet[s].size) return;
516 tmp2 = malloc( j * sizeof(StgVar) );
517 if (!tmp2) internal("resizeStgVarSet -- can't malloc memory");
519 for (i = 0; i < varSet[s].used; i++)
525 /* Deallocation ... */
526 void freeStgVarSet ( StgVarSet s )
528 if (s < 0 || s >= M_VAR_SETS ||
529 !varSet[s].inUse || !varSet[s].vs)
530 internal("freeStgVarSet");
532 varSet[s].inUse = FALSE;
534 varSet[s].nextfree = varSet_nextfree;
541 void initStgVarSets ( void )
544 for (i = M_VAR_SETS-1; i >= 0; i--) {
545 varSet[i].inUse = FALSE;
547 varSet[i].nextfree = i+1;
549 varSet[M_VAR_SETS-1].nextfree = -1;
551 varSet_nfree = M_VAR_SETS;
555 /* Find a var using binary search */
556 Int findInStgVarSet ( StgVarSet s, StgVar v )
560 hi = varSet[s].used-1;
562 if (lo > hi) return -1;
564 if (varSet[s].vs[mid] == v) return mid;
565 if (varSet[s].vs[mid] < v) lo = mid+1; else hi = mid-1;
570 Bool elemStgVarSet ( StgVarSet s, StgVar v )
572 return findInStgVarSet(s,v) != -1;
575 void ppSet ( StgVarSet s )
578 fprintf(stderr, "{ ");
579 for (i = 0; i < varSet[s].used; i++)
580 fprintf(stderr, "%d ", varSet[s].vs[i] );
581 fprintf(stderr, "}\n" );
585 void deleteFromStgVarSet ( StgVarSet s, StgVar v )
588 i = findInStgVarSet(s,v);
590 j = varSet[s].used-1;
591 for (; i < j; i++) varSet[s].vs[i] = varSet[s].vs[i+1];
596 void singletonStgVarSet ( StgVarSet s, StgVar v )
603 void emptyStgVarSet ( StgVarSet s )
609 void copyStgVarSets ( StgVarSet dst, StgVarSet src )
612 varSet[dst].used = varSet[src].used;
613 for (i = 0; i < varSet[dst].used; i++)
614 varSet[dst].vs[i] = varSet[src].vs[i];
618 Int sizeofVarSet ( StgVarSet s )
620 return varSet[s].used;
624 void unionStgVarSets ( StgVarSet dst, StgVarSet src )
627 Int pd, ps, i, res_used, tmp_used, dst_used, src_used;
632 dst_vs = varSet[dst].vs;
634 /* fast track a common (~ 50%) case */
635 if (varSet[src].used == 1) {
636 v1 = varSet[src].vs[0];
637 pd = findInStgVarSet(dst,v1);
638 if (pd != -1) return;
639 if (varSet[dst].used < varSet[dst].size) {
640 i = varSet[dst].used;
641 while (i > 0 && dst_vs[i-1] > v1) {
642 dst_vs[i] = dst_vs[i-1];
651 res_used = varSet[dst].used + varSet[src].used;
652 if (res_used > M_UNION_TMP)
653 internal("unionStgVarSets -- M_UNION_TMP too small");
655 resizeStgVarSet(dst,res_used);
656 dst_vs = varSet[dst].vs;
657 src_vs = varSet[src].vs;
660 dst_used = varSet[dst].used;
661 src_used = varSet[src].used;
663 /* merge the two sets into tmp */
665 while (pd < dst_used || ps < src_used) {
667 tmp_vs[tmp_used++] = src_vs[ps++];
670 tmp_vs[tmp_used++] = dst_vs[pd++];
672 StgVar vald = dst_vs[pd];
673 StgVar vals = src_vs[ps];
675 tmp_vs[tmp_used++] = vald, pd++;
678 tmp_vs[tmp_used++] = vals, ps++;
680 tmp_vs[tmp_used++] = vals, ps++, pd++;
684 /* copy setTmp back to dst */
685 varSet[dst].used = tmp_used;
686 for (i = 0; i < tmp_used; i++) {
687 dst_vs[i] = tmp_vs[i];
693 /* --------------------------------------------------------------------------
694 * Strongly-connected-components machinery for STG let bindings.
695 * Arranges let bindings in minimal mutually recursive groups, and
696 * then throws away any groups not referred to in the body of the let.
698 * How it works: does a bottom-up sweep of the tree. Each call returns
699 * the set of variables free in the tree. All nodes except LETREC are
702 * When 'let v1=e1 .. vn=en in e' is encountered:
703 * -- recursively make a call on e. This returns fvs(e) and scc-ifies
705 * -- do recursive calls for e1 .. en too, giving fvs(e1) ... fvs(en).
707 * Then, using fvs(e1) ... fvs(en), the dependancy graph for v1 ... vn
708 * can be cheaply computed. Using that, compute the strong components
709 * and rearrange the let binding accordingly.
710 * Finally, for each of the strong components, we can use fvs(en) to
711 * cheaply determine if the component is used in the body of the let,
712 * and if not, it can be omitted.
714 * oaScc destructively modifies the tree -- when it gets to a let --
715 * we need to pass the address of the expression to scc, not the
716 * (more usual) heap index of it.
718 * The main requirement of this algorithm is an efficient implementation
719 * of sets of variables. Because there is no name shadowing in these
720 * trees, either mentioned-sets or free-sets would be ok, although
721 * free sets are presumably smaller.
722 * ------------------------------------------------------------------------*/
725 #define SCC stgScc /* make scc algorithm for StgVars */
726 #define LOWLINK stgLowlink
727 #define DEPENDS(t) thd3(t)
728 #define SETDEPENDS(c,v) thd3(c)=v
736 StgVarSet oaScc ( StgExpr* e_orig )
740 StgVarSet e_fvs, s1, s2;
741 List bs, bs2, bs3, bsFinal, augs, augsL;
743 bs=bs2=bs3=bsFinal=augs=augsL=e_fvs=s1=s2=e=NIL;
748 //fprintf(stderr,"\n==================\n");
749 //ppStgExpr(*e_orig);
750 //fprintf(stderr,"\n\n");fflush(stderr);fflush(stdout);
753 switch(whatIsStg(e)) {
755 /* first, recurse into the let body */
756 e_fvs = oaScc(&stgLetBody(*e_orig));
758 /* Make bs :: [StgVar] and e :: Stgexpr. */
762 /* make augs :: [(StgVar,fvs(bindee),NIL)] */
764 for (; nonNull(bs); bs=tl(bs)) {
765 StgVarSet fvs_bindee = oaScc(&stgVarBody(hd(bs)));
766 augs = cons( triple(hd(bs),mkInt(fvs_bindee),NIL), augs );
769 bs2=bs3=bsFinal=augsL=s1=s2=NIL;
771 /* In each of the triples in aug, replace the NIL field with
772 a list of the let-bound vars appearing in the bindee.
773 ie, construct the adjacency list for the graph.
775 augs :: [(StgVar,fvs(bindee),[pointers-back-to-this-list-of-pairs])]
777 for (bs=augs;nonNull(bs);bs=tl(bs)) {
779 for (bs2=augs;nonNull(bs2);bs2=tl(bs2))
780 if (elemStgVarSet( intOf(snd3(hd(bs))), fst3(hd(bs2)) ))
781 augsL = cons(hd(bs2),augsL);
782 thd3(hd(bs)) = augsL;
785 bs2=bs3=bsFinal=augsL=s1=s2=NIL;
788 augs becomes :: [[(StgVar,fvs(bindee),aux_info_field)]] */
791 /* work backwards through augs, reconstructing the expression,
792 dumping any unused groups as you go.
795 for (augs=rev(augs); nonNull(augs); augs=tl(augs)) {
797 for (augsL=hd(augs);nonNull(augsL); augsL=tl(augsL))
798 bs2 = cons(fst3(hd(augsL)),bs2);
800 for (bs3=bs2;nonNull(bs3);bs3=tl(bs3))
801 if (elemStgVarSet(e_fvs,hd(bs3))) { grpUsed=TRUE; break; }
803 //e = mkStgLet(bs2,e);
804 bsFinal = dupOnto(bs2,bsFinal);
805 for (augsL=hd(augs);nonNull(augsL);augsL=tl(augsL)) {
806 unionStgVarSets(e_fvs, intOf(snd3(hd(augsL))) );
807 freeStgVarSet(intOf(snd3(hd(augsL))));
810 nLetrecGroupsDropped++;
811 for (augsL=hd(augs);nonNull(augsL);augsL=tl(augsL)) {
812 freeStgVarSet(intOf(snd3(hd(augsL))));
817 *e_orig = mkStgLet(bsFinal,e);
821 s1 = oaScc(&stgLambdaBody(e));
822 for (bs=stgLambdaArgs(e);nonNull(bs);bs=tl(bs))
823 deleteFromStgVarSet(s1,hd(bs));
826 s1 = oaScc(&stgCaseScrut(e));
827 for (bs=stgCaseAlts(e);nonNull(bs);bs=tl(bs)) {
829 unionStgVarSets(s1,s2);
834 s1 = oaScc(&stgPrimCaseScrut(e));
835 for (bs=stgPrimCaseAlts(e);nonNull(bs);bs=tl(bs)) {
837 unionStgVarSets(s1,s2);
842 s1 = oaScc(&stgAppFun(e));
843 for (bs=stgAppArgs(e);nonNull(bs);bs=tl(bs)) {
845 unionStgVarSets(s1,s2);
850 s1 = oaScc(&stgPrimOp(e));
851 for (bs=stgPrimArgs(e);nonNull(bs);bs=tl(bs)) {
853 unionStgVarSets(s1,s2);
858 s1 = allocStgVarSet(0);
859 for (bs=stgPrimArgs(e);nonNull(bs);bs=tl(bs)) {
861 unionStgVarSets(s1,s2);
866 s1 = oaScc(&stgCaseAltBody(e));
867 for (bs=stgCaseAltVars(e);nonNull(bs);bs=tl(bs))
868 deleteFromStgVarSet(s1,hd(bs));
871 s1 = oaScc(&stgDefaultBody(e));
872 deleteFromStgVarSet(s1,stgDefaultVar(e));
875 s1 = oaScc(&stgPrimAltBody(e));
876 for (bs=stgPrimAltVars(e);nonNull(bs);bs=tl(bs))
877 deleteFromStgVarSet(s1,hd(bs));
880 s1 = allocStgVarSet(1);
881 singletonStgVarSet(s1,e);
890 return allocStgVarSet(0);
893 fprintf(stderr, "oaScc: unknown stuff %d\n",whatIsStg(e));
900 /* --------------------------------------------------------------------------
901 * Occurrence analyser. Marks each let-bound var with the number of times
902 * it is used, or some number >= OCC_IN_LAMBDA if it is used inside a lambda.
904 * Firstly, oaPre traverses the tree, attaching a mutable INT cell to each
905 * let bound var, and NIL-ing the counts on all other vars.
907 * Then oaCount traveses the tree. Because variables are represented by
908 * pointers in the heap, we can just increment the count field of each
909 * variable we see. However, to deal with lambdas, the Hugs stack holds
910 * all let-bound variables currently in scope, and the uppermost portion
911 * of the stack, stack(spBase .. sp) inclusive, denotes the variables
912 * introduced into scope since the nearest enclosing lambda. When a
913 * let-bound var is seen, we search stack(spBase .. sp). If it appears
914 * there, no lambda exists between the binding site and this usage of the
915 * var, so we can safely increment its use. Otherwise, we must set it to
918 * When passing a lambda, spBase is set to sp+1, so as to effectively
919 * empty the set of vars-bound-since-the-latest-lambda.
921 * Because oaPre pre-annotates the tree with mutable INT cells, oaCount
922 * doesn't allocate any heap at all.
923 * ------------------------------------------------------------------------*/
928 #define OCC_IN_LAMBDA 50 /* any number > 1 will do */
929 #define nullCount(vv) stgVarInfo(vv)=NIL
930 #define nullCounts(vvs) { List tt=(vvs);for(;nonNull(tt);tt=tl(tt)) nullCount(hd(tt));}
934 void oaPre ( StgExpr e )
937 switch(whatIsStg(e)) {
939 for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
940 stgVarInfo(hd(bs)) = mkInt(0);
941 for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
942 oaPre(stgVarBody(hd(bs)));
943 oaPre(stgLetBody(e));
946 nullCounts(stgLambdaArgs(e));
947 oaPre(stgLambdaBody(e));
950 oaPre(stgCaseScrut(e));
951 mapProc(oaPre,stgCaseAlts(e));
954 oaPre(stgPrimCaseScrut(e));
955 mapProc(oaPre,stgPrimCaseAlts(e));
959 mapProc(oaPre,stgAppArgs(e));
962 mapProc(oaPre,stgPrimArgs(e));
965 mapProc(oaPre,stgConArgs(e));
968 nullCounts(stgCaseAltVars(e));
969 oaPre(stgCaseAltBody(e));
972 nullCount(stgDefaultVar(e));
973 oaPre(stgDefaultBody(e));
976 nullCounts(stgPrimAltVars(e));
977 oaPre(stgPrimAltBody(e));
989 fprintf(stderr, "oaPre: unknown stuff %d\n",whatIsStg(e));
996 -- the stack is always the set of let-bound vars currently
997 in scope. viz, stack(0 .. sp) inclusive.
998 -- spBase is always >= 0 and <= sp.
999 stack(spBase .. sp) inclusive will be the let vars bound
1000 since the nearest enclosing lambda. When entering a lambda,
1001 we set spBase=sp+1 so as record this fact, and restore spBase
1004 void oaCount ( StgExpr e )
1009 switch(whatIsStg(e)) {
1011 for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
1013 for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
1014 oaCount(stgVarBody(hd(bs)));
1015 oaCount(stgLetBody(e));
1016 for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
1020 spBase_saved = spBase;
1022 oaCount(stgLambdaBody(e));
1023 spBase = spBase_saved;
1026 oaCount(stgCaseScrut(e));
1027 mapProc(oaCount,stgCaseAlts(e));
1030 oaCount(stgPrimCaseScrut(e));
1031 mapProc(oaCount,stgPrimCaseAlts(e));
1034 oaCount(stgAppFun(e));
1035 mapProc(oaCount,stgAppArgs(e));
1038 mapProc(oaCount,stgPrimArgs(e));
1041 mapProc(oaCount,stgConArgs(e));
1044 nullCounts(stgCaseAltVars(e));
1045 oaCount(stgCaseAltBody(e));
1048 nullCount(stgDefaultVar(e));
1049 oaCount(stgDefaultBody(e));
1052 nullCounts(stgPrimAltVars(e));
1053 oaCount(stgPrimAltBody(e));
1056 if (isInt(stgVarInfo(e))) {
1059 for (i = sp; i >= spBase; i--)
1060 if (stack(i) == e) { j = i; break; };
1062 stgVarInfo(e) = mkInt(OCC_IN_LAMBDA); else
1063 stgVarInfo(e) = mkInt(1 + intOf(stgVarInfo(e)));
1075 fprintf(stderr, "oaCount: unknown stuff %d\n",whatIsStg(e));
1080 void stgTopSanity ( char*, StgVar );
1082 /* Top level entry point for the occurrence analyser. */
1083 void oaTop ( StgVar v )
1085 assert (varSet_nfree == M_VAR_SETS);
1086 freeStgVarSet(oaScc(&stgVarBody(v)));
1087 assert (varSet_nfree == M_VAR_SETS);
1088 oaPre(stgVarBody(v));
1089 clearStack(); spBase = 0;
1090 oaCount(stgVarBody(v));
1091 assert(stackEmpty());
1092 stgTopSanity("oaTop",stgVarBody(v));
1096 /* --------------------------------------------------------------------------
1097 * Transformation machinery proper
1098 * ------------------------------------------------------------------------*/
1100 #define streq(aa,bb) (strcmp((aa),(bb))==0)
1101 /* Return TRUE if the non-default alts in the given list are exhaustive.
1102 If in doubt, return FALSE.
1104 Bool stgAltsExhaustive ( List alts )
1112 while (nonNull(alts) && isDefaultAlt(hd(alts))) alts=tl(alts);
1116 con = stgCaseAltCon(hd(alts));
1117 /* special case: dictionary constructor */
1118 if (strncmp("Make.",textToStr(name(con).text),5)==0)
1120 /* special case: constructor boxing an unboxed value. */
1121 if (isBoxingCon(con))
1123 /* some other special cases which are not boxingCons */
1124 s = textToStr(name(con).text);
1125 if (streq(s,"Integer#")
1127 || streq(s,"PrimMutableArray#")
1128 || streq(s,"PrimMutableByteArray#")
1129 || streq(s,"PrimByteArray#")
1130 || streq(s,"PrimArray#")
1133 if (strcmp("Ref#",textToStr(name(con).text))==0)
1135 /* special case: Tuples */
1136 if (isTuple(con) || (isName(con) && con==nameUnit))
1138 if (isNull(name(con).parent)) internal("stgAltsExhaustive(1)");
1139 t = name(con).parent;
1141 if (tycon(t).what != DATATYPE) internal("stgAltsExhaustive(2)");
1142 nDefnCons = length(cs);
1143 for (; nonNull(alts0);alts0=tl(alts0)) {
1144 if (isDefaultAlt(hd(alts0))) continue;
1148 return nDefnCons == 0;
1153 /* If in doubt, return FALSE.
1155 Bool isManifestCon ( StgExpr e )
1158 switch (whatIsStg(e)) {
1159 case STGCON: return TRUE;
1160 case LETREC: return isManifestCon(stgLetBody(e));
1161 case CASE: if (length(stgCaseAlts(e))==1) {
1162 if (isDefaultAlt(hd(stgCaseAlts(e))))
1163 altB = stgDefaultBody(hd(stgCaseAlts(e))); else
1164 altB = stgCaseAltBody(hd(stgCaseAlts(e)));
1165 return isManifestCon(altB);
1169 default: return FALSE;
1174 /* Like isManifestCon, but doesn't give up at non-singular cases */
1175 Bool constructsCon ( StgExpr e )
1178 switch (whatIsStg(e)) {
1179 case STGCON: return TRUE;
1180 case LETREC: return constructsCon(stgLetBody(e));
1181 case CASE: for (as = stgCaseAlts(e); nonNull(as); as=tl(as))
1182 if (!constructsCon(hd(as))) return FALSE;
1184 case PRIMCASE: for (as = stgPrimCaseAlts(e); nonNull(as); as=tl(as))
1185 if (!constructsCon(hd(as))) return FALSE;
1187 case CASEALT: return constructsCon(stgCaseAltBody(e));
1188 case DEEFALT: return constructsCon(stgDefaultBody(e));
1189 case PRIMALT: return constructsCon(stgPrimAltBody(e));
1190 default: return FALSE;
1195 /* Inline v in the special case where expr is
1196 case v of C a1 ... an -> E
1197 and v's bindee returns a product constructed with C.
1198 and v does not appear in E
1199 and v does not appear in letDefs (ie, this expr isn't
1200 part of the definition of v.
1202 void tryLoopbreakerHack ( List letDefs, StgExpr expr )
1205 StgExpr scrut, ee, v_bindee;
1208 assert (whatIsStg(expr)==CASE);
1209 alts = stgCaseAlts(expr);
1210 scrut = stgCaseScrut(expr);
1211 if (whatIsStg(scrut) != STGVAR || isNull(stgVarBody(scrut))) return;
1212 if (length(alts) != 1 || isDefaultAlt(hd(alts))) return;
1213 if (!stgAltsExhaustive(alts)) return;
1215 ee = stgCaseAltBody(alt);
1216 if (nonNull(cellIsMember(scrut,letDefs))) return;
1218 v_bindee = stgVarBody(scrut);
1219 if (!isManifestCon(v_bindee)) return;
1221 stgCaseScrut(expr) = cloneStgTop(v_bindee);
1222 nLoopBreakersInlined++;
1226 /* Traverse a tree. Replace let-bound vars marked as used-once
1227 by their definitions. Replace references to top-level
1228 values marked inlineMe with their bodies. Carry around a list
1229 of let-bound variables whose definitions we are currently in
1230 so as to know not to inline let-bound vars in their own
1233 StgExpr copyIn ( List letDefs, InlineCtx ctx, StgExpr e )
1237 switch(whatIsStg(e)) {
1238 // these are the only two interesting cases
1240 assert(isPtr(stgVarInfo(e)) || isNull(stgVarInfo(e)) ||
1241 isInt(stgVarInfo(e)));
1242 if (isInt(stgVarInfo(e)) && intOf(stgVarInfo(e))==1) {
1244 return cloneStgTop(stgVarBody(e));
1248 // if we're not inlining top vars on this round, do nothing
1249 if (!copyInTopvar) return e;
1250 // if it doesn't want to be inlined, do nothing
1251 if (!name(e).inlineMe) return e;
1252 // we decline to inline dictionary builders inside other builders
1253 if (inDBuilder && name(e).isDBuilder) {
1254 //fprintf(stderr, "decline to inline dbuilder %s\n", textToStr(name(e).text));
1257 // in fact, only inline dict builders into a case scrutinee
1258 if (name(e).isDBuilder && ctx != CTX_SCRUT)
1262 assert( stgSize(stgVarBody(name(e).stgVar)) == name(e).stgSize );
1265 // only inline large dict builders if it returns a manifest con
1266 if (name(e).isDBuilder &&
1267 name(e).stgSize > 180 &&
1268 !isManifestCon(stgVarBody(name(e).stgVar)))
1271 // if it's huge, don't inline into a boring place
1272 if (ctx != CTX_SCRUT &&
1273 name(e).stgSize > 270)
1278 return cloneStgTop(stgVarBody(name(e).stgVar));
1280 // the rest are a boring recursive traversal of the tree
1282 stgLetBody(e) = copyIn(letDefs,CTX_OTHER,stgLetBody(e));
1283 letDefs = dupOnto(stgLetBinds(e),letDefs);
1284 for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
1285 stgVarBody(hd(bs)) = copyIn(letDefs,CTX_OTHER,stgVarBody(hd(bs)));
1288 stgLambdaBody(e) = copyIn(letDefs,CTX_OTHER,stgLambdaBody(e));
1291 stgCaseScrut(e) = copyIn(letDefs,CTX_SCRUT,stgCaseScrut(e));
1292 map2Over(copyIn,letDefs,CTX_OTHER,stgCaseAlts(e));
1293 if (copyInTopvar) tryLoopbreakerHack(letDefs,e);
1296 stgPrimCaseScrut(e) = copyIn(letDefs,CTX_OTHER,stgPrimCaseScrut(e));
1297 map2Over(copyIn,letDefs,CTX_OTHER,stgPrimCaseAlts(e));
1300 stgAppFun(e) = copyIn(letDefs,CTX_OTHER,stgAppFun(e));
1303 stgCaseAltBody(e) = copyIn(letDefs,CTX_OTHER,stgCaseAltBody(e));
1306 stgDefaultBody(e) = copyIn(letDefs,CTX_OTHER,stgDefaultBody(e));
1309 stgPrimAltBody(e) = copyIn(letDefs,CTX_OTHER,stgPrimAltBody(e));
1320 fprintf(stderr, "copyIn: unknown stuff %d\n",whatIsStg(e));
1332 /* case (C a1 ... an) of
1337 e with v1/a1 ... vn/an
1339 StgExpr doCaseOfCon ( StgExpr expr, Bool* done )
1344 List alts, altvs, as, sub;
1347 alts = stgCaseAlts(expr);
1348 scrut = stgCaseScrut(expr);
1350 apC = stgConCon(scrut);
1353 for (alts = stgCaseAlts(expr); nonNull(alts); alts=tl(alts))
1354 if (!isDefaultAlt(hd(alts)) && stgCaseAltCon(hd(alts)) == apC) {
1359 if (isNull(theAlt)) return expr;
1360 altvs = stgCaseAltVars(theAlt);
1361 e = stgCaseAltBody(theAlt);
1362 as = stgConArgs(scrut);
1364 if (length(as)!=length(altvs)) return expr;
1367 while (nonNull(altvs)) {
1368 sub = cons(pair(hd(altvs),hd(as)),sub);
1374 return zubstExpr(sub,e);
1378 /* case (let binds in e) of alts
1380 let binds in case e of alts
1382 StgExpr doCaseOfLet ( StgExpr expr, Bool* done )
1387 letexpr = stgCaseScrut(expr);
1388 e = stgLetBody(letexpr);
1389 binds = stgLetBinds(letexpr);
1390 alts = stgCaseAlts(expr);
1393 return mkStgLet(binds,mkStgCase(e,alts));
1398 /* case (case e of p1 -> e1 ... pn -> en) of
1404 p1 -> case e1 of q1 -> h1 ... qk -> hk
1406 pn -> case en of q1 -> h1 ... qk -> kl
1408 StgExpr doCaseOfCase ( StgExpr expr )
1410 StgExpr innercase, e, tmpcase, protocase;
1411 List ps_n_es, qs_n_hs, newAlts;
1412 StgCaseAlt newAlt, p_n_e;
1416 innercase = stgCaseScrut(expr);
1417 e = stgCaseScrut(innercase);
1418 ps_n_es = stgCaseAlts(innercase);
1419 qs_n_hs = stgCaseAlts(expr);
1421 /* protocase = case (hole-to-fill-in) of q1 -> h1 ... qk -> hk */
1422 protocase = mkStgCase( mkInt(0), qs_n_hs);
1425 for (;nonNull(ps_n_es);ps_n_es = tl(ps_n_es)) {
1426 tmpcase = cloneStgTop(protocase);
1427 p_n_e = hd(ps_n_es);
1428 if (isDefaultAlt(p_n_e)) {
1429 stgCaseScrut(tmpcase) = stgDefaultBody(p_n_e);
1430 newAlt = mkStgDefault(stgDefaultVar(p_n_e), tmpcase);
1432 stgCaseScrut(tmpcase) = stgCaseAltBody(p_n_e);
1433 newAlt = mkStgCaseAlt(stgCaseAltCon(p_n_e),stgCaseAltVars(p_n_e),tmpcase);
1435 newAlts = cons(newAlt,newAlts);
1437 newAlts = rev(newAlts);
1439 mkStgCase(e, newAlts);
1444 /* case (case# e of p1 -> e1 ... pn -> en) of
1450 p1 -> case e1 of q1 -> h1 ... qk -> hk
1452 pn -> case en of q1 -> h1 ... qk -> kl
1454 StgExpr doCaseOfPrimCase ( StgExpr expr )
1456 StgExpr innercase, e, tmpcase, protocase;
1457 List ps_n_es, qs_n_hs, newAlts;
1458 StgCaseAlt newAlt, p_n_e;
1462 innercase = stgCaseScrut(expr);
1463 e = stgPrimCaseScrut(innercase);
1464 ps_n_es = stgPrimCaseAlts(innercase);
1465 qs_n_hs = stgCaseAlts(expr);
1467 /* protocase = case (hole-to-fill-in) of q1 -> h1 ... qk -> hk */
1468 protocase = mkStgCase( mkInt(0), qs_n_hs);
1471 for (;nonNull(ps_n_es);ps_n_es = tl(ps_n_es)) {
1472 tmpcase = cloneStgTop(protocase);
1473 p_n_e = hd(ps_n_es);
1474 stgPrimCaseScrut(tmpcase) = stgPrimAltBody(p_n_e);
1475 newAlt = mkStgPrimAlt(stgPrimAltVars(p_n_e),tmpcase);
1476 newAlts = cons(newAlt,newAlts);
1478 newAlts = rev(newAlts);
1480 mkStgPrimCase(e, newAlts);
1484 Bool isStgCaseWithSingleNonDefaultAlt ( StgExpr e )
1487 whatIsStg(e)==CASE &&
1488 length(stgCaseAlts(e))==1 &&
1489 !isDefaultAlt(hd(stgCaseAlts(e)));
1493 /* Do simplifications on an Stg tree. Invariant is that the
1494 input and output trees should have no name shadowing.
1500 -- dump individual let-bindings with usage counts of zero
1502 -- dump let-binding groups for which none of the bound vars
1503 occur in the let body
1505 -- (\v1 ... vn -> e) a1 ... am
1507 -- the usual beta reduction. There are no constraints on n and m, so
1508 the result can be a lambda term (if n > m), or an application of e
1509 to the unused args (if n < m).
1512 Scheme is: bottom-up traversal of the tree. First simplify child
1513 trees. Then try to do local transformations. If a local transformation
1514 succeeds, jump to the local-transformation code for whatever node
1515 is produced -- so as to try and maximise the amount of work which
1516 happens on each call to simplify.
1518 StgExpr simplify ( List caseEnv, StgExpr e )
1525 switch(whatIsStg(e)) {
1533 /* first dump dead binds, so as not to waste effort simplifying them */
1535 for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
1536 if (!isInt(stgVarInfo(hd(bs))) ||
1537 intOf(stgVarInfo(hd(bs))) > 0) {
1538 bs2=cons(hd(bs),bs2);
1542 if (isNull(bs2)) { e = stgLetBody(e); goto restart; };
1543 stgLetBinds(e) = rev(bs2);
1545 for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
1546 stgVarBody(hd(bs)) = simplify(caseEnv,stgVarBody(hd(bs)));
1547 stgLetBody(e) = simplify(caseEnv,stgLetBody(e));
1549 /* Merge let ... in let ... in e. Grouping lets together
1550 sometimes reduces the number of iterations needed.
1551 oaScc should do this anyway, but this just to make sure.
1553 while (whatIsStg(stgLetBody(e))==LETREC) {
1554 stgLetBinds(e) = dupOnto(stgLetBinds(stgLetBody(e)),stgLetBinds(e));
1555 stgLetBody(e) = stgLetBody(stgLetBody(e));
1559 /* let binds in case v-not-in-binds of singleAlt -> expr
1561 case v-not-in-binds of singleAlt -> let binds in expr
1563 if (isStgCaseWithSingleNonDefaultAlt(stgLetBody(e)) &&
1564 whatIsStg(stgCaseScrut(stgLetBody(e)))==STGVAR &&
1565 isNull(cellIsMember(stgCaseScrut(stgLetBody(e)),stgLetBinds(e)))) {
1566 StgVar v = stgCaseScrut(stgLetBody(e));
1567 StgCaseAlt a = hd(stgCaseAlts(stgLetBody(e)));
1568 nLetsFloatedIntoCase++;
1575 mkStgLet(stgLetBinds(e),stgCaseAltBody(a))
1579 assert(whatIsStg(e)==CASE);
1586 stgLambdaBody(e) = simplify(caseEnv,stgLambdaBody(e));
1589 while (whatIsStg(stgLambdaBody(e))==LAMBDA) {
1591 stgLambdaArgs(e) = appendOnto(stgLambdaArgs(e),
1592 stgLambdaArgs(stgLambdaBody(e)));
1593 stgLambdaBody(e) = stgLambdaBody(stgLambdaBody(e));
1599 stgCaseScrut(e) = simplify(caseEnv,stgCaseScrut(e));
1600 if (isStgCaseWithSingleNonDefaultAlt(e) &&
1601 (whatIsStg(stgCaseScrut(e))==STGVAR ||
1602 whatIsStg(stgCaseScrut(e))==NAME)) {
1603 List caseEnv2 = cons(
1604 pair(stgCaseScrut(e),stgCaseAltVars(hd(stgCaseAlts(e)))),
1607 map1Over(simplify,caseEnv2,stgCaseAlts(e));
1609 map1Over(simplify,caseEnv,stgCaseAlts(e));
1613 /* zap redundant default alternatives */
1614 if (stgAltsExhaustive(stgCaseAlts(e))) {
1615 Bool droppedDef = FALSE;
1617 for (bs = dupList(stgCaseAlts(e));nonNull(bs);bs=tl(bs))
1618 if (!isDefaultAlt(hd(bs))) {
1619 bs2=cons(hd(bs),bs2);
1624 stgCaseAlts(e) = bs2;
1625 if (droppedDef) nCaseDefaultsDropped++;
1628 switch (whatIsStg(stgCaseScrut(e))) {
1630 /* attempt case-of-case */
1631 n = length(stgCaseAlts(e));
1634 (stgSize(e)-stgSize(stgCaseScrut(e))) < 100 &&
1635 constructsCon(stgCaseScrut(e)))
1637 e = doCaseOfCase(e);
1638 assert(whatIsStg(e)==CASE);
1643 /* attempt case-of-case# */
1644 n = length(stgCaseAlts(e));
1647 (stgSize(e)-stgSize(stgCaseScrut(e))) < 100 &&
1648 constructsCon(stgCaseScrut(e)))
1650 e = doCaseOfPrimCase(e);
1651 assert(whatIsStg(e)==PRIMCASE);
1652 goto primcase_local;
1656 /* attempt case-of-let */
1657 e = doCaseOfLet(e,&done);
1658 if (done) { assert(whatIsStg(e)==LETREC); goto let_local; };
1661 /* attempt case-of-constructor */
1662 e = doCaseOfCon(e,&done);
1663 /* we don't know what the result is, so can't jump to local */
1667 /* attempt to remove case on something already cased on */
1668 List outervs, innervs, sub;
1670 if (!isStgCaseWithSingleNonDefaultAlt(e)) break;
1671 lookupResult = cellAssoc(stgCaseScrut(e),caseEnv);
1672 if (isNull(lookupResult)) break;
1673 outervs = snd(lookupResult);
1676 innervs = stgCaseAltVars(hd(stgCaseAlts(e)));
1677 for (; nonNull(outervs) && nonNull(innervs);
1678 outervs=tl(outervs), innervs=tl(innervs))
1679 sub = cons(pair(hd(innervs),hd(outervs)),sub);
1680 assert (isNull(outervs) && isNull(innervs));
1681 return zubstExpr(sub, stgCaseAltBody(hd(stgCaseAlts(e))));
1688 stgCaseAltBody(e) = simplify(caseEnv,stgCaseAltBody(e));
1691 stgDefaultBody(e) = simplify(caseEnv,stgDefaultBody(e));
1694 stgPrimAltBody(e) = simplify(caseEnv,stgPrimAltBody(e));
1697 stgPrimCaseScrut(e) = simplify(caseEnv,stgPrimCaseScrut(e));
1698 map1Over(simplify,caseEnv,stgPrimCaseAlts(e));
1707 stgAppFun(e) = simplify(caseEnv,stgAppFun(e));
1708 map1Over(simplify,caseEnv,stgAppArgs(e));
1711 args = stgAppArgs(e);
1713 switch (whatIsStg(fun)) {
1716 stgAppArgs(e) = appendOnto(stgAppArgs(fun),args);
1717 stgAppFun(e) = stgAppFun(fun);
1720 /* (let binds in f) args ==> let binds in (f args) */
1721 nLetsFloatedOutOfFn++;
1722 e = mkStgLet(stgLetBinds(fun),mkStgApp(stgLetBody(fun),args));
1723 assert(whatIsStg(e)==LETREC);
1727 if (length(stgCaseAlts(fun))==1 &&
1728 !isDefaultAlt(hd(stgCaseAlts(fun)))) {
1729 StgCaseAlt theAlt = hd(stgCaseAlts(fun));
1730 /* (case e of alt -> f) args ==> case e of alt -> f args */
1733 singleton(mkStgCaseAlt(stgCaseAltCon(theAlt),
1734 stgCaseAltVars(theAlt),
1735 mkStgApp(stgCaseAltBody(theAlt),args))
1738 nCasesFloatedOutOfFn++;
1739 assert(whatIsStg(e)==CASE);
1745 formals = stgLambdaArgs(fun);
1746 while (nonNull(formals) && nonNull(args)) {
1747 sub = cons(pair(hd(formals),hd(args)),sub);
1748 formals = tl(formals);
1751 subd_body = zubstExpr(sub,stgLambdaBody(fun));
1754 assert(isNull(formals) || isNull(args));
1755 if (isNull(formals) && isNull(args)) {
1756 /* fn and args match exactly */
1761 if (isNull(formals) && nonNull(args)) {
1762 /* more args than we could deal with. Build a new Ap. */
1763 e = mkStgApp(subd_body,args);
1767 if (nonNull(formals) && isNull(args)) {
1768 /* partial application. We get a new Lambda */
1769 e = mkStgLambda(formals,subd_body);
1790 fprintf(stderr, "simplify: unknown stuff %d\n",whatIsStg(e));
1801 /* Restore STG representation invariants broken by simplify.
1802 -- Let-bind any constructor applications which appear
1803 anywhere other than a let.
1804 -- Let-bind non-atomic case scrutinees (ToDo).
1806 StgExpr restoreStg ( StgExpr e )
1811 if (isNull(e)) return e;
1813 switch(whatIsStg(e)) {
1815 for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs)) {
1816 if (whatIsStg(stgVarBody(hd(bs))) == STGCON) {
1820 if (whatIsStg(stgVarBody(hd(bs))) == LAMBDA) {
1821 stgLambdaBody(stgVarBody(hd(bs)))
1822 = restoreStg(stgLambdaBody(stgVarBody(hd(bs))));
1825 stgVarBody(hd(bs)) = restoreStg(stgVarBody(hd(bs)));
1828 stgLetBody(e) = restoreStg(stgLetBody(e));
1831 /* note that the check in LETREC above ensures we won't
1832 get here for legitimate (let-bound) lambdas. */
1833 stgLambdaBody(e) = restoreStg(stgLambdaBody(e));
1834 newv = mkStgVar(e,NIL);
1835 e = mkStgLet(singleton(newv),newv);
1838 stgCaseScrut(e) = restoreStg(stgCaseScrut(e));
1839 mapOver(restoreStg,stgCaseAlts(e));
1840 if (!isAtomic(stgCaseScrut(e))) {
1841 newv = mkStgVar(stgCaseScrut(e),NIL);
1842 return mkStgLet(singleton(newv),mkStgCase(newv,stgCaseAlts(e)));
1846 stgPrimCaseScrut(e) = restoreStg(stgPrimCaseScrut(e));
1847 mapOver(restoreStg,stgPrimCaseAlts(e));
1850 stgAppFun(e) = restoreStg(stgAppFun(e));
1851 mapOver(restoreStg,stgAppArgs(e)); /* probably incorrect */
1852 if (!isAtomic(stgAppFun(e))) {
1853 newv = mkStgVar(stgAppFun(e),NIL);
1854 e = mkStgLet(singleton(newv),mkStgApp(newv,stgAppArgs(e)));
1858 mapOver(restoreStg,stgPrimArgs(e));
1861 /* note that the check in LETREC above ensures we won't
1862 get here for legitimate constructor applications. */
1863 mapOver(restoreStg,stgConArgs(e));
1864 newv = mkStgVar(e,NIL);
1865 return mkStgLet(singleton(newv),newv);
1868 stgCaseAltBody(e) = restoreStg(stgCaseAltBody(e));
1869 if (whatIsStg(stgCaseAltBody(e))==LAMBDA) {
1870 newv = mkStgVar(stgCaseAltBody(e),NIL);
1871 stgCaseAltBody(e) = mkStgLet(singleton(newv),newv);
1875 stgDefaultBody(e) = restoreStg(stgDefaultBody(e));
1876 if (whatIsStg(stgDefaultBody(e))==LAMBDA) {
1877 newv = mkStgVar(stgDefaultBody(e),NIL);
1878 stgDefaultBody(e) = mkStgLet(singleton(newv),newv);
1882 stgPrimAltBody(e) = restoreStg(stgPrimAltBody(e));
1893 fprintf(stderr, "restoreStg: unknown stuff %d\n",whatIsStg(e));
1902 StgExpr restoreStgTop ( StgExpr e )
1904 if (whatIs(e)==LAMBDA)
1905 stgLambdaBody(e) = restoreStg(stgLambdaBody(e)); else
1911 void simplTopRefs ( StgExpr e )
1915 switch(whatIsStg(e)) {
1916 /* the only interesting case */
1918 if (name(e).inlineMe && !name(e).simplified) {
1919 /* printf("\n((%d)) request for %s\n",rDepth, textToStr(name(e).text)); */
1920 name(e).simplified = TRUE;
1921 optimiseTopBind(name(e).stgVar);
1922 /* printf("((%d)) done for %s\n",rDepth, textToStr(name(e).text)); */
1926 simplTopRefs(stgLetBody(e));
1927 for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
1928 simplTopRefs(stgVarBody(hd(bs)));
1931 simplTopRefs(stgLambdaBody(e));
1934 simplTopRefs(stgCaseScrut(e));
1935 mapProc(simplTopRefs,stgCaseAlts(e));
1938 simplTopRefs(stgPrimCaseScrut(e));
1939 mapProc(simplTopRefs,stgPrimCaseAlts(e));
1942 simplTopRefs(stgAppFun(e));
1943 mapProc(simplTopRefs,stgAppArgs(e));
1946 mapProc(simplTopRefs,stgConArgs(e));
1949 simplTopRefs(stgPrimOp(e));
1950 mapProc(simplTopRefs,stgPrimArgs(e));
1953 simplTopRefs(stgCaseAltBody(e));
1956 simplTopRefs(stgDefaultBody(e));
1959 simplTopRefs(stgPrimAltBody(e));
1971 fprintf(stderr, "simplTopRefs: unknown stuff %d\n",whatIsStg(e));
1980 char* maybeName ( StgVar v )
1982 Name n = nameFromStgVar(v);
1983 if (isNull(n)) return "(unknown)";
1984 return textToStr(name(n).text);
1988 /* --------------------------------------------------------------------------
1989 * Sanity checking (weak :-(
1990 * ------------------------------------------------------------------------*/
1994 int stgSanity_checkStack ( StgVar v )
1998 for (i = 0; i <= sp; i++)
1999 if (stack(i)==v) j++;
2003 void stgSanity_dropVar ( StgVar v )
2008 void stgSanity_pushVar ( StgVar v )
2010 if (stgSanity_checkStack(v) != 0) stgError = TRUE;
2015 void stgSanity ( StgExpr e )
2019 switch(whatIsStg(e)) {
2021 mapProc(stgSanity_pushVar,stgLetBinds(e));
2022 stgSanity(stgLetBody(e));
2023 for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
2024 stgSanity(stgVarBody(hd(bs)));
2025 mapProc(stgSanity_dropVar,stgLetBinds(e));
2028 mapProc(stgSanity_pushVar,stgLambdaArgs(e));
2029 stgSanity(stgLambdaBody(e));
2030 mapProc(stgSanity_dropVar,stgLambdaArgs(e));
2033 stgSanity(stgCaseScrut(e));
2034 mapProc(stgSanity,stgCaseAlts(e));
2037 stgSanity(stgPrimCaseScrut(e));
2038 mapProc(stgSanity,stgPrimCaseAlts(e));
2041 stgSanity(stgAppFun(e));
2042 mapProc(stgSanity,stgAppArgs(e));
2045 stgSanity(stgConCon(e));
2046 mapProc(stgSanity,stgConArgs(e));
2049 stgSanity(stgPrimOp(e));
2050 mapProc(stgSanity,stgPrimArgs(e));
2053 mapProc(stgSanity_pushVar,stgCaseAltVars(e));
2054 stgSanity(stgCaseAltBody(e));
2055 mapProc(stgSanity_dropVar,stgCaseAltVars(e));
2058 stgSanity_pushVar(stgDefaultVar(e));
2059 stgSanity(stgDefaultBody(e));
2060 stgSanity_dropVar(stgDefaultVar(e));
2063 mapProc(stgSanity_pushVar,stgPrimAltVars(e));
2064 stgSanity(stgPrimAltBody(e));
2065 mapProc(stgSanity_dropVar,stgPrimAltVars(e));
2068 if (stgSanity_checkStack(e) == 1) break;
2069 if (nonNull(nameFromStgVar(e))) return;
2080 fprintf(stderr, "stgSanity: unknown stuff %d\n",whatIsStg(e));
2090 void stgTopSanity ( char* caller, StgExpr e )
2099 fprintf(stderr, "\n\nstgTopSanity (caller = %s):\n\n", caller );
2107 /* Check if e is in a form which the code generator can deal with.
2108 * stgexpr-ness is what we need to enforce. The extended version,
2109 * expr, may only occur as the rhs of a let binding.
2111 * stgexpr ::= case atom of alts
2112 * | case# primop{atom*} of primalts
2113 * | let v_i = expr_i in stgexpr
2120 * alt ::= con vars -> stgexpr (primalt and default similarly)
2122 * atom ::= var | int | char etc (unboxed, that is)
2124 Bool isStgExpr ( StgExpr e );
2125 Bool isStgFullExpr ( StgExpr e );
2127 Bool isStgExpr ( StgExpr e )
2130 switch (whatIs(e)) {
2135 for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
2136 if (!isStgFullExpr(stgVarBody(hd(bs))))
2138 return isStgExpr(stgLetBody(e));
2140 for (bs=stgCaseAlts(e); nonNull(bs); bs=tl(bs))
2141 if (!isStgExpr(hd(bs))) return FALSE;
2142 return isAtomic(stgCaseScrut(e));
2144 for (bs=stgPrimCaseAlts(e); nonNull(bs); bs=tl(bs))
2145 if (!isStgExpr(hd(bs))) return FALSE;
2146 if (isAtomic(stgPrimCaseScrut(e))) return TRUE;
2147 if (whatIs(stgPrimCaseScrut(e))==STGPRIM)
2148 return isStgExpr(stgPrimCaseScrut(e));
2154 for (bs=stgAppArgs(e); nonNull(bs); bs=tl(bs))
2155 if (!isAtomic(hd(bs))) return FALSE;
2156 if (isStgVar(stgAppFun(e)) || isName(stgAppFun(e))) return TRUE;
2159 for (bs=stgPrimArgs(e); nonNull(bs); bs=tl(bs))
2160 if (!isAtomic(hd(bs))) return FALSE;
2161 if (isName(stgPrimOp(e))) return TRUE;
2164 return isStgExpr(stgCaseAltBody(e));
2166 return isStgExpr(stgDefaultBody(e));
2168 return isStgExpr(stgPrimAltBody(e));
2175 Bool isStgFullExpr ( StgExpr e )
2178 switch (whatIs(e)) {
2180 return isStgExpr(stgLambdaBody(e));
2182 for (bs=stgConArgs(e); nonNull(bs); bs=tl(bs))
2183 if (!isAtomic(hd(bs))) return FALSE;
2184 if (isName(stgConCon(e)) || isTuple(stgConCon(e)))
2188 return isStgExpr(e);
2193 /* --------------------------------------------------------------------------
2195 * ------------------------------------------------------------------------*/
2197 /* Set ddumpSimpl to TRUE if you want to see simplified code. */
2198 static Bool ddumpSimpl = FALSE;
2200 /* Leave this one alone ... */
2204 static void local optimiseTopBind( StgVar v )
2206 /* Bool ppPrel = FALSE; */
2209 Int oldSize, newSize;
2212 /* printf( "[[%d]] looking at %s\n", rDepth, maybeName(v)); */
2213 assert(whatIsStg(v)==STGVAR);
2216 if (nonNull(stgVarBody(v))) simplTopRefs(stgVarBody(v));
2220 //me= 0&& 0==strcmp("tcUnify",maybeName(v));
2221 me= 0&& 0==strcmp("ttt",maybeName(v));
2223 nTotSizeIn += stgSize(stgVarBody(v));
2225 printf( "%28s: in %4d ", maybeName(v),stgSize(stgVarBody(v)));
2230 naam = nameFromStgVar(v);
2231 if (nonNull(naam) && name(naam).isDBuilder) inDBuilder = TRUE;
2234 if (nonNull(naam)) {
2235 assert(name(naam).stgSize == stgSize(stgVarBody(name(naam).stgVar)));
2240 fflush(stdout); fflush(stderr);
2241 fprintf ( stderr, "{{%d}}-----------------------------\n", -v );fflush(stderr);
2242 printStg ( stderr, v );
2243 fprintf(stderr, "\n" );
2246 stgTopSanity ( "initial", stgVarBody(v));
2248 if (nonNull(stgVarBody(v))) {
2251 for (n = 0; n < 8; n++) { // originally 7
2252 if (noisy) printf("%4d", stgSize(stgVarBody(v)));
2253 copyInTopvar = TRUE;
2254 stgTopSanity ( "outer-1", stgVarBody(v));
2256 stgTopSanity ( "outer-2", stgVarBody(v));
2257 stgVarBody(v) = copyIn ( NIL, CTX_OTHER, stgVarBody(v) );
2258 stgTopSanity ( "outer-3", stgVarBody(v));
2259 stgVarBody(v) = simplify ( NIL, stgVarBody(v) );
2260 stgTopSanity ( "outer-4", stgVarBody(v));
2262 for (m = 0; m < 3; m++) { // oprignally 3
2263 if (noisy) printf(".");
2265 copyInTopvar = FALSE;
2266 stgTopSanity ( "inner-1", stgVarBody(v));
2268 stgTopSanity ( "inner-2", stgVarBody(v));
2269 stgVarBody(v) = copyIn ( NIL, CTX_OTHER, stgVarBody(v) );
2270 stgTopSanity ( "inner-3", stgVarBody(v));
2271 stgVarBody(v) = simplify ( NIL, stgVarBody(v) );
2274 fprintf(stderr,"\n-%d- - - - - - - - - - - - - -\n", n+1);
2275 printStg ( stderr,v );
2277 stgTopSanity ( "inner-post", stgVarBody(v));
2282 fprintf(stderr,"\n-%d-=-=-=-=-=-=-=-=-=-=-=-=-=-\n", n+1);
2283 printStg ( stderr,v );
2286 stgTopSanity ( "outer-post", stgVarBody(v));
2288 newSize = stgSize ( stgVarBody(v) );
2289 if (newSize == oldSize) break;
2292 n++; for (; n < 8; n++) for (m = 0; m <= 3+3; m++) if (noisy) printf ( " " );
2293 if (noisy) printf(" --> %4d\n", stgSize(stgVarBody(v)) );
2294 stgVarBody(v) = restoreStgTop ( stgVarBody(v) );
2296 if (nonNull(naam)) {
2297 assert(name(naam).stgVar == v);
2298 name(naam).stgSize = stgSize(stgVarBody(v));
2303 if (!isStgFullExpr(stgVarBody(v))) {
2304 fprintf(stderr, "\n\nrestoreStg failed!\n\n" );
2305 printStg(stderr, v);
2306 fprintf(stderr, "\n" );
2312 nTotSizeOut += stgSize(stgVarBody(v));
2315 fprintf(stderr,"\n=============================\n");
2316 printStg ( stderr,v );
2317 fprintf(stderr, "\n\n" );
2324 void optimiseTopBinds ( List bs )
2330 noisy = ddumpSimpl && (lastModule() != modulePrelude);
2333 if (noisy) printf("\n");
2336 for (t = bs; nonNull(t); t=tl(t)) {
2337 n = nameFromStgVar(hd(t));
2338 if (isNull(n) || !name(n).simplified) {
2340 optimiseTopBind(hd(t));
2344 if (noisy) printOptStats ( stderr );
2349 /* --------------------------------------------------------------------------
2350 * Optimiser control:
2351 * ------------------------------------------------------------------------*/
2353 Void optimiser(what)
2358 case RESET : spClone = SP_NOT_IN_USE;
2363 case MARK : markPairs();
2368 case GCDONE : checkStgVarSets();
2373 /*-------------------------------------------------------------------------*/