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