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 CoreLint         ( showPass, endPass )
  21 import ErrUtils         ( dumpIfSet_dyn )
  22 import SaAbsInt
  23 import SaLib
  24 import Demand           ( Demand, wwStrict, isStrict, isLazy )
  25 import Util             ( zipWith3Equal, stretchZipWith, compareLength )
  26 import BasicTypes       ( Activation( NeverActive ) )
  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` NeverActive
 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 _)
 237                                    | compareLength ds args /= LT
 238                                               -- 'ds' is at least as long as 'args'.
 239                                         -> ds ++ minDemands
 240                                 other   -> minDemands
 241                  other -> minDemands
 242
 243     sa_args = stretchZipWith isTypeArg (error "saApp:dmd")
 244                              sa_arg args arg_dmds
 245         -- The arg_dmds are for value args only, we need to skip
 246         -- over the type args when pairing up with the demands
 247         -- Hence the stretchZipWith
 248
 249     sa_arg arg dmd = saExpr dmd' str_env abs_env arg
 250                    where
 251                         -- Bring arg demand up to minDemand
 252                         dmd' | isLazy dmd = minDemand
 253                              | otherwise  = dmd
 254
 255 saExpr _ _ _ e@(Var _)  = returnSa e
 256 saExpr _ _ _ e@(Lit _)  = returnSa e
 257 saExpr _ _ _ e@(Type _) = returnSa e
 258
 259 saExpr dmd str_env abs_env (Lam bndr body)
 260   =     -- Don't bother to set the demand-info on a lambda binder
 261         -- We do that only for let(rec)-bound functions
 262     saExpr minDemand str_env abs_env body       `thenSa` \ new_body ->
 263     returnSa (Lam bndr new_body)
 264
 265 saExpr dmd str_env abs_env e@(App fun arg)
 266   = saApp str_env abs_env (collectArgs e)
 267
 268 saExpr dmd str_env abs_env (Note note expr)
 269   = saExpr dmd str_env abs_env expr     `thenSa` \ new_expr ->
 270     returnSa (Note note new_expr)
 271
 272 saExpr dmd str_env abs_env (Case expr case_bndr alts)
 273   = saExpr minDemand str_env abs_env expr       `thenSa` \ new_expr  ->
 274     mapSa sa_alt alts                           `thenSa` \ new_alts  ->
 275     let
 276         new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
 277     in
 278     returnSa (Case new_expr new_case_bndr new_alts)
 279   where
 280     sa_alt (con, binders, rhs)
 281       = saExpr dmd str_env abs_env rhs  `thenSa` \ new_rhs ->
 282         let
 283             new_binders = map add_demand_info binders
 284             add_demand_info bndr | isTyVar bndr = bndr
 285                                  | otherwise    = addDemandInfoToId dmd str_env abs_env rhs bndr
 286         in
 287         tickCases new_binders       `thenSa_` -- stats
 288         returnSa (con, new_binders, new_rhs)
 289
 290 saExpr dmd str_env abs_env (Let (NonRec binder rhs) body)
 291   =     -- Analyse the RHS in the environment at hand
 292     let
 293         -- Find the demand on the RHS
 294         rhs_dmd = findDemand dmd str_env abs_env body binder
 295
 296         -- Bind this binder to the abstract value of the RHS; analyse
 297         -- the body of the `let' in the extended environment.
 298         str_rhs_val     = absEval StrAnal rhs str_env
 299         abs_rhs_val     = absEval AbsAnal rhs abs_env
 300
 301         widened_str_rhs = widen StrAnal str_rhs_val
 302         widened_abs_rhs = widen AbsAnal abs_rhs_val
 303                 -- The widening above is done for efficiency reasons.
 304                 -- See notes on Let case in SaAbsInt.lhs
 305
 306         new_str_env     = addOneToAbsValEnv str_env binder widened_str_rhs
 307         new_abs_env     = addOneToAbsValEnv abs_env binder widened_abs_rhs
 308
 309         -- Now determine the strictness of this binder; use that info
 310         -- to record DemandInfo/StrictnessInfo in the binder.
 311         new_binder = addStrictnessInfoToId
 312                         widened_str_rhs widened_abs_rhs
 313                         (binder `setIdDemandInfo` rhs_dmd)
 314     in
 315     tickLet new_binder                          `thenSa_` -- stats
 316     saExpr rhs_dmd str_env abs_env rhs          `thenSa` \ new_rhs  ->
 317     saExpr dmd new_str_env new_abs_env body     `thenSa` \ new_body ->
 318     returnSa (Let (NonRec new_binder new_rhs) new_body)
 319
 320 saExpr dmd str_env abs_env (Let (Rec pairs) body)
 321   = let
 322         (binders,rhss) = unzip pairs
 323         str_vals       = fixpoint StrAnal binders rhss str_env
 324         abs_vals       = fixpoint AbsAnal binders rhss abs_env
 325                          -- fixpoint returns widened values
 326         new_str_env    = growAbsValEnvList str_env (binders `zip` str_vals)
 327         new_abs_env    = growAbsValEnvList abs_env (binders `zip` abs_vals)
 328     in
 329     saExpr dmd new_str_env new_abs_env body                     `thenSa` \ new_body ->
 330     mapSa (saExpr minDemand new_str_env new_abs_env) rhss       `thenSa` \ new_rhss ->
 331     let
 332 --              DON'T add demand info in a Rec!
 333 --              a) it's useless: we can't do let-to-case
 334 --              b) it's incorrect.  Consider
 335 --                      letrec x = ...y...
 336 --                             y = ...x...
 337 --                      in ...x...
 338 --                 When we ask whether y is demanded we'll bind y to bottom and
 339 --                 evaluate the body of the letrec.  But that will result in our
 340 --                 deciding that y is absent, which is plain wrong!
 341 --              It's much easier simply not to do this.
 342
 343         improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
 344                                          str_vals abs_vals binders
 345
 346         new_pairs   = improved_binders `zip` new_rhss
 347     in
 348     returnSa (Let (Rec new_pairs) new_body)
 349 \end{code}
 350
 351
 352 %************************************************************************
 353 %*                                                                      *
 354 \subsection[computeInfos]{Add computed info to binders}
 355 %*                                                                      *
 356 %************************************************************************
 357
 358 Important note (Sept 93).  @addStrictnessInfoToId@ is used only for
 359 let(rec) bound variables, and is use to attach the strictness (not
 360 demand) info to the binder.  We are careful to restrict this
 361 strictness info to the lambda-bound arguments which are actually
 362 visible, at the top level, lest we accidentally lose laziness by
 363 eagerly looking for an "extra" argument.  So we "dig for lambdas" in a
 364 rather syntactic way.
 365
 366 A better idea might be to have some kind of arity analysis to
 367 tell how many args could safely be grabbed.
 368
 369 \begin{code}
 370 addStrictnessInfoToId
 371         :: AbsVal               -- Abstract strictness value
 372         -> AbsVal               -- Ditto absence
 373         -> Id                   -- The id
 374         -> Id                   -- Augmented with strictness
 375
 376 addStrictnessInfoToId str_val abs_val binder
 377   = binder `setIdStrictness` findStrictness binder str_val abs_val
 378 \end{code}
 379
 380 \begin{code}
 381 addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
 382                   -> CoreExpr   -- The scope of the id
 383                   -> Id
 384                   -> Id                 -- Id augmented with Demand info
 385
 386 addDemandInfoToId dmd str_env abs_env expr binder
 387   = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
 388
 389 addDemandInfoToCaseBndr dmd str_env abs_env alts binder
 390   = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
 391 \end{code}
 392
 393 %************************************************************************
 394 %*                                                                      *
 395 \subsection{Monad used herein for stats}
 396 %*                                                                      *
 397 %************************************************************************
 398
 399 \begin{code}
 400 data SaStats
 401   = SaStats FastInt FastInt     -- total/marked-demanded lambda-bound
 402             FastInt FastInt     -- total/marked-demanded case-bound
 403             FastInt FastInt     -- total/marked-demanded let-bound
 404                                 -- (excl. top-level; excl. letrecs)
 405
 406 nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0)
 407
 408 thenSa        :: SaM a -> (a -> SaM b) -> SaM b
 409 thenSa_       :: SaM a -> SaM b -> SaM b
 410 returnSa      :: a -> SaM a
 411
 412 {-# INLINE thenSa #-}
 413 {-# INLINE thenSa_ #-}
 414 {-# INLINE returnSa #-}
 415
 416 tickLambda :: Id   -> SaM ()
 417 tickCases  :: [CoreBndr] -> SaM ()
 418 tickLet    :: Id   -> SaM ()
 419
 420 #ifndef OMIT_STRANAL_STATS
 421 type SaM a = SaStats -> (a, SaStats)
 422
 423 thenSa expr cont stats
 424   = case (expr stats) of { (result, stats1) ->
 425     cont result stats1 }
 426
 427 thenSa_ expr cont stats
 428   = case (expr stats) of { (_, stats1) ->
 429     cont stats1 }
 430
 431 returnSa x stats = (x, stats)
 432
 433 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
 434   = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
 435     let tot = iUnbox totB ; demanded = iUnbox demandedB
 436     in
 437     ((), SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet) }
 438
 439 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
 440   = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
 441     let tot = iUnbox totB ; demanded = iUnbox demandedB
 442     in
 443     ((), SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) }
 444
 445 tickLet var (SaStats tlam dlam tc dc tlet dlet)
 446   = case (tick_demanded var (0,0))        of { (totB, demandedB) ->
 447     let tot = iUnbox totB ; demanded = iUnbox demandedB
 448     in
 449     ((), SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) }
 450
 451 tick_demanded var (tot, demanded)
 452   | isTyVar var = (tot, demanded)
 453   | otherwise
 454   = (tot + 1,
 455      if (isStrict (idDemandInfo var))
 456      then demanded + 1
 457      else demanded)
 458
 459 pp_stats (SaStats tlam dlam tc dc tlet dlet)
 460       = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
 461               ptext SLIT("; Case vars: "), int (iBox dc),   char '/', int (iBox tc),
 462               ptext SLIT("; Let vars: "),  int (iBox dlet), char '/', int (iBox tlet)
 463         ]
 464
 465 #else {-OMIT_STRANAL_STATS-}
 466 -- identity monad
 467 type SaM a = a
 468
 469 thenSa expr cont = cont expr
 470
 471 thenSa_ expr cont = cont
 472
 473 returnSa x = x
 474
 475 tickLambda var  = panic "OMIT_STRANAL_STATS: tickLambda"
 476 tickCases  vars = panic "OMIT_STRANAL_STATS: tickCases"
 477 tickLet    var  = panic "OMIT_STRANAL_STATS: tickLet"
 478
 479 #endif {-OMIT_STRANAL_STATS-}
 480
 481 mapSa         :: (a -> SaM b) -> [a] -> SaM [b]
 482
 483 mapSa f []     = returnSa []
 484 mapSa f (x:xs) = f x            `thenSa` \ r  ->
 485                  mapSa f xs     `thenSa` \ rs ->
 486                  returnSa (r:rs)
 487
 488 sequenceSa :: [SaM a] -> SaM [a]
 489 sequenceSa []     = returnSa []
 490 sequenceSa (m:ms) = m             `thenSa` \ r ->
 491                     sequenceSa ms `thenSa` \ rs ->
 492                     returnSa (r:rs)
 493 #endif /* DEBUG */
 494 \end{code}