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 import 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 (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 (Case expr (AlgAlts alts deflt))
 275   = saExpr    str_env abs_env expr  `thenSa` \ new_expr  ->
 276     saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
 277     mapSa sa_alt alts               `thenSa` \ new_alts  ->
 278     returnSa (Case new_expr (AlgAlts new_alts new_deflt))
 279   where
 280     sa_alt (con, binders, rhs)
 281       = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
 282         let
 283             new_binders = addDemandInfoToIds str_env abs_env rhs binders
 284         in
 285         tickCases new_binders       `thenSa_` -- stats
 286         returnSa (con, new_binders, new_rhs)
 287
 288 saExpr str_env abs_env (Case expr (PrimAlts alts deflt))
 289   = saExpr    str_env abs_env expr  `thenSa` \ new_expr  ->
 290     saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
 291     mapSa sa_alt alts               `thenSa` \ new_alts  ->
 292     returnSa (Case new_expr (PrimAlts new_alts new_deflt))
 293   where
 294     sa_alt (lit, rhs)
 295       = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
 296         returnSa (lit, new_rhs)
 297
 298 saExpr str_env abs_env (Let (NonRec binder rhs) body)
 299   =     -- Analyse the RHS in the environment at hand
 300     saExpr str_env abs_env rhs  `thenSa` \ new_rhs  ->
 301     let
 302         strflags = getStrAnalFlags str_env
 303
 304         -- Bind this binder to the abstract value of the RHS; analyse
 305         -- the body of the `let' in the extended environment.
 306         str_rhs_val     = absEval StrAnal rhs str_env
 307         abs_rhs_val     = absEval AbsAnal rhs abs_env
 308
 309         widened_str_rhs = widen StrAnal str_rhs_val
 310         widened_abs_rhs = widen AbsAnal abs_rhs_val
 311                 -- The widening above is done for efficiency reasons.
 312                 -- See notes on Let case in SaAbsInt.lhs
 313
 314         new_str_env     = addOneToAbsValEnv str_env binder widened_str_rhs
 315         new_abs_env     = addOneToAbsValEnv abs_env binder widened_abs_rhs
 316
 317         -- Now determine the strictness of this binder; use that info
 318         -- to record DemandInfo/StrictnessInfo in the binder.
 319         new_binder = addStrictnessInfoToId strflags
 320                         widened_str_rhs widened_abs_rhs
 321                         (addDemandInfoToId str_env abs_env body binder)
 322                         rhs
 323     in
 324     tickLet new_binder                  `thenSa_` -- stats
 325     saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
 326     returnSa (Let (NonRec new_binder new_rhs) new_body)
 327
 328 saExpr str_env abs_env (Let (Rec pairs) body)
 329   = let
 330         strflags       = getStrAnalFlags str_env
 331         (binders,rhss) = unzip pairs
 332         str_vals       = fixpoint StrAnal binders rhss str_env
 333         abs_vals       = fixpoint AbsAnal binders rhss abs_env
 334                          -- fixpoint returns widened values
 335         new_str_env    = growAbsValEnvList str_env (binders `zip` str_vals)
 336         new_abs_env    = growAbsValEnvList abs_env (binders `zip` abs_vals)
 337     in
 338     saExpr new_str_env new_abs_env body         `thenSa` \ new_body ->
 339     mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
 340     let
 341 --      new_binders      = addDemandInfoToIds new_str_env new_abs_env body binders
 342 --              DON'T add demand info in a Rec!
 343 --              a) it's useless: we can't do let-to-case
 344 --              b) it's incorrect.  Consider
 345 --                      letrec x = ...y...
 346 --                             y = ...x...
 347 --                      in ...x...
 348 --                 When we ask whether y is demanded we'll bind y to bottom and
 349 --                 evaluate the body of the letrec.  But that will result in our
 350 --                 deciding that y is absent, which is plain wrong!
 351 --              It's much easier simply not to do this.
 352
 353         improved_binders = zipWith4Equal (addStrictnessInfoToId strflags)
 354                                          str_vals abs_vals binders rhss
 355
 356         whiter_than_white_binders = launder improved_binders
 357
 358         new_pairs   = whiter_than_white_binders `zip` new_rhss
 359     in
 360     returnSa (Let (Rec new_pairs) new_body)
 361   where
 362     launder me = {-still-} me
 363 \end{code}
 364
 365 \begin{code}
 366 saDefault str_env abs_env NoDefault = returnSa NoDefault
 367
 368 saDefault str_env abs_env (BindDefault bdr rhs)
 369   = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
 370     let
 371         new_bdr = addDemandInfoToId str_env abs_env rhs bdr
 372     in
 373     tickCases [new_bdr]         `thenSa_` -- stats
 374     returnSa (BindDefault new_bdr new_rhs)
 375 \end{code}
 376
 377
 378 %************************************************************************
 379 %*                                                                      *
 380 \subsection[computeInfos]{Add computed info to binders}
 381 %*                                                                      *
 382 %************************************************************************
 383
 384 Important note (Sept 93).  @addStrictnessInfoToId@ is used only for
 385 let(rec) bound variables, and is use to attach the strictness (not
 386 demand) info to the binder.  We are careful to restrict this
 387 strictness info to the lambda-bound arguments which are actually
 388 visible, at the top level, lest we accidentally lose laziness by
 389 eagerly looking for an "extra" argument.  So we "dig for lambdas" in a
 390 rather syntactic way.
 391
 392 A better idea might be to have some kind of arity analysis to
 393 tell how many args could safely be grabbed.
 394
 395 \begin{code}
 396 addStrictnessInfoToId
 397         :: StrAnalFlags
 398         -> AbsVal               -- Abstract strictness value
 399         -> AbsVal               -- Ditto absence
 400         -> Id                   -- The id
 401         -> CoreExpr     -- Its RHS
 402         -> Id                   -- Augmented with strictness
 403
 404 addStrictnessInfoToId strflags str_val abs_val binder body
 405   = if isWrapperId binder then
 406         binder  -- Avoid clobbering existing strictness info
 407                 -- (and, more importantly, worker info).
 408                 -- Deeply suspicious (SLPJ)
 409     else
 410     if (isBot str_val) then
 411         binder `addIdStrictness` mkBottomStrictnessInfo
 412     else
 413         case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
 414         let
 415                 tys        = map idType lambda_bounds
 416                 strictness = findStrictness strflags tys str_val abs_val
 417         in
 418         binder `addIdStrictness` mkStrictnessInfo strictness Nothing
 419         }
 420 \end{code}
 421
 422 \begin{code}
 423 addDemandInfoToId :: StrictEnv -> AbsenceEnv
 424                   -> CoreExpr   -- The scope of the id
 425                   -> Id
 426                   -> Id                 -- Id augmented with Demand info
 427
 428 addDemandInfoToId str_env abs_env expr binder
 429   = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
 430
 431 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
 432
 433 addDemandInfoToIds str_env abs_env expr binders
 434   = map (addDemandInfoToId str_env abs_env expr) binders
 435 \end{code}
 436
 437 %************************************************************************
 438 %*                                                                      *
 439 \subsection{Monad used herein for stats}
 440 %*                                                                      *
 441 %************************************************************************
 442
 443 \begin{code}
 444 data SaStats
 445   = SaStats FAST_INT FAST_INT   -- total/marked-demanded lambda-bound
 446             FAST_INT FAST_INT   -- total/marked-demanded case-bound
 447             FAST_INT FAST_INT   -- total/marked-demanded let-bound
 448                                 -- (excl. top-level; excl. letrecs)
 449
 450 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
 451
 452 thenSa        :: SaM a -> (a -> SaM b) -> SaM b
 453 thenSa_       :: SaM a -> SaM b -> SaM b
 454 returnSa      :: a -> SaM a
 455
 456 {-# INLINE thenSa #-}
 457 {-# INLINE thenSa_ #-}
 458 {-# INLINE returnSa #-}
 459
 460 tickLambda :: Id   -> SaM ()
 461 tickCases  :: [Id] -> SaM ()
 462 tickLet    :: Id   -> SaM ()
 463
 464 #ifndef OMIT_STRANAL_STATS
 465 type SaM a = SaStats -> (a, SaStats)
 466
 467 thenSa expr cont stats
 468   = case (expr stats) of { (result, stats1) ->
 469     cont result stats1 }
 470
 471 thenSa_ expr cont stats
 472   = case (expr stats) of { (_, stats1) ->
 473     cont stats1 }
 474
 475 returnSa x stats = (x, stats)
 476
 477 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
 478   = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
 479     ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
 480
 481 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
 482   = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
 483     ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
 484
 485 tickLet var (SaStats tlam dlam tc dc tlet dlet)
 486   = case (tick_demanded var (0,0))        of { (IBOX(tot),IBOX(demanded)) ->
 487     ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
 488
 489 tick_demanded var (tot, demanded)
 490   = (tot + 1,
 491      if (willBeDemanded (getIdDemandInfo var))
 492      then demanded + 1
 493      else demanded)
 494
 495 #else {-OMIT_STRANAL_STATS-}
 496 -- identity monad
 497 type SaM a = a
 498
 499 thenSa expr cont = cont expr
 500
 501 thenSa_ expr cont = cont
 502
 503 returnSa x = x
 504
 505 tickLambda var  = panic "OMIT_STRANAL_STATS: tickLambda"
 506 tickCases  vars = panic "OMIT_STRANAL_STATS: tickCases"
 507 tickLet    var  = panic "OMIT_STRANAL_STATS: tickLet"
 508
 509 #endif {-OMIT_STRANAL_STATS-}
 510
 511 mapSa         :: (a -> SaM b) -> [a] -> SaM [b]
 512
 513 mapSa f []     = returnSa []
 514 mapSa f (x:xs)
 515   = f x         `thenSa` \ r  ->
 516     mapSa f xs  `thenSa` \ rs ->
 517     returnSa (r:rs)
 518 \end{code}