ghc/compiler/simplCore/LiberateCase.lhs

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