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