ghc/compiler/stranal/StrictAnal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   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_Trace
  15 import Outputable
  16 import Pretty
  17
  18 import CmdLineOpts      ( GlobalSwitch(..) )
  19 import CoreSyn          -- ToDo: get pprCoreBinding straight from PlainCore?
  20 import Id               ( addIdDemandInfo, isWrapperId, addIdStrictness,
  21                           getIdUniType, getIdDemandInfo
  22                           IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling
  23                         )
  24 import IdEnv
  25 import IdInfo
  26 import PlainCore
  27 import SaAbsInt
  28 import SaLib
  29 import SplitUniq
  30 import Unique
  31 import Util
  32 import WorkWrap         -- "back-end" of strictness analyser
  33 import WwLib            ( WwM(..) )
  34 \end{code}
  35
  36
  37 %************************************************************************
  38 %*                                                                      *
  39 \subsection[Thoughts]{Random thoughts}
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 A note about worker-wrappering.  If we have
  44
  45         f :: Int -> Int
  46         f = let v = <expensive>
  47             in \x -> <body>
  48
  49 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
  50
  51         f = \x -> case x of Int x# -> fw x#
  52         fw = \x# -> let x = Int x#
  53                     in
  54                     let v = <expensive>
  55                     in <body>
  56
  57 because this obviously loses laziness, since now <expensive>
  58 is done each time.  Alas.
  59
  60 WATCH OUT!  This can mean that something is unboxed only to be
  61 boxed again. For example
  62
  63         g x y = f x
  64
  65 Here g is strict, and *will* split into worker-wrapper.  A call to
  66 g, with the wrapper inlined will then be
  67
  68         case arg of Int a# -> gw a#
  69
  70 Now g calls f, which has no wrapper, so it has to box it.
  71
  72         gw = \a# -> f (Int a#)
  73
  74 Alas and alack.
  75
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection[iface-StrictAnal]{Interface to the outside world}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 saWwTopBinds :: SplitUniqSupply
  85              -> (GlobalSwitch -> Bool)
  86              -> [PlainCoreBinding]
  87              -> [PlainCoreBinding]
  88
  89 saWwTopBinds us switch_chker binds
  90   = let
  91         strflags = (switch_chker AllStrict, switch_chker NumbersStrict)
  92
  93         -- mark each binder with its strictness
  94 #ifndef OMIT_STRANAL_STATS
  95         (binds_w_strictness, sa_stats)
  96           = sa_top_binds strflags binds nullSaStats
  97 #else
  98         binds_w_strictness
  99           = sa_top_binds strflags binds
 100 #endif
 101     in
 102     -- possibly show what we decided about strictness...
 103     (if switch_chker D_dump_stranal
 104      then pprTrace "Strictness:\n" (ppAboves (
 105            map (pprCoreBinding PprDebug pprBigCoreBinder pprBigCoreBinder ppr) binds_w_strictness))
 106      else id
 107     )
 108     -- possibly show how many things we marked as demanded...
 109     ((if switch_chker 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 switch_chker))
 121 #ifndef OMIT_STRANAL_STATS
 122   where
 123     pp_stats (SaStats tlam dlam tc dc tlet dlet)
 124       = pprTrace "Binders marked demanded: "
 125         (ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam),
 126                   ppStr "; Case vars: ",   ppInt IBOX(dc),   ppChar '/', ppInt IBOX(tc),
 127                   ppStr "; Let vars: ",    ppInt IBOX(dlet), ppChar '/', ppInt 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   :: StrAnalFlags -> [PlainCoreBinding] -> [PlainCoreBinding]     -- exported
 155 sa_top_binds :: StrAnalFlags -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported
 156
 157 saTopBinds strflags binds
 158 #ifndef OMIT_STRANAL_STATS
 159   = fst (sa_top_binds strflags binds nullSaStats)
 160 #else
 161   = sa_top_binds strflags binds
 162 #endif
 163
 164 sa_top_binds strflags binds
 165   = let
 166         starting_abs_env = nullAbsValEnv strflags
 167     in
 168     do_it starting_abs_env starting_abs_env binds
 169   where
 170     do_it _    _    [] = returnSa []
 171     do_it senv aenv (b:bs)
 172       = saTopBind senv  aenv  b  `thenSa` \ (senv2, aenv2, new_b) ->
 173         do_it     senv2 aenv2 bs `thenSa` \ new_bs ->
 174         returnSa (new_b : new_bs)
 175 \end{code}
 176
 177 @saTopBind@ is only used for the top level.  We don't add any demand
 178 info to these ids because we can't work it out.  In any case, it
 179 doesn't do us any good to know whether top-level binders are sure to
 180 be used; we can't turn top-level @let@s into @case@s.
 181
 182 \begin{code}
 183 saTopBind :: StrictEnv -> AbsenceEnv
 184           -> PlainCoreBinding
 185           -> SaM (StrictEnv, AbsenceEnv, PlainCoreBinding)
 186
 187 saTopBind str_env abs_env (CoNonRec binder rhs)
 188   = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
 189     let
 190         strflags = getStrAnalFlags str_env
 191
 192         str_rhs = absEval StrAnal rhs str_env
 193         abs_rhs = absEval AbsAnal rhs abs_env
 194
 195         widened_str_rhs = widen StrAnal str_rhs
 196         widened_abs_rhs = widen AbsAnal abs_rhs
 197                 -- The widening above is done for efficiency reasons.
 198                 -- See notes on CoLet case in SaAbsInt.lhs
 199
 200         new_binder
 201           = addStrictnessInfoToId
 202                 strflags
 203                 widened_str_rhs widened_abs_rhs
 204                 binder
 205                 rhs
 206
 207           -- Augment environments with a mapping of the
 208           -- binder to its abstract values, computed by absEval
 209         new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
 210         new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
 211     in
 212     returnSa (new_str_env, new_abs_env, CoNonRec new_binder new_rhs)
 213
 214 saTopBind str_env abs_env (CoRec pairs)
 215   = let
 216         strflags    = getStrAnalFlags str_env
 217         (binders,rhss) = unzip pairs
 218         str_rhss    = fixpoint StrAnal binders rhss str_env
 219         abs_rhss    = fixpoint AbsAnal binders rhss abs_env
 220                       -- fixpoint returns widened values
 221         new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
 222         new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
 223         new_binders = zipWith4 (addStrictnessInfoToId strflags)
 224                                 str_rhss abs_rhss binders rhss
 225     in
 226     mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
 227     let
 228         new_pairs   = new_binders `zip` new_rhss
 229     in
 230     returnSa (new_str_env, new_abs_env, CoRec new_pairs)
 231 \end{code}
 232
 233 %************************************************************************
 234 %*                                                                      *
 235 \subsection[saExpr]{Strictness analysis of an expression}
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 @saExpr@ computes the strictness of an expression within a given
 240 environment.
 241
 242 \begin{code}
 243 saExpr :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> SaM PlainCoreExpr
 244
 245 saExpr _ _ e@(CoVar _)      = returnSa e
 246 saExpr _ _ e@(CoLit _)      = returnSa e
 247 saExpr _ _ e@(CoCon _ _ _)  = returnSa e
 248 saExpr _ _ e@(CoPrim _ _ _) = returnSa e
 249
 250 saExpr str_env abs_env (CoLam args body)
 251   = saExpr str_env abs_env body `thenSa` \ new_body ->
 252     let
 253         new_args  = addDemandInfoToIds str_env abs_env body args
 254     in
 255     tickLambdas new_args        `thenSa_` -- stats
 256     returnSa (CoLam new_args new_body)
 257
 258 saExpr str_env abs_env (CoTyLam ty expr)
 259   = saExpr str_env abs_env expr `thenSa` \ new_expr ->
 260     returnSa (CoTyLam ty new_expr)
 261
 262 saExpr str_env abs_env (CoApp fun arg)
 263   = saExpr str_env abs_env fun  `thenSa` \ new_fun ->
 264     returnSa (CoApp new_fun arg)
 265
 266 saExpr str_env abs_env (CoTyApp expr ty)
 267   = saExpr str_env abs_env expr `thenSa` \ new_expr ->
 268     returnSa (CoTyApp new_expr ty)
 269
 270 saExpr str_env abs_env (CoSCC cc expr)
 271   = saExpr str_env abs_env expr `thenSa` \ new_expr ->
 272     returnSa (CoSCC cc new_expr)
 273
 274 saExpr str_env abs_env (CoCase expr (CoAlgAlts 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 (CoCase new_expr (CoAlgAlts 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 (CoCase expr (CoPrimAlts 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 (CoCase new_expr (CoPrimAlts 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 (CoLet (CoNonRec 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 CoLet 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 (CoLet (CoNonRec new_binder new_rhs) new_body)
 327
 328 saExpr str_env abs_env (CoLet (CoRec 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 CoRec!
 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 = zipWith4 (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 (CoLet (CoRec new_pairs) new_body)
 361   where
 362     launder me = {-still-} me
 363 \end{code}
 364
 365 \begin{code}
 366 saDefault str_env abs_env CoNoDefault = returnSa CoNoDefault
 367
 368 saDefault str_env abs_env (CoBindDefault 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 (CoBindDefault 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         -> PlainCoreExpr        -- 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 (digForLambdas body) of { (_, lambda_bounds, rhs) ->
 414         let
 415                 tys        = map getIdUniType 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                   -> PlainCoreExpr      -- 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 -> PlainCoreExpr -> [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 #ifdef __GLASGOW_HASKELL__
 457 {-# INLINE thenSa #-}
 458 {-# INLINE thenSa_ #-}
 459 {-# INLINE returnSa #-}
 460 #endif
 461
 462 tickLambdas :: [Id] -> SaM ()
 463 tickCases   :: [Id] -> SaM ()
 464 tickLet     :: Id   -> SaM ()
 465
 466 #ifndef OMIT_STRANAL_STATS
 467 type SaM a = SaStats -> (a, SaStats)
 468
 469 thenSa expr cont stats
 470   = case (expr stats) of { (result, stats1) ->
 471     cont result stats1 }
 472
 473 thenSa_ expr cont stats
 474   = case (expr stats) of { (_, stats1) ->
 475     cont stats1 }
 476
 477 returnSa x stats = (x, stats)
 478
 479 tickLambdas vars (SaStats tlam dlam tc dc tlet dlet)
 480   = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
 481     ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
 482
 483 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
 484   = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
 485     ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
 486
 487 tickLet var (SaStats tlam dlam tc dc tlet dlet)
 488   = case (tick_demanded var (0,0))        of { (IBOX(tot),IBOX(demanded)) ->
 489     ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
 490
 491 tick_demanded var (tot, demanded)
 492   = (tot + 1,
 493      if (willBeDemanded (getIdDemandInfo var))
 494      then demanded + 1
 495      else demanded)
 496
 497 #else {-OMIT_STRANAL_STATS-}
 498 -- identity monad
 499 type SaM a = a
 500
 501 thenSa expr cont = cont expr
 502
 503 thenSa_ expr cont = cont
 504
 505 returnSa x = x
 506
 507 tickLambdas vars = panic "OMIT_STRANAL_STATS: tickLambdas"
 508 tickCases   vars = panic "OMIT_STRANAL_STATS: tickCases"
 509 tickLet     var  = panic "OMIT_STRANAL_STATS: tickLet"
 510
 511 #endif {-OMIT_STRANAL_STATS-}
 512
 513 mapSa         :: (a -> SaM b) -> [a] -> SaM [b]
 514
 515 mapSa f []     = returnSa []
 516 mapSa f (x:xs)
 517   = f x         `thenSa` \ r  ->
 518     mapSa f xs  `thenSa` \ rs ->
 519     returnSa (r:rs)
 520 \end{code}