ghc/compiler/simplCore/LiberateCase.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994
   3 %
   4 \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
   5
   6
   7 \begin{code}
   8 #include "HsVersions.h"
   9
  10 module LiberateCase ( liberateCase ) where
  11
  12 import CoreUnfold       ( UnfoldingGuidance(..) )
  13 import Id               ( localiseId, toplevelishId{-debugging-} )
  14 import Maybes
  15 import Outputable
  16 import Pretty
  17 import Util
  18 \end{code}
  19
  20 This module walks over @Core@, and looks for @case@ on free variables.
  21 The criterion is:
  22         if there is case on a free on the route to the recursive call,
  23         then the recursive call is replaced with an unfolding.
  24
  25 Example
  26
  27 \begin{verbatim}
  28 f = \ t -> case v of
  29                V a b -> a : f t
  30 \end{verbatim}
  31
  32 => the inner f is replaced.
  33
  34 \begin{verbatim}
  35 f = \ t -> case v of
  36                V a b -> a : (letrec
  37                                 f =  \ t -> case v of
  38                                                V a b -> a : f t
  39                              in f) t
  40 \end{verbatim}
  41 (note the NEED for shadowing)
  42
  43 => Run Andr\'e's wonder pass ...
  44 \begin{verbatim}
  45 f = \ t -> case v of
  46                V a b -> a : (letrec
  47                                 f = \ t -> a : f t
  48                              in f t)
  49 \begin{verbatim}
  50 Better code, because 'a' is  free inside the inner letrec, rather
  51 than needing projection from v.
  52
  53
  54 To think about (Apr 94)
  55 ~~~~~~~~~~~~~~
  56
  57 Main worry: duplicating code excessively.  At the moment we duplicate
  58 the entire binding group once at each recursive call.  But there may
  59 be a group of recursive calls which share a common set of evaluated
  60 free variables, in which case the duplication is a plain waste.
  61
  62 Another thing we could consider adding is some unfold-threshold thing,
  63 so that we'll only duplicate if the size of the group rhss isn't too
  64 big.
  65
  66 Data types
  67 ~~~~~~~~~~
  68
  69 The ``level'' of a binder tells how many
  70 recursive defns lexically enclose the binding
  71 A recursive defn "encloses" its RHS, not its
  72 scope.  For example:
  73 \begin{verbatim}
  74         letrec f = let g = ... in ...
  75         in
  76         let h = ...
  77         in ...
  78 \end{verbatim}
  79 Here, the level of @f@ is zero, the level of @g@ is one,
  80 and the level of @h@ is zero (NB not one).
  81
  82 \begin{code}
  83 type LibCaseLevel = Int
  84
  85 topLevel :: LibCaseLevel
  86 topLevel = 0
  87 \end{code}
  88
  89 \begin{code}
  90 data LibCaseEnv
  91   = LibCaseEnv
  92         Int                     -- Bomb-out size for deciding if
  93                                 -- potential liberatees are too big.
  94                                 -- (passed in from cmd-line args)
  95
  96         LibCaseLevel            -- Current level
  97
  98         (IdEnv LibCaseLevel)    -- Binds all non-top-level in-scope Ids
  99                                 -- (top-level and imported things have
 100                                 -- a level of zero)
 101
 102         (IdEnv CoreBinding)-- Binds *only* recursively defined
 103                                 -- Ids, to their own binding group,
 104                                 -- and *only* in their own RHSs
 105
 106         [(Id,LibCaseLevel)]     -- Each of these Ids was scrutinised by an
 107                                 -- enclosing case expression, with the
 108                                 -- specified number of enclosing
 109                                 -- recursive bindings; furthermore,
 110                                 -- the Id is bound at a lower level
 111                                 -- than the case expression.  The
 112                                 -- order is insignificant; it's a bag
 113                                 -- really
 114
 115 initEnv :: Int -> LibCaseEnv
 116 initEnv bomb_size = LibCaseEnv bomb_size 0 nullIdEnv nullIdEnv []
 117
 118 bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
 119 \end{code}
 120
 121
 122 Programs
 123 ~~~~~~~~
 124 \begin{code}
 125 liberateCase :: Int -> [CoreBinding] -> [CoreBinding]
 126 liberateCase bomb_size prog
 127   = do_prog (initEnv bomb_size) prog
 128   where
 129     do_prog env [] = []
 130     do_prog env (bind:binds) = bind' : do_prog env' binds
 131                              where
 132                                (env', bind') = libCaseBind env bind
 133 \end{code}
 134
 135 Bindings
 136 ~~~~~~~~
 137
 138 \begin{code}
 139 libCaseBind :: LibCaseEnv -> CoreBinding -> (LibCaseEnv, CoreBinding)
 140
 141 libCaseBind env (NonRec binder rhs)
 142   = (addBinders env [binder], NonRec binder (libCase env rhs))
 143
 144 libCaseBind env (Rec pairs)
 145   = (env_body, Rec pairs')
 146   where
 147     (binders, rhss) = unzip pairs
 148
 149     env_body = addBinders env binders
 150
 151     pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]
 152
 153     env_rhs = if all rhs_small_enough rhss then extended_env else env
 154
 155         -- We extend the rec-env by binding each Id to its rhs, first
 156         -- processing the rhs with an *un-extended* environment, so
 157         -- that the same process doesn't occur for ever!
 158
 159     extended_env
 160       = addRecBinds env [ (localiseId binder, libCase env_body rhs)
 161                         | (binder, rhs) <- pairs ]
 162
 163         -- Why "localiseId" above?  Because we're creating a new local
 164         -- copy of the original binding.  In particular, the original
 165         -- binding might have been for a TopLevId, and this copy clearly
 166         -- will not be top-level!
 167
 168         -- It is enough to change just the binder, because subsequent
 169         -- simplification will propagate the right info from the binder.
 170
 171         -- Why does it matter?  Because the codeGen keeps a separate
 172         -- environment for top-level Ids, and it is disastrous for it
 173         -- to think that something is top-level when it isn't.
 174
 175     rhs_small_enough rhs
 176       = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE rhs) of
 177           UnfoldNever -> False
 178           _           -> True   -- we didn't BOMB, so it must be OK
 179
 180     lIBERATE_BOMB_SIZE = bombOutSize env
 181 \end{code}
 182
 183
 184 Expressions
 185 ~~~~~~~~~~~
 186
 187 \begin{code}
 188 libCase :: LibCaseEnv
 189         -> CoreExpr
 190         -> CoreExpr
 191
 192 libCase env (Lit lit)            = Lit lit
 193 libCase env (Var v)              = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
 194 libCase env (App fun arg)      = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
 195 libCase env (CoTyApp fun ty)     = CoTyApp (libCase env fun) ty
 196 libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
 197 libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
 198 libCase env (CoTyLam tyvar body) = CoTyLam tyvar (libCase env body)
 199 libCase env (SCC cc body)      = SCC cc (libCase env body)
 200
 201 libCase env (Lam binder body)
 202   = Lam binder (libCase (addBinders env [binder]) body)
 203
 204 libCase env (Let bind body)
 205   = Let bind' (libCase env_body body)
 206   where
 207     (env_body, bind') = libCaseBind env bind
 208
 209 libCase env (Case scrut alts)
 210   = Case (libCase env scrut) (libCaseAlts env_alts alts)
 211   where
 212     env_alts = case scrut of
 213                   Var scrut_var -> addScrutedVar env scrut_var
 214                   other           -> env
 215 \end{code}
 216
 217
 218 Case alternatives
 219 ~~~~~~~~~~~~~~~~~
 220
 221 \begin{code}
 222 libCaseAlts env (AlgAlts alts deflt)
 223   = AlgAlts (map do_alt alts) (libCaseDeflt env deflt)
 224   where
 225     do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
 226
 227 libCaseAlts env (PrimAlts alts deflt)
 228   = PrimAlts (map do_alt alts) (libCaseDeflt env deflt)
 229   where
 230     do_alt (lit,rhs) = (lit, libCase env rhs)
 231
 232 libCaseDeflt env NoDefault
 233    = NoDefault
 234 libCaseDeflt env (BindDefault binder rhs)
 235    = BindDefault binder (libCase (addBinders env [binder]) rhs)
 236 \end{code}
 237
 238 Atoms and Ids
 239 ~~~~~~~~~~~~~
 240 \begin{code}
 241 libCaseAtoms :: LibCaseEnv -> [CoreArg] -> [CoreBinding]
 242 libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms]
 243
 244 libCaseAtom :: LibCaseEnv -> CoreArg -> [CoreBinding]
 245 libCaseAtom env (VarArg arg_id) = libCaseId env arg_id
 246 libCaseAtom env (LitArg lit)    = []
 247
 248 libCaseId :: LibCaseEnv -> Id -> [CoreBinding]
 249 libCaseId env v
 250   | maybeToBool maybe_rec_bind &&       -- It's a use of a recursive thing
 251     there_are_free_scruts               -- with free vars scrutinised in RHS
 252   = [the_bind]
 253
 254   | otherwise
 255   = []
 256
 257   where
 258     maybe_rec_bind :: Maybe CoreBinding -- The binding of the recursive thingy
 259     maybe_rec_bind = lookupRecId env v
 260     Just the_bind = maybe_rec_bind
 261
 262     rec_id_level = lookupLevel env v
 263
 264     there_are_free_scruts = freeScruts env rec_id_level
 265 \end{code}
 266
 267
 268
 269 Utility functions
 270 ~~~~~~~~~~~~~~~~~
 271 \begin{code}
 272 addBinders :: LibCaseEnv -> [Id] -> LibCaseEnv
 273 addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders
 274   = LibCaseEnv bomb lvl lvl_env' rec_env scruts
 275   where
 276     lvl_env' = growIdEnvList lvl_env (binders `zip` repeat lvl)
 277
 278 addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
 279 addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
 280   = LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
 281   where
 282     lvl'     = lvl + 1
 283     lvl_env' = growIdEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
 284     rec_env' = growIdEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
 285
 286 addScrutedVar :: LibCaseEnv
 287               -> Id             -- This Id is being scrutinised by a case expression
 288               -> LibCaseEnv
 289
 290 addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
 291   | bind_lvl < lvl
 292   = LibCaseEnv bomb lvl lvl_env rec_env scruts'
 293         -- Add to scruts iff the scrut_var is being scrutinised at
 294         -- a deeper level than its defn
 295
 296   | otherwise = env
 297   where
 298     scruts'  = (scrut_var, lvl) : scruts
 299     bind_lvl = case lookupIdEnv lvl_env scrut_var of
 300                  Just lvl -> lvl
 301                  Nothing  -> --false: ASSERT(toplevelishId scrut_var)
 302                              topLevel
 303
 304 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
 305 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 306 #ifndef DEBUG
 307   = lookupIdEnv rec_env id
 308 #else
 309   = case (lookupIdEnv rec_env id) of
 310       xxx@(Just _) -> xxx
 311       xxx          -> --false: ASSERT(toplevelishId id)
 312                       xxx
 313 #endif
 314
 315 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 316 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 317   = case lookupIdEnv lvl_env id of
 318       Just lvl -> lvl
 319       Nothing  -> ASSERT(toplevelishId id)
 320                   topLevel
 321
 322 freeScruts :: LibCaseEnv
 323            -> LibCaseLevel      -- Level of the recursive Id
 324            -> Bool              -- True <=> there is an enclosing case of a variable
 325                                 -- bound outside (ie level <=) the recursive Id.
 326 freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
 327   = not (null free_scruts)
 328   where
 329     free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
 330 \end{code}