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