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"
23 import CoreUtils ( coreExprType )
24 import Id ( idType, mkSysLocal,
25 nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
28 import Outputable ( isLocallyDefined, getSrcLoc )
29 import PrelInfo ( liftDataCon, mkLiftTy, statePrimTyCon )
30 import TyCon ( isBoxedTyCon, TyCon{-instance-} )
31 import Type ( maybeAppDataTyCon, eqTy )
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 (Let (NonRec binder rhs) body) -- special case: no lifting
133 = liftCoreExpr rhs `thenL` \ rhs ->
134 liftCoreExpr body `thenL` \ body ->
135 returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
137 liftCoreExpr (Let bind body) -- general case
138 = liftBindAndScope False bind (
139 liftCoreExpr body `thenL` \ body ->
140 returnL (ItsAnExpr body)
141 ) `thenL` \ (bind, ItsAnExpr body) ->
142 returnL (Let bind body)
144 liftCoreExpr (Con con args)
145 = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
146 returnL (applyBindUnlifts unlifts (Con con args))
148 liftCoreExpr (Prim op args)
149 = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
150 returnL (applyBindUnlifts unlifts (Prim op args))
152 liftCoreExpr (App fun arg)
155 lift_app (App fun arg) args
156 = lift_app fun (arg:args)
157 lift_app other_fun args
158 = liftCoreExpr other_fun `thenL` \ other_fun ->
159 mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
160 returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
162 liftCoreExpr (Lam binder expr)
163 = liftCoreExpr expr `thenL` \ expr ->
164 returnL (Lam binder expr)
166 liftCoreExpr (Case scrut alts)
167 = liftCoreExpr scrut `thenL` \ scrut ->
168 liftCoreAlts alts `thenL` \ alts ->
169 returnL (Case scrut alts)
172 liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
174 liftCoreAlts (AlgAlts alg_alts deflt)
175 = mapL liftAlgAlt alg_alts `thenL` \ alg_alts ->
176 liftDeflt deflt `thenL` \ deflt ->
177 returnL (AlgAlts alg_alts deflt)
179 liftCoreAlts (PrimAlts prim_alts deflt)
180 = mapL liftPrimAlt prim_alts `thenL` \ prim_alts ->
181 liftDeflt deflt `thenL` \ deflt ->
182 returnL (PrimAlts prim_alts deflt)
185 liftAlgAlt (con,args,rhs)
186 = liftCoreExpr rhs `thenL` \ rhs ->
187 returnL (con,args,rhs)
190 liftPrimAlt (lit,rhs)
191 = liftCoreExpr rhs `thenL` \ rhs ->
197 liftDeflt (BindDefault binder rhs)
198 = liftCoreExpr rhs `thenL` \ rhs ->
199 returnL (BindDefault binder rhs)
202 %************************************************************************
204 \subsection{Misc functions}
206 %************************************************************************
210 = IdEnv (Id, Id) -- lifted Ids are mapped to:
211 -- * lifted Id with the same Unique
212 -- (top-level bindings must keep their
213 -- unique (see TopLevId in Id.lhs))
214 -- * unlifted version with a new Unique
215 -> UniqSupply -- unique supply
219 = ItsABinds [CoreBinding]
222 initL m us = m nullIdEnv us
224 returnL :: a -> LiftM a
225 returnL r idenv us = r
227 thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
229 = case (splitUniqSupply s0) of { (s1, s2) ->
230 case (m idenv s1) of { r ->
234 mapL :: (a -> LiftM b) -> [a] -> LiftM [b]
235 mapL f [] = returnL []
238 mapL f xs `thenL` \ rs ->
241 mapAndUnzipL :: (a -> LiftM (b1, b2)) -> [a] -> LiftM ([b1],[b2])
242 mapAndUnzipL f [] = returnL ([],[])
243 mapAndUnzipL f (x:xs)
244 = f x `thenL` \ (r1, r2) ->
245 mapAndUnzipL f xs `thenL` \ (rs1,rs2) ->
246 returnL ((r1:rs1),(r2:rs2))
248 -- liftBinders is only called for top-level or recusive case
249 liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing
251 liftBinders False (NonRec _ _) liftM idenv s0
252 = panic "CoreLift:liftBinders" -- should be caught by special case above
254 liftBinders top_lev bind liftM idenv s0
255 = liftM (growIdEnvList idenv lift_map) s2
257 (s1, s2) = splitUniqSupply s0
258 lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
259 lift_uniqs = getUniques (length lift_ids) s1
260 lift_map = zipEqual lift_ids (zipWithEqual mkLiftedId lift_ids lift_uniqs)
262 -- ToDo: Give warning for recursive bindings involving unboxed values ???
264 isLiftedId :: Id -> LiftM (Maybe (Id, Id))
265 isLiftedId id idenv us
266 | isLocallyDefined id
267 = lookupIdEnv idenv id
268 | otherwise -- ensure all imported ids are lifted
269 = if isUnboxedButNotState (idType id)
270 then Just (mkLiftedId id (getUnique us))
273 mkLiftedId :: Id -> Unique -> (Id,Id)
275 = ASSERT (isUnboxedButNotState unlifted_ty)
276 (lifted_id, unlifted_id)
278 id_name = panic "CoreLift.mkLiftedId:id_name" --LATER: getOccName id
279 lifted_id = updateIdType id lifted_ty
280 unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
282 unlifted_ty = idType id
283 lifted_ty = mkLiftTy unlifted_ty
285 bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
286 bindUnlift vlift vunlift expr
287 = ASSERT (isUnboxedButNotState unlift_ty)
288 ASSERT (lift_ty `eqTy` mkLiftTy unlift_ty)
290 (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
292 lift_ty = idType vlift
293 unlift_ty = idType vunlift
295 liftExpr :: Id -> CoreExpr -> CoreExpr
297 = ASSERT (isUnboxedButNotState unlift_ty)
298 ASSERT (rhs_ty `eqTy` unlift_ty)
299 Case rhs (PrimAlts []
300 (BindDefault vunlift (mkCon liftDataCon [] [unlift_ty] [VarArg vunlift])))
302 rhs_ty = coreExprType rhs
303 unlift_ty = idType vunlift
306 applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
307 applyBindUnlifts [] expr = expr
308 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
310 isUnboxedButNotState ty
311 = case (maybeAppDataTyCon ty) of
313 Just (tycon, _, _) ->
314 not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)