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