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.
14 -- The above warning supression flag is a temporary kludge.
15 -- While working on this module you are encouraged to remove it and fix
16 -- any warnings in the module. See
17 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
22 #include "HsVersions.h"
24 import Panic ( panic )
26 junk_from_SATMonad = panic "SATMonad.junk"
28 {- LATER: to end of file:
31 SATInfo(..), updSAEnv,
32 SatM(..), initSAT, emptyEnvSAT,
33 returnSAT, thenSAT, thenSAT_, mapSAT, getSATInfo, newSATName,
34 getArgLists, Arg(..), insSAEnv, saTransform,
36 SATEnv(..), isStatic, dropStatics
39 import Type ( mkTyVarTy, mkSigmaTy,
40 splitSigmaTy, splitFunTys,
44 import MkId ( mkSysLocal )
45 import Id ( idType, idName, mkLocalId )
49 infixr 9 `thenSAT`, `thenSAT_`
52 %************************************************************************
54 \subsection{Static Argument Transformation Environment}
56 %************************************************************************
59 type SATEnv = IdEnv SATInfo
61 type SATInfo = ([Arg Type],[Arg Id])
63 data Arg a = Static a | NotStatic
66 delOneFromSAEnv v us env
67 = ((), delVarEnv env v)
69 updSAEnv :: Maybe (Id,SATInfo) -> SatM ()
72 updSAEnv (Just (b,(tyargs,args)))
73 = getSATInfo b `thenSAT` (\ r ->
75 Nothing -> returnSAT ()
76 Just (tyargs',args') -> delOneFromSAEnv b `thenSAT_`
77 insSAEnv b (checkArgs tyargs tyargs',
81 checkArgs as [] = notStatics (length as)
82 checkArgs [] as = notStatics (length as)
83 checkArgs (a:as) (a':as') | a == a' = a:checkArgs as as'
84 checkArgs (_:as) (_:as') = NotStatic:checkArgs as as'
86 notStatics :: Int -> [Arg a]
87 notStatics n = nOfThem n NotStatic
89 insSAEnv :: Id -> SATInfo -> SatM ()
90 insSAEnv b info us env
91 = ((), extendVarEnv env b info)
94 %************************************************************************
96 \subsection{Static Argument Transformation Monad}
98 %************************************************************************
100 Two items of state to thread around: a UniqueSupply and a SATEnv.
104 = UniqSupply -> SATEnv -> (result, SATEnv)
106 initSAT :: SatM a -> UniqSupply -> a
108 initSAT f us = fst (f us emptyVarEnv)
111 = case splitUniqSupply us of { (s1, s2) ->
112 case m s1 env of { (m_result, menv) ->
113 k m_result s2 menv }}
116 = case splitUniqSupply us of { (s1, s2) ->
117 case m s1 env of { (_, menv) ->
120 emptyEnvSAT :: SatM ()
121 emptyEnvSAT us _ = ((), emptyVarEnv)
123 returnSAT v us env = (v, env)
125 mapSAT f [] = returnSAT []
127 = f x `thenSAT` \ x' ->
128 mapSAT f xs `thenSAT` \ xs' ->
132 %************************************************************************
134 \subsection{Utility Functions}
136 %************************************************************************
139 getSATInfo :: Id -> SatM (Maybe SATInfo)
140 getSATInfo var us env
141 = (lookupVarEnv env var, env)
143 newSATName :: Id -> Type -> SatM Id
144 newSATName id ty us env
145 = case (getUnique us) of { unique ->
147 new_name = mkCompoundName SLIT("$sat") unique (idName id)
149 (mkLocalId new_name ty, env) }
151 getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
154 (tvs, lambda_bounds, body) = collectBinders expr
156 ([ Static (mkTyVarTy tv) | tv <- tvs ],
157 [ Static v | v <- lambda_bounds ])
159 dropArgs :: CoreExpr -> CoreExpr
160 dropArgs (Lam _ e) = dropArgs e
161 dropArgs (CoTyLam _ e) = dropArgs e
165 We implement saTransform using shadowing of binders, that is
167 map = \f as -> case as of
169 (a':as') -> let x = f a'
173 map = \f as -> let map = \f as -> map' as
174 in let rec map' = \as -> case as of
176 (a':as') -> let x = f a'
181 the inner map should get inlined and eliminated.
183 saTransform :: Id -> CoreExpr -> SatM CoreBinding
184 saTransform binder rhs
185 = getSATInfo binder `thenSAT` \ r ->
187 -- [Andre] test: do it only if we have more than one static argument.
188 --Just (tyargs,args) | any isStatic args
189 Just (tyargs,args) | (filter isStatic args) `lengthExceeds` 1
190 -> newSATName binder (new_ty tyargs args) `thenSAT` \ binder' ->
191 mkNewRhs binder binder' tyargs args rhs `thenSAT` \ new_rhs ->
192 trace ("SAT "++ show (length (filter isStatic args))) (
193 returnSAT (NonRec binder new_rhs)
195 _ -> returnSAT (Rec [(binder, rhs)])
197 mkNewRhs binder binder' tyargs args rhs
199 non_static_args :: [Id]
201 = get_nsa args (snd (getArgLists rhs))
203 get_nsa :: [Arg a] -> [Arg a] -> [a]
206 get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
207 get_nsa (_:args) (_:as) = get_nsa args as
209 local_body = foldl App (Var binder')
210 [VarArg a | a <- non_static_args]
212 nonrec_rhs = origLams local_body
214 -- HACK! The following is a fake SysLocal binder with
215 -- *the same* unique as binder.
216 -- the reason for this is the following:
217 -- this binder *will* get inlined but if it happen to be
218 -- a top level binder it is never removed as dead code,
219 -- therefore we have to remove that information (of it being
220 -- top-level or exported somehow.)
221 -- A better fix is to use binder directly but with the TopLevel
222 -- tag (or Exported tag) modified.
223 fake_binder = mkSysLocal SLIT("sat")
226 rec_body = mkValLam non_static_args
227 ( Let (NonRec fake_binder nonrec_rhs)
228 {-in-} (dropArgs rhs))
231 origLams (Let (Rec [(binder',rec_body)]) {-in-} local_body)
234 origLams = origLams' rhs
236 origLams' (Lam v e) e' = Lam v (origLams' e e')
237 origLams' (CoTyLam ty e) e' = CoTyLam ty (origLams' e e')
241 = substTy (mk_inst_tyenv tyargs tv_tmpl)
242 (mkSigmaTy tv_tmpl' dict_tys' tau_ty')
244 -- get type info for the local function:
245 (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
246 (reg_arg_tys, res_type) = splitFunTys tau_ty
248 -- now, we drop the ones that are
249 -- static, that is, the ones we will not pass to the local function
250 tv_tmpl' = dropStatics tyargs tv_tmpl
252 (args1, args2) = splitAtList dict_tys args
253 dict_tys' = dropStatics args1 dict_tys
254 reg_arg_tys' = dropStatics args2 reg_arg_tys
256 tau_ty' = glueTyArgs reg_arg_tys' res_type
258 mk_inst_tyenv [] _ = emptyVarEnv
259 mk_inst_tyenv (Static s:args) (t:ts) = extendVarEnv (mk_inst_tyenv args ts) t s
260 mk_inst_tyenv (_:args) (_:ts) = mk_inst_tyenv args ts
263 dropStatics (Static _:args) (t:ts) = dropStatics args ts
264 dropStatics (_:args) (t:ts) = t:dropStatics args ts
266 isStatic :: Arg a -> Bool
267 isStatic NotStatic = False