2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[CoreLift]{Lifts unboxed bindings and any references to them}
7 #include "HsVersions.h"
18 CoreBinding, PlainCoreBinding(..),
19 CoreExpr, PlainCoreExpr(..),
20 Id, SplitUniqSupply, Unique
26 import AbsPrel ( liftDataCon, mkLiftTy )
27 import TysPrim ( statePrimTyCon ) -- ToDo: get from AbsPrel
29 import Id ( getIdUniType, updateIdType, mkSysLocal, isLocallyDefined )
40 %************************************************************************
42 \subsection{``lift'' for various constructs}
44 %************************************************************************
46 @liftCoreBindings@ is the top-level interface function.
49 liftCoreBindings :: SplitUniqSupply -- unique supply
50 -> [PlainCoreBinding] -- unlifted bindings
51 -> [PlainCoreBinding] -- lifted bindings
53 liftCoreBindings us binds
54 = initL (lift_top_binds binds) us
57 = liftBindAndScope True b (
58 lift_top_binds bs `thenL` \ bs ->
59 returnL (ItsABinds bs)
60 ) `thenL` \ (b, ItsABinds bs) ->
66 liftBindAndScope :: Bool -- top level ?
67 -> PlainCoreBinding -- As yet unprocessed
68 -> LiftM BindsOrExpr -- Do the scope of the bindings
69 -> LiftM (PlainCoreBinding, -- Processed
72 liftBindAndScope top_lev bind scopeM
73 = liftBinders top_lev bind (
74 liftCoreBind bind `thenL` \ bind ->
75 scopeM `thenL` \ bindsorexpr ->
76 returnL (bind, bindsorexpr)
80 liftCoreAtom :: PlainCoreAtom -> LiftM (PlainCoreAtom, PlainCoreExpr -> PlainCoreExpr)
82 liftCoreAtom (CoLitAtom lit)
83 = returnL (CoLitAtom lit, id)
85 liftCoreAtom (CoVarAtom v)
86 = isLiftedId v `thenL` \ lifted ->
88 Just (lifted, unlifted) ->
89 returnL (CoVarAtom unlifted, bindUnlift lifted unlifted)
91 returnL (CoVarAtom v, id)
94 liftCoreBind :: PlainCoreBinding -> LiftM PlainCoreBinding
96 liftCoreBind (CoNonRec b rhs)
97 = liftOneBind (b,rhs) `thenL` \ (b,rhs) ->
98 returnL (CoNonRec b rhs)
100 liftCoreBind (CoRec pairs)
101 = mapL liftOneBind pairs `thenL` \ pairs ->
102 returnL (CoRec pairs)
104 liftOneBind (binder,rhs)
105 = liftCoreExpr rhs `thenL` \ rhs ->
106 isLiftedId binder `thenL` \ lifted ->
108 Just (lifted, unlifted) ->
109 returnL (lifted, liftExpr unlifted rhs)
111 returnL (binder, rhs)
113 liftCoreExpr :: PlainCoreExpr -> LiftM PlainCoreExpr
115 liftCoreExpr (CoVar var)
116 = isLiftedId var `thenL` \ lifted ->
118 Just (lifted, unlifted) ->
119 returnL (bindUnlift lifted unlifted (CoVar unlifted))
123 liftCoreExpr (CoLit lit)
124 = returnL (CoLit lit)
126 liftCoreExpr (CoSCC label expr)
127 = liftCoreExpr expr `thenL` \ expr ->
128 returnL (CoSCC label expr)
130 liftCoreExpr (CoLet (CoNonRec binder rhs) body) -- special case: no lifting
131 = liftCoreExpr rhs `thenL` \ rhs ->
132 liftCoreExpr body `thenL` \ body ->
133 returnL (mkCoLetUnboxedToCase (CoNonRec binder rhs) body)
135 liftCoreExpr (CoLet bind body) -- general case
136 = liftBindAndScope False bind (
137 liftCoreExpr body `thenL` \ body ->
138 returnL (ItsAnExpr body)
139 ) `thenL` \ (bind, ItsAnExpr body) ->
140 returnL (CoLet bind body)
142 liftCoreExpr (CoCon con tys args)
143 = mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) ->
144 returnL (applyBindUnlifts unlifts (CoCon con tys args))
146 liftCoreExpr (CoPrim op tys args)
147 = mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) ->
148 returnL (applyBindUnlifts unlifts (CoPrim op tys args))
150 liftCoreExpr (CoApp fun arg)
153 lift_app (CoApp fun arg) args
154 = lift_app fun (arg:args)
155 lift_app other_fun args
156 = liftCoreExpr other_fun `thenL` \ other_fun ->
157 mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) ->
158 returnL (applyBindUnlifts unlifts (foldl CoApp other_fun args))
160 liftCoreExpr (CoTyApp fun ty_arg)
161 = liftCoreExpr fun `thenL` \ fun ->
162 returnL (CoTyApp fun ty_arg)
164 liftCoreExpr (CoLam binders expr)
165 = liftCoreExpr expr `thenL` \ expr ->
166 returnL (CoLam binders expr)
168 liftCoreExpr (CoTyLam tyvar expr)
169 = liftCoreExpr expr `thenL` \ expr ->
170 returnL (CoTyLam tyvar expr)
172 liftCoreExpr (CoCase scrut alts)
173 = liftCoreExpr scrut `thenL` \ scrut ->
174 liftCoreAlts alts `thenL` \ alts ->
175 returnL (CoCase scrut alts)
178 liftCoreAlts :: PlainCoreCaseAlternatives -> LiftM PlainCoreCaseAlternatives
180 liftCoreAlts (CoAlgAlts alg_alts deflt)
181 = mapL liftAlgAlt alg_alts `thenL` \ alg_alts ->
182 liftDeflt deflt `thenL` \ deflt ->
183 returnL (CoAlgAlts alg_alts deflt)
185 liftCoreAlts (CoPrimAlts prim_alts deflt)
186 = mapL liftPrimAlt prim_alts `thenL` \ prim_alts ->
187 liftDeflt deflt `thenL` \ deflt ->
188 returnL (CoPrimAlts prim_alts deflt)
191 liftAlgAlt (con,args,rhs)
192 = liftCoreExpr rhs `thenL` \ rhs ->
193 returnL (con,args,rhs)
195 liftPrimAlt (lit,rhs)
196 = liftCoreExpr rhs `thenL` \ rhs ->
199 liftDeflt CoNoDefault
200 = returnL CoNoDefault
201 liftDeflt (CoBindDefault binder rhs)
202 = liftCoreExpr rhs `thenL` \ rhs ->
203 returnL (CoBindDefault binder rhs)
207 %************************************************************************
209 \subsection{Misc functions}
211 %************************************************************************
214 type LiftM a = IdEnv (Id, Id) -- lifted Ids are mapped to:
215 -- * lifted Id with the same Unique
216 -- (top-level bindings must keep their
217 -- unique (see TopLevId in Id.lhs))
218 -- * unlifted version with a new Unique
219 -> SplitUniqSupply -- unique supply
222 data BindsOrExpr = ItsABinds [PlainCoreBinding]
223 | ItsAnExpr PlainCoreExpr
228 returnL :: a -> LiftM a
232 thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
234 = case splitUniqSupply s0 of { (s1, s2) ->
235 case (m idenv s1) of { r ->
239 mapL :: (a -> LiftM b) -> [a] -> LiftM [b]
240 mapL f [] = returnL []
243 mapL f xs `thenL` \ rs ->
246 mapAndUnzipL :: (a -> LiftM (b1, b2)) -> [a] -> LiftM ([b1],[b2])
247 mapAndUnzipL f [] = returnL ([],[])
248 mapAndUnzipL f (x:xs)
249 = f x `thenL` \ (r1, r2) ->
250 mapAndUnzipL f xs `thenL` \ (rs1,rs2) ->
251 returnL ((r1:rs1),(r2:rs2))
253 -- liftBinders is only called for top-level or recusive case
254 liftBinders :: Bool -> PlainCoreBinding -> LiftM thing -> LiftM thing
256 liftBinders False (CoNonRec _ _) liftM idenv s0
257 = error "CoreLift:liftBinders" -- should be caught by special case above
259 liftBinders top_lev bind liftM idenv s0
260 = liftM (growIdEnvList idenv lift_map) s1
262 lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (getIdUniType id) ]
263 (lift_uniqs, s1) = getSUniquesAndDepleted (length lift_ids) s0
264 lift_map = zip lift_ids (zipWith mkLiftedId lift_ids lift_uniqs)
266 -- ToDo: Give warning for recursive bindings involving unboxed values ???
269 isLiftedId :: Id -> LiftM (Maybe (Id, Id))
270 isLiftedId id idenv us
271 | isLocallyDefined id
272 = lookupIdEnv idenv id
273 | otherwise -- ensure all imported ids are lifted
274 = if isUnboxedButNotState (getIdUniType id)
275 then Just (mkLiftedId id (getSUnique us))
278 mkLiftedId :: Id -> Unique -> (Id,Id)
280 = ASSERT (isUnboxedButNotState unlifted_ty)
281 (lifted_id, unlifted_id)
283 id_name = getOccurrenceName id
284 lifted_id = updateIdType id lifted_ty
285 unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
287 unlifted_ty = getIdUniType id
288 lifted_ty = mkLiftTy unlifted_ty
290 bindUnlift :: Id -> Id -> PlainCoreExpr -> PlainCoreExpr
291 bindUnlift vlift vunlift expr
292 = ASSERT (isUnboxedButNotState unlift_ty)
293 ASSERT (lift_ty == mkLiftTy unlift_ty)
295 (CoAlgAlts [(liftDataCon, [vunlift], expr)] CoNoDefault)
297 lift_ty = getIdUniType vlift
298 unlift_ty = getIdUniType vunlift
300 liftExpr :: Id -> PlainCoreExpr -> PlainCoreExpr
302 = ASSERT (isUnboxedButNotState unlift_ty)
303 ASSERT (rhs_ty == unlift_ty)
304 CoCase rhs (CoPrimAlts [] (CoBindDefault vunlift
305 (CoCon liftDataCon [unlift_ty] [CoVarAtom vunlift])))
307 rhs_ty = typeOfCoreExpr rhs
308 unlift_ty = getIdUniType vunlift
311 applyBindUnlifts :: [PlainCoreExpr -> PlainCoreExpr] -> PlainCoreExpr -> PlainCoreExpr
312 applyBindUnlifts [] expr = expr
313 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
315 isUnboxedButNotState ty
316 = case (getUniDataTyCon_maybe ty) of
318 Just (tycon, _, _) ->
319 not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)