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