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