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