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