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 import 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 rhs) of
 184           UnfoldNever -> False
 185           _           -> True   -- we didn't BOMB, so it must be OK
 186
 187     lIBERATE_BOMB_SIZE = bombOutSize env
 188 \end{code}
 189
 190
 191 Expressions
 192 ~~~~~~~~~~~
 193
 194 \begin{code}
 195 libCase :: LibCaseEnv
 196         -> CoreExpr
 197         -> CoreExpr
 198
 199 libCase env (Lit lit)            = Lit lit
 200 libCase env (Var v)              = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
 201 libCase env (App fun arg)      = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
 202 libCase env (CoTyApp fun ty)     = CoTyApp (libCase env fun) ty
 203 libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
 204 libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
 205 libCase env (CoTyLam tyvar body) = CoTyLam tyvar (libCase env body)
 206 libCase env (SCC cc body)      = SCC cc (libCase env body)
 207
 208 libCase env (Lam binder body)
 209   = Lam binder (libCase (addBinders env [binder]) body)
 210
 211 libCase env (Let bind body)
 212   = Let bind' (libCase env_body body)
 213   where
 214     (env_body, bind') = libCaseBind env bind
 215
 216 libCase env (Case scrut alts)
 217   = Case (libCase env scrut) (libCaseAlts env_alts alts)
 218   where
 219     env_alts = case scrut of
 220                   Var scrut_var -> addScrutedVar env scrut_var
 221                   other           -> env
 222 \end{code}
 223
 224
 225 Case alternatives
 226 ~~~~~~~~~~~~~~~~~
 227
 228 \begin{code}
 229 libCaseAlts env (AlgAlts alts deflt)
 230   = AlgAlts (map do_alt alts) (libCaseDeflt env deflt)
 231   where
 232     do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
 233
 234 libCaseAlts env (PrimAlts alts deflt)
 235   = PrimAlts (map do_alt alts) (libCaseDeflt env deflt)
 236   where
 237     do_alt (lit,rhs) = (lit, libCase env rhs)
 238
 239 libCaseDeflt env NoDefault
 240    = NoDefault
 241 libCaseDeflt env (BindDefault binder rhs)
 242    = BindDefault binder (libCase (addBinders env [binder]) rhs)
 243 \end{code}
 244
 245 Atoms and Ids
 246 ~~~~~~~~~~~~~
 247 \begin{code}
 248 libCaseAtoms :: LibCaseEnv -> [CoreArg] -> [CoreBinding]
 249 libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms]
 250
 251 libCaseAtom :: LibCaseEnv -> CoreArg -> [CoreBinding]
 252 libCaseAtom env (VarArg arg_id) = libCaseId env arg_id
 253 libCaseAtom env (LitArg lit)    = []
 254
 255 libCaseId :: LibCaseEnv -> Id -> [CoreBinding]
 256 libCaseId env v
 257   | maybeToBool maybe_rec_bind &&       -- It's a use of a recursive thing
 258     there_are_free_scruts               -- with free vars scrutinised in RHS
 259   = [the_bind]
 260
 261   | otherwise
 262   = []
 263
 264   where
 265     maybe_rec_bind :: Maybe CoreBinding -- The binding of the recursive thingy
 266     maybe_rec_bind = lookupRecId env v
 267     Just the_bind = maybe_rec_bind
 268
 269     rec_id_level = lookupLevel env v
 270
 271     there_are_free_scruts = freeScruts env rec_id_level
 272 \end{code}
 273
 274
 275
 276 Utility functions
 277 ~~~~~~~~~~~~~~~~~
 278 \begin{code}
 279 addBinders :: LibCaseEnv -> [Id] -> LibCaseEnv
 280 addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders
 281   = LibCaseEnv bomb lvl lvl_env' rec_env scruts
 282   where
 283     lvl_env' = growIdEnvList lvl_env (binders `zip` repeat lvl)
 284
 285 addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
 286 addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
 287   = LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
 288   where
 289     lvl'     = lvl + 1
 290     lvl_env' = growIdEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
 291     rec_env' = growIdEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
 292
 293 addScrutedVar :: LibCaseEnv
 294               -> Id             -- This Id is being scrutinised by a case expression
 295               -> LibCaseEnv
 296
 297 addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
 298   | bind_lvl < lvl
 299   = LibCaseEnv bomb lvl lvl_env rec_env scruts'
 300         -- Add to scruts iff the scrut_var is being scrutinised at
 301         -- a deeper level than its defn
 302
 303   | otherwise = env
 304   where
 305     scruts'  = (scrut_var, lvl) : scruts
 306     bind_lvl = case lookupIdEnv lvl_env scrut_var of
 307                  Just lvl -> lvl
 308                  Nothing  -> --false: ASSERT(toplevelishId scrut_var)
 309                              topLevel
 310
 311 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
 312 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 313 #ifndef DEBUG
 314   = lookupIdEnv rec_env id
 315 #else
 316   = case (lookupIdEnv rec_env id) of
 317       xxx@(Just _) -> xxx
 318       xxx          -> --false: ASSERT(toplevelishId id)
 319                       xxx
 320 #endif
 321
 322 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 323 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 324   = case lookupIdEnv lvl_env id of
 325       Just lvl -> lvl
 326       Nothing  -> ASSERT(toplevelishId id)
 327                   topLevel
 328
 329 freeScruts :: LibCaseEnv
 330            -> LibCaseLevel      -- Level of the recursive Id
 331            -> Bool              -- True <=> there is an enclosing case of a variable
 332                                 -- bound outside (ie level <=) the recursive Id.
 333 freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
 334   = not (null free_scruts)
 335   where
 336     free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
 337 -}
 338 \end{code}