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         do_all_strict = switch_chker AllStrict
  92
  93         -- mark each binder with its strictness
  94 #ifndef OMIT_STRANAL_STATS
  95         (binds_w_strictness, sa_stats)
  96           = sa_top_binds do_all_strict binds nullSaStats
  97 #else
  98         binds_w_strictness
  99           = sa_top_binds do_all_strict 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   :: Bool -> [PlainCoreBinding] -> [PlainCoreBinding]     -- exported
 155 sa_top_binds :: Bool -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported
 156
 157 saTopBinds do_all_strict binds
 158 #ifndef OMIT_STRANAL_STATS
 159   = fst (sa_top_binds do_all_strict binds nullSaStats)
 160 #else
 161   = sa_top_binds do_all_strict binds
 162 #endif
 163
 164 sa_top_binds do_all_strict binds
 165   = do_it (nullAbsValEnv do_all_strict) (nullAbsValEnv False) binds
 166   where
 167     do_it _    _    [] = returnSa []
 168     do_it senv aenv (b:bs)
 169       = saTopBind senv  aenv  b  `thenSa` \ (senv2, aenv2, new_b) ->
 170         do_it     senv2 aenv2 bs `thenSa` \ new_bs ->
 171         returnSa (new_b : new_bs)
 172 \end{code}
 173
 174 @saTopBind@ is only used for the top level.  We don't add any demand
 175 info to these ids because we can't work it out.  In any case, it
 176 doesn't do us any good to know whether top-level binders are sure to
 177 be used; we can't turn top-level @let@s into @case@s.
 178
 179 \begin{code}
 180 saTopBind :: StrictEnv -> AbsenceEnv
 181           -> PlainCoreBinding
 182           -> SaM (StrictEnv, AbsenceEnv, PlainCoreBinding)
 183
 184 saTopBind str_env abs_env (CoNonRec binder rhs)
 185   = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
 186     let
 187         str_rhs    = absEval StrAnal rhs str_env
 188         abs_rhs    = absEval AbsAnal rhs abs_env
 189
 190         widened_str_rhs = widen StrAnal str_rhs
 191         widened_abs_rhs = widen AbsAnal abs_rhs
 192                 -- The widening above is done for efficiency reasons.
 193                 -- See notes on CoLet case in SaAbsInt.lhs
 194
 195         new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs
 196                         binder
 197                         rhs
 198
 199           -- Augment environments with a mapping of the
 200           -- binder to its abstract values, computed by absEval
 201         new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
 202         new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
 203     in
 204     returnSa (new_str_env, new_abs_env, CoNonRec new_binder new_rhs)
 205
 206 saTopBind str_env abs_env (CoRec pairs)
 207   = let
 208         (binders,rhss) = unzip pairs
 209         str_rhss    = fixpoint StrAnal binders rhss str_env
 210         abs_rhss    = fixpoint AbsAnal binders rhss abs_env
 211                       -- fixpoint returns widened values
 212         new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
 213         new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
 214         new_binders = zipWith4 addStrictnessInfoToId str_rhss abs_rhss binders rhss
 215     in
 216     mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
 217     let
 218         new_pairs   = new_binders `zip` new_rhss
 219     in
 220     returnSa (new_str_env, new_abs_env, CoRec new_pairs)
 221 \end{code}
 222
 223 %************************************************************************
 224 %*                                                                      *
 225 \subsection[saExpr]{Strictness analysis of an expression}
 226 %*                                                                      *
 227 %************************************************************************
 228
 229 @saExpr@ computes the strictness of an expression within a given
 230 environment.
 231
 232 \begin{code}
 233 saExpr :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> SaM PlainCoreExpr
 234
 235 saExpr _ _ e@(CoVar _)      = returnSa e
 236 saExpr _ _ e@(CoLit _)      = returnSa e
 237 saExpr _ _ e@(CoCon _ _ _)  = returnSa e
 238 saExpr _ _ e@(CoPrim _ _ _) = returnSa e
 239
 240 saExpr str_env abs_env (CoLam args body)
 241   = saExpr str_env abs_env body `thenSa` \ new_body ->
 242     let
 243         new_args  = addDemandInfoToIds str_env abs_env body args
 244     in
 245     tickLambdas new_args        `thenSa_` -- stats
 246     returnSa (CoLam new_args new_body)
 247
 248 saExpr str_env abs_env (CoTyLam ty expr)
 249   = saExpr str_env abs_env expr `thenSa` \ new_expr ->
 250     returnSa (CoTyLam ty new_expr)
 251
 252 saExpr str_env abs_env (CoApp fun arg)
 253   = saExpr str_env abs_env fun  `thenSa` \ new_fun ->
 254     returnSa (CoApp new_fun arg)
 255
 256 saExpr str_env abs_env (CoTyApp expr ty)
 257   = saExpr str_env abs_env expr `thenSa` \ new_expr ->
 258     returnSa (CoTyApp new_expr ty)
 259
 260 saExpr str_env abs_env (CoSCC cc expr)
 261   = saExpr str_env abs_env expr `thenSa` \ new_expr ->
 262     returnSa (CoSCC cc new_expr)
 263
 264 saExpr str_env abs_env (CoCase expr (CoAlgAlts alts deflt))
 265   = saExpr    str_env abs_env expr  `thenSa` \ new_expr  ->
 266     saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
 267     mapSa sa_alt alts               `thenSa` \ new_alts  ->
 268     returnSa (CoCase new_expr (CoAlgAlts new_alts new_deflt))
 269   where
 270     sa_alt (con, binders, rhs)
 271       = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
 272         let
 273             new_binders = addDemandInfoToIds str_env abs_env rhs binders
 274         in
 275         tickCases new_binders       `thenSa_` -- stats
 276         returnSa (con, new_binders, new_rhs)
 277
 278 saExpr str_env abs_env (CoCase expr (CoPrimAlts 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 (CoCase new_expr (CoPrimAlts new_alts new_deflt))
 283   where
 284     sa_alt (lit, rhs)
 285       = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
 286         returnSa (lit, new_rhs)
 287
 288 saExpr str_env abs_env (CoLet (CoNonRec binder rhs) body)
 289   =     -- Analyse the RHS in the environment at hand
 290     saExpr str_env abs_env rhs  `thenSa` \ new_rhs  ->
 291     let
 292         -- Bind this binder to the abstract value of the RHS; analyse
 293         -- the body of the `let' in the extended environment.
 294         str_rhs_val     = absEval StrAnal rhs str_env
 295         abs_rhs_val     = absEval AbsAnal rhs abs_env
 296
 297         widened_str_rhs = widen StrAnal str_rhs_val
 298         widened_abs_rhs = widen AbsAnal abs_rhs_val
 299                 -- The widening above is done for efficiency reasons.
 300                 -- See notes on CoLet case in SaAbsInt.lhs
 301
 302         new_str_env     = addOneToAbsValEnv str_env binder widened_str_rhs
 303         new_abs_env     = addOneToAbsValEnv abs_env binder widened_abs_rhs
 304
 305         -- Now determine the strictness of this binder; use that info
 306         -- to record DemandInfo/StrictnessInfo in the binder.
 307         new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs
 308                         (addDemandInfoToId str_env abs_env body binder)
 309                         rhs
 310     in
 311     tickLet new_binder                  `thenSa_` -- stats
 312     saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
 313     returnSa (CoLet (CoNonRec new_binder new_rhs) new_body)
 314
 315 saExpr str_env abs_env (CoLet (CoRec pairs) body)
 316   = let
 317         (binders,rhss) = unzip pairs
 318         str_vals       = fixpoint StrAnal binders rhss str_env
 319         abs_vals       = fixpoint AbsAnal binders rhss abs_env
 320                          -- fixpoint returns widened values
 321         new_str_env    = growAbsValEnvList str_env (binders `zip` str_vals)
 322         new_abs_env    = growAbsValEnvList abs_env (binders `zip` abs_vals)
 323     in
 324     saExpr new_str_env new_abs_env body         `thenSa` \ new_body ->
 325     mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
 326     let
 327 --      new_binders      = addDemandInfoToIds new_str_env new_abs_env body binders
 328 --              DON'T add demand info in a CoRec!
 329 --              a) it's useless: we can't do let-to-case
 330 --              b) it's incorrect.  Consider
 331 --                      letrec x = ...y...
 332 --                             y = ...x...
 333 --                      in ...x...
 334 --                 When we ask whether y is demanded we'll bind y to bottom and
 335 --                 evaluate the body of the letrec.  But that will result in our
 336 --                 deciding that y is absent, which is plain wrong!
 337 --              It's much easier simply not to do this.
 338
 339         improved_binders = zipWith4 addStrictnessInfoToId str_vals abs_vals binders rhss
 340         whiter_than_white_binders = launder improved_binders
 341
 342         new_pairs   = whiter_than_white_binders `zip` new_rhss
 343     in
 344     returnSa (CoLet (CoRec new_pairs) new_body)
 345   where
 346     launder me = {-still-} me
 347 \end{code}
 348
 349 \begin{code}
 350 saDefault str_env abs_env CoNoDefault = returnSa CoNoDefault
 351
 352 saDefault str_env abs_env (CoBindDefault bdr rhs)
 353   = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
 354     let
 355         new_bdr = addDemandInfoToId str_env abs_env rhs bdr
 356     in
 357     tickCases [new_bdr]         `thenSa_` -- stats
 358     returnSa (CoBindDefault new_bdr new_rhs)
 359 \end{code}
 360
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \subsection[computeInfos]{Add computed info to binders}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 Important note (Sept 93).  @addStrictnessInfoToId@ is used only for let(rec)
 369 bound variables, and is use to attach the strictness (not demand) info
 370 to the binder.  We are careful to restrict this strictness info to the
 371 lambda-bound arguments which are actually visible, at the top level,
 372 lest we accidentally lose laziness by eagerly looking for an "extra" argument.
 373 So we "dig for lambdas" in a rather syntactic way.
 374
 375 A better idea might be to have some kind of arity analysis to
 376 tell how many args could safely be grabbed.
 377
 378 \begin{code}
 379 addStrictnessInfoToId
 380         :: AbsVal               -- Abstract strictness value
 381         -> AbsVal               -- Ditto absence
 382         -> Id                   -- The id
 383         -> PlainCoreExpr        -- Its RHS
 384         -> Id                   -- Augmented with strictness
 385
 386 addStrictnessInfoToId str_val abs_val binder body
 387   = if isWrapperId binder then
 388         binder  -- Avoid clobbering existing strictness info
 389                 -- (and, more importantly, worker info).
 390                 -- Deeply suspicious (SLPJ)
 391     else
 392     if (isBot str_val) then
 393         binder `addIdStrictness` mkBottomStrictnessInfo
 394     else
 395         case (digForLambdas body) of { (_, lambda_bounds, rhs) ->
 396         let
 397                 tys        = map getIdUniType lambda_bounds
 398                 strictness = findStrictness tys str_val abs_val
 399         in
 400         binder `addIdStrictness` mkStrictnessInfo strictness Nothing
 401         }
 402 \end{code}
 403
 404 \begin{code}
 405 addDemandInfoToId :: StrictEnv -> AbsenceEnv
 406                   -> PlainCoreExpr      -- The scope of the id
 407                   -> Id
 408                   -> Id                 -- Id augmented with Demand info
 409
 410 addDemandInfoToId str_env abs_env expr binder
 411   = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
 412
 413 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> [Id] -> [Id]
 414
 415 addDemandInfoToIds str_env abs_env expr binders
 416   = map (addDemandInfoToId str_env abs_env expr) binders
 417 \end{code}
 418
 419 %************************************************************************
 420 %*                                                                      *
 421 \subsection{Monad used herein for stats}
 422 %*                                                                      *
 423 %************************************************************************
 424
 425 \begin{code}
 426 data SaStats
 427   = SaStats FAST_INT FAST_INT   -- total/marked-demanded lambda-bound
 428             FAST_INT FAST_INT   -- total/marked-demanded case-bound
 429             FAST_INT FAST_INT   -- total/marked-demanded let-bound
 430                                 -- (excl. top-level; excl. letrecs)
 431
 432 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
 433
 434 thenSa        :: SaM a -> (a -> SaM b) -> SaM b
 435 thenSa_       :: SaM a -> SaM b -> SaM b
 436 returnSa      :: a -> SaM a
 437
 438 #ifdef __GLASGOW_HASKELL__
 439 {-# INLINE thenSa #-}
 440 {-# INLINE thenSa_ #-}
 441 {-# INLINE returnSa #-}
 442 #endif
 443
 444 tickLambdas :: [Id] -> SaM ()
 445 tickCases   :: [Id] -> SaM ()
 446 tickLet     :: Id   -> SaM ()
 447
 448 #ifndef OMIT_STRANAL_STATS
 449 type SaM a = SaStats -> (a, SaStats)
 450
 451 thenSa expr cont stats
 452   = case (expr stats) of { (result, stats1) ->
 453     cont result stats1 }
 454
 455 thenSa_ expr cont stats
 456   = case (expr stats) of { (_, stats1) ->
 457     cont stats1 }
 458
 459 returnSa x stats = (x, stats)
 460
 461 tickLambdas vars (SaStats tlam dlam tc dc tlet dlet)
 462   = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
 463     ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
 464
 465 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
 466   = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
 467     ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
 468
 469 tickLet var (SaStats tlam dlam tc dc tlet dlet)
 470   = case (tick_demanded var (0,0))        of { (IBOX(tot),IBOX(demanded)) ->
 471     ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
 472
 473 tick_demanded var (tot, demanded)
 474   = (tot + 1,
 475      if (willBeDemanded (getIdDemandInfo var))
 476      then demanded + 1
 477      else demanded)
 478
 479 #else {-OMIT_STRANAL_STATS-}
 480 -- identity monad
 481 type SaM a = a
 482
 483 thenSa expr cont = cont expr
 484
 485 thenSa_ expr cont = cont
 486
 487 returnSa x = x
 488
 489 tickLambdas vars = panic "OMIT_STRANAL_STATS: tickLambdas"
 490 tickCases   vars = panic "OMIT_STRANAL_STATS: tickCases"
 491 tickLet     var  = panic "OMIT_STRANAL_STATS: tickLet"
 492
 493 #endif {-OMIT_STRANAL_STATS-}
 494
 495 mapSa         :: (a -> SaM b) -> [a] -> SaM [b]
 496
 497 mapSa f []     = returnSa []
 498 mapSa f (x:xs)
 499   = f x         `thenSa` \ r  ->
 500     mapSa f xs  `thenSa` \ rs ->
 501     returnSa (r:rs)
 502 \end{code}