2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %************************************************************************
6 \section[SATMonad]{The Static Argument Transformation pass Monad}
8 %************************************************************************
10 96/03: We aren't using the static-argument transformation right now.
15 #include "HsVersions.h"
17 import Panic ( panic )
19 junk_from_SATMonad = panic "SATMonad.junk"
21 {- LATER: to end of file:
24 SATInfo(..), updSAEnv,
25 SatM(..), initSAT, emptyEnvSAT,
26 returnSAT, thenSAT, thenSAT_, mapSAT, getSATInfo, newSATName,
27 getArgLists, Arg(..), insSAEnv, saTransform,
29 SATEnv(..), isStatic, dropStatics
32 import Type ( mkTyVarTy, mkSigmaTy,
33 splitSigmaTy, splitFunTys,
37 import MkId ( mkSysLocal )
38 import Id ( idType, idName, mkVanillaId )
42 infixr 9 `thenSAT`, `thenSAT_`
45 %************************************************************************
47 \subsection{Static Argument Transformation Environment}
49 %************************************************************************
52 type SATEnv = IdEnv SATInfo
54 type SATInfo = ([Arg Type],[Arg Id])
56 data Arg a = Static a | NotStatic
59 delOneFromSAEnv v us env
60 = ((), delVarEnv env v)
62 updSAEnv :: Maybe (Id,SATInfo) -> SatM ()
65 updSAEnv (Just (b,(tyargs,args)))
66 = getSATInfo b `thenSAT` (\ r ->
68 Nothing -> returnSAT ()
69 Just (tyargs',args') -> delOneFromSAEnv b `thenSAT_`
70 insSAEnv b (checkArgs tyargs tyargs',
74 checkArgs as [] = notStatics (length as)
75 checkArgs [] as = notStatics (length as)
76 checkArgs (a:as) (a':as') | a == a' = a:checkArgs as as'
77 checkArgs (_:as) (_:as') = NotStatic:checkArgs as as'
79 notStatics :: Int -> [Arg a]
80 notStatics n = nOfThem n NotStatic
82 insSAEnv :: Id -> SATInfo -> SatM ()
83 insSAEnv b info us env
84 = ((), extendVarEnv env b info)
87 %************************************************************************
89 \subsection{Static Argument Transformation Monad}
91 %************************************************************************
93 Two items of state to thread around: a UniqueSupply and a SATEnv.
97 = UniqSupply -> SATEnv -> (result, SATEnv)
99 initSAT :: SatM a -> UniqSupply -> a
101 initSAT f us = fst (f us emptyVarEnv)
104 = case splitUniqSupply us of { (s1, s2) ->
105 case m s1 env of { (m_result, menv) ->
106 k m_result s2 menv }}
109 = case splitUniqSupply us of { (s1, s2) ->
110 case m s1 env of { (_, menv) ->
113 emptyEnvSAT :: SatM ()
114 emptyEnvSAT us _ = ((), emptyVarEnv)
116 returnSAT v us env = (v, env)
118 mapSAT f [] = returnSAT []
120 = f x `thenSAT` \ x' ->
121 mapSAT f xs `thenSAT` \ xs' ->
125 %************************************************************************
127 \subsection{Utility Functions}
129 %************************************************************************
132 getSATInfo :: Id -> SatM (Maybe SATInfo)
133 getSATInfo var us env
134 = (lookupVarEnv env var, env)
136 newSATName :: Id -> Type -> SatM Id
137 newSATName id ty us env
138 = case (getUnique us) of { unique ->
140 new_name = mkCompoundName SLIT("$sat") unique (idName id)
142 (mkVanillaId new_name ty, env) }
144 getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
147 (tvs, lambda_bounds, body) = collectBinders expr
149 ([ Static (mkTyVarTy tv) | tv <- tvs ],
150 [ Static v | v <- lambda_bounds ])
152 dropArgs :: CoreExpr -> CoreExpr
153 dropArgs (Lam _ e) = dropArgs e
154 dropArgs (CoTyLam _ e) = dropArgs e
158 We implement saTransform using shadowing of binders, that is
160 map = \f as -> case as of
162 (a':as') -> let x = f a'
166 map = \f as -> let map = \f as -> map' as
167 in let rec map' = \as -> case as of
169 (a':as') -> let x = f a'
174 the inner map should get inlined and eliminated.
176 saTransform :: Id -> CoreExpr -> SatM CoreBinding
177 saTransform binder rhs
178 = getSATInfo binder `thenSAT` \ r ->
180 -- [Andre] test: do it only if we have more than one static argument.
181 --Just (tyargs,args) | any isStatic args
182 Just (tyargs,args) | length (filter isStatic args) > 1
183 -> newSATName binder (new_ty tyargs args) `thenSAT` \ binder' ->
184 mkNewRhs binder binder' tyargs args rhs `thenSAT` \ new_rhs ->
185 trace ("SAT "++ show (length (filter isStatic args))) (
186 returnSAT (NonRec binder new_rhs)
188 _ -> returnSAT (Rec [(binder, rhs)])
190 mkNewRhs binder binder' tyargs args rhs
192 non_static_args :: [Id]
194 = get_nsa args (snd (getArgLists rhs))
196 get_nsa :: [Arg a] -> [Arg a] -> [a]
199 get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
200 get_nsa (_:args) (_:as) = get_nsa args as
202 local_body = foldl App (Var binder')
203 [VarArg a | a <- non_static_args]
205 nonrec_rhs = origLams local_body
207 -- HACK! The following is a fake SysLocal binder with
208 -- *the same* unique as binder.
209 -- the reason for this is the following:
210 -- this binder *will* get inlined but if it happen to be
211 -- a top level binder it is never removed as dead code,
212 -- therefore we have to remove that information (of it being
213 -- top-level or exported somehow.)
214 -- A better fix is to use binder directly but with the TopLevel
215 -- tag (or Exported tag) modified.
216 fake_binder = mkSysLocal SLIT("sat")
219 rec_body = mkValLam non_static_args
220 ( Let (NonRec fake_binder nonrec_rhs)
221 {-in-} (dropArgs rhs))
224 origLams (Let (Rec [(binder',rec_body)]) {-in-} local_body)
227 origLams = origLams' rhs
229 origLams' (Lam v e) e' = Lam v (origLams' e e')
230 origLams' (CoTyLam ty e) e' = CoTyLam ty (origLams' e e')
234 = substTy (mk_inst_tyenv tyargs tv_tmpl)
235 (mkSigmaTy tv_tmpl' dict_tys' tau_ty')
237 -- get type info for the local function:
238 (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
239 (reg_arg_tys, res_type) = splitFunTys tau_ty
241 -- now, we drop the ones that are
242 -- static, that is, the ones we will not pass to the local function
244 tv_tmpl' = dropStatics tyargs tv_tmpl
245 dict_tys' = dropStatics (take l args) dict_tys
246 reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
247 tau_ty' = glueTyArgs reg_arg_tys' res_type
249 mk_inst_tyenv [] _ = emptyVarEnv
250 mk_inst_tyenv (Static s:args) (t:ts) = extendVarEnv (mk_inst_tyenv args ts) t s
251 mk_inst_tyenv (_:args) (_:ts) = mk_inst_tyenv args ts
254 dropStatics (Static _:args) (t:ts) = dropStatics args ts
255 dropStatics (_:args) (t:ts) = t:dropStatics args ts
257 isStatic :: Arg a -> Bool
258 isStatic NotStatic = False