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