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