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