2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[CoreLift]{Lifts unboxed bindings and any references to them}
7 #include "HsVersions.h"
22 import CoreUtils ( coreExprType )
23 import Id ( idType, mkSysLocal,
24 nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv),
27 import Name ( isLocallyDefined, getSrcLoc )
28 import TyCon ( isBoxedTyCon, TyCon{-instance-} )
29 import Type ( maybeAppDataTyConExpandingDicts, eqTy )
30 import TysPrim ( statePrimTyCon )
31 import TysWiredIn ( liftDataCon, mkLiftTy )
32 import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
33 import Util ( zipEqual, zipWithEqual, assertPanic, panic )
37 updateIdType = panic "CoreLift.updateIdType"
40 %************************************************************************
42 \subsection{``lift'' for various constructs}
44 %************************************************************************
46 @liftCoreBindings@ is the top-level interface function.
49 liftCoreBindings :: UniqSupply -- unique supply
50 -> [CoreBinding] -- unlifted bindings
51 -> [CoreBinding] -- lifted bindings
53 liftCoreBindings us binds
54 = initL (lift_top_binds binds) us
56 lift_top_binds [] = returnL []
59 = liftBindAndScope True b (
60 lift_top_binds bs `thenL` \ bs ->
61 returnL (ItsABinds bs)
62 ) `thenL` \ (b, ItsABinds bs) ->
66 -----------------------
67 liftBindAndScope :: Bool -- top level ?
68 -> CoreBinding -- As yet unprocessed
69 -> LiftM BindsOrExpr -- Do the scope of the bindings
70 -> LiftM (CoreBinding, -- Processed
73 liftBindAndScope top_lev bind scopeM
74 = liftBinders top_lev bind (
75 liftCoreBind bind `thenL` \ bind ->
76 scopeM `thenL` \ bindsorexpr ->
77 returnL (bind, bindsorexpr)
80 -----------------------
81 liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr)
83 liftCoreArg arg@(TyArg _) = returnL (arg, id)
84 liftCoreArg arg@(UsageArg _) = returnL (arg, id)
85 liftCoreArg arg@(LitArg _) = returnL (arg, id)
86 liftCoreArg arg@(VarArg v)
87 = isLiftedId v `thenL` \ lifted ->
89 Nothing -> returnL (arg, id)
91 Just (lifted, unlifted) ->
92 returnL (VarArg unlifted, bindUnlift lifted unlifted)
95 -----------------------
96 liftCoreBind :: CoreBinding -> LiftM CoreBinding
98 liftCoreBind (NonRec b rhs)
99 = liftOneBind (b,rhs) `thenL` \ (b,rhs) ->
100 returnL (NonRec b rhs)
102 liftCoreBind (Rec pairs)
103 = mapL liftOneBind pairs `thenL` \ pairs ->
106 -----------------------
107 liftOneBind (binder,rhs)
108 = liftCoreExpr rhs `thenL` \ rhs ->
109 isLiftedId binder `thenL` \ lifted ->
111 Just (lifted, unlifted) ->
112 returnL (lifted, liftExpr unlifted rhs)
114 returnL (binder, rhs)
116 -----------------------
117 liftCoreExpr :: CoreExpr -> LiftM CoreExpr
119 liftCoreExpr expr@(Var var)
120 = isLiftedId var `thenL` \ lifted ->
122 Nothing -> returnL expr
123 Just (lifted, unlifted) ->
124 returnL (bindUnlift lifted unlifted (Var unlifted))
126 liftCoreExpr expr@(Lit lit) = returnL expr
128 liftCoreExpr (SCC label expr)
129 = liftCoreExpr expr `thenL` \ expr ->
130 returnL (SCC label expr)
132 liftCoreExpr (Coerce coerce ty expr)
133 = liftCoreExpr expr `thenL` \ expr ->
134 returnL (Coerce coerce ty expr) -- ToDo:right?:Coerce
136 liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
137 = liftCoreExpr rhs `thenL` \ rhs ->
138 liftCoreExpr body `thenL` \ body ->
139 returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
141 liftCoreExpr (Let bind body) -- general case
142 = liftBindAndScope False bind (
143 liftCoreExpr body `thenL` \ body ->
144 returnL (ItsAnExpr body)
145 ) `thenL` \ (bind, ItsAnExpr body) ->
146 returnL (Let bind body)
148 liftCoreExpr (Con con args)
149 = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
150 returnL (applyBindUnlifts unlifts (Con con args))
152 liftCoreExpr (Prim op args)
153 = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
154 returnL (applyBindUnlifts unlifts (Prim op args))
156 liftCoreExpr (App fun arg)
159 lift_app (App fun arg) args
160 = lift_app fun (arg:args)
161 lift_app other_fun args
162 = liftCoreExpr other_fun `thenL` \ other_fun ->
163 mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
164 returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
166 liftCoreExpr (Lam binder expr)
167 = liftCoreExpr expr `thenL` \ expr ->
168 returnL (Lam binder expr)
170 liftCoreExpr (Case scrut alts)
171 = liftCoreExpr scrut `thenL` \ scrut ->
172 liftCoreAlts alts `thenL` \ alts ->
173 returnL (Case scrut alts)
176 liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
178 liftCoreAlts (AlgAlts alg_alts deflt)
179 = mapL liftAlgAlt alg_alts `thenL` \ alg_alts ->
180 liftDeflt deflt `thenL` \ deflt ->
181 returnL (AlgAlts alg_alts deflt)
183 liftCoreAlts (PrimAlts prim_alts deflt)
184 = mapL liftPrimAlt prim_alts `thenL` \ prim_alts ->
185 liftDeflt deflt `thenL` \ deflt ->
186 returnL (PrimAlts prim_alts deflt)
189 liftAlgAlt (con,args,rhs)
190 = liftCoreExpr rhs `thenL` \ rhs ->
191 returnL (con,args,rhs)
194 liftPrimAlt (lit,rhs)
195 = liftCoreExpr rhs `thenL` \ rhs ->
201 liftDeflt (BindDefault binder rhs)
202 = liftCoreExpr rhs `thenL` \ rhs ->
203 returnL (BindDefault binder rhs)
206 %************************************************************************
208 \subsection{Misc functions}
210 %************************************************************************
214 = 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 -> UniqSupply -- unique supply
223 = ItsABinds [CoreBinding]
226 initL m us = m nullIdEnv us
228 returnL :: a -> LiftM a
229 returnL r idenv us = r
231 thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
233 = case (splitUniqSupply s0) of { (s1, s2) ->
234 case (m idenv s1) of { r ->
238 mapL :: (a -> LiftM b) -> [a] -> LiftM [b]
239 mapL f [] = returnL []
242 mapL f xs `thenL` \ rs ->
245 mapAndUnzipL :: (a -> LiftM (b1, b2)) -> [a] -> LiftM ([b1],[b2])
246 mapAndUnzipL f [] = returnL ([],[])
247 mapAndUnzipL f (x:xs)
248 = f x `thenL` \ (r1, r2) ->
249 mapAndUnzipL f xs `thenL` \ (rs1,rs2) ->
250 returnL ((r1:rs1),(r2:rs2))
252 -- liftBinders is only called for top-level or recusive case
253 liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing
255 liftBinders False (NonRec _ _) liftM idenv s0
256 = panic "CoreLift:liftBinders" -- should be caught by special case above
258 liftBinders top_lev bind liftM idenv s0
259 = liftM (growIdEnvList idenv lift_map) s2
261 (s1, s2) = splitUniqSupply s0
262 lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
263 lift_uniqs = getUniques (length lift_ids) s1
264 lift_map = zipEqual "liftBinders" lift_ids (zipWithEqual "liftBinders" mkLiftedId lift_ids lift_uniqs)
266 -- ToDo: Give warning for recursive bindings involving unboxed values ???
268 isLiftedId :: Id -> LiftM (Maybe (Id, Id))
269 isLiftedId id idenv us
270 | isLocallyDefined id
271 = lookupIdEnv idenv id
272 | otherwise -- ensure all imported ids are lifted
273 = if isUnboxedButNotState (idType id)
274 then Just (mkLiftedId id (getUnique us))
277 mkLiftedId :: Id -> Unique -> (Id,Id)
279 = ASSERT (isUnboxedButNotState unlifted_ty)
280 (lifted_id, unlifted_id)
282 id_name = panic "CoreLift.mkLiftedId:id_name" --LATER: getOccName id
283 lifted_id = updateIdType id lifted_ty
284 unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
286 unlifted_ty = idType id
287 lifted_ty = mkLiftTy unlifted_ty
289 bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
290 bindUnlift vlift vunlift expr
291 = ASSERT (isUnboxedButNotState unlift_ty)
292 ASSERT (lift_ty `eqTy` mkLiftTy unlift_ty)
294 (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
296 lift_ty = idType vlift
297 unlift_ty = idType vunlift
299 liftExpr :: Id -> CoreExpr -> CoreExpr
301 = ASSERT (isUnboxedButNotState unlift_ty)
302 ASSERT (rhs_ty `eqTy` unlift_ty)
303 Case rhs (PrimAlts []
304 (BindDefault vunlift (mkCon liftDataCon [] [unlift_ty] [VarArg vunlift])))
306 rhs_ty = coreExprType rhs
307 unlift_ty = idType vunlift
310 applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
311 applyBindUnlifts [] expr = expr
312 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
314 isUnboxedButNotState ty
315 = case (maybeAppDataTyConExpandingDicts ty) of
317 Just (tycon, _, _) ->
318 not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)