2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 %************************************************************************
6 \section[SATMonad]{The Static Argument Transformation pass Monad}
8 %************************************************************************
10 96/03: We aren't using the static-argument transformation right now.
13 #include "HsVersions.h"
20 junk_from_SATMonad = panic "SATMonad.junk"
22 {- LATER: to end of file:
25 SATInfo(..), updSAEnv,
26 SatM(..), initSAT, emptyEnvSAT,
27 returnSAT, thenSAT, thenSAT_, mapSAT, getSATInfo, newSATName,
28 getArgLists, Arg(..), insSAEnv, saTransform,
30 SATEnv(..), isStatic, dropStatics
33 import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
34 splitSigmaTy, splitTyArgs,
35 glueTyArgs, instantiateTy, TauType(..),
36 Class, ThetaType(..), SigmaType(..),
39 import Id ( mkSysLocal, idType )
40 import Maybes ( Maybe(..) )
41 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
45 infixr 9 `thenSAT`, `thenSAT_`
48 %************************************************************************
50 \subsection{Static Argument Transformation Environment}
52 %************************************************************************
55 type SATEnv = IdEnv SATInfo
57 type SATInfo = ([Arg Type],[Arg Id])
59 data Arg a = Static a | NotStatic
62 delOneFromSAEnv v us env
63 = ((), delOneFromIdEnv env v)
65 updSAEnv :: Maybe (Id,SATInfo) -> SatM ()
68 updSAEnv (Just (b,(tyargs,args)))
69 = getSATInfo b `thenSAT` (\ r ->
71 Nothing -> returnSAT ()
72 Just (tyargs',args') -> delOneFromSAEnv b `thenSAT_`
73 insSAEnv b (checkArgs tyargs tyargs',
77 checkArgs as [] = notStatics (length as)
78 checkArgs [] as = notStatics (length as)
79 checkArgs (a:as) (a':as') | a == a' = a:checkArgs as as'
80 checkArgs (_:as) (_:as') = NotStatic:checkArgs as as'
82 notStatics :: Int -> [Arg a]
83 notStatics n = nOfThem n NotStatic
85 insSAEnv :: Id -> SATInfo -> SatM ()
86 insSAEnv b info us env
87 = ((), addOneToIdEnv env b info)
90 %************************************************************************
92 \subsection{Static Argument Transformation Monad}
94 %************************************************************************
96 Two items of state to thread around: a UniqueSupply and a SATEnv.
100 = UniqSupply -> SATEnv -> (result, SATEnv)
102 initSAT :: SatM a -> UniqSupply -> a
104 initSAT f us = fst (f us nullIdEnv)
107 = case splitUniqSupply us of { (s1, s2) ->
108 case m s1 env of { (m_result, menv) ->
109 k m_result s2 menv }}
112 = case splitUniqSupply us of { (s1, s2) ->
113 case m s1 env of { (_, menv) ->
116 emptyEnvSAT :: SatM ()
117 emptyEnvSAT us _ = ((), nullIdEnv)
119 returnSAT v us env = (v, env)
121 mapSAT f [] = returnSAT []
123 = f x `thenSAT` \ x' ->
124 mapSAT f xs `thenSAT` \ xs' ->
128 %************************************************************************
130 \subsection{Utility Functions}
132 %************************************************************************
135 getSATInfo :: Id -> SatM (Maybe SATInfo)
136 getSATInfo var us env
137 = (lookupIdEnv env var, env)
139 newSATName :: Id -> Type -> SatM Id
140 newSATName id ty us env
141 = case (getUnique us) of { unique ->
142 (mkSysLocal new_str unique ty mkUnknownSrcLoc, env) }
144 new_str = panic "SATMonad.newSATName (ToDo)" -- getOccName id _APPEND_ SLIT("_sat")
146 getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
149 (uvs, tvs, lambda_bounds, body) = collectBinders expr
151 ([ Static (mkTyVarTy tv) | tv <- tvs ],
152 [ Static v | v <- lambda_bounds ])
154 dropArgs :: CoreExpr -> CoreExpr
155 dropArgs (Lam _ e) = dropArgs e
156 dropArgs (CoTyLam _ e) = dropArgs e
160 We implement saTransform using shadowing of binders, that is
162 map = \f as -> case as of
164 (a':as') -> let x = f a'
168 map = \f as -> let map = \f as -> map' as
169 in let rec map' = \as -> case as of
171 (a':as') -> let x = f a'
176 the inner map should get inlined and eliminated.
178 saTransform :: Id -> CoreExpr -> SatM CoreBinding
179 saTransform binder rhs
180 = getSATInfo binder `thenSAT` \ r ->
182 -- [Andre] test: do it only if we have more than one static argument.
183 --Just (tyargs,args) | any isStatic args
184 Just (tyargs,args) | length (filter isStatic args) > 1
185 -> newSATName binder (new_ty tyargs args) `thenSAT` \ binder' ->
186 mkNewRhs binder binder' tyargs args rhs `thenSAT` \ new_rhs ->
187 trace ("SAT "++ show (length (filter isStatic args))) (
188 returnSAT (NonRec binder new_rhs)
190 _ -> returnSAT (Rec [(binder, rhs)])
192 mkNewRhs binder binder' tyargs args rhs
194 non_static_args :: [Id]
196 = get_nsa args (snd (getArgLists rhs))
198 get_nsa :: [Arg a] -> [Arg a] -> [a]
201 get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
202 get_nsa (_:args) (_:as) = get_nsa args as
204 local_body = foldl App (Var binder')
205 [VarArg a | a <- non_static_args]
207 nonrec_rhs = origLams local_body
209 -- HACK! The following is a fake SysLocal binder with
210 -- *the same* unique as binder.
211 -- the reason for this is the following:
212 -- this binder *will* get inlined but if it happen to be
213 -- a top level binder it is never removed as dead code,
214 -- therefore we have to remove that information (of it being
215 -- top-level or exported somehow.)
216 -- A better fix is to use binder directly but with the TopLevel
217 -- tag (or Exported tag) modified.
218 fake_binder = mkSysLocal
219 (getOccName binder _APPEND_ SLIT("_fsat"))
223 rec_body = mkValLam non_static_args
224 ( Let (NonRec fake_binder nonrec_rhs)
225 {-in-} (dropArgs rhs))
228 origLams (Let (Rec [(binder',rec_body)]) {-in-} local_body)
231 origLams = origLams' rhs
233 origLams' (Lam v e) e' = Lam v (origLams' e e')
234 origLams' (CoTyLam ty e) e' = CoTyLam ty (origLams' e e')
238 = instantiateTy (mk_inst_tyenv tyargs tv_tmpl)
239 (mkSigmaTy tv_tmpl' dict_tys' tau_ty')
241 -- get type info for the local function:
242 (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
243 (reg_arg_tys, res_type) = splitTyArgs tau_ty
245 -- now, we drop the ones that are
246 -- static, that is, the ones we will not pass to the local function
248 tv_tmpl' = dropStatics tyargs tv_tmpl
249 dict_tys' = dropStatics (take l args) dict_tys
250 reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
251 tau_ty' = glueTyArgs reg_arg_tys' res_type
253 mk_inst_tyenv [] _ = []
254 mk_inst_tyenv (Static s:args) (t:ts) = (t,s) : mk_inst_tyenv args ts
255 mk_inst_tyenv (_:args) (_:ts) = mk_inst_tyenv args ts
258 dropStatics (Static _:args) (t:ts) = dropStatics args ts
259 dropStatics (_:args) (t:ts) = t:dropStatics args ts
261 isStatic :: Arg a -> Bool
262 isStatic NotStatic = False