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