ghc/compiler/simplCore/LiberateCase.lhs

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