2 % (c) The AQUA Project, Glasgow University, 1994-1998
4 \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
7 module LiberateCase ( liberateCase ) where
9 #include "HsVersions.h"
11 import CmdLineOpts ( opt_D_verbose_core2core, opt_LiberateCaseThreshold )
12 import CoreLint ( beginPass, endPass )
14 import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..) )
22 This module walks over @Core@, and looks for @case@ on free variables.
24 if there is case on a free on the route to the recursive call,
25 then the recursive call is replaced with an unfolding.
34 => the inner f is replaced.
43 (note the NEED for shadowing)
45 => Run Andr\'e's wonder pass ...
52 Better code, because 'a' is free inside the inner letrec, rather
53 than needing projection from v.
55 Other examples we'd like to catch with this kind of transformation
61 We'd like to avoid the redundant pattern match, transforming to
65 last (x:(y:ys)) = last' y ys
68 last' _ (y:ys) = last' y ys
70 (is this necessarily an improvement)
77 drop n (x:xs) = drop (n-1) xs
79 Would like to pass n along unboxed.
82 To think about (Apr 94)
85 Main worry: duplicating code excessively. At the moment we duplicate
86 the entire binding group once at each recursive call. But there may
87 be a group of recursive calls which share a common set of evaluated
88 free variables, in which case the duplication is a plain waste.
90 Another thing we could consider adding is some unfold-threshold thing,
91 so that we'll only duplicate if the size of the group rhss isn't too
97 The ``level'' of a binder tells how many
98 recursive defns lexically enclose the binding
99 A recursive defn "encloses" its RHS, not its
102 letrec f = let g = ... in ...
107 Here, the level of @f@ is zero, the level of @g@ is one,
108 and the level of @h@ is zero (NB not one).
111 type LibCaseLevel = Int
113 topLevel :: LibCaseLevel
120 Int -- Bomb-out size for deciding if
121 -- potential liberatees are too big.
122 -- (passed in from cmd-line args)
124 LibCaseLevel -- Current level
126 (IdEnv LibCaseLevel) -- Binds all non-top-level in-scope Ids
127 -- (top-level and imported things have
130 (IdEnv CoreBind)-- Binds *only* recursively defined
131 -- Ids, to their own binding group,
132 -- and *only* in their own RHSs
134 [(Id,LibCaseLevel)] -- Each of these Ids was scrutinised by an
135 -- enclosing case expression, with the
136 -- specified number of enclosing
137 -- recursive bindings; furthermore,
138 -- the Id is bound at a lower level
139 -- than the case expression. The
140 -- order is insignificant; it's a bag
143 initEnv :: Int -> LibCaseEnv
144 initEnv bomb_size = LibCaseEnv bomb_size 0 emptyVarEnv emptyVarEnv []
146 bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
153 liberateCase :: [CoreBind] -> IO [CoreBind]
156 beginPass "Liberate case" ;
157 let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
158 endPass "Liberate case"
159 opt_D_verbose_core2core {- no specific flag for dumping -}
164 do_prog env (bind:binds) = bind' : do_prog env' binds
166 (env', bind') = libCaseBind env bind
173 libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
175 libCaseBind env (NonRec binder rhs)
176 = (addBinders env [binder], NonRec binder (libCase env rhs))
178 libCaseBind env (Rec pairs)
179 = (env_body, Rec pairs')
181 (binders, rhss) = unzip pairs
183 env_body = addBinders env binders
185 pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]
187 env_rhs = if all rhs_small_enough rhss then extended_env else env
189 -- We extend the rec-env by binding each Id to its rhs, first
190 -- processing the rhs with an *un-extended* environment, so
191 -- that the same process doesn't occur for ever!
194 = addRecBinds env [ (binder, libCase env_body rhs)
195 | (binder, rhs) <- pairs ]
197 -- Why "localiseId" above? Because we're creating a new local
198 -- copy of the original binding. In particular, the original
199 -- binding might have been for a top-level, and this copy clearly
200 -- will not be top-level!
202 -- It is enough to change just the binder, because subsequent
203 -- simplification will propagate the right info from the binder.
205 -- Why does it matter? Because the codeGen keeps a separate
206 -- environment for top-level Ids, and it is disastrous for it
207 -- to think that something is top-level when it isn't.
209 -- [May 98: all this is now handled by SimplCore.tidyCore]
212 = case (calcUnfoldingGuidance lIBERATE_BOMB_SIZE rhs) of
214 _ -> True -- we didn't BOMB, so it must be OK
216 lIBERATE_BOMB_SIZE = bombOutSize env
224 libCase :: LibCaseEnv
228 libCase env (Var v) = libCaseId env v
229 libCase env (Type ty) = Type ty
230 libCase env (App fun arg) = App (libCase env fun) (libCase env arg)
231 libCase env (Con con args) = Con con (map (libCase env) args)
232 libCase env (Note note body) = Note note (libCase env body)
234 libCase env (Lam binder body)
235 = Lam binder (libCase (addBinders env [binder]) body)
237 libCase env (Let bind body)
238 = Let bind' (libCase env_body body)
240 (env_body, bind') = libCaseBind env bind
242 libCase env (Case scrut bndr alts)
243 = Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts)
245 env_alts = addBinders env [bndr]
246 env_with_scrut = case scrut of
247 Var scrut_var -> addScrutedVar env scrut_var
250 libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
256 libCaseId :: LibCaseEnv -> Id -> CoreExpr
258 | maybeToBool maybe_rec_bind && -- It's a use of a recursive thing
259 there_are_free_scruts -- with free vars scrutinised in RHS
260 = Let the_bind (Var v)
266 maybe_rec_bind :: Maybe CoreBind -- The binding of the recursive thingy
267 maybe_rec_bind = lookupRecId env v
268 Just the_bind = maybe_rec_bind
270 rec_id_level = lookupLevel env v
272 there_are_free_scruts = freeScruts env rec_id_level
280 addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
281 addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders
282 = LibCaseEnv bomb lvl lvl_env' rec_env scruts
284 lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)
286 addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
287 addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
288 = LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
291 lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
292 rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
294 addScrutedVar :: LibCaseEnv
295 -> Id -- This Id is being scrutinised by a case expression
298 addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
300 = LibCaseEnv bomb lvl lvl_env rec_env scruts'
301 -- Add to scruts iff the scrut_var is being scrutinised at
302 -- a deeper level than its defn
306 scruts' = (scrut_var, lvl) : scruts
307 bind_lvl = case lookupVarEnv lvl_env scrut_var of
311 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
312 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
314 = lookupVarEnv rec_env id
316 = case (lookupVarEnv rec_env id) of
321 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
322 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
323 = case lookupVarEnv lvl_env id of
327 freeScruts :: LibCaseEnv
328 -> LibCaseLevel -- Level of the recursive Id
329 -> Bool -- True <=> there is an enclosing case of a variable
330 -- bound outside (ie level <=) the recursive Id.
331 freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
332 = not (null free_scruts)
334 free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]