2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
6 96/03: We aren't using this at the moment
9 #include "HsVersions.h"
11 module LiberateCase ( liberateCase ) where
16 liberateCase = panic "LiberateCase.liberateCase: ToDo"
18 {- LATER: to end of file:
19 import CoreUnfold ( UnfoldingGuidance(..) )
20 import Id ( localiseId, toplevelishId{-debugging-} )
27 This module walks over @Core@, and looks for @case@ on free variables.
29 if there is case on a free on the route to the recursive call,
30 then the recursive call is replaced with an unfolding.
39 => the inner f is replaced.
48 (note the NEED for shadowing)
50 => Run Andr\'e's wonder pass ...
57 Better code, because 'a' is free inside the inner letrec, rather
58 than needing projection from v.
61 To think about (Apr 94)
64 Main worry: duplicating code excessively. At the moment we duplicate
65 the entire binding group once at each recursive call. But there may
66 be a group of recursive calls which share a common set of evaluated
67 free variables, in which case the duplication is a plain waste.
69 Another thing we could consider adding is some unfold-threshold thing,
70 so that we'll only duplicate if the size of the group rhss isn't too
76 The ``level'' of a binder tells how many
77 recursive defns lexically enclose the binding
78 A recursive defn "encloses" its RHS, not its
81 letrec f = let g = ... in ...
86 Here, the level of @f@ is zero, the level of @g@ is one,
87 and the level of @h@ is zero (NB not one).
90 type LibCaseLevel = Int
92 topLevel :: LibCaseLevel
99 Int -- Bomb-out size for deciding if
100 -- potential liberatees are too big.
101 -- (passed in from cmd-line args)
103 LibCaseLevel -- Current level
105 (IdEnv LibCaseLevel) -- Binds all non-top-level in-scope Ids
106 -- (top-level and imported things have
109 (IdEnv CoreBinding)-- Binds *only* recursively defined
110 -- Ids, to their own binding group,
111 -- and *only* in their own RHSs
113 [(Id,LibCaseLevel)] -- Each of these Ids was scrutinised by an
114 -- enclosing case expression, with the
115 -- specified number of enclosing
116 -- recursive bindings; furthermore,
117 -- the Id is bound at a lower level
118 -- than the case expression. The
119 -- order is insignificant; it's a bag
122 initEnv :: Int -> LibCaseEnv
123 initEnv bomb_size = LibCaseEnv bomb_size 0 nullIdEnv nullIdEnv []
125 bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
132 liberateCase :: Int -> [CoreBinding] -> [CoreBinding]
133 liberateCase bomb_size prog
134 = do_prog (initEnv bomb_size) prog
137 do_prog env (bind:binds) = bind' : do_prog env' binds
139 (env', bind') = libCaseBind env bind
146 libCaseBind :: LibCaseEnv -> CoreBinding -> (LibCaseEnv, CoreBinding)
148 libCaseBind env (NonRec binder rhs)
149 = (addBinders env [binder], NonRec binder (libCase env rhs))
151 libCaseBind env (Rec pairs)
152 = (env_body, Rec pairs')
154 (binders, rhss) = unzip pairs
156 env_body = addBinders env binders
158 pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]
160 env_rhs = if all rhs_small_enough rhss then extended_env else env
162 -- We extend the rec-env by binding each Id to its rhs, first
163 -- processing the rhs with an *un-extended* environment, so
164 -- that the same process doesn't occur for ever!
167 = addRecBinds env [ (localiseId binder, libCase env_body rhs)
168 | (binder, rhs) <- pairs ]
170 -- Why "localiseId" above? Because we're creating a new local
171 -- copy of the original binding. In particular, the original
172 -- binding might have been for a TopLevId, and this copy clearly
173 -- will not be top-level!
175 -- It is enough to change just the binder, because subsequent
176 -- simplification will propagate the right info from the binder.
178 -- Why does it matter? Because the codeGen keeps a separate
179 -- environment for top-level Ids, and it is disastrous for it
180 -- to think that something is top-level when it isn't.
183 = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE cON_DISCOUNT rhs) of
185 _ -> True -- we didn't BOMB, so it must be OK
187 lIBERATE_BOMB_SIZE = bombOutSize env
188 cON_DISCOUNT = error "libCaseBind"
196 libCase :: LibCaseEnv
200 libCase env (Lit lit) = Lit lit
201 libCase env (Var v) = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
202 libCase env (App fun arg) = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
203 libCase env (CoTyApp fun ty) = CoTyApp (libCase env fun) ty
204 libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
205 libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
206 libCase env (CoTyLam tv body) = CoTyLam tv (libCase env body)
207 libCase env (SCC cc body) = SCC cc (libCase env body)
208 libCase env (Coerce c ty body) = Coerce c ty (libCase env body)
210 libCase env (Lam binder body)
211 = Lam binder (libCase (addBinders env [binder]) body)
213 libCase env (Let bind body)
214 = Let bind' (libCase env_body body)
216 (env_body, bind') = libCaseBind env bind
218 libCase env (Case scrut alts)
219 = Case (libCase env scrut) (libCaseAlts env_alts alts)
221 env_alts = case scrut of
222 Var scrut_var -> addScrutedVar env scrut_var
231 libCaseAlts env (AlgAlts alts deflt)
232 = AlgAlts (map do_alt alts) (libCaseDeflt env deflt)
234 do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
236 libCaseAlts env (PrimAlts alts deflt)
237 = PrimAlts (map do_alt alts) (libCaseDeflt env deflt)
239 do_alt (lit,rhs) = (lit, libCase env rhs)
241 libCaseDeflt env NoDefault
243 libCaseDeflt env (BindDefault binder rhs)
244 = BindDefault binder (libCase (addBinders env [binder]) rhs)
250 libCaseAtoms :: LibCaseEnv -> [CoreArg] -> [CoreBinding]
251 libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms]
253 libCaseAtom :: LibCaseEnv -> CoreArg -> [CoreBinding]
254 libCaseAtom env (VarArg arg_id) = libCaseId env arg_id
255 libCaseAtom env (LitArg lit) = []
257 libCaseId :: LibCaseEnv -> Id -> [CoreBinding]
259 | maybeToBool maybe_rec_bind && -- It's a use of a recursive thing
260 there_are_free_scruts -- with free vars scrutinised in RHS
267 maybe_rec_bind :: Maybe CoreBinding -- The binding of the recursive thingy
268 maybe_rec_bind = lookupRecId env v
269 Just the_bind = maybe_rec_bind
271 rec_id_level = lookupLevel env v
273 there_are_free_scruts = freeScruts env rec_id_level
281 addBinders :: LibCaseEnv -> [Id] -> LibCaseEnv
282 addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders
283 = LibCaseEnv bomb lvl lvl_env' rec_env scruts
285 lvl_env' = growIdEnvList lvl_env (binders `zip` repeat lvl)
287 addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
288 addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
289 = LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
292 lvl_env' = growIdEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
293 rec_env' = growIdEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
295 addScrutedVar :: LibCaseEnv
296 -> Id -- This Id is being scrutinised by a case expression
299 addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
301 = LibCaseEnv bomb lvl lvl_env rec_env scruts'
302 -- Add to scruts iff the scrut_var is being scrutinised at
303 -- a deeper level than its defn
307 scruts' = (scrut_var, lvl) : scruts
308 bind_lvl = case lookupIdEnv lvl_env scrut_var of
310 Nothing -> --false: ASSERT(toplevelishId scrut_var)
313 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
314 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
316 = lookupIdEnv rec_env id
318 = case (lookupIdEnv rec_env id) of
320 xxx -> --false: ASSERT(toplevelishId id)
324 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
325 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
326 = case lookupIdEnv lvl_env id of
328 Nothing -> ASSERT(toplevelishId id)
331 freeScruts :: LibCaseEnv
332 -> LibCaseLevel -- Level of the recursive Id
333 -> Bool -- True <=> there is an enclosing case of a variable
334 -- bound outside (ie level <=) the recursive Id.
335 freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
336 = not (null free_scruts)
338 free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]