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