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