ghc/compiler/stranal/StrictAnal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   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 #include "HsVersions.h"
  11
  12 module StrictAnal ( saWwTopBinds, saTopBinds ) where
  13
  14 IMP_Ubiq(){-uitous-}
  15
  16 import CmdLineOpts      ( opt_AllStrict, opt_NumbersStrict,
  17                           opt_D_dump_stranal, opt_D_simplifier_stats
  18                         )
  19 import CoreSyn
  20 import Id               ( idType, addIdStrictness, isWrapperId,
  21                           getIdDemandInfo, addIdDemandInfo,
  22                           GenId{-instance Outputable-}
  23                         )
  24 import IdInfo           ( mkStrictnessInfo, mkBottomStrictnessInfo,
  25                           mkDemandInfo, willBeDemanded, DemandInfo
  26                         )
  27 import PprCore          ( pprCoreBinding, pprBigCoreBinder )
  28 import PprStyle         ( PprStyle(..) )
  29 import PprType          ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
  30 import Pretty           ( ppBesides, ppStr, ppInt, ppChar, ppAboves )
  31 import SaAbsInt
  32 import SaLib
  33 import TyVar            ( GenTyVar{-instance Eq-} )
  34 import WorkWrap         -- "back-end" of strictness analyser
  35 import Unique           ( Unique{-instance Eq -} )
  36 import Util             ( zipWith4Equal, pprTrace, panic )
  37 \end{code}
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \subsection[Thoughts]{Random thoughts}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 A note about worker-wrappering.  If we have
  46
  47         f :: Int -> Int
  48         f = let v = <expensive>
  49             in \x -> <body>
  50
  51 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
  52
  53         f = \x -> case x of Int x# -> fw x#
  54         fw = \x# -> let x = Int x#
  55                     in
  56                     let v = <expensive>
  57                     in <body>
  58
  59 because this obviously loses laziness, since now <expensive>
  60 is done each time.  Alas.
  61
  62 WATCH OUT!  This can mean that something is unboxed only to be
  63 boxed again. For example
  64
  65         g x y = f x
  66
  67 Here g is strict, and *will* split into worker-wrapper.  A call to
  68 g, with the wrapper inlined will then be
  69
  70         case arg of Int a# -> gw a#
  71
  72 Now g calls f, which has no wrapper, so it has to box it.
  73
  74         gw = \a# -> f (Int a#)
  75
  76 Alas and alack.
  77
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 \subsection[iface-StrictAnal]{Interface to the outside world}
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 \begin{code}
  86 saWwTopBinds :: UniqSupply
  87              -> [CoreBinding]
  88              -> [CoreBinding]
  89
  90 saWwTopBinds us binds
  91   = let
  92         strflags = (opt_AllStrict, opt_NumbersStrict)
  93
  94         -- mark each binder with its strictness
  95 #ifndef OMIT_STRANAL_STATS
  96         (binds_w_strictness, sa_stats)
  97           = sa_top_binds strflags binds nullSaStats
  98 #else
  99         binds_w_strictness
 100           = sa_top_binds strflags binds
 101 #endif
 102     in
 103     -- possibly show what we decided about strictness...
 104     (if opt_D_dump_stranal
 105      then pprTrace "Strictness:\n" (ppAboves (
 106            map (pprCoreBinding PprDebug)  binds_w_strictness))
 107      else id
 108     )
 109     -- possibly show how many things we marked as demanded...
 110     ((if opt_D_simplifier_stats
 111 #ifndef OMIT_STRANAL_STATS
 112      then pp_stats sa_stats
 113 #else
 114      then id
 115 #endif
 116      else id
 117     )
 118         -- create worker/wrappers, and mark binders with their
 119         -- "strictness info" [which encodes their
 120         -- worker/wrapper-ness]
 121     (workersAndWrappers binds_w_strictness us))
 122 #ifndef OMIT_STRANAL_STATS
 123   where
 124     pp_stats (SaStats tlam dlam tc dc tlet dlet)
 125       = pprTrace "Binders marked demanded: "
 126         (ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam),
 127                   ppStr "; Case vars: ",   ppInt IBOX(dc),   ppChar '/', ppInt IBOX(tc),
 128                   ppStr "; Let vars: ",    ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet)
 129         ])
 130 #endif
 131 \end{code}
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection[saBinds]{Strictness analysis of bindings}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 [Some of the documentation about types, etc., in \tr{SaLib} may be
 140 helpful for understanding this module.]
 141
 142 @saTopBinds@ tags each binder in the program with its @Demand@.
 143 That tells how each binder is {\em used}; if @Strict@, then the binder
 144 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
 145 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
 146
 147 (The above info is actually recorded for posterity in each binder's
 148 IdInfo, notably its @DemandInfo@.)
 149
 150 We proceed by analysing the bindings top-to-bottom, building up an
 151 environment which maps @Id@s to their abstract values (i.e., an
 152 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
 153
 154 \begin{code}
 155 saTopBinds   :: StrAnalFlags -> [CoreBinding] -> [CoreBinding]     -- exported
 156 sa_top_binds :: StrAnalFlags -> [CoreBinding] -> SaM [CoreBinding] -- not exported
 157
 158 saTopBinds strflags binds
 159 #ifndef OMIT_STRANAL_STATS
 160   = fst (sa_top_binds strflags binds nullSaStats)
 161 #else
 162   = sa_top_binds strflags binds
 163 #endif
 164
 165 sa_top_binds strflags binds
 166   = let
 167         starting_abs_env = nullAbsValEnv strflags
 168     in
 169     do_it starting_abs_env starting_abs_env binds
 170   where
 171     do_it _    _    [] = returnSa []
 172     do_it senv aenv (b:bs)
 173       = saTopBind senv  aenv  b  `thenSa` \ (senv2, aenv2, new_b) ->
 174         do_it     senv2 aenv2 bs `thenSa` \ new_bs ->
 175         returnSa (new_b : new_bs)
 176 \end{code}
 177
 178 @saTopBind@ is only used for the top level.  We don't add any demand
 179 info to these ids because we can't work it out.  In any case, it
 180 doesn't do us any good to know whether top-level binders are sure to
 181 be used; we can't turn top-level @let@s into @case@s.
 182
 183 \begin{code}
 184 saTopBind :: StrictEnv -> AbsenceEnv
 185           -> CoreBinding
 186           -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
 187
 188 saTopBind str_env abs_env (NonRec binder rhs)
 189   = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
 190     let
 191         strflags = getStrAnalFlags str_env
 192
 193         str_rhs = absEval StrAnal rhs str_env
 194         abs_rhs = absEval AbsAnal rhs abs_env
 195
 196         widened_str_rhs = widen StrAnal str_rhs
 197         widened_abs_rhs = widen AbsAnal abs_rhs
 198                 -- The widening above is done for efficiency reasons.
 199                 -- See notes on Let case in SaAbsInt.lhs
 200
 201         new_binder
 202           = addStrictnessInfoToId
 203                 strflags
 204                 widened_str_rhs widened_abs_rhs
 205                 binder
 206                 rhs
 207
 208           -- Augment environments with a mapping of the
 209           -- binder to its abstract values, computed by absEval
 210         new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
 211         new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
 212     in
 213     returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
 214
 215 saTopBind str_env abs_env (Rec pairs)
 216   = let
 217         strflags    = getStrAnalFlags str_env
 218         (binders,rhss) = unzip pairs
 219         str_rhss    = fixpoint StrAnal binders rhss str_env
 220         abs_rhss    = fixpoint AbsAnal binders rhss abs_env
 221                       -- fixpoint returns widened values
 222         new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
 223         new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
 224         new_binders = zipWith4Equal "saTopBind" (addStrictnessInfoToId strflags)
 225                                     str_rhss abs_rhss binders rhss
 226     in
 227     mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
 228     let
 229         new_pairs   = new_binders `zip` new_rhss
 230     in
 231     returnSa (new_str_env, new_abs_env, Rec new_pairs)
 232 \end{code}
 233
 234 %************************************************************************
 235 %*                                                                      *
 236 \subsection[saExpr]{Strictness analysis of an expression}
 237 %*                                                                      *
 238 %************************************************************************
 239
 240 @saExpr@ computes the strictness of an expression within a given
 241 environment.
 242
 243 \begin{code}
 244 saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
 245
 246 saExpr _ _ e@(Var _)    = returnSa e
 247 saExpr _ _ e@(Lit _)    = returnSa e
 248 saExpr _ _ e@(Con  _ _) = returnSa e
 249 saExpr _ _ e@(Prim _ _) = returnSa e
 250
 251 saExpr str_env abs_env (Lam (ValBinder arg) body)
 252   = saExpr str_env abs_env body `thenSa` \ new_body ->
 253     let
 254         new_arg = addDemandInfoToId str_env abs_env body arg
 255     in
 256     tickLambda new_arg  `thenSa_` -- stats
 257     returnSa (Lam (ValBinder new_arg) new_body)
 258
 259 saExpr str_env abs_env (Lam other_binder expr)
 260   = saExpr str_env abs_env expr `thenSa` \ new_expr ->
 261     returnSa (Lam other_binder new_expr)
 262
 263 saExpr str_env abs_env (App fun arg)
 264   = saExpr str_env abs_env fun  `thenSa` \ new_fun ->
 265     returnSa (App new_fun arg)
 266
 267 saExpr str_env abs_env (SCC cc expr)
 268   = saExpr str_env abs_env expr `thenSa` \ new_expr ->
 269     returnSa (SCC cc new_expr)
 270
 271 saExpr str_env abs_env (Coerce c ty expr)
 272   = saExpr str_env abs_env expr `thenSa` \ new_expr ->
 273     returnSa (Coerce c ty new_expr)
 274
 275 saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
 276   = saExpr    str_env abs_env expr  `thenSa` \ new_expr  ->
 277     saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
 278     mapSa sa_alt alts               `thenSa` \ new_alts  ->
 279     returnSa (Case new_expr (AlgAlts new_alts new_deflt))
 280   where
 281     sa_alt (con, binders, rhs)
 282       = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
 283         let
 284             new_binders = addDemandInfoToIds str_env abs_env rhs binders
 285         in
 286         tickCases new_binders       `thenSa_` -- stats
 287         returnSa (con, new_binders, new_rhs)
 288
 289 saExpr str_env abs_env (Case expr (PrimAlts alts deflt))
 290   = saExpr    str_env abs_env expr  `thenSa` \ new_expr  ->
 291     saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
 292     mapSa sa_alt alts               `thenSa` \ new_alts  ->
 293     returnSa (Case new_expr (PrimAlts new_alts new_deflt))
 294   where
 295     sa_alt (lit, rhs)
 296       = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
 297         returnSa (lit, new_rhs)
 298
 299 saExpr str_env abs_env (Let (NonRec binder rhs) body)
 300   =     -- Analyse the RHS in the environment at hand
 301     saExpr str_env abs_env rhs  `thenSa` \ new_rhs  ->
 302     let
 303         strflags = getStrAnalFlags str_env
 304
 305         -- Bind this binder to the abstract value of the RHS; analyse
 306         -- the body of the `let' in the extended environment.
 307         str_rhs_val     = absEval StrAnal rhs str_env
 308         abs_rhs_val     = absEval AbsAnal rhs abs_env
 309
 310         widened_str_rhs = widen StrAnal str_rhs_val
 311         widened_abs_rhs = widen AbsAnal abs_rhs_val
 312                 -- The widening above is done for efficiency reasons.
 313                 -- See notes on Let case in SaAbsInt.lhs
 314
 315         new_str_env     = addOneToAbsValEnv str_env binder widened_str_rhs
 316         new_abs_env     = addOneToAbsValEnv abs_env binder widened_abs_rhs
 317
 318         -- Now determine the strictness of this binder; use that info
 319         -- to record DemandInfo/StrictnessInfo in the binder.
 320         new_binder = addStrictnessInfoToId strflags
 321                         widened_str_rhs widened_abs_rhs
 322                         (addDemandInfoToId str_env abs_env body binder)
 323                         rhs
 324     in
 325     tickLet new_binder                  `thenSa_` -- stats
 326     saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
 327     returnSa (Let (NonRec new_binder new_rhs) new_body)
 328
 329 saExpr str_env abs_env (Let (Rec pairs) body)
 330   = let
 331         strflags       = getStrAnalFlags str_env
 332         (binders,rhss) = unzip pairs
 333         str_vals       = fixpoint StrAnal binders rhss str_env
 334         abs_vals       = fixpoint AbsAnal binders rhss abs_env
 335                          -- fixpoint returns widened values
 336         new_str_env    = growAbsValEnvList str_env (binders `zip` str_vals)
 337         new_abs_env    = growAbsValEnvList abs_env (binders `zip` abs_vals)
 338     in
 339     saExpr new_str_env new_abs_env body         `thenSa` \ new_body ->
 340     mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
 341     let
 342 --      new_binders      = addDemandInfoToIds new_str_env new_abs_env body binders
 343 --              DON'T add demand info in a Rec!
 344 --              a) it's useless: we can't do let-to-case
 345 --              b) it's incorrect.  Consider
 346 --                      letrec x = ...y...
 347 --                             y = ...x...
 348 --                      in ...x...
 349 --                 When we ask whether y is demanded we'll bind y to bottom and
 350 --                 evaluate the body of the letrec.  But that will result in our
 351 --                 deciding that y is absent, which is plain wrong!
 352 --              It's much easier simply not to do this.
 353
 354         improved_binders = zipWith4Equal "saExpr" (addStrictnessInfoToId strflags)
 355                                          str_vals abs_vals binders rhss
 356
 357         whiter_than_white_binders = launder improved_binders
 358
 359         new_pairs   = whiter_than_white_binders `zip` new_rhss
 360     in
 361     returnSa (Let (Rec new_pairs) new_body)
 362   where
 363     launder me = {-still-} me
 364 \end{code}
 365
 366 \begin{code}
 367 saDefault str_env abs_env NoDefault = returnSa NoDefault
 368
 369 saDefault str_env abs_env (BindDefault bdr rhs)
 370   = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
 371     let
 372         new_bdr = addDemandInfoToId str_env abs_env rhs bdr
 373     in
 374     tickCases [new_bdr]         `thenSa_` -- stats
 375     returnSa (BindDefault new_bdr new_rhs)
 376 \end{code}
 377
 378
 379 %************************************************************************
 380 %*                                                                      *
 381 \subsection[computeInfos]{Add computed info to binders}
 382 %*                                                                      *
 383 %************************************************************************
 384
 385 Important note (Sept 93).  @addStrictnessInfoToId@ is used only for
 386 let(rec) bound variables, and is use to attach the strictness (not
 387 demand) info to the binder.  We are careful to restrict this
 388 strictness info to the lambda-bound arguments which are actually
 389 visible, at the top level, lest we accidentally lose laziness by
 390 eagerly looking for an "extra" argument.  So we "dig for lambdas" in a
 391 rather syntactic way.
 392
 393 A better idea might be to have some kind of arity analysis to
 394 tell how many args could safely be grabbed.
 395
 396 \begin{code}
 397 addStrictnessInfoToId
 398         :: StrAnalFlags
 399         -> AbsVal               -- Abstract strictness value
 400         -> AbsVal               -- Ditto absence
 401         -> Id                   -- The id
 402         -> CoreExpr     -- Its RHS
 403         -> Id                   -- Augmented with strictness
 404
 405 addStrictnessInfoToId strflags str_val abs_val binder body
 406
 407   | isBot str_val
 408   = binder `addIdStrictness` mkBottomStrictnessInfo
 409
 410   | otherwise
 411   = case (collectBinders body) of
 412         (_, _, [], rhs)            -> binder
 413         (_, _, lambda_bounds, rhs) -> binder `addIdStrictness`
 414                                       mkStrictnessInfo strictness Nothing
 415                 where
 416                     tys        = map idType lambda_bounds
 417                     strictness = findStrictness strflags tys str_val abs_val
 418 \end{code}
 419
 420 \begin{code}
 421 addDemandInfoToId :: StrictEnv -> AbsenceEnv
 422                   -> CoreExpr   -- The scope of the id
 423                   -> Id
 424                   -> Id                 -- Id augmented with Demand info
 425
 426 addDemandInfoToId str_env abs_env expr binder
 427   = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
 428
 429 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
 430
 431 addDemandInfoToIds str_env abs_env expr binders
 432   = map (addDemandInfoToId str_env abs_env expr) binders
 433 \end{code}
 434
 435 %************************************************************************
 436 %*                                                                      *
 437 \subsection{Monad used herein for stats}
 438 %*                                                                      *
 439 %************************************************************************
 440
 441 \begin{code}
 442 data SaStats
 443   = SaStats FAST_INT FAST_INT   -- total/marked-demanded lambda-bound
 444             FAST_INT FAST_INT   -- total/marked-demanded case-bound
 445             FAST_INT FAST_INT   -- total/marked-demanded let-bound
 446                                 -- (excl. top-level; excl. letrecs)
 447
 448 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
 449
 450 thenSa        :: SaM a -> (a -> SaM b) -> SaM b
 451 thenSa_       :: SaM a -> SaM b -> SaM b
 452 returnSa      :: a -> SaM a
 453
 454 {-# INLINE thenSa #-}
 455 {-# INLINE thenSa_ #-}
 456 {-# INLINE returnSa #-}
 457
 458 tickLambda :: Id   -> SaM ()
 459 tickCases  :: [Id] -> SaM ()
 460 tickLet    :: Id   -> SaM ()
 461
 462 #ifndef OMIT_STRANAL_STATS
 463 type SaM a = SaStats -> (a, SaStats)
 464
 465 thenSa expr cont stats
 466   = case (expr stats) of { (result, stats1) ->
 467     cont result stats1 }
 468
 469 thenSa_ expr cont stats
 470   = case (expr stats) of { (_, stats1) ->
 471     cont stats1 }
 472
 473 returnSa x stats = (x, stats)
 474
 475 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
 476   = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
 477     ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
 478
 479 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
 480   = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
 481     ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
 482
 483 tickLet var (SaStats tlam dlam tc dc tlet dlet)
 484   = case (tick_demanded var (0,0))        of { (IBOX(tot),IBOX(demanded)) ->
 485     ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
 486
 487 tick_demanded var (tot, demanded)
 488   = (tot + 1,
 489      if (willBeDemanded (getIdDemandInfo var))
 490      then demanded + 1
 491      else demanded)
 492
 493 #else {-OMIT_STRANAL_STATS-}
 494 -- identity monad
 495 type SaM a = a
 496
 497 thenSa expr cont = cont expr
 498
 499 thenSa_ expr cont = cont
 500
 501 returnSa x = x
 502
 503 tickLambda var  = panic "OMIT_STRANAL_STATS: tickLambda"
 504 tickCases  vars = panic "OMIT_STRANAL_STATS: tickCases"
 505 tickLet    var  = panic "OMIT_STRANAL_STATS: tickLet"
 506
 507 #endif {-OMIT_STRANAL_STATS-}
 508
 509 mapSa         :: (a -> SaM b) -> [a] -> SaM [b]
 510
 511 mapSa f []     = returnSa []
 512 mapSa f (x:xs)
 513   = f x         `thenSa` \ r  ->
 514     mapSa f xs  `thenSa` \ rs ->
 515     returnSa (r:rs)
 516 \end{code}