LiberateCase.lhs 12.5 KB
 partain committed Jan 08, 1996 1 %  simonm committed Dec 02, 1998 2 % (c) The AQUA Project, Glasgow University, 1994-1998  partain committed Jan 08, 1996 3 4 5 6 % \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} \begin{code}  Ian Lynagh committed Nov 04, 2011 7 8 9 10 11 12 13 {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details  partain committed Jan 08, 1996 14 15 module LiberateCase ( liberateCase ) where  simonm committed Jan 08, 1998 16 17 #include "HsVersions.h"  simonpj@microsoft.com committed Jan 11, 2007 18 import DynFlags  simonm committed Dec 02, 1998 19 import CoreSyn  simonpj committed Mar 23, 2000 20 import CoreUnfold ( couldBeSmallEnoughToInline )  simonpj@microsoft.com committed Jan 11, 2007 21 import Id  simonm committed Dec 02, 1998 22 import VarEnv  sof committed Apr 05, 2002 23 import Util ( notNull )  partain committed Jan 08, 1996 24 25 \end{code}  simonpj@microsoft.com committed Jan 11, 2007 26 27 The liberate-case transformation ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  partain committed Jan 08, 1996 28 29 30 31 32 33 34 This module walks over @Core@, and looks for @case@ on free variables. The criterion is: if there is case on a free on the route to the recursive call, then the recursive call is replaced with an unfolding. Example  simonpj@microsoft.com committed Jan 11, 2007 35 36  f = \ t -> case v of V a b -> a : f t  partain committed Jan 08, 1996 37 38 39  => the inner f is replaced.  simonpj@microsoft.com committed Jan 11, 2007 40 41  f = \ t -> case v of V a b -> a : (letrec  partain committed Jan 08, 1996 42  f = \ t -> case v of  partain committed Mar 19, 1996 43  V a b -> a : f t  simonpj@microsoft.com committed Jan 11, 2007 44  in f) t  partain committed Jan 08, 1996 45 46 (note the NEED for shadowing)  simonpj committed Dec 08, 2000 47 48 => Simplify  simonpj@microsoft.com committed Jan 11, 2007 49 50  f = \ t -> case v of V a b -> a : (letrec  partain committed Mar 19, 1996 51  f = \ t -> a : f t  simonpj@microsoft.com committed Jan 11, 2007 52  in f t)  simonpj committed Dec 08, 2000 53   partain committed Jan 08, 1996 54 55 56 Better code, because 'a' is free inside the inner letrec, rather than needing projection from v.  simonpj@microsoft.com committed Oct 29, 2007 57 58 Note that this deals with *free variables*. SpecConstr deals with *arguments* that are of known form. E.g.  simonm committed Dec 02, 1998 59 60 61 62 63 64  last [] = error last (x:[]) = x last (x:xs) = last xs  simonpj@microsoft.com committed Oct 04, 2006 65 66 67 68 69 70 Note [Scrutinee with cast] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this: f = \ t -> case (v cast co) of V a b -> a : f t  simonpj@microsoft.com committed Jan 31, 2007 71 Exactly the same optimisation (unrolling one call to f) will work here,  simonpj@microsoft.com committed Oct 04, 2006 72 73 despite the cast. See mk_alt_env in the Case branch of libCase.  partain committed Jan 08, 1996 74   simonpj@microsoft.com committed Jun 20, 2007 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 Note [Only functions!] ~~~~~~~~~~~~~~~~~~~~~~ Consider the following code f = g (case v of V a b -> a : t f) where g is expensive. If we aren't careful, liberate case will turn this into f = g (case v of V a b -> a : t (letrec f = g (case v of V a b -> a : f t) in f) ) Yikes! We evaluate g twice. This leads to a O(2^n) explosion if g calls back to the same code recursively. Solution: make sure that we only do the liberate-case thing on *functions*  partain committed Jan 08, 1996 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 To think about (Apr 94) ~~~~~~~~~~~~~~ Main worry: duplicating code excessively. At the moment we duplicate the entire binding group once at each recursive call. But there may be a group of recursive calls which share a common set of evaluated free variables, in which case the duplication is a plain waste. Another thing we could consider adding is some unfold-threshold thing, so that we'll only duplicate if the size of the group rhss isn't too big. Data types ~~~~~~~~~~ The level'' of a binder tells how many recursive defns lexically enclose the binding A recursive defn "encloses" its RHS, not its scope. For example: \begin{verbatim} letrec f = let g = ... in ... in let h = ... in ... \end{verbatim}  partain committed Mar 19, 1996 116 Here, the level of @f@ is zero, the level of @g@ is one,  partain committed Jan 08, 1996 117 118 and the level of @h@ is zero (NB not one).  simonpj@microsoft.com committed Jan 11, 2007 119 120 121 122 123 124  %************************************************************************ %* * Top-level code %* * %************************************************************************  partain committed Jan 08, 1996 125 126  \begin{code}  Simon Peyton Jones committed Sep 23, 2011 127 liberateCase :: DynFlags -> CoreProgram -> CoreProgram  simonpj@microsoft.com committed Oct 30, 2008 128 liberateCase dflags binds = do_prog (initEnv dflags) binds  partain committed Jan 08, 1996 129  where  Ian Lynagh committed May 04, 2008 130  do_prog _ [] = []  partain committed Jan 08, 1996 131 132 133 134 135  do_prog env (bind:binds) = bind' : do_prog env' binds where (env', bind') = libCaseBind env bind \end{code}  simonpj@microsoft.com committed Jan 11, 2007 136 137 138 139 140 141 142  %************************************************************************ %* * Main payload %* * %************************************************************************  partain committed Jan 08, 1996 143 144 145 Bindings ~~~~~~~~ \begin{code}  simonm committed Dec 02, 1998 146 libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)  partain committed Jan 08, 1996 147   partain committed Mar 19, 1996 148 149 libCaseBind env (NonRec binder rhs) = (addBinders env [binder], NonRec binder (libCase env rhs))  partain committed Jan 08, 1996 150   partain committed Mar 19, 1996 151 152 libCaseBind env (Rec pairs) = (env_body, Rec pairs')  partain committed Jan 08, 1996 153  where  simonpj@microsoft.com committed Feb 04, 2009 154  binders = map fst pairs  partain committed Jan 08, 1996 155 156 157 158 159 160 161 162  env_body = addBinders env binders pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] -- We extend the rec-env by binding each Id to its rhs, first -- processing the rhs with an *un-extended* environment, so -- that the same process doesn't occur for ever!  simonpj@microsoft.com committed Feb 04, 2009 163 164 165 166 167 168 169  env_rhs = addRecBinds env [ (localiseId binder, libCase env_body rhs) | (binder, rhs) <- pairs , rhs_small_enough binder rhs ] -- localiseID : see Note [Need to localiseId in libCaseBind] rhs_small_enough id rhs -- Note [Small enough]  simonpj@microsoft.com committed Jun 20, 2007 170  = idArity id > 0 -- Note [Only functions!]  ian@well-typed.com committed Oct 09, 2012 171  && maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs)  rl@cse.unsw.edu.au committed Dec 14, 2007 172  (bombOutSize env)  partain committed Jan 08, 1996 173 174 \end{code}  simonpj@microsoft.com committed Feb 04, 2009 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 Note [Need to localiseId in libCaseBind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The call to localiseId is needed for two subtle reasons (a) Reset the export flags on the binders so that we don't get name clashes on exported things if the local binding floats out to top level. This is most unlikely to happen, since the whole point concerns free variables. But resetting the export flag is right regardless. (b) Make the name an Internal one. External Names should never be nested; if it were floated to the top level, we'd get a name clash at code generation time. Note [Small enough] ~~~~~~~~~~~~~~~~~~~ Consider \fv. letrec f = \x. BIG...(case fv of { (a,b) -> ...g.. })... g = \y. SMALL...f... Then we *can* do liberate-case on g (small RHS) but not for f (too big). But we can choose on a item-by-item basis, and that's what the rhs_small_enough call in the comprehension for env_rhs does.  partain committed Jan 08, 1996 197 198 199 200 201 202  Expressions ~~~~~~~~~~~ \begin{code} libCase :: LibCaseEnv  partain committed Mar 19, 1996 203 204  -> CoreExpr -> CoreExpr  partain committed Jan 08, 1996 205   Ian Lynagh committed May 04, 2008 206 207 208 libCase env (Var v) = libCaseId env v libCase _ (Lit lit) = Lit lit libCase _ (Type ty) = Type ty  209 libCase _ (Coercion co) = Coercion co  simonm committed Dec 02, 1998 210 libCase env (App fun arg) = App (libCase env fun) (libCase env arg)  Simon Marlow committed Nov 02, 2011 211 libCase env (Tick tickish body) = Tick tickish (libCase env body)  kevind@bu.edu committed Aug 01, 2006 212 libCase env (Cast e co) = Cast (libCase env e) co  partain committed Jan 08, 1996 213   partain committed Mar 19, 1996 214 215 libCase env (Lam binder body) = Lam binder (libCase (addBinders env [binder]) body)  partain committed Jan 08, 1996 216   partain committed Mar 19, 1996 217 218 libCase env (Let bind body) = Let bind' (libCase env_body body)  partain committed Jan 08, 1996 219 220 221  where (env_body, bind') = libCaseBind env bind  simonpj committed Sep 30, 2004 222 libCase env (Case scrut bndr ty alts)  simonpj@microsoft.com committed May 23, 2007 223  = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)  partain committed Jan 08, 1996 224  where  simonpj@microsoft.com committed Oct 04, 2006 225 226 227  env_alts = addBinders (mk_alt_env scrut) [bndr] mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast]  Ian Lynagh committed May 04, 2008 228  mk_alt_env _ = env  partain committed Jan 08, 1996 229   Ian Lynagh committed May 04, 2008 230 231 libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr) -> (AltCon, [CoreBndr], CoreExpr)  simonm committed Dec 02, 1998 232 libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)  partain committed Jan 08, 1996 233 234 \end{code}  simonpj@microsoft.com committed Jan 11, 2007 235   simonm committed Dec 02, 1998 236 237 Ids ~~~  partain committed Jan 08, 1996 238 \begin{code}  simonm committed Dec 02, 1998 239 libCaseId :: LibCaseEnv -> Id -> CoreExpr  partain committed Jan 08, 1996 240 libCaseId env v  simonpj committed Dec 08, 2000 241  | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing  sof committed Apr 05, 2002 242  , notNull free_scruts -- with free vars scrutinised in RHS  simonpj committed Dec 08, 2000 243  = Let the_bind (Var v)  partain committed Jan 08, 1996 244 245  | otherwise  simonm committed Dec 02, 1998 246  = Var v  partain committed Jan 08, 1996 247 248  where  simonpj committed Dec 08, 2000 249 250  rec_id_level = lookupLevel env v free_scruts = freeScruts env rec_id_level  simonpj@microsoft.com committed Oct 29, 2007 251 252 253 254 255 256  freeScruts :: LibCaseEnv -> LibCaseLevel -- Level of the recursive Id -> [Id] -- Ids that are scrutinised between the binding -- of the recursive Id and here freeScruts env rec_bind_lvl  simonpj@microsoft.com committed Feb 04, 2009 257 258 259  = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env , scrut_bind_lvl <= rec_bind_lvl , scrut_at_lvl > rec_bind_lvl]  simonpj@microsoft.com committed Oct 29, 2007 260  -- Note [When to specialise]  simonpj@microsoft.com committed Feb 04, 2009 261  -- Note [Avoiding fruitless liberate-case]  partain committed Mar 19, 1996 262 \end{code}  partain committed Jan 08, 1996 263   simonpj@microsoft.com committed Oct 29, 2007 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 Note [When to specialise] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f = \x. letrec g = \y. case x of True -> ... (f a) ... False -> ... (g b) ... We get the following levels f 0 x 1 g 1 y 2 Then 'x' is being scrutinised at a deeper level than its binding, so it's added to lc_sruts: [(x,1)]  Gabor Greif committed Jan 30, 2013 280 We do *not* want to specialise the call to 'f', because 'x' is not free  simonpj@microsoft.com committed Oct 29, 2007 281 282 283 284 285 in 'f'. So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0). We *do* want to specialise the call to 'g', because 'x' is free in g. Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).  simonpj@microsoft.com committed Feb 04, 2009 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 Note [Avoiding fruitless liberate-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider also: f = \x. case top_lvl_thing of I# _ -> let g = \y. ... g ... in ... Here, top_lvl_thing is scrutinised at a level (1) deeper than its binding site (0). Nevertheless, we do NOT want to specialise the call to 'g' because all the structure in its free variables is already visible at the definition site for g. Hence, when considering specialising an occurrence of 'g', we want to check that there's a scruted-var v st a) v's binding site is *outside* g b) v's scrutinisation site is *inside* g  partain committed Jan 08, 1996 302   simonpj@microsoft.com committed Jan 11, 2007 303 304 305 306 307 %************************************************************************ %* * Utility functions %* * %************************************************************************  partain committed Jan 08, 1996 308 309  \begin{code}  simonm committed Dec 02, 1998 310 addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv  simonpj@microsoft.com committed Jan 03, 2007 311 312 addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders = env { lc_lvl_env = lvl_env' }  partain committed Jan 08, 1996 313  where  simonm committed Dec 02, 1998 314  lvl_env' = extendVarEnvList lvl_env (binders zip repeat lvl)  partain committed Jan 08, 1996 315   partain committed Mar 19, 1996 316 addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv  simonpj@microsoft.com committed Jan 03, 2007 317 318 319 addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env, lc_rec_env = rec_env}) pairs = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' }  partain committed Jan 08, 1996 320 321  where lvl' = lvl + 1  simonm committed Dec 02, 1998 322 323  lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs] rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]  partain committed Jan 08, 1996 324   partain committed Mar 19, 1996 325 addScrutedVar :: LibCaseEnv  partain committed Jan 08, 1996 326  -> Id -- This Id is being scrutinised by a case expression  partain committed Mar 19, 1996 327  -> LibCaseEnv  partain committed Jan 08, 1996 328   simonpj@microsoft.com committed Jan 03, 2007 329 330 addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, lc_scruts = scruts }) scrut_var  partain committed Jan 08, 1996 331  | bind_lvl < lvl  simonpj@microsoft.com committed Jan 03, 2007 332  = env { lc_scruts = scruts' }  partain committed Jan 08, 1996 333  -- Add to scruts iff the scrut_var is being scrutinised at  partain committed Mar 19, 1996 334  -- a deeper level than its defn  partain committed Jan 08, 1996 335 336 337  | otherwise = env where  simonpj@microsoft.com committed Feb 04, 2009 338  scruts' = (scrut_var, bind_lvl, lvl) : scruts  simonm committed Dec 02, 1998 339  bind_lvl = case lookupVarEnv lvl_env scrut_var of  partain committed Jan 08, 1996 340  Just lvl -> lvl  simonpj committed Dec 19, 1996 341  Nothing -> topLevel  partain committed Jan 08, 1996 342   simonm committed Dec 02, 1998 343 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind  simonpj@microsoft.com committed Jan 03, 2007 344 lookupRecId env id = lookupVarEnv (lc_rec_env env) id  partain committed Jan 08, 1996 345 346  lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel  simonpj@microsoft.com committed Jan 03, 2007 347 348 lookupLevel env id = case lookupVarEnv (lc_lvl_env env) id of  simonpj@microsoft.com committed May 11, 2007 349  Just lvl -> lvl  simonpj committed Dec 19, 1996 350  Nothing -> topLevel  partain committed Mar 19, 1996 351 \end{code}  simonpj@microsoft.com committed Jan 11, 2007 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368  %************************************************************************ %* * The environment %* * %************************************************************************ \begin{code} type LibCaseLevel = Int topLevel :: LibCaseLevel topLevel = 0 \end{code} \begin{code} data LibCaseEnv = LibCaseEnv {  ian@well-typed.com committed Oct 09, 2012 369  lc_dflags :: DynFlags,  simonpj@microsoft.com committed Jan 11, 2007 370 371  lc_lvl :: LibCaseLevel, -- Current level  simonpj@microsoft.com committed Oct 29, 2007 372 373 374  -- The level is incremented when (and only when) going -- inside the RHS of a (sufficiently small) recursive -- function.  simonpj@microsoft.com committed Jan 11, 2007 375 376  lc_lvl_env :: IdEnv LibCaseLevel,  simonpj@microsoft.com committed Oct 29, 2007 377 378  -- Binds all non-top-level in-scope Ids (top-level and -- imported things have a level of zero)  simonpj@microsoft.com committed Jan 11, 2007 379 380  lc_rec_env :: IdEnv CoreBind,  simonpj@microsoft.com committed Oct 29, 2007 381 382  -- Binds *only* recursively defined ids, to their own -- binding group, and *only* in their own RHSs  simonpj@microsoft.com committed Jan 11, 2007 383   simonpj@microsoft.com committed Feb 04, 2009 384  lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]  simonpj@microsoft.com committed Oct 29, 2007 385 386  -- Each of these Ids was scrutinised by an enclosing -- case expression, at a level deeper than its binding  simonpj@microsoft.com committed Feb 04, 2009 387 388 389 390 391 392 393 394  -- level. -- -- The first LibCaseLevel is the *binding level* of -- the scrutinised Id, -- The second is the level *at which it was scrutinised*. -- (see Note [Avoiding fruitless liberate-case]) -- The former is a bit redundant, since you could always -- look it up in lc_lvl_env, but it's just cached here  simonpj@microsoft.com committed Oct 29, 2007 395 396  -- -- The order is insignificant; it's a bag really  simonpj@microsoft.com committed Feb 04, 2009 397 398 399 400 401  -- -- There's one element per scrutinisation; -- in principle the same Id may appear multiple times, -- although that'd be unusual: -- case x of { (a,b) -> ....(case x of ...) .. }  simonpj@microsoft.com committed Jan 11, 2007 402 403  }  simonpj@microsoft.com committed May 23, 2007 404 405 initEnv :: DynFlags -> LibCaseEnv initEnv dflags  ian@well-typed.com committed Oct 09, 2012 406  = LibCaseEnv { lc_dflags = dflags,  simonpj@microsoft.com committed Jan 11, 2007 407 408 409  lc_lvl = 0, lc_lvl_env = emptyVarEnv, lc_rec_env = emptyVarEnv,  simonpj@microsoft.com committed May 23, 2007 410  lc_scruts = [] }  simonpj@microsoft.com committed Jan 11, 2007 411   ian@well-typed.com committed Oct 09, 2012 412 413 414 -- Bomb-out size for deciding if -- potential liberatees are too big. -- (passed in from cmd-line args)  Ian Lynagh committed May 04, 2008 415 bombOutSize :: LibCaseEnv -> Maybe Int  ian@well-typed.com committed Oct 09, 2012 416 bombOutSize = liberateCaseThreshold . lc_dflags  simonpj@microsoft.com committed Jan 11, 2007 417 418 \end{code}