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,
  17                           getIdDemandInfo, setIdDemandInfo,
  18                           Id
  19                         )
  20 import IdInfo           ( mkStrictnessInfo )
  21 import CoreLint         ( beginPass, endPass )
  22 import Type             ( repType, splitFunTys )
  23 import ErrUtils         ( dumpIfSet )
  24 import SaAbsInt
  25 import SaLib
  26 import Demand           ( isStrict )
  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 @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 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           = addStrictnessInfoToId
 163                 widened_str_rhs widened_abs_rhs
 164                 binder
 165                 rhs
 166
 167           -- Augment environments with a mapping of the
 168           -- binder to its abstract values, computed by absEval
 169         new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
 170         new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
 171     in
 172     returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
 173
 174 saTopBind str_env abs_env (Rec pairs)
 175   = let
 176         (binders,rhss) = unzip pairs
 177         str_rhss    = fixpoint StrAnal binders rhss str_env
 178         abs_rhss    = fixpoint AbsAnal binders rhss abs_env
 179                       -- fixpoint returns widened values
 180         new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
 181         new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
 182         new_binders = zipWith4Equal "saTopBind" addStrictnessInfoToId
 183                                     str_rhss abs_rhss binders rhss
 184     in
 185     mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
 186     let
 187         new_pairs   = new_binders `zip` new_rhss
 188     in
 189     returnSa (new_str_env, new_abs_env, Rec new_pairs)
 190 \end{code}
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection[saExpr]{Strictness analysis of an expression}
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 @saExpr@ computes the strictness of an expression within a given
 199 environment.
 200
 201 \begin{code}
 202 saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
 203
 204 saExpr _ _ e@(Var _)    = returnSa e
 205 saExpr _ _ e@(Con  _ _) = returnSa e
 206 saExpr _ _ e@(Type _)   = returnSa e
 207
 208 saExpr str_env abs_env (Lam bndr body)
 209   =     -- Don't bother to set the demand-info on a lambda binder
 210         -- We do that only for let(rec)-bound functions
 211     saExpr str_env abs_env body `thenSa` \ new_body ->
 212     returnSa (Lam bndr new_body)
 213
 214 saExpr str_env abs_env (App fun arg)
 215   = saExpr str_env abs_env fun  `thenSa` \ new_fun ->
 216     saExpr str_env abs_env arg  `thenSa` \ new_arg ->
 217     returnSa (App new_fun new_arg)
 218
 219 saExpr str_env abs_env (Note note expr)
 220   = saExpr str_env abs_env expr `thenSa` \ new_expr ->
 221     returnSa (Note note new_expr)
 222
 223 saExpr str_env abs_env (Case expr case_bndr alts)
 224   = saExpr str_env abs_env expr         `thenSa` \ new_expr  ->
 225     mapSa sa_alt alts                   `thenSa` \ new_alts  ->
 226     let
 227         new_case_bndr = addDemandInfoToCaseBndr str_env abs_env alts case_bndr
 228     in
 229     returnSa (Case new_expr new_case_bndr new_alts)
 230   where
 231     sa_alt (con, binders, rhs)
 232       = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
 233         let
 234             new_binders = map add_demand_info binders
 235             add_demand_info bndr | isTyVar bndr = bndr
 236                                  | otherwise    = addDemandInfoToId str_env abs_env rhs bndr
 237         in
 238         tickCases new_binders       `thenSa_` -- stats
 239         returnSa (con, new_binders, new_rhs)
 240
 241 saExpr str_env abs_env (Let (NonRec binder rhs) body)
 242   =     -- Analyse the RHS in the environment at hand
 243     saExpr str_env abs_env rhs  `thenSa` \ new_rhs  ->
 244     let
 245         -- Bind this binder to the abstract value of the RHS; analyse
 246         -- the body of the `let' in the extended environment.
 247         str_rhs_val     = absEval StrAnal rhs str_env
 248         abs_rhs_val     = absEval AbsAnal rhs abs_env
 249
 250         widened_str_rhs = widen StrAnal str_rhs_val
 251         widened_abs_rhs = widen AbsAnal abs_rhs_val
 252                 -- The widening above is done for efficiency reasons.
 253                 -- See notes on Let case in SaAbsInt.lhs
 254
 255         new_str_env     = addOneToAbsValEnv str_env binder widened_str_rhs
 256         new_abs_env     = addOneToAbsValEnv abs_env binder widened_abs_rhs
 257
 258         -- Now determine the strictness of this binder; use that info
 259         -- to record DemandInfo/StrictnessInfo in the binder.
 260         new_binder = addStrictnessInfoToId
 261                         widened_str_rhs widened_abs_rhs
 262                         (addDemandInfoToId str_env abs_env body binder)
 263                         rhs
 264     in
 265     tickLet new_binder                  `thenSa_` -- stats
 266     saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
 267     returnSa (Let (NonRec new_binder new_rhs) new_body)
 268
 269 saExpr str_env abs_env (Let (Rec pairs) body)
 270   = let
 271         (binders,rhss) = unzip pairs
 272         str_vals       = fixpoint StrAnal binders rhss str_env
 273         abs_vals       = fixpoint AbsAnal binders rhss abs_env
 274                          -- fixpoint returns widened values
 275         new_str_env    = growAbsValEnvList str_env (binders `zip` str_vals)
 276         new_abs_env    = growAbsValEnvList abs_env (binders `zip` abs_vals)
 277     in
 278     saExpr new_str_env new_abs_env body         `thenSa` \ new_body ->
 279     mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
 280     let
 281 --      new_binders      = addDemandInfoToIds new_str_env new_abs_env body binders
 282 --              DON'T add demand info in a Rec!
 283 --              a) it's useless: we can't do let-to-case
 284 --              b) it's incorrect.  Consider
 285 --                      letrec x = ...y...
 286 --                             y = ...x...
 287 --                      in ...x...
 288 --                 When we ask whether y is demanded we'll bind y to bottom and
 289 --                 evaluate the body of the letrec.  But that will result in our
 290 --                 deciding that y is absent, which is plain wrong!
 291 --              It's much easier simply not to do this.
 292
 293         improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId
 294                                          str_vals abs_vals binders rhss
 295
 296         new_pairs   = improved_binders `zip` new_rhss
 297     in
 298     returnSa (Let (Rec new_pairs) new_body)
 299 \end{code}
 300
 301
 302 %************************************************************************
 303 %*                                                                      *
 304 \subsection[computeInfos]{Add computed info to binders}
 305 %*                                                                      *
 306 %************************************************************************
 307
 308 Important note (Sept 93).  @addStrictnessInfoToId@ is used only for
 309 let(rec) bound variables, and is use to attach the strictness (not
 310 demand) info to the binder.  We are careful to restrict this
 311 strictness info to the lambda-bound arguments which are actually
 312 visible, at the top level, lest we accidentally lose laziness by
 313 eagerly looking for an "extra" argument.  So we "dig for lambdas" in a
 314 rather syntactic way.
 315
 316 A better idea might be to have some kind of arity analysis to
 317 tell how many args could safely be grabbed.
 318
 319 \begin{code}
 320 addStrictnessInfoToId
 321         :: AbsVal               -- Abstract strictness value
 322         -> AbsVal               -- Ditto absence
 323         -> Id                   -- The id
 324         -> CoreExpr     -- Its RHS
 325         -> Id                   -- Augmented with strictness
 326
 327 addStrictnessInfoToId str_val abs_val binder body
 328   = binder `setIdStrictness` mkStrictnessInfo strictness
 329   where
 330     arg_tys = collect_arg_tys (idType binder)
 331     strictness = findStrictness arg_tys str_val abs_val
 332
 333     collect_arg_tys ty
 334         | null arg_tys = []
 335         | otherwise    = arg_tys ++ collect_arg_tys res_ty
 336         where
 337           (arg_tys, res_ty) = splitFunTys (repType ty)
 338     -- repType looks through for-alls and new-types.  And since we look on the
 339     -- type info, we aren't confused by INLINE prags.
 340     -- In particular, foldr is marked INLINE,
 341     -- but we still want it to be strict in its third arg, so that
 342     --  foldr k z (case e of p -> build g)
 343     -- gets transformed to
 344     --  case e of p -> foldr k z (build g)
 345     -- [foldr is only inlined late in compilation, after strictness analysis]
 346 \end{code}
 347
 348 \begin{code}
 349 addDemandInfoToId :: StrictEnv -> AbsenceEnv
 350                   -> CoreExpr   -- The scope of the id
 351                   -> Id
 352                   -> Id                 -- Id augmented with Demand info
 353
 354 addDemandInfoToId str_env abs_env expr binder
 355   = binder `setIdDemandInfo` (findDemand str_env abs_env expr binder)
 356
 357 addDemandInfoToCaseBndr str_env abs_env alts binder
 358   = binder `setIdDemandInfo` (findDemandAlts str_env abs_env alts binder)
 359
 360 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
 361
 362 addDemandInfoToIds str_env abs_env expr binders
 363   = map (addDemandInfoToId str_env abs_env expr) binders
 364 \end{code}
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 \subsection{Monad used herein for stats}
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 \begin{code}
 373 data SaStats
 374   = SaStats FAST_INT FAST_INT   -- total/marked-demanded lambda-bound
 375             FAST_INT FAST_INT   -- total/marked-demanded case-bound
 376             FAST_INT FAST_INT   -- total/marked-demanded let-bound
 377                                 -- (excl. top-level; excl. letrecs)
 378
 379 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
 380
 381 thenSa        :: SaM a -> (a -> SaM b) -> SaM b
 382 thenSa_       :: SaM a -> SaM b -> SaM b
 383 returnSa      :: a -> SaM a
 384
 385 {-# INLINE thenSa #-}
 386 {-# INLINE thenSa_ #-}
 387 {-# INLINE returnSa #-}
 388
 389 tickLambda :: Id   -> SaM ()
 390 tickCases  :: [CoreBndr] -> SaM ()
 391 tickLet    :: Id   -> SaM ()
 392
 393 #ifndef OMIT_STRANAL_STATS
 394 type SaM a = SaStats -> (a, SaStats)
 395
 396 thenSa expr cont stats
 397   = case (expr stats) of { (result, stats1) ->
 398     cont result stats1 }
 399
 400 thenSa_ expr cont stats
 401   = case (expr stats) of { (_, stats1) ->
 402     cont stats1 }
 403
 404 returnSa x stats = (x, stats)
 405
 406 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
 407   = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
 408     ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
 409
 410 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
 411   = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
 412     ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
 413
 414 tickLet var (SaStats tlam dlam tc dc tlet dlet)
 415   = case (tick_demanded var (0,0))        of { (IBOX(tot),IBOX(demanded)) ->
 416     ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
 417
 418 tick_demanded var (tot, demanded)
 419   | isTyVar var = (tot, demanded)
 420   | otherwise
 421   = (tot + 1,
 422      if (isStrict (getIdDemandInfo var))
 423      then demanded + 1
 424      else demanded)
 425
 426 pp_stats (SaStats tlam dlam tc dc tlet dlet)
 427       = hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam),
 428                     ptext SLIT("; Case vars: "), int IBOX(dc),   char '/', int IBOX(tc),
 429                     ptext SLIT("; Let vars: "),  int IBOX(dlet), char '/', int IBOX(tlet)
 430         ]
 431
 432 #else {-OMIT_STRANAL_STATS-}
 433 -- identity monad
 434 type SaM a = a
 435
 436 thenSa expr cont = cont expr
 437
 438 thenSa_ expr cont = cont
 439
 440 returnSa x = x
 441
 442 tickLambda var  = panic "OMIT_STRANAL_STATS: tickLambda"
 443 tickCases  vars = panic "OMIT_STRANAL_STATS: tickCases"
 444 tickLet    var  = panic "OMIT_STRANAL_STATS: tickLet"
 445
 446 #endif {-OMIT_STRANAL_STATS-}
 447
 448 mapSa         :: (a -> SaM b) -> [a] -> SaM [b]
 449
 450 mapSa f []     = returnSa []
 451 mapSa f (x:xs)
 452   = f x         `thenSa` \ r  ->
 453     mapSa f xs  `thenSa` \ rs ->
 454     returnSa (r:rs)
 455 \end{code}