2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[CoreLift]{Lifts unboxed bindings and any references to them}
17 #include "HsVersions.h"
20 import CoreUtils ( coreExprType )
21 import MkId ( mkSysLocal )
22 import Id ( idType, mkIdWithNewType,
23 nullIdEnv, growIdEnvList, lookupIdEnv,
26 import Name ( isLocallyDefined, getSrcLoc, getOccString )
27 import TyCon ( isBoxedTyCon, TyCon{-instance-} )
28 import Type ( splitAlgTyConApp_maybe )
29 import TysPrim ( statePrimTyCon )
30 import TysWiredIn ( liftDataCon, mkLiftTy )
31 import Unique ( Unique )
32 import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
33 import Util ( zipEqual, zipWithEqual, assertPanic, panic )
39 %************************************************************************
41 \subsection{``lift'' for various constructs}
43 %************************************************************************
45 @liftCoreBindings@ is the top-level interface function.
48 liftCoreBindings :: UniqSupply -- unique supply
49 -> [CoreBinding] -- unlifted bindings
50 -> [CoreBinding] -- lifted bindings
52 liftCoreBindings us binds
53 = initL (lift_top_binds binds) us
55 lift_top_binds [] = returnL []
58 = liftBindAndScope True b (
59 lift_top_binds bs `thenL` \ bs ->
60 returnL (ItsABinds bs)
61 ) `thenL` \ (b, ItsABinds bs) ->
65 -----------------------
66 liftBindAndScope :: Bool -- top level ?
67 -> CoreBinding -- As yet unprocessed
68 -> LiftM BindsOrExpr -- Do the scope of the bindings
69 -> LiftM (CoreBinding, -- 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)
79 -----------------------
80 liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr)
82 liftCoreArg arg@(TyArg _) = returnL (arg, id)
83 liftCoreArg arg@(LitArg _) = returnL (arg, id)
84 liftCoreArg arg@(VarArg v)
85 = isLiftedId v `thenL` \ lifted ->
87 Nothing -> returnL (arg, id)
89 Just (lifted, unlifted) ->
90 returnL (VarArg unlifted, bindUnlift lifted unlifted)
93 -----------------------
94 liftCoreBind :: CoreBinding -> LiftM CoreBinding
96 liftCoreBind (NonRec b rhs)
97 = liftOneBind (b,rhs) `thenL` \ (b,rhs) ->
98 returnL (NonRec b rhs)
100 liftCoreBind (Rec pairs)
101 = mapL liftOneBind pairs `thenL` \ pairs ->
104 -----------------------
105 liftOneBind (binder,rhs)
106 = liftCoreExpr rhs `thenL` \ rhs ->
107 isLiftedId binder `thenL` \ lifted ->
109 Just (lifted, unlifted) ->
110 returnL (lifted, liftExpr unlifted rhs)
112 returnL (binder, rhs)
114 -----------------------
115 liftCoreExpr :: CoreExpr -> LiftM CoreExpr
117 liftCoreExpr expr@(Var var)
118 = isLiftedId var `thenL` \ lifted ->
120 Nothing -> returnL expr
121 Just (lifted, unlifted) ->
122 returnL (bindUnlift lifted unlifted (Var unlifted))
124 liftCoreExpr expr@(Lit lit) = returnL expr
126 liftCoreExpr (Note note expr)
127 = liftCoreExpr expr `thenL` \ expr ->
128 returnL (Note note expr)
130 liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
131 = liftCoreExpr rhs `thenL` \ rhs ->
132 liftCoreExpr body `thenL` \ body ->
133 returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
135 liftCoreExpr (Let bind body) -- general case
136 = liftBindAndScope False bind (
137 liftCoreExpr body `thenL` \ body ->
138 returnL (ItsAnExpr body)
139 ) `thenL` \ (bind, ItsAnExpr body) ->
140 returnL (Let bind body)
142 liftCoreExpr (Con con args)
143 = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
144 returnL (applyBindUnlifts unlifts (Con con args))
146 liftCoreExpr (Prim op args)
147 = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
148 returnL (applyBindUnlifts unlifts (Prim op args))
150 liftCoreExpr (App fun arg)
153 lift_app (App fun arg) args
154 = lift_app fun (arg:args)
155 lift_app other_fun args
156 = liftCoreExpr other_fun `thenL` \ other_fun ->
157 mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
158 returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
160 liftCoreExpr (Lam binder expr)
161 = liftCoreExpr expr `thenL` \ expr ->
162 returnL (Lam binder expr)
164 liftCoreExpr (Case scrut alts)
165 = liftCoreExpr scrut `thenL` \ scrut ->
166 liftCoreAlts alts `thenL` \ alts ->
167 returnL (Case scrut alts)
170 liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
172 liftCoreAlts (AlgAlts alg_alts deflt)
173 = mapL liftAlgAlt alg_alts `thenL` \ alg_alts ->
174 liftDeflt deflt `thenL` \ deflt ->
175 returnL (AlgAlts alg_alts deflt)
177 liftCoreAlts (PrimAlts prim_alts deflt)
178 = mapL liftPrimAlt prim_alts `thenL` \ prim_alts ->
179 liftDeflt deflt `thenL` \ deflt ->
180 returnL (PrimAlts prim_alts deflt)
183 liftAlgAlt (con,args,rhs)
184 = liftCoreExpr rhs `thenL` \ rhs ->
185 returnL (con,args,rhs)
188 liftPrimAlt (lit,rhs)
189 = liftCoreExpr rhs `thenL` \ rhs ->
195 liftDeflt (BindDefault binder rhs)
196 = liftCoreExpr rhs `thenL` \ rhs ->
197 returnL (BindDefault binder rhs)
200 %************************************************************************
202 \subsection{Misc functions}
204 %************************************************************************
208 = IdEnv (Id, Id) -- lifted Ids are mapped to:
209 -- * lifted Id with the same Unique
210 -- (top-level bindings must keep their unique
211 -- * unlifted version with a new Unique
212 -> UniqSupply -- unique supply
216 = ItsABinds [CoreBinding]
219 initL m us = m nullIdEnv us
221 returnL :: a -> LiftM a
222 returnL r idenv us = r
224 thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
226 = case (splitUniqSupply s0) of { (s1, s2) ->
227 case (m idenv s1) of { r ->
231 mapL :: (a -> LiftM b) -> [a] -> LiftM [b]
232 mapL f [] = returnL []
235 mapL f xs `thenL` \ rs ->
238 mapAndUnzipL :: (a -> LiftM (b1, b2)) -> [a] -> LiftM ([b1],[b2])
239 mapAndUnzipL f [] = returnL ([],[])
240 mapAndUnzipL f (x:xs)
241 = f x `thenL` \ (r1, r2) ->
242 mapAndUnzipL f xs `thenL` \ (rs1,rs2) ->
243 returnL ((r1:rs1),(r2:rs2))
245 -- liftBinders is only called for top-level or recusive case
246 liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing
248 liftBinders False (NonRec _ _) liftM idenv s0
249 = panic "CoreLift:liftBinders" -- should be caught by special case above
251 liftBinders top_lev bind liftM idenv s0
252 = liftM (growIdEnvList idenv lift_map) s2
254 (s1, s2) = splitUniqSupply s0
255 lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
256 lift_uniqs = getUniques (length lift_ids) s1
257 lift_map = zipEqual "liftBinders" lift_ids (zipWithEqual "liftBinders" mkLiftedId lift_ids lift_uniqs)
259 -- ToDo: Give warning for recursive bindings involving unboxed values ???
261 isLiftedId :: Id -> LiftM (Maybe (Id, Id))
262 isLiftedId id idenv us
263 | isLocallyDefined id
264 = lookupIdEnv idenv id
265 | otherwise -- ensure all imported ids are lifted
266 = if isUnboxedButNotState (idType id)
267 then Just (mkLiftedId id (getUnique us))
270 mkLiftedId :: Id -> Unique -> (Id,Id)
272 = ASSERT (isUnboxedButNotState unlifted_ty)
273 (lifted_id, unlifted_id)
275 id_name = _PK_ (getOccString id) -- yuk!
276 lifted_id = mkIdWithNewType id lifted_ty
277 unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
279 unlifted_ty = idType id
280 lifted_ty = mkLiftTy unlifted_ty
282 bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
283 bindUnlift vlift vunlift expr
284 = ASSERT (isUnboxedButNotState unlift_ty)
285 ASSERT (lift_ty == mkLiftTy unlift_ty)
287 (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
289 lift_ty = idType vlift
290 unlift_ty = idType vunlift
292 liftExpr :: Id -> CoreExpr -> CoreExpr
294 = ASSERT (isUnboxedButNotState unlift_ty)
295 ASSERT (rhs_ty == unlift_ty)
296 Case rhs (PrimAlts []
297 (BindDefault vunlift (mkCon liftDataCon [unlift_ty] [VarArg vunlift])))
299 rhs_ty = coreExprType rhs
300 unlift_ty = idType vunlift
303 applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
304 applyBindUnlifts [] expr = expr
305 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
307 isUnboxedButNotState ty =
308 case (splitAlgTyConApp_maybe ty) of
310 Just (tycon, _, _) ->
311 not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)