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