[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / coreSyn / CoreLift.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
3 %
4 \section[CoreLift]{Lifts unboxed bindings and any references to them}
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module CoreLift (
10         liftCoreBindings,
11
12         mkLiftedId,
13         liftExpr,
14         bindUnlift,
15         applyBindUnlifts,
16         
17         CoreBinding, PlainCoreBinding(..),
18         CoreExpr, PlainCoreExpr(..),
19         Id, SplitUniqSupply, Unique
20     ) where
21
22 IMPORT_Trace
23
24 import AbsPrel          ( liftDataCon, mkLiftTy )
25 import TysPrim          ( statePrimTyCon ) -- ToDo: get from AbsPrel
26 import AbsUniType
27 import Id               ( getIdUniType, updateIdType, mkSysLocal, isLocallyDefined )
28 import IdEnv
29 import Outputable
30 import PlainCore
31 import SplitUniq
32 import Util
33
34 infixr 9 `thenL`
35
36 \end{code}
37
38 %************************************************************************
39 %*                                                                      *
40 \subsection{``lift'' for various constructs}
41 %*                                                                      *
42 %************************************************************************
43
44 @liftCoreBindings@ is the top-level interface function.
45
46 \begin{code}
47 liftCoreBindings :: SplitUniqSupply     -- unique supply
48                  -> [PlainCoreBinding]  -- unlifted bindings
49                  -> [PlainCoreBinding]  -- lifted bindings
50
51 liftCoreBindings us binds
52   = initL (lift_top_binds binds) us
53   where
54     lift_top_binds (b:bs)
55       = liftBindAndScope True (is_rec b) b (
56           lift_top_binds bs `thenL` \ bs ->
57           returnL (ItsABinds bs)
58         )                       `thenL` \ (b, ItsABinds bs) ->
59         returnL (b:bs)
60
61     lift_top_binds []
62       = returnL []
63     
64 is_rec (CoNonRec _ _) = False
65 is_rec _              = True
66
67 liftBindAndScope :: Bool                -- True <=> a top level group
68         -> Bool                         -- True <=> a recursive group
69         -> PlainCoreBinding             -- As yet unprocessed
70         -> LiftM BindsOrExpr            -- Do the scope of the bindings
71         -> LiftM (PlainCoreBinding,     -- Processed
72                   BindsOrExpr)
73
74 liftBindAndScope toplev is_rec bind scopeM
75   = liftBinders toplev is_rec binders (
76       liftCoreBind bind `thenL` \ bind ->
77       scopeM            `thenL` \ bindsorexpr ->
78       returnL (bind, bindsorexpr)
79     )
80   where
81     binders = bindersOf bind
82
83 liftCoreAtom :: PlainCoreAtom -> LiftM (PlainCoreAtom, PlainCoreExpr -> PlainCoreExpr)
84
85 liftCoreAtom (CoLitAtom lit)
86  = returnL (CoLitAtom lit, id)
87
88 liftCoreAtom (CoVarAtom v)
89  = isLiftedId v                 `thenL` \ lifted ->
90     case lifted of
91         Just (lifted, unlifted) ->
92             returnL (CoVarAtom unlifted, bindUnlift lifted unlifted)
93         Nothing ->
94             returnL (CoVarAtom v, id)
95
96
97 liftCoreBind :: PlainCoreBinding -> LiftM PlainCoreBinding
98
99 liftCoreBind (CoNonRec b rhs)
100   = liftOneBind (b,rhs)         `thenL` \ (b,rhs) ->
101     returnL (CoNonRec b rhs)
102
103 liftCoreBind (CoRec pairs) 
104   = mapL liftOneBind pairs      `thenL` \ pairs -> 
105     returnL (CoRec pairs)
106
107 liftOneBind (binder,rhs)
108   = liftCoreExpr rhs            `thenL` \ rhs ->
109     isLiftedId binder           `thenL` \ lifted ->
110     case lifted of
111         Just (lifted, unlifted) ->
112             returnL (lifted, liftExpr unlifted rhs)
113         Nothing ->
114             returnL (binder, rhs)
115
116 liftCoreExpr :: PlainCoreExpr -> LiftM PlainCoreExpr
117
118 liftCoreExpr (CoVar var)
119   = isLiftedId var              `thenL` \ lifted ->
120     case lifted of
121         Just (lifted, unlifted) ->
122             returnL (bindUnlift lifted unlifted (CoVar unlifted))
123         Nothing ->
124             returnL (CoVar var)
125
126 liftCoreExpr (CoLit lit)
127   = returnL (CoLit lit)
128
129 liftCoreExpr (CoSCC label expr)
130   = liftCoreExpr expr           `thenL` \ expr ->
131     returnL (CoSCC label expr)
132
133 liftCoreExpr (CoLet (CoNonRec binder rhs) body) -- special case: for speed
134   = liftCoreExpr rhs    `thenL` \ rhs2 ->
135     liftCoreExpr body   `thenL` \ body2 ->
136     returnL (mkCoLetUnboxedToCase (CoNonRec binder rhs2) body2)
137
138 liftCoreExpr (CoLet bind body)  -- general case
139   = liftBindAndScope False{-not top-level-} (is_rec bind) bind (
140       liftCoreExpr body `thenL` \ body ->
141       returnL (ItsAnExpr body)
142     )                           `thenL` \ (bind, ItsAnExpr body) ->
143     returnL (CoLet bind body)
144
145 liftCoreExpr (CoCon con tys args)
146   = mapAndUnzipL liftCoreAtom args      `thenL` \ (args, unlifts) ->
147     returnL (applyBindUnlifts unlifts (CoCon con tys args))
148
149 liftCoreExpr (CoPrim op tys args)
150   = mapAndUnzipL liftCoreAtom args      `thenL` \ (args, unlifts) ->
151     returnL (applyBindUnlifts unlifts (CoPrim op tys args))
152
153 liftCoreExpr (CoApp fun arg)
154   = lift_app fun [arg]
155   where
156     lift_app (CoApp fun arg) args
157       = lift_app fun (arg:args)
158     lift_app other_fun args
159       = liftCoreExpr other_fun          `thenL` \ other_fun ->
160         mapAndUnzipL liftCoreAtom args  `thenL` \ (args, unlifts) ->
161         returnL (applyBindUnlifts unlifts (foldl CoApp other_fun args))
162
163 liftCoreExpr (CoTyApp fun ty_arg)
164   = liftCoreExpr fun            `thenL` \ fun ->
165     returnL (CoTyApp fun ty_arg)
166
167 liftCoreExpr (CoLam binders expr)
168   = liftCoreExpr expr           `thenL` \ expr ->
169     returnL (CoLam binders expr)
170
171 liftCoreExpr (CoTyLam tyvar expr)
172   = liftCoreExpr expr           `thenL` \ expr ->
173     returnL (CoTyLam tyvar expr)
174
175 liftCoreExpr (CoCase scrut alts)
176  = liftCoreExpr scrut           `thenL` \ scrut ->
177    liftCoreAlts alts            `thenL` \ alts ->
178    returnL (CoCase scrut alts)
179
180
181 liftCoreAlts :: PlainCoreCaseAlternatives -> LiftM PlainCoreCaseAlternatives
182
183 liftCoreAlts (CoAlgAlts alg_alts deflt)
184  = mapL liftAlgAlt alg_alts     `thenL` \ alg_alts ->
185    liftDeflt deflt              `thenL` \ deflt ->
186    returnL (CoAlgAlts alg_alts deflt)
187
188 liftCoreAlts (CoPrimAlts prim_alts deflt)
189  = mapL liftPrimAlt prim_alts   `thenL` \ prim_alts ->
190    liftDeflt deflt              `thenL` \ deflt ->
191    returnL (CoPrimAlts prim_alts deflt)
192
193
194 liftAlgAlt (con,args,rhs)
195   = liftCoreExpr rhs            `thenL` \ rhs ->
196     returnL (con,args,rhs)
197
198 liftPrimAlt (lit,rhs)
199   = liftCoreExpr rhs            `thenL` \ rhs ->
200     returnL (lit,rhs)
201    
202 liftDeflt CoNoDefault
203   = returnL CoNoDefault
204 liftDeflt (CoBindDefault binder rhs)
205   = liftCoreExpr rhs            `thenL` \ rhs ->
206     returnL (CoBindDefault binder rhs)
207
208 \end{code}
209
210 %************************************************************************
211 %*                                                                      *
212 \subsection{Misc functions}
213 %*                                                                      *
214 %************************************************************************
215
216 \begin{code}
217 type LiftM a = IdEnv (Id, Id)   -- lifted Ids are mapped to:
218                                 --   * lifted Id with the same Unique
219                                 --     (top-level bindings must keep their
220                                 --      unique (see TopLevId in Id.lhs))
221                                 --   * unlifted version with a new Unique
222             -> SplitUniqSupply  -- unique supply
223             -> a                -- result
224
225 data BindsOrExpr = ItsABinds [PlainCoreBinding]
226                  | ItsAnExpr PlainCoreExpr
227
228 initL m us
229   = m nullIdEnv us
230
231 returnL :: a -> LiftM a
232 returnL r idenv us
233   = r
234
235 thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
236 thenL m k idenv s0
237   = case splitUniqSupply s0        of { (s1, s2) ->
238     case (m idenv s1) of { r ->
239     k r idenv s2 }}
240
241
242 mapL :: (a -> LiftM b) -> [a] -> LiftM [b]
243 mapL f [] = returnL []
244 mapL f (x:xs)
245   = f x                 `thenL` \ r ->
246     mapL f xs           `thenL` \ rs ->
247     returnL (r:rs)
248
249 mapAndUnzipL  :: (a -> LiftM (b1, b2))  -> [a] -> LiftM ([b1],[b2])
250 mapAndUnzipL f [] = returnL ([],[])
251 mapAndUnzipL f (x:xs)
252   = f x                 `thenL` \ (r1, r2) ->
253     mapAndUnzipL f xs   `thenL` \ (rs1,rs2) ->
254     returnL ((r1:rs1),(r2:rs2))
255
256
257 liftBinders :: Bool -> Bool -> [Id] -> LiftM thing -> LiftM thing
258 liftBinders toplev is_rec ids liftM idenv s0
259
260 --ToDo  | toplev || is_rec -- *must* play the lifting game
261   = liftM (growIdEnvList idenv lift_map) s1
262   where
263     lift_ids = [ id | id <- ids, is_unboxed_but_not_state (getIdUniType id) ]
264     (lift_uniqs, s1) = getSUniquesAndDepleted (length lift_ids) s0
265     lift_map = zip lift_ids (zipWith mkLiftedId lift_ids lift_uniqs)
266
267 isLiftedId :: Id -> LiftM (Maybe (Id, Id))
268 isLiftedId id idenv us
269   | isLocallyDefined id 
270      = lookupIdEnv idenv id
271   | otherwise   -- ensure all imported ids are lifted
272      = if is_unboxed_but_not_state (getIdUniType id)
273        then Just (mkLiftedId id (getSUnique us))
274        else Nothing
275
276 mkLiftedId :: Id -> Unique -> (Id,Id)
277 mkLiftedId id u
278   = ASSERT (is_unboxed_but_not_state unlifted_ty)
279     (lifted_id, unlifted_id)
280   where
281     id_name     = getOccurrenceName id
282     lifted_id   = updateIdType id lifted_ty
283     unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
284
285     unlifted_ty = getIdUniType id
286     lifted_ty   = mkLiftTy unlifted_ty
287
288 bindUnlift :: Id -> Id -> PlainCoreExpr -> PlainCoreExpr
289 bindUnlift vlift vunlift expr
290   = ASSERT (is_unboxed_but_not_state unlift_ty && lift_ty == mkLiftTy unlift_ty)
291     CoCase (CoVar vlift)
292            (CoAlgAlts [(liftDataCon, [vunlift], expr)] CoNoDefault)
293   where
294     lift_ty   = getIdUniType vlift
295     unlift_ty = getIdUniType vunlift
296
297 liftExpr :: Id -> PlainCoreExpr -> PlainCoreExpr
298 liftExpr vunlift rhs
299   = ASSERT (is_unboxed_but_not_state unlift_ty && rhs_ty == unlift_ty)
300     CoCase rhs (CoPrimAlts [] (CoBindDefault vunlift 
301                               (CoCon liftDataCon [unlift_ty] [CoVarAtom vunlift])))
302   where
303     rhs_ty    = typeOfCoreExpr rhs
304     unlift_ty = getIdUniType vunlift
305
306
307 applyBindUnlifts :: [PlainCoreExpr -> PlainCoreExpr] -> PlainCoreExpr -> PlainCoreExpr
308 applyBindUnlifts []     expr = expr
309 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
310
311 is_unboxed_but_not_state ty
312   = case (getUniDataTyCon_maybe ty) of
313       Nothing -> False
314       Just (tycon, _, _) ->
315         not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)
316 \end{code}