2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 %************************************************************************
6 \section[SAT]{Static Argument Transformation pass}
8 %************************************************************************
10 May be seen as removing invariants from loops:
11 Arguments of recursive functions that do not change in recursive
12 calls are removed from the recursion, which is done locally
13 and only passes the arguments which effectively change.
16 map = /\ ab -> \f -> \xs -> case xs of
18 (a:b) -> f a : map f b
20 as map is recursively called with the same argument f (unmodified)
23 map = /\ ab -> \f -> \xs -> let map' ys = case ys of
28 Notice that for a compiler that uses lambda lifting this is
29 useless as map' will be transformed back to what map was.
32 #include "HsVersions.h"
34 module StgSAT ( doStaticArgs ) where
39 import UniqSupply ( SYN_IE(UniqSM) )
44 doStaticArgs :: [StgBinding] -> UniqSupply -> [StgBinding]
46 doStaticArgs = panic "StgSAT.doStaticArgs"
48 {- LATER: to end of file:
50 = initSAT (mapSAT sat_bind binds)
52 sat_bind (StgNonRec binder expr)
53 = emptyEnvSAT `thenSAT_`
54 satRhs expr `thenSAT` (\ expr' ->
55 returnSAT (StgNonRec binder expr'))
56 sat_bind (StgRec [(binder,rhs)])
57 = emptyEnvSAT `thenSAT_`
58 insSAEnv binder (getArgLists rhs) `thenSAT_`
59 satRhs rhs `thenSAT` (\ rhs' ->
60 saTransform binder rhs')
61 sat_bind (StgRec pairs)
62 = emptyEnvSAT `thenSAT_`
63 mapSAT satRhs rhss `thenSAT` \ rhss' ->
64 returnSAT (StgRec (binders `zip` rhss'))
66 (binders, rhss) = unzip pairs
71 = updSAEnv (Just (v,([],[]))) `thenSAT_`
74 satAtom _ = returnSAT ()
78 satExpr :: StgExpr -> SatM StgExpr
80 satExpr e@(StgCon con args lvs)
81 = mapSAT satAtom args `thenSAT_`
84 satExpr e@(StgPrim op args lvs)
85 = mapSAT satAtom args `thenSAT_`
88 satExpr e@(StgApp (StgLitArg _) _ _)
91 satExpr e@(StgApp (StgVarArg v) args _)
92 = updSAEnv (Just (v,([],map tagArg args))) `thenSAT_`
93 mapSAT satAtom args `thenSAT_`
96 tagArg (StgVarArg v) = Static v
99 satExpr (StgCase expr lv1 lv2 uniq alts)
100 = satExpr expr `thenSAT` \ expr' ->
101 sat_alts alts `thenSAT` \ alts' ->
102 returnSAT (StgCase expr' lv1 lv2 uniq alts')
104 sat_alts (StgAlgAlts ty alts deflt)
105 = mapSAT satAlgAlt alts `thenSAT` \ alts' ->
106 sat_default deflt `thenSAT` \ deflt' ->
107 returnSAT (StgAlgAlts ty alts' deflt')
109 satAlgAlt (con, params, use_mask, rhs)
110 = satExpr rhs `thenSAT` \ rhs' ->
111 returnSAT (con, params, use_mask, rhs')
113 sat_alts (StgPrimAlts ty alts deflt)
114 = mapSAT satPrimAlt alts `thenSAT` \ alts' ->
115 sat_default deflt `thenSAT` \ deflt' ->
116 returnSAT (StgPrimAlts ty alts' deflt')
118 satPrimAlt (lit, rhs)
119 = satExpr rhs `thenSAT` \ rhs' ->
120 returnSAT (lit, rhs')
122 sat_default StgNoDefault
123 = returnSAT StgNoDefault
124 sat_default (StgBindDefault binder used rhs)
125 = satExpr rhs `thenSAT` \ rhs' ->
126 returnSAT (StgBindDefault binder used rhs')
128 satExpr (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs) body)
129 = satExpr body `thenSAT` \ body' ->
130 satRhs rhs `thenSAT` \ rhs' ->
131 returnSAT (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs') body')
133 satExpr (StgLetNoEscape lv1 lv2 (StgRec [(binder,rhs)]) body)
134 = satExpr body `thenSAT` \ body' ->
135 insSAEnv binder (getArgLists rhs) `thenSAT_`
136 satRhs rhs `thenSAT` \ rhs' ->
137 saTransform binder rhs' `thenSAT` \ binding ->
138 returnSAT (StgLetNoEscape lv1 lv2 binding body')
140 satExpr (StgLetNoEscape lv1 lv2 (StgRec binds) body)
141 = let (binders, rhss) = unzip binds
143 satExpr body `thenSAT` \ body' ->
144 mapSAT satRhs rhss `thenSAT` \ rhss' ->
145 returnSAT (StgLetNoEscape lv1 lv2 (StgRec (binders `zip` rhss')) body')
147 satExpr (StgLet (StgNonRec binder rhs) body)
148 = satExpr body `thenSAT` \ body' ->
149 satRhs rhs `thenSAT` \ rhs' ->
150 returnSAT (StgLet (StgNonRec binder rhs') body')
152 satExpr (StgLet (StgRec [(binder,rhs)]) body)
153 = satExpr body `thenSAT` \ body' ->
154 insSAEnv binder (getArgLists rhs) `thenSAT_`
155 satRhs rhs `thenSAT` \ rhs' ->
156 saTransform binder rhs' `thenSAT` \ binding ->
157 returnSAT (StgLet binding body')
159 satExpr (StgLet (StgRec binds) body)
160 = let (binders, rhss) = unzip binds
162 satExpr body `thenSAT` \ body' ->
163 mapSAT satRhs rhss `thenSAT` \ rhss' ->
164 returnSAT (StgLet (StgRec (binders `zip` rhss')) body')
166 satExpr (StgSCC ty cc expr)
167 = satExpr expr `thenSAT` \ expr' ->
168 returnSAT (StgSCC ty cc expr')
172 satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs
174 satRhs (StgRhsClosure cc bi fvs upd args body)
175 = satExpr body `thenSAT` \ body' ->
176 returnSAT (StgRhsClosure cc bi fvs upd args body')