compiler/stranal/StrictAnal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
   5
   6 The original version(s) of all strictness-analyser code (except the
   7 Semantique analyser) was written by Andy Gill.
   8
   9 \begin{code}
  10 {-# OPTIONS -w #-}
  11 -- The above warning supression flag is a temporary kludge.
  12 -- While working on this module you are encouraged to remove it and fix
  13 -- any warnings in the module. See
  14 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  15 -- for details
  16
  17 #ifndef OLD_STRICTNESS
  18 module StrictAnal ( ) where
  19
  20 #else
  21
  22 module StrictAnal ( saBinds ) where
  23
  24 #include "HsVersions.h"
  25
  26 import DynFlags ( DynFlags, DynFlag(..) )
  27 import CoreSyn
  28 import Id               ( setIdStrictness, setInlinePragma,
  29                           idDemandInfo, setIdDemandInfo, isBottomingId,
  30                           Id
  31                         )
  32 import ErrUtils         ( dumpIfSet_dyn )
  33 import SaAbsInt
  34 import SaLib
  35 import Demand           ( Demand, wwStrict, isStrict, isLazy )
  36 import Util             ( zipWith3Equal, stretchZipWith, compareLength )
  37 import BasicTypes       ( Activation( NeverActive ) )
  38 import Outputable
  39 import FastTypes
  40 import State
  41 \end{code}
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsection[Thoughts]{Random thoughts}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 A note about worker-wrappering.  If we have
  50
  51         f :: Int -> Int
  52         f = let v = <expensive>
  53             in \x -> <body>
  54
  55 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
  56
  57         f = \x -> case x of Int x# -> fw x#
  58         fw = \x# -> let x = Int x#
  59                     in
  60                     let v = <expensive>
  61                     in <body>
  62
  63 because this obviously loses laziness, since now <expensive>
  64 is done each time.  Alas.
  65
  66 WATCH OUT!  This can mean that something is unboxed only to be
  67 boxed again. For example
  68
  69         g x y = f x
  70
  71 Here g is strict, and *will* split into worker-wrapper.  A call to
  72 g, with the wrapper inlined will then be
  73
  74         case arg of Int a# -> gw a#
  75
  76 Now g calls f, which has no wrapper, so it has to box it.
  77
  78         gw = \a# -> f (Int a#)
  79
  80 Alas and alack.
  81
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 \subsection[iface-StrictAnal]{Interface to the outside world}
  86 %*                                                                      *
  87 %************************************************************************
  88
  89 @saBinds@ decorates bindings with strictness info.  A later
  90 worker-wrapper pass can use this info to create wrappers and
  91 strict workers.
  92
  93 \begin{code}
  94 saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
  95 saBinds dflags binds
  96   = do {
  97         -- Mark each binder with its strictness
  98 #ifndef OMIT_STRANAL_STATS
  99         let { (binds_w_strictness, sa_stats) = runState $ (saTopBinds binds) nullSaStats };
 100         dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
 101                   (pp_stats sa_stats);
 102 #else
 103         let { binds_w_strictness = unSaM $ saTopBindsBinds binds };
 104 #endif
 105
 106         return binds_w_strictness
 107     }
 108 \end{code}
 109
 110 %************************************************************************
 111 %*                                                                      *
 112 \subsection[saBinds]{Strictness analysis of bindings}
 113 %*                                                                      *
 114 %************************************************************************
 115
 116 [Some of the documentation about types, etc., in \tr{SaLib} may be
 117 helpful for understanding this module.]
 118
 119 @saTopBinds@ tags each binder in the program with its @Demand@.
 120 That tells how each binder is {\em used}; if @Strict@, then the binder
 121 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
 122 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
 123
 124 (The above info is actually recorded for posterity in each binder's
 125 IdInfo, notably its @DemandInfo@.)
 126
 127 We proceed by analysing the bindings top-to-bottom, building up an
 128 environment which maps @Id@s to their abstract values (i.e., an
 129 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
 130
 131 \begin{code}
 132 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
 133
 134 saTopBinds binds
 135   = let
 136         starting_abs_env = nullAbsValEnv
 137     in
 138     do_it starting_abs_env starting_abs_env binds
 139   where
 140     do_it _    _    [] = return []
 141     do_it senv aenv (b:bs) = do
 142         (senv2, aenv2, new_b) <- saTopBind senv  aenv  b
 143         new_bs                <- do_it     senv2 aenv2 bs
 144         return (new_b : new_bs)
 145 \end{code}
 146
 147 @saTopBind@ is only used for the top level.  We don't add any demand
 148 info to these ids because we can't work it out.  In any case, it
 149 doesn't do us any good to know whether top-level binders are sure to
 150 be used; we can't turn top-level @let@s into @case@s.
 151
 152 \begin{code}
 153 saTopBind :: StrictEnv -> AbsenceEnv
 154           -> CoreBind
 155           -> SaM (StrictEnv, AbsenceEnv, CoreBind)
 156
 157 saTopBind str_env abs_env (NonRec binder rhs) = do
 158     new_rhs <- saExpr minDemand str_env abs_env rhs
 159     let
 160         str_rhs = absEval StrAnal rhs str_env
 161         abs_rhs = absEval AbsAnal rhs abs_env
 162
 163         widened_str_rhs = widen StrAnal str_rhs
 164         widened_abs_rhs = widen AbsAnal abs_rhs
 165                 -- The widening above is done for efficiency reasons.
 166                 -- See notes on Let case in SaAbsInt.lhs
 167
 168         new_binder
 169           = addStrictnessInfoToTopId
 170                 widened_str_rhs widened_abs_rhs
 171                 binder
 172
 173           -- Augment environments with a mapping of the
 174           -- binder to its abstract values, computed by absEval
 175         new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
 176         new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
 177
 178     return (new_str_env, new_abs_env, NonRec new_binder new_rhs)
 179
 180 saTopBind str_env abs_env (Rec pairs)
 181   = let
 182         (binders,rhss) = unzip pairs
 183         str_rhss    = fixpoint StrAnal binders rhss str_env
 184         abs_rhss    = fixpoint AbsAnal binders rhss abs_env
 185                       -- fixpoint returns widened values
 186         new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
 187         new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
 188         new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId
 189                                     str_rhss abs_rhss binders
 190
 191     new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss
 192     let
 193         new_pairs   = new_binders `zip` new_rhss
 194
 195     return (new_str_env, new_abs_env, Rec new_pairs)
 196
 197 -- Hack alert!
 198 -- Top level divergent bindings are marked NOINLINE
 199 -- This avoids fruitless inlining of top level error functions
 200 addStrictnessInfoToTopId str_val abs_val bndr
 201   = if isBottomingId new_id then
 202         new_id `setInlinePragma` NeverActive
 203     else
 204         new_id
 205   where
 206     new_id = addStrictnessInfoToId str_val abs_val bndr
 207 \end{code}
 208
 209 %************************************************************************
 210 %*                                                                      *
 211 \subsection[saExpr]{Strictness analysis of an expression}
 212 %*                                                                      *
 213 %************************************************************************
 214
 215 @saExpr@ computes the strictness of an expression within a given
 216 environment.
 217
 218 \begin{code}
 219 saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
 220         -- The demand is the least demand we expect on the
 221         -- expression.  WwStrict is the least, because we're only
 222         -- interested in the expression at all if it's being evaluated,
 223         -- but the demand may be more.  E.g.
 224         --      f E
 225         -- where f has strictness u(LL), will evaluate E with demand u(LL)
 226
 227 minDemand = wwStrict
 228 minDemands = repeat minDemand
 229
 230 -- When we find an application, do the arguments
 231 -- with demands gotten from the function
 232 saApp str_env abs_env (fun, args) = do
 233     args' <- sequence sa_args
 234     fun' <- saExpr minDemand str_env abs_env fun
 235     return (mkApps fun' args')
 236   where
 237     arg_dmds = case fun of
 238                  Var var -> case lookupAbsValEnv str_env var of
 239                                 Just (AbsApproxFun ds _)
 240                                    | compareLength ds args /= LT
 241                                               -- 'ds' is at least as long as 'args'.
 242                                         -> ds ++ minDemands
 243                                 other   -> minDemands
 244                  other -> minDemands
 245
 246     sa_args = stretchZipWith isTypeArg (error "saApp:dmd")
 247                              sa_arg args arg_dmds
 248         -- The arg_dmds are for value args only, we need to skip
 249         -- over the type args when pairing up with the demands
 250         -- Hence the stretchZipWith
 251
 252     sa_arg arg dmd = saExpr dmd' str_env abs_env arg
 253                    where
 254                         -- Bring arg demand up to minDemand
 255                         dmd' | isLazy dmd = minDemand
 256                              | otherwise  = dmd
 257
 258 saExpr _ _ _ e@(Var _)  = return e
 259 saExpr _ _ _ e@(Lit _)  = return e
 260 saExpr _ _ _ e@(Type _) = return e
 261
 262 saExpr dmd str_env abs_env (Lam bndr body)
 263   = do  -- Don't bother to set the demand-info on a lambda binder
 264         -- We do that only for let(rec)-bound functions
 265     new_body <- saExpr minDemand str_env abs_env body
 266     return (Lam bndr new_body)
 267
 268 saExpr dmd str_env abs_env e@(App fun arg)
 269   = saApp str_env abs_env (collectArgs e)
 270
 271 saExpr dmd str_env abs_env (Note note expr) = do
 272     new_expr <- saExpr dmd str_env abs_env expr
 273     return (Note note new_expr)
 274
 275 saExpr dmd str_env abs_env (Case expr case_bndr alts) = do
 276     new_expr <- saExpr minDemand str_env abs_env expr
 277     new_alts <- mapM sa_alt alts
 278     let
 279         new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
 280     return (Case new_expr new_case_bndr new_alts)
 281   where
 282     sa_alt (con, binders, rhs) = do
 283         new_rhs <- saExpr dmd str_env abs_env rhs
 284         let
 285             new_binders = map add_demand_info binders
 286             add_demand_info bndr | isTyVar bndr = bndr
 287                                  | otherwise    = addDemandInfoToId dmd str_env abs_env rhs bndr
 288
 289         tickCases new_binders -- stats
 290         return (con, new_binders, new_rhs)
 291
 292 saExpr dmd str_env abs_env (Let (NonRec binder rhs) body) = do
 293         -- Analyse the RHS in the environment at hand
 294     let
 295         -- Find the demand on the RHS
 296         rhs_dmd = findDemand dmd str_env abs_env body binder
 297
 298         -- Bind this binder to the abstract value of the RHS; analyse
 299         -- the body of the `let' in the extended environment.
 300         str_rhs_val     = absEval StrAnal rhs str_env
 301         abs_rhs_val     = absEval AbsAnal rhs abs_env
 302
 303         widened_str_rhs = widen StrAnal str_rhs_val
 304         widened_abs_rhs = widen AbsAnal abs_rhs_val
 305                 -- The widening above is done for efficiency reasons.
 306                 -- See notes on Let case in SaAbsInt.lhs
 307
 308         new_str_env     = addOneToAbsValEnv str_env binder widened_str_rhs
 309         new_abs_env     = addOneToAbsValEnv abs_env binder widened_abs_rhs
 310
 311         -- Now determine the strictness of this binder; use that info
 312         -- to record DemandInfo/StrictnessInfo in the binder.
 313         new_binder = addStrictnessInfoToId
 314                         widened_str_rhs widened_abs_rhs
 315                         (binder `setIdDemandInfo` rhs_dmd)
 316
 317     tickLet new_binder           -- stats
 318     new_rhs <- saExpr rhs_dmd str_env abs_env rhs
 319     new_body <- saExpr dmd new_str_env new_abs_env body
 320     return (Let (NonRec new_binder new_rhs) new_body)
 321
 322 saExpr dmd str_env abs_env (Let (Rec pairs) body) = do
 323     let
 324         (binders,rhss) = unzip pairs
 325         str_vals       = fixpoint StrAnal binders rhss str_env
 326         abs_vals       = fixpoint AbsAnal binders rhss abs_env
 327                          -- fixpoint returns widened values
 328         new_str_env    = growAbsValEnvList str_env (binders `zip` str_vals)
 329         new_abs_env    = growAbsValEnvList abs_env (binders `zip` abs_vals)
 330
 331     new_body <- saExpr dmd new_str_env new_abs_env body
 332     new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss
 333     let
 334 --              DON'T add demand info in a Rec!
 335 --              a) it's useless: we can't do let-to-case
 336 --              b) it's incorrect.  Consider
 337 --                      letrec x = ...y...
 338 --                             y = ...x...
 339 --                      in ...x...
 340 --                 When we ask whether y is demanded we'll bind y to bottom and
 341 --                 evaluate the body of the letrec.  But that will result in our
 342 --                 deciding that y is absent, which is plain wrong!
 343 --              It's much easier simply not to do this.
 344
 345         improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
 346                                          str_vals abs_vals binders
 347
 348         new_pairs   = improved_binders `zip` new_rhss
 349
 350     return (Let (Rec new_pairs) new_body)
 351 \end{code}
 352
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsection[computeInfos]{Add computed info to binders}
 357 %*                                                                      *
 358 %************************************************************************
 359
 360 Important note (Sept 93).  @addStrictnessInfoToId@ is used only for
 361 let(rec) bound variables, and is use to attach the strictness (not
 362 demand) info to the binder.  We are careful to restrict this
 363 strictness info to the lambda-bound arguments which are actually
 364 visible, at the top level, lest we accidentally lose laziness by
 365 eagerly looking for an "extra" argument.  So we "dig for lambdas" in a
 366 rather syntactic way.
 367
 368 A better idea might be to have some kind of arity analysis to
 369 tell how many args could safely be grabbed.
 370
 371 \begin{code}
 372 addStrictnessInfoToId
 373         :: AbsVal               -- Abstract strictness value
 374         -> AbsVal               -- Ditto absence
 375         -> Id                   -- The id
 376         -> Id                   -- Augmented with strictness
 377
 378 addStrictnessInfoToId str_val abs_val binder
 379   = binder `setIdStrictness` findStrictness binder str_val abs_val
 380 \end{code}
 381
 382 \begin{code}
 383 addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
 384                   -> CoreExpr   -- The scope of the id
 385                   -> Id
 386                   -> Id                 -- Id augmented with Demand info
 387
 388 addDemandInfoToId dmd str_env abs_env expr binder
 389   = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
 390
 391 addDemandInfoToCaseBndr dmd str_env abs_env alts binder
 392   = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
 393 \end{code}
 394
 395 %************************************************************************
 396 %*                                                                      *
 397 \subsection{Monad used herein for stats}
 398 %*                                                                      *
 399 %************************************************************************
 400
 401 \begin{code}
 402 data SaStats
 403   = SaStats FastInt FastInt     -- total/marked-demanded lambda-bound
 404             FastInt FastInt     -- total/marked-demanded case-bound
 405             FastInt FastInt     -- total/marked-demanded let-bound
 406                                 -- (excl. top-level; excl. letrecs)
 407
 408 nullSaStats = SaStats
 409    (_ILIT(0)) (_ILIT(0))
 410    (_ILIT(0)) (_ILIT(0))
 411    (_ILIT(0)) (_ILIT(0))
 412
 413 tickLambda :: Id   -> SaM ()
 414 tickCases  :: [CoreBndr] -> SaM ()
 415 tickLet    :: Id   -> SaM ()
 416
 417 #ifndef OMIT_STRANAL_STATS
 418 type SaM a = State SaStats a
 419
 420 tickLambda var = modify $ \(SaStats tlam dlam tc dc tlet dlet)
 421   -> case (tick_demanded var (0,0)) of { (totB, demandedB) ->
 422      let tot = iUnbox totB ; demanded = iUnbox demandedB
 423      in SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet)
 424
 425 tickCases vars = modify $ \(SaStats tlam dlam tc dc tlet dlet)
 426   = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
 427     let tot = iUnbox totB ; demanded = iUnbox demandedB
 428     in  SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet)
 429
 430 tickLet var = modify $ \(SaStats tlam dlam tc dc tlet dlet)
 431   = case (tick_demanded var (0,0))        of { (totB, demandedB) ->
 432     let tot = iUnbox totB ; demanded = iUnbox demandedB
 433     in SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded))
 434
 435 tick_demanded var (tot, demanded)
 436   | isTyVar var = (tot, demanded)
 437   | otherwise
 438   = (tot + 1,
 439      if (isStrict (idDemandInfo var))
 440      then demanded + 1
 441      else demanded)
 442
 443 pp_stats (SaStats tlam dlam tc dc tlet dlet)
 444       = hcat [ptext (sLit "Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
 445               ptext (sLit "; Case vars: "), int (iBox dc),   char '/', int (iBox tc),
 446               ptext (sLit "; Let vars: "),  int (iBox dlet), char '/', int (iBox tlet)
 447         ]
 448
 449 #else /* OMIT_STRANAL_STATS */
 450 -- identity monad
 451 newtype SaM a = SaM { unSaM :: a }
 452
 453 instance Monad SaM where
 454     return x    = SaM x
 455     SaM x >>= f = f x
 456
 457 tickLambda var  = panic "OMIT_STRANAL_STATS: tickLambda"
 458 tickCases  vars = panic "OMIT_STRANAL_STATS: tickCases"
 459 tickLet    var  = panic "OMIT_STRANAL_STATS: tickLet"
 460
 461 #endif /* OMIT_STRANAL_STATS */
 462
 463 #endif /* OLD_STRICTNESS */
 464 \end{code}