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),
25 GenId{-instances-}, SYN_IE(Id)
27 import Name ( isLocallyDefined, getSrcLoc, getOccString )
28 import TyCon ( isBoxedTyCon, TyCon{-instance-} )
29 import Type ( maybeAppDataTyConExpandingDicts, eqTy )
30 import TysPrim ( statePrimTyCon )
31 import TysWiredIn ( liftDataCon, mkLiftTy )
32 import Unique ( Unique )
33 import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
34 import Util ( zipEqual, zipWithEqual, assertPanic, panic )
38 updateIdType = panic "CoreLift.updateIdType"
41 %************************************************************************
43 \subsection{``lift'' for various constructs}
45 %************************************************************************
47 @liftCoreBindings@ is the top-level interface function.
50 liftCoreBindings :: UniqSupply -- unique supply
51 -> [CoreBinding] -- unlifted bindings
52 -> [CoreBinding] -- lifted bindings
54 liftCoreBindings us binds
55 = initL (lift_top_binds binds) us
57 lift_top_binds [] = returnL []
60 = liftBindAndScope True b (
61 lift_top_binds bs `thenL` \ bs ->
62 returnL (ItsABinds bs)
63 ) `thenL` \ (b, ItsABinds bs) ->
67 -----------------------
68 liftBindAndScope :: Bool -- top level ?
69 -> CoreBinding -- As yet unprocessed
70 -> LiftM BindsOrExpr -- Do the scope of the bindings
71 -> LiftM (CoreBinding, -- Processed
74 liftBindAndScope top_lev bind scopeM
75 = liftBinders top_lev bind (
76 liftCoreBind bind `thenL` \ bind ->
77 scopeM `thenL` \ bindsorexpr ->
78 returnL (bind, bindsorexpr)
81 -----------------------
82 liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr)
84 liftCoreArg arg@(TyArg _) = returnL (arg, id)
85 liftCoreArg arg@(UsageArg _) = returnL (arg, id)
86 liftCoreArg arg@(LitArg _) = returnL (arg, id)
87 liftCoreArg arg@(VarArg v)
88 = isLiftedId v `thenL` \ lifted ->
90 Nothing -> returnL (arg, id)
92 Just (lifted, unlifted) ->
93 returnL (VarArg unlifted, bindUnlift lifted unlifted)
96 -----------------------
97 liftCoreBind :: CoreBinding -> LiftM CoreBinding
99 liftCoreBind (NonRec b rhs)
100 = liftOneBind (b,rhs) `thenL` \ (b,rhs) ->
101 returnL (NonRec b rhs)
103 liftCoreBind (Rec pairs)
104 = mapL liftOneBind pairs `thenL` \ pairs ->
107 -----------------------
108 liftOneBind (binder,rhs)
109 = liftCoreExpr rhs `thenL` \ rhs ->
110 isLiftedId binder `thenL` \ lifted ->
112 Just (lifted, unlifted) ->
113 returnL (lifted, liftExpr unlifted rhs)
115 returnL (binder, rhs)
117 -----------------------
118 liftCoreExpr :: CoreExpr -> LiftM CoreExpr
120 liftCoreExpr expr@(Var var)
121 = isLiftedId var `thenL` \ lifted ->
123 Nothing -> returnL expr
124 Just (lifted, unlifted) ->
125 returnL (bindUnlift lifted unlifted (Var unlifted))
127 liftCoreExpr expr@(Lit lit) = returnL expr
129 liftCoreExpr (SCC label expr)
130 = liftCoreExpr expr `thenL` \ expr ->
131 returnL (SCC label expr)
133 liftCoreExpr (Coerce coerce ty expr)
134 = liftCoreExpr expr `thenL` \ expr ->
135 returnL (Coerce coerce ty expr) -- ToDo:right?:Coerce
137 liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
138 = liftCoreExpr rhs `thenL` \ rhs ->
139 liftCoreExpr body `thenL` \ body ->
140 returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
142 liftCoreExpr (Let bind body) -- general case
143 = liftBindAndScope False bind (
144 liftCoreExpr body `thenL` \ body ->
145 returnL (ItsAnExpr body)
146 ) `thenL` \ (bind, ItsAnExpr body) ->
147 returnL (Let bind body)
149 liftCoreExpr (Con con args)
150 = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
151 returnL (applyBindUnlifts unlifts (Con con args))
153 liftCoreExpr (Prim op args)
154 = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
155 returnL (applyBindUnlifts unlifts (Prim op args))
157 liftCoreExpr (App fun arg)
160 lift_app (App fun arg) args
161 = lift_app fun (arg:args)
162 lift_app other_fun args
163 = liftCoreExpr other_fun `thenL` \ other_fun ->
164 mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
165 returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
167 liftCoreExpr (Lam binder expr)
168 = liftCoreExpr expr `thenL` \ expr ->
169 returnL (Lam binder expr)
171 liftCoreExpr (Case scrut alts)
172 = liftCoreExpr scrut `thenL` \ scrut ->
173 liftCoreAlts alts `thenL` \ alts ->
174 returnL (Case scrut alts)
177 liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
179 liftCoreAlts (AlgAlts alg_alts deflt)
180 = mapL liftAlgAlt alg_alts `thenL` \ alg_alts ->
181 liftDeflt deflt `thenL` \ deflt ->
182 returnL (AlgAlts alg_alts deflt)
184 liftCoreAlts (PrimAlts prim_alts deflt)
185 = mapL liftPrimAlt prim_alts `thenL` \ prim_alts ->
186 liftDeflt deflt `thenL` \ deflt ->
187 returnL (PrimAlts prim_alts deflt)
190 liftAlgAlt (con,args,rhs)
191 = liftCoreExpr rhs `thenL` \ rhs ->
192 returnL (con,args,rhs)
195 liftPrimAlt (lit,rhs)
196 = liftCoreExpr rhs `thenL` \ rhs ->
202 liftDeflt (BindDefault binder rhs)
203 = liftCoreExpr rhs `thenL` \ rhs ->
204 returnL (BindDefault binder rhs)
207 %************************************************************************
209 \subsection{Misc functions}
211 %************************************************************************
215 = IdEnv (Id, Id) -- lifted Ids are mapped to:
216 -- * lifted Id with the same Unique
217 -- (top-level bindings must keep their unique
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 = _PK_ (getOccString id) -- yuk!
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)