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 #include "HsVersions.h"
  10
  11 module LiberateCase ( liberateCase ) where
  12
  13 IMP_Ubiq(){-uitous-}
  14 import Util             ( panic )
  15
  16 liberateCase = panic "LiberateCase.liberateCase: ToDo"
  17
  18 {- LATER: to end of file:
  19 import CoreUnfold       ( UnfoldingGuidance(..) )
  20 import Id               ( localiseId, toplevelishId{-debugging-} )
  21 import Maybes
  22 import Outputable
  23 import Pretty
  24 import Util
  25 \end{code}
  26
  27 This module walks over @Core@, and looks for @case@ on free variables.
  28 The criterion is:
  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.
  31
  32 Example
  33
  34 \begin{verbatim}
  35 f = \ t -> case v of
  36                V a b -> a : f t
  37 \end{verbatim}
  38
  39 => the inner f is replaced.
  40
  41 \begin{verbatim}
  42 f = \ t -> case v of
  43                V a b -> a : (letrec
  44                                 f =  \ t -> case v of
  45                                                V a b -> a : f t
  46                              in f) t
  47 \end{verbatim}
  48 (note the NEED for shadowing)
  49
  50 => Run Andr\'e's wonder pass ...
  51 \begin{verbatim}
  52 f = \ t -> case v of
  53                V a b -> a : (letrec
  54                                 f = \ t -> a : f t
  55                              in f t)
  56 \begin{verbatim}
  57 Better code, because 'a' is  free inside the inner letrec, rather
  58 than needing projection from v.
  59
  60
  61 To think about (Apr 94)
  62 ~~~~~~~~~~~~~~
  63
  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.
  68
  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
  71 big.
  72
  73 Data types
  74 ~~~~~~~~~~
  75
  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
  79 scope.  For example:
  80 \begin{verbatim}
  81         letrec f = let g = ... in ...
  82         in
  83         let h = ...
  84         in ...
  85 \end{verbatim}
  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).
  88
  89 \begin{code}
  90 type LibCaseLevel = Int
  91
  92 topLevel :: LibCaseLevel
  93 topLevel = 0
  94 \end{code}
  95
  96 \begin{code}
  97 data LibCaseEnv
  98   = LibCaseEnv
  99         Int                     -- Bomb-out size for deciding if
 100                                 -- potential liberatees are too big.
 101                                 -- (passed in from cmd-line args)
 102
 103         LibCaseLevel            -- Current level
 104
 105         (IdEnv LibCaseLevel)    -- Binds all non-top-level in-scope Ids
 106                                 -- (top-level and imported things have
 107                                 -- a level of zero)
 108
 109         (IdEnv CoreBinding)-- Binds *only* recursively defined
 110                                 -- Ids, to their own binding group,
 111                                 -- and *only* in their own RHSs
 112
 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
 120                                 -- really
 121
 122 initEnv :: Int -> LibCaseEnv
 123 initEnv bomb_size = LibCaseEnv bomb_size 0 nullIdEnv nullIdEnv []
 124
 125 bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
 126 \end{code}
 127
 128
 129 Programs
 130 ~~~~~~~~
 131 \begin{code}
 132 liberateCase :: Int -> [CoreBinding] -> [CoreBinding]
 133 liberateCase bomb_size prog
 134   = do_prog (initEnv bomb_size) prog
 135   where
 136     do_prog env [] = []
 137     do_prog env (bind:binds) = bind' : do_prog env' binds
 138                              where
 139                                (env', bind') = libCaseBind env bind
 140 \end{code}
 141
 142 Bindings
 143 ~~~~~~~~
 144
 145 \begin{code}
 146 libCaseBind :: LibCaseEnv -> CoreBinding -> (LibCaseEnv, CoreBinding)
 147
 148 libCaseBind env (NonRec binder rhs)
 149   = (addBinders env [binder], NonRec binder (libCase env rhs))
 150
 151 libCaseBind env (Rec pairs)
 152   = (env_body, Rec pairs')
 153   where
 154     (binders, rhss) = unzip pairs
 155
 156     env_body = addBinders env binders
 157
 158     pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]
 159
 160     env_rhs = if all rhs_small_enough rhss then extended_env else env
 161
 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!
 165
 166     extended_env
 167       = addRecBinds env [ (localiseId binder, libCase env_body rhs)
 168                         | (binder, rhs) <- pairs ]
 169
 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!
 174
 175         -- It is enough to change just the binder, because subsequent
 176         -- simplification will propagate the right info from the binder.
 177
 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.
 181
 182     rhs_small_enough rhs
 183       = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE cON_DISCOUNT rhs) of
 184           UnfoldNever -> False
 185           _           -> True   -- we didn't BOMB, so it must be OK
 186
 187     lIBERATE_BOMB_SIZE = bombOutSize env
 188     cON_DISCOUNT = error "libCaseBind"
 189 \end{code}
 190
 191
 192 Expressions
 193 ~~~~~~~~~~~
 194
 195 \begin{code}
 196 libCase :: LibCaseEnv
 197         -> CoreExpr
 198         -> CoreExpr
 199
 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)
 209
 210 libCase env (Lam binder body)
 211   = Lam binder (libCase (addBinders env [binder]) body)
 212
 213 libCase env (Let bind body)
 214   = Let bind' (libCase env_body body)
 215   where
 216     (env_body, bind') = libCaseBind env bind
 217
 218 libCase env (Case scrut alts)
 219   = Case (libCase env scrut) (libCaseAlts env_alts alts)
 220   where
 221     env_alts = case scrut of
 222                   Var scrut_var -> addScrutedVar env scrut_var
 223                   other           -> env
 224 \end{code}
 225
 226
 227 Case alternatives
 228 ~~~~~~~~~~~~~~~~~
 229
 230 \begin{code}
 231 libCaseAlts env (AlgAlts alts deflt)
 232   = AlgAlts (map do_alt alts) (libCaseDeflt env deflt)
 233   where
 234     do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
 235
 236 libCaseAlts env (PrimAlts alts deflt)
 237   = PrimAlts (map do_alt alts) (libCaseDeflt env deflt)
 238   where
 239     do_alt (lit,rhs) = (lit, libCase env rhs)
 240
 241 libCaseDeflt env NoDefault
 242    = NoDefault
 243 libCaseDeflt env (BindDefault binder rhs)
 244    = BindDefault binder (libCase (addBinders env [binder]) rhs)
 245 \end{code}
 246
 247 Atoms and Ids
 248 ~~~~~~~~~~~~~
 249 \begin{code}
 250 libCaseAtoms :: LibCaseEnv -> [CoreArg] -> [CoreBinding]
 251 libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms]
 252
 253 libCaseAtom :: LibCaseEnv -> CoreArg -> [CoreBinding]
 254 libCaseAtom env (VarArg arg_id) = libCaseId env arg_id
 255 libCaseAtom env (LitArg lit)    = []
 256
 257 libCaseId :: LibCaseEnv -> Id -> [CoreBinding]
 258 libCaseId env v
 259   | maybeToBool maybe_rec_bind &&       -- It's a use of a recursive thing
 260     there_are_free_scruts               -- with free vars scrutinised in RHS
 261   = [the_bind]
 262
 263   | otherwise
 264   = []
 265
 266   where
 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
 270
 271     rec_id_level = lookupLevel env v
 272
 273     there_are_free_scruts = freeScruts env rec_id_level
 274 \end{code}
 275
 276
 277
 278 Utility functions
 279 ~~~~~~~~~~~~~~~~~
 280 \begin{code}
 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
 284   where
 285     lvl_env' = growIdEnvList lvl_env (binders `zip` repeat lvl)
 286
 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
 290   where
 291     lvl'     = lvl + 1
 292     lvl_env' = growIdEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
 293     rec_env' = growIdEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
 294
 295 addScrutedVar :: LibCaseEnv
 296               -> Id             -- This Id is being scrutinised by a case expression
 297               -> LibCaseEnv
 298
 299 addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
 300   | bind_lvl < lvl
 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
 304
 305   | otherwise = env
 306   where
 307     scruts'  = (scrut_var, lvl) : scruts
 308     bind_lvl = case lookupIdEnv lvl_env scrut_var of
 309                  Just lvl -> lvl
 310                  Nothing  -> --false: ASSERT(toplevelishId scrut_var)
 311                              topLevel
 312
 313 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
 314 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 315 #ifndef DEBUG
 316   = lookupIdEnv rec_env id
 317 #else
 318   = case (lookupIdEnv rec_env id) of
 319       xxx@(Just _) -> xxx
 320       xxx          -> --false: ASSERT(toplevelishId id)
 321                       xxx
 322 #endif
 323
 324 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 325 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 326   = case lookupIdEnv lvl_env id of
 327       Just lvl -> lvl
 328       Nothing  -> ASSERT(toplevelishId id)
 329                   topLevel
 330
 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)
 337   where
 338     free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
 339 -}
 340 \end{code}