compiler/stranal/DmdAnal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5                         -----------------
   6                         A demand analysis
   7                         -----------------
   8
   9 \begin{code}
  10 {-# OPTIONS -w #-}
  11 -- The above warning supression flag is a temporary kludge.
  12 -- While working on this module you are encouraged to remove it and fix
  13 -- any warnings in the module. See
  14 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  15 -- for details
  16
  17 module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs,
  18                  both {- needed by WwLib -}
  19    ) where
  20
  21 #include "HsVersions.h"
  22
  23 import DynFlags         ( DynFlags, DynFlag(..) )
  24 import StaticFlags      ( opt_MaxWorkerArgs )
  25 import NewDemand        -- All of it
  26 import CoreSyn
  27 import PprCore
  28 import CoreUtils        ( exprIsHNF, exprIsTrivial, exprArity )
  29 import DataCon          ( dataConTyCon )
  30 import TyCon            ( isProductTyCon, isRecursiveTyCon )
  31 import Id               ( Id, idType, idInlinePragma,
  32                           isDataConWorkId, isGlobalId, idArity,
  33 #ifdef OLD_STRICTNESS
  34                           idDemandInfo,  idStrictness, idCprInfo, idName,
  35 #endif
  36                           idNewStrictness, idNewStrictness_maybe,
  37                           setIdNewStrictness, idNewDemandInfo,
  38                           idNewDemandInfo_maybe,
  39                           setIdNewDemandInfo
  40                         )
  41 #ifdef OLD_STRICTNESS
  42 import IdInfo           ( newStrictnessFromOld, newDemand )
  43 #endif
  44 import Var              ( Var )
  45 import VarEnv
  46 import TysWiredIn       ( unboxedPairDataCon )
  47 import TysPrim          ( realWorldStatePrimTy )
  48 import UniqFM           ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
  49                           keysUFM, minusUFM, ufmToList, filterUFM )
  50 import Type             ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
  51 import Coercion         ( coercionKind )
  52 import CoreLint         ( showPass, endPass )
  53 import Util             ( mapAndUnzip, lengthIs )
  54 import BasicTypes       ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
  55                           RecFlag(..), isRec )
  56 import Maybes           ( orElse, expectJust )
  57 import Outputable
  58
  59 import Data.List
  60 \end{code}
  61
  62 To think about
  63
  64 * set a noinline pragma on bottoming Ids
  65
  66 * Consider f x = x+1 `fatbar` error (show x)
  67   We'd like to unbox x, even if that means reboxing it in the error case.
  68
  69
  70 %************************************************************************
  71 %*                                                                      *
  72 \subsection{Top level stuff}
  73 %*                                                                      *
  74 %************************************************************************
  75
  76 \begin{code}
  77 dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
  78 dmdAnalPgm dflags binds
  79   = do {
  80         let { binds_plus_dmds = do_prog binds } ;
  81 #ifdef OLD_STRICTNESS
  82         -- Only if OLD_STRICTNESS is on, because only then is the old
  83         -- strictness analyser run
  84         let { dmd_changes = get_changes binds_plus_dmds } ;
  85         printDump (text "Changes in demands" $$ dmd_changes) ;
  86 #endif
  87         return binds_plus_dmds
  88     }
  89   where
  90     do_prog :: [CoreBind] -> [CoreBind]
  91     do_prog binds = snd $ mapAccumL dmdAnalTopBind emptySigEnv binds
  92
  93 dmdAnalTopBind :: SigEnv
  94                -> CoreBind
  95                -> (SigEnv, CoreBind)
  96 dmdAnalTopBind sigs (NonRec id rhs)
  97   = let
  98         (    _, _, (_,   rhs1)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs)
  99         (sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs1)
 100                 -- Do two passes to improve CPR information
 101                 -- See comments with ignore_cpr_info in mk_sig_ty
 102                 -- and with extendSigsWithLam
 103     in
 104     (sigs2, NonRec id2 rhs2)
 105
 106 dmdAnalTopBind sigs (Rec pairs)
 107   = let
 108         (sigs', _, pairs')  = dmdFix TopLevel sigs pairs
 109                 -- We get two iterations automatically
 110                 -- c.f. the NonRec case above
 111     in
 112     (sigs', Rec pairs')
 113 \end{code}
 114
 115 \begin{code}
 116 dmdAnalTopRhs :: CoreExpr -> (StrictSig, CoreExpr)
 117 -- Analyse the RHS and return
 118 --      a) appropriate strictness info
 119 --      b) the unfolding (decorated with stricntess info)
 120 dmdAnalTopRhs rhs
 121   = (sig, rhs2)
 122   where
 123     call_dmd       = vanillaCall (exprArity rhs)
 124     (_,      rhs1) = dmdAnal emptySigEnv call_dmd rhs
 125     (rhs_ty, rhs2) = dmdAnal emptySigEnv call_dmd rhs1
 126     sig            = mkTopSigTy rhs rhs_ty
 127         -- Do two passes; see notes with extendSigsWithLam
 128         -- Otherwise we get bogus CPR info for constructors like
 129         --      newtype T a = MkT a
 130         -- The constructor looks like (\x::T a -> x), modulo the coerce
 131         -- extendSigsWithLam will optimistically give x a CPR tag the
 132         -- first time, which is wrong in the end.
 133 \end{code}
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsection{The analyser itself}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr)
 143
 144 dmdAnal sigs Abs  e = (topDmdType, e)
 145
 146 dmdAnal sigs dmd e
 147   | not (isStrictDmd dmd)
 148   = let
 149         (res_ty, e') = dmdAnal sigs evalDmd e
 150     in
 151     (deferType res_ty, e')
 152         -- It's important not to analyse e with a lazy demand because
 153         -- a) When we encounter   case s of (a,b) ->
 154         --      we demand s with U(d1d2)... but if the overall demand is lazy
 155         --      that is wrong, and we'd need to reduce the demand on s,
 156         --      which is inconvenient
 157         -- b) More important, consider
 158         --      f (let x = R in x+x), where f is lazy
 159         --    We still want to mark x as demanded, because it will be when we
 160         --    enter the let.  If we analyse f's arg with a Lazy demand, we'll
 161         --    just mark x as Lazy
 162         -- c) The application rule wouldn't be right either
 163         --    Evaluating (f x) in a L demand does *not* cause
 164         --    evaluation of f in a C(L) demand!
 165
 166
 167 dmdAnal sigs dmd (Lit lit)
 168   = (topDmdType, Lit lit)
 169
 170 dmdAnal sigs dmd (Var var)
 171   = (dmdTransform sigs var dmd, Var var)
 172
 173 dmdAnal sigs dmd (Cast e co)
 174   = (dmd_ty, Cast e' co)
 175   where
 176     (dmd_ty, e') = dmdAnal sigs dmd' e
 177     to_co        = snd (coercionKind co)
 178     dmd'
 179       | Just (tc, args) <- splitTyConApp_maybe to_co
 180       , isRecursiveTyCon tc = evalDmd
 181       | otherwise           = dmd
 182         -- This coerce usually arises from a recursive
 183         -- newtype, and we don't want to look inside them
 184         -- for exactly the same reason that we don't look
 185         -- inside recursive products -- we might not reach
 186         -- a fixpoint.  So revert to a vanilla Eval demand
 187
 188 dmdAnal sigs dmd (Note n e)
 189   = (dmd_ty, Note n e')
 190   where
 191     (dmd_ty, e') = dmdAnal sigs dmd e
 192
 193 dmdAnal sigs dmd (App fun (Type ty))
 194   = (fun_ty, App fun' (Type ty))
 195   where
 196     (fun_ty, fun') = dmdAnal sigs dmd fun
 197
 198 -- Lots of the other code is there to make this
 199 -- beautiful, compositional, application rule :-)
 200 dmdAnal sigs dmd e@(App fun arg)        -- Non-type arguments
 201   = let                         -- [Type arg handled above]
 202         (fun_ty, fun')    = dmdAnal sigs (Call dmd) fun
 203         (arg_ty, arg')    = dmdAnal sigs arg_dmd arg
 204         (arg_dmd, res_ty) = splitDmdTy fun_ty
 205     in
 206     (res_ty `bothType` arg_ty, App fun' arg')
 207
 208 dmdAnal sigs dmd (Lam var body)
 209   | isTyVar var
 210   = let
 211         (body_ty, body') = dmdAnal sigs dmd body
 212     in
 213     (body_ty, Lam var body')
 214
 215   | Call body_dmd <- dmd        -- A call demand: good!
 216   = let
 217         sigs'            = extendSigsWithLam sigs var
 218         (body_ty, body') = dmdAnal sigs' body_dmd body
 219         (lam_ty, var')   = annotateLamIdBndr body_ty var
 220     in
 221     (lam_ty, Lam var' body')
 222
 223   | otherwise   -- Not enough demand on the lambda; but do the body
 224   = let         -- anyway to annotate it and gather free var info
 225         (body_ty, body') = dmdAnal sigs evalDmd body
 226         (lam_ty, var')   = annotateLamIdBndr body_ty var
 227     in
 228     (deferType lam_ty, Lam var' body')
 229
 230 dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
 231   | let tycon = dataConTyCon dc,
 232     isProductTyCon tycon,
 233     not (isRecursiveTyCon tycon)
 234   = let
 235         sigs_alt              = extendSigEnv NotTopLevel sigs case_bndr case_bndr_sig
 236         (alt_ty, alt')        = dmdAnalAlt sigs_alt dmd alt
 237         (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
 238         (_, bndrs', _)        = alt'
 239         case_bndr_sig         = cprSig
 240                 -- Inside the alternative, the case binder has the CPR property.
 241                 -- Meaning that a case on it will successfully cancel.
 242                 -- Example:
 243                 --      f True  x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 }
 244                 --      f False x = I# 3
 245                 --
 246                 -- We want f to have the CPR property:
 247                 --      f b x = case fw b x of { r -> I# r }
 248                 --      fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
 249                 --      fw False x = 3
 250
 251         -- Figure out whether the demand on the case binder is used, and use
 252         -- that to set the scrut_dmd.  This is utterly essential.
 253         -- Consider     f x = case x of y { (a,b) -> k y a }
 254         -- If we just take scrut_demand = U(L,A), then we won't pass x to the
 255         -- worker, so the worker will rebuild
 256         --      x = (a, absent-error)
 257         -- and that'll crash.
 258         -- So at one stage I had:
 259         --      dead_case_bndr           = isAbsentDmd (idNewDemandInfo case_bndr')
 260         --      keepity | dead_case_bndr = Drop
 261         --              | otherwise      = Keep
 262         --
 263         -- But then consider
 264         --      case x of y { (a,b) -> h y + a }
 265         -- where h : U(LL) -> T
 266         -- The above code would compute a Keep for x, since y is not Abs, which is silly
 267         -- The insight is, of course, that a demand on y is a demand on the
 268         -- scrutinee, so we need to `both` it with the scrut demand
 269
 270         alt_dmd            = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b])
 271         scrut_dmd          = alt_dmd `both`
 272                              idNewDemandInfo case_bndr'
 273
 274         (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
 275     in
 276     (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt'])
 277
 278 dmdAnal sigs dmd (Case scrut case_bndr ty alts)
 279   = let
 280         (alt_tys, alts')        = mapAndUnzip (dmdAnalAlt sigs dmd) alts
 281         (scrut_ty, scrut')      = dmdAnal sigs evalDmd scrut
 282         (alt_ty, case_bndr')    = annotateBndr (foldr1 lubType alt_tys) case_bndr
 283     in
 284 --    pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys)
 285     (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts')
 286
 287 dmdAnal sigs dmd (Let (NonRec id rhs) body)
 288   = let
 289         (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive sigs (id, rhs)
 290         (body_ty, body')              = dmdAnal sigs' dmd body
 291         (body_ty1, id2)               = annotateBndr body_ty id1
 292         body_ty2                      = addLazyFVs body_ty1 lazy_fv
 293     in
 294         -- If the actual demand is better than the vanilla call
 295         -- demand, you might think that we might do better to re-analyse
 296         -- the RHS with the stronger demand.
 297         -- But (a) That seldom happens, because it means that *every* path in
 298         --         the body of the let has to use that stronger demand
 299         -- (b) It often happens temporarily in when fixpointing, because
 300         --     the recursive function at first seems to place a massive demand.
 301         --     But we don't want to go to extra work when the function will
 302         --     probably iterate to something less demanding.
 303         -- In practice, all the times the actual demand on id2 is more than
 304         -- the vanilla call demand seem to be due to (b).  So we don't
 305         -- bother to re-analyse the RHS.
 306     (body_ty2, Let (NonRec id2 rhs') body')
 307
 308 dmdAnal sigs dmd (Let (Rec pairs) body)
 309   = let
 310         bndrs                    = map fst pairs
 311         (sigs', lazy_fv, pairs') = dmdFix NotTopLevel sigs pairs
 312         (body_ty, body')         = dmdAnal sigs' dmd body
 313         body_ty1                 = addLazyFVs body_ty lazy_fv
 314     in
 315     sigs' `seq` body_ty `seq`
 316     let
 317         (body_ty2, _) = annotateBndrs body_ty1 bndrs
 318                 -- Don't bother to add demand info to recursive
 319                 -- binders as annotateBndr does;
 320                 -- being recursive, we can't treat them strictly.
 321                 -- But we do need to remove the binders from the result demand env
 322     in
 323     (body_ty2,  Let (Rec pairs') body')
 324
 325
 326 dmdAnalAlt sigs dmd (con,bndrs,rhs)
 327   = let
 328         (rhs_ty, rhs')   = dmdAnal sigs dmd rhs
 329         (alt_ty, bndrs') = annotateBndrs rhs_ty bndrs
 330         final_alt_ty | io_hack_reqd = alt_ty `lubType` topDmdType
 331                      | otherwise    = alt_ty
 332
 333         -- There's a hack here for I/O operations.  Consider
 334         --      case foo x s of { (# s, r #) -> y }
 335         -- Is this strict in 'y'.  Normally yes, but what if 'foo' is an I/O
 336         -- operation that simply terminates the program (not in an erroneous way)?
 337         -- In that case we should not evaluate y before the call to 'foo'.
 338         -- Hackish solution: spot the IO-like situation and add a virtual branch,
 339         -- as if we had
 340         --      case foo x s of
 341         --         (# s, r #) -> y
 342         --         other      -> return ()
 343         -- So the 'y' isn't necessarily going to be evaluated
 344         --
 345         -- A more complete example where this shows up is:
 346         --      do { let len = <expensive> ;
 347         --         ; when (...) (exitWith ExitSuccess)
 348         --         ; print len }
 349
 350         io_hack_reqd = con == DataAlt unboxedPairDataCon &&
 351                        idType (head bndrs) `coreEqType` realWorldStatePrimTy
 352     in
 353     (final_alt_ty, (con, bndrs', rhs'))
 354 \end{code}
 355
 356 %************************************************************************
 357 %*                                                                      *
 358 \subsection{Bindings}
 359 %*                                                                      *
 360 %************************************************************************
 361
 362 \begin{code}
 363 dmdFix :: TopLevelFlag
 364        -> SigEnv                -- Does not include bindings for this binding
 365        -> [(Id,CoreExpr)]
 366        -> (SigEnv, DmdEnv,
 367            [(Id,CoreExpr)])     -- Binders annotated with stricness info
 368
 369 dmdFix top_lvl sigs orig_pairs
 370   = loop 1 initial_sigs orig_pairs
 371   where
 372     bndrs        = map fst orig_pairs
 373     initial_sigs = extendSigEnvList sigs [(id, (initialSig id, top_lvl)) | id <- bndrs]
 374
 375     loop :: Int
 376          -> SigEnv                      -- Already contains the current sigs
 377          -> [(Id,CoreExpr)]
 378          -> (SigEnv, DmdEnv, [(Id,CoreExpr)])
 379     loop n sigs pairs
 380       | found_fixpoint
 381       = (sigs', lazy_fv, pairs')
 382                 -- Note: use pairs', not pairs.   pairs' is the result of
 383                 -- processing the RHSs with sigs (= sigs'), whereas pairs
 384                 -- is the result of processing the RHSs with the *previous*
 385                 -- iteration of sigs.
 386
 387       | n >= 10  = pprTrace "dmdFix loop" (ppr n <+> (vcat
 388                                 [ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs],
 389                                   text "env:" <+> ppr (ufmToList sigs),
 390                                   text "binds:" <+> pprCoreBinding (Rec pairs)]))
 391                               (emptySigEnv, lazy_fv, orig_pairs)        -- Safe output
 392                         -- The lazy_fv part is really important!  orig_pairs has no strictness
 393                         -- info, including nothing about free vars.  But if we have
 394                         --      letrec f = ....y..... in ...f...
 395                         -- where 'y' is free in f, we must record that y is mentioned,
 396                         -- otherwise y will get recorded as absent altogether
 397
 398       | otherwise    = loop (n+1) sigs' pairs'
 399       where
 400         found_fixpoint = all (same_sig sigs sigs') bndrs
 401                 -- Use the new signature to do the next pair
 402                 -- The occurrence analyser has arranged them in a good order
 403                 -- so this can significantly reduce the number of iterations needed
 404         ((sigs',lazy_fv), pairs') = mapAccumL (my_downRhs top_lvl) (sigs, emptyDmdEnv) pairs
 405
 406     my_downRhs top_lvl (sigs,lazy_fv) (id,rhs)
 407         = -- pprTrace "downRhs {" (ppr id <+> (ppr old_sig))
 408           -- (new_sig `seq`
 409           --    pprTrace "downRhsEnd" (ppr id <+> ppr new_sig <+> char '}' )
 410           ((sigs', lazy_fv'), pair')
 411           --     )
 412         where
 413           (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive sigs (id,rhs)
 414           lazy_fv'                 = plusUFM_C both lazy_fv lazy_fv1
 415           -- old_sig               = lookup sigs id
 416           -- new_sig               = lookup sigs' id
 417
 418     same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
 419     lookup sigs var = case lookupVarEnv sigs var of
 420                         Just (sig,_) -> sig
 421
 422         -- Get an initial strictness signature from the Id
 423         -- itself.  That way we make use of earlier iterations
 424         -- of the fixpoint algorithm.  (Cunning plan.)
 425         -- Note that the cunning plan extends to the DmdEnv too,
 426         -- since it is part of the strictness signature
 427 initialSig id = idNewStrictness_maybe id `orElse` botSig
 428
 429 dmdAnalRhs :: TopLevelFlag -> RecFlag
 430         -> SigEnv -> (Id, CoreExpr)
 431         -> (SigEnv,  DmdEnv, (Id, CoreExpr))
 432 -- Process the RHS of the binding, add the strictness signature
 433 -- to the Id, and augment the environment with the signature as well.
 434
 435 dmdAnalRhs top_lvl rec_flag sigs (id, rhs)
 436  = (sigs', lazy_fv, (id', rhs'))
 437  where
 438   arity              = idArity id   -- The idArity should be up to date
 439                                     -- The simplifier was run just beforehand
 440   (rhs_dmd_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs
 441   (lazy_fv, sig_ty)  = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id )
 442                                 -- The RHS can be eta-reduced to just a variable,
 443                                 -- in which case we should not complain.
 444                        mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty
 445   id'                = id `setIdNewStrictness` sig_ty
 446   sigs'              = extendSigEnv top_lvl sigs id sig_ty
 447 \end{code}
 448
 449 %************************************************************************
 450 %*                                                                      *
 451 \subsection{Strictness signatures and types}
 452 %*                                                                      *
 453 %************************************************************************
 454
 455 \begin{code}
 456 mkTopSigTy :: CoreExpr -> DmdType -> StrictSig
 457         -- Take a DmdType and turn it into a StrictSig
 458         -- NB: not used for never-inline things; hence False
 459 mkTopSigTy rhs dmd_ty = snd (mk_sig_ty False False rhs dmd_ty)
 460
 461 mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
 462 mkSigTy top_lvl rec_flag id rhs dmd_ty
 463   = mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty
 464   where
 465     never_inline = isNeverActive (idInlinePragma id)
 466     maybe_id_dmd = idNewDemandInfo_maybe id
 467         -- Is Nothing the first time round
 468
 469     thunk_cpr_ok
 470         | isTopLevel top_lvl       = False      -- Top level things don't get
 471                                                 -- their demandInfo set at all
 472         | isRec rec_flag           = False      -- Ditto recursive things
 473         | Just dmd <- maybe_id_dmd = isStrictDmd dmd
 474         | otherwise                = True       -- Optimistic, first time round
 475                                                 -- See notes below
 476 \end{code}
 477
 478 The thunk_cpr_ok stuff [CPR-AND-STRICTNESS]
 479 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 480 If the rhs is a thunk, we usually forget the CPR info, because
 481 it is presumably shared (else it would have been inlined, and
 482 so we'd lose sharing if w/w'd it into a function).  E.g.
 483
 484         let r = case expensive of
 485                   (a,b) -> (b,a)
 486         in ...
 487
 488 If we marked r as having the CPR property, then we'd w/w into
 489
 490         let $wr = \() -> case expensive of
 491                             (a,b) -> (# b, a #)
 492             r = case $wr () of
 493                   (# b,a #) -> (b,a)
 494         in ...
 495
 496 But now r is a thunk, which won't be inlined, so we are no further ahead.
 497 But consider
 498
 499         f x = let r = case expensive of (a,b) -> (b,a)
 500               in if foo r then r else (x,x)
 501
 502 Does f have the CPR property?  Well, no.
 503
 504 However, if the strictness analyser has figured out (in a previous
 505 iteration) that it's strict, then we DON'T need to forget the CPR info.
 506 Instead we can retain the CPR info and do the thunk-splitting transform
 507 (see WorkWrap.splitThunk).
 508
 509 This made a big difference to PrelBase.modInt, which had something like
 510         modInt = \ x -> let r = ... -> I# v in
 511                         ...body strict in r...
 512 r's RHS isn't a value yet; but modInt returns r in various branches, so
 513 if r doesn't have the CPR property then neither does modInt
 514 Another case I found in practice (in Complex.magnitude), looks like this:
 515                 let k = if ... then I# a else I# b
 516                 in ... body strict in k ....
 517 (For this example, it doesn't matter whether k is returned as part of
 518 the overall result; but it does matter that k's RHS has the CPR property.)
 519 Left to itself, the simplifier will make a join point thus:
 520                 let $j k = ...body strict in k...
 521                 if ... then $j (I# a) else $j (I# b)
 522 With thunk-splitting, we get instead
 523                 let $j x = let k = I#x in ...body strict in k...
 524                 in if ... then $j a else $j b
 525 This is much better; there's a good chance the I# won't get allocated.
 526
 527 The difficulty with this is that we need the strictness type to
 528 look at the body... but we now need the body to calculate the demand
 529 on the variable, so we can decide whether its strictness type should
 530 have a CPR in it or not.  Simple solution:
 531         a) use strictness info from the previous iteration
 532         b) make sure we do at least 2 iterations, by doing a second
 533            round for top-level non-recs.  Top level recs will get at
 534            least 2 iterations except for totally-bottom functions
 535            which aren't very interesting anyway.
 536
 537 NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
 538
 539 The Nothing case in thunk_cpr_ok [CPR-AND-STRICTNESS]
 540 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 541 Demand info now has a 'Nothing' state, just like strictness info.
 542 The analysis works from 'dangerous' towards a 'safe' state; so we
 543 start with botSig for 'Nothing' strictness infos, and we start with
 544 "yes, it's demanded" for 'Nothing' in the demand info.  The
 545 fixpoint iteration will sort it all out.
 546
 547 We can't start with 'not-demanded' because then consider
 548         f x = let
 549                   t = ... I# x
 550               in
 551               if ... then t else I# y else f x'
 552
 553 In the first iteration we'd have no demand info for x, so assume
 554 not-demanded; then we'd get TopRes for f's CPR info.  Next iteration
 555 we'd see that t was demanded, and so give it the CPR property, but by
 556 now f has TopRes, so it will stay TopRes.  Instead, with the Nothing
 557 setting the first time round, we say 'yes t is demanded' the first
 558 time.
 559
 560 However, this does mean that for non-recursive bindings we must
 561 iterate twice to be sure of not getting over-optimistic CPR info,
 562 in the case where t turns out to be not-demanded.  This is handled
 563 by dmdAnalTopBind.
 564
 565
 566 Note [NOINLINE and strictness]
 567 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 568 The strictness analyser used to have a HACK which ensured that NOINLNE
 569 things were not strictness-analysed.  The reason was unsafePerformIO.
 570 Left to itself, the strictness analyser would discover this strictness
 571 for unsafePerformIO:
 572         unsafePerformIO:  C(U(AV))
 573 But then consider this sub-expression
 574         unsafePerformIO (\s -> let r = f x in
 575                                case writeIORef v r s of (# s1, _ #) ->
 576                                (# s1, r #)
 577 The strictness analyser will now find that r is sure to be eval'd,
 578 and may then hoist it out.  This makes tests/lib/should_run/memo002
 579 deadlock.
 580
 581 Solving this by making all NOINLINE things have no strictness info is overkill.
 582 In particular, it's overkill for runST, which is perfectly respectable.
 583 Consider
 584         f x = runST (return x)
 585 This should be strict in x.
 586
 587 So the new plan is to define unsafePerformIO using the 'lazy' combinator:
 588
 589         unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
 590
 591 Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
 592 magically NON-STRICT, and is inlined after strictness analysis.  So
 593 unsafePerformIO will look non-strict, and that's what we want.
 594
 595 Now we don't need the hack in the strictness analyser.  HOWEVER, this
 596 decision does mean that even a NOINLINE function is not entirely
 597 opaque: some aspect of its implementation leaks out, notably its
 598 strictness.  For example, if you have a function implemented by an
 599 error stub, but which has RULES, you may want it not to be eliminated
 600 in favour of error!
 601
 602
 603 \begin{code}
 604 mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res)
 605   = (lazy_fv, mkStrictSig dmd_ty)
 606         -- Re unused never_inline, see Note [NOINLINE and strictness]
 607   where
 608     dmd_ty = DmdType strict_fv final_dmds res'
 609
 610     lazy_fv   = filterUFM (not . isStrictDmd) fv
 611     strict_fv = filterUFM isStrictDmd         fv
 612         -- We put the strict FVs in the DmdType of the Id, so
 613         -- that at its call sites we unleash demands on its strict fvs.
 614         -- An example is 'roll' in imaginary/wheel-sieve2
 615         -- Something like this:
 616         --      roll x = letrec
 617         --                   go y = if ... then roll (x-1) else x+1
 618         --               in
 619         --               go ms
 620         -- We want to see that roll is strict in x, which is because
 621         -- go is called.   So we put the DmdEnv for x in go's DmdType.
 622         --
 623         -- Another example:
 624         --      f :: Int -> Int -> Int
 625         --      f x y = let t = x+1
 626         --          h z = if z==0 then t else
 627         --                if z==1 then x+1 else
 628         --                x + h (z-1)
 629         --      in
 630         --      h y
 631         -- Calling h does indeed evaluate x, but we can only see
 632         -- that if we unleash a demand on x at the call site for t.
 633         --
 634         -- Incidentally, here's a place where lambda-lifting h would
 635         -- lose the cigar --- we couldn't see the joint strictness in t/x
 636         --
 637         --      ON THE OTHER HAND
 638         -- We don't want to put *all* the fv's from the RHS into the
 639         -- DmdType, because that makes fixpointing very slow --- the
 640         -- DmdType gets full of lazy demands that are slow to converge.
 641
 642     final_dmds = setUnpackStrategy dmds
 643         -- Set the unpacking strategy
 644
 645     res' = case res of
 646                 RetCPR | ignore_cpr_info -> TopRes
 647                 other                    -> res
 648     ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
 649 \end{code}
 650
 651 The unpack strategy determines whether we'll *really* unpack the argument,
 652 or whether we'll just remember its strictness.  If unpacking would give
 653 rise to a *lot* of worker args, we may decide not to unpack after all.
 654
 655 \begin{code}
 656 setUnpackStrategy :: [Demand] -> [Demand]
 657 setUnpackStrategy ds
 658   = snd (go (opt_MaxWorkerArgs - nonAbsentArgs ds) ds)
 659   where
 660     go :: Int                   -- Max number of args available for sub-components of [Demand]
 661        -> [Demand]
 662        -> (Int, [Demand])       -- Args remaining after subcomponents of [Demand] are unpacked
 663
 664     go n (Eval (Prod cs) : ds)
 665         | n' >= 0   = Eval (Prod cs') `cons` go n'' ds
 666         | otherwise = Box (Eval (Prod cs)) `cons` go n ds
 667         where
 668           (n'',cs') = go n' cs
 669           n' = n + 1 - non_abs_args
 670                 -- Add one to the budget 'cos we drop the top-level arg
 671           non_abs_args = nonAbsentArgs cs
 672                 -- Delete # of non-absent args to which we'll now be committed
 673
 674     go n (d:ds) = d `cons` go n ds
 675     go n []     = (n,[])
 676
 677     cons d (n,ds) = (n, d:ds)
 678
 679 nonAbsentArgs :: [Demand] -> Int
 680 nonAbsentArgs []         = 0
 681 nonAbsentArgs (Abs : ds) = nonAbsentArgs ds
 682 nonAbsentArgs (d   : ds) = 1 + nonAbsentArgs ds
 683 \end{code}
 684
 685
 686 %************************************************************************
 687 %*                                                                      *
 688 \subsection{Strictness signatures and types}
 689 %*                                                                      *
 690 %************************************************************************
 691
 692 \begin{code}
 693 unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes
 694
 695 addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd
 696   | isTopLevel top_lvl = dmd_ty         -- Don't record top level things
 697   | otherwise          = DmdType (extendVarEnv fv var dmd) ds res
 698
 699 addLazyFVs (DmdType fv ds res) lazy_fvs
 700   = DmdType both_fv1 ds res
 701   where
 702     both_fv = (plusUFM_C both fv lazy_fvs)
 703     both_fv1 = modifyEnv (isBotRes res) (`both` Bot) lazy_fvs fv both_fv
 704         -- This modifyEnv is vital.  Consider
 705         --      let f = \x -> (x,y)
 706         --      in  error (f 3)
 707         -- Here, y is treated as a lazy-fv of f, but we must `both` that L
 708         -- demand with the bottom coming up from 'error'
 709         --
 710         -- I got a loop in the fixpointer without this, due to an interaction
 711         -- with the lazy_fv filtering in mkSigTy.  Roughly, it was
 712         --      letrec f n x
 713         --          = letrec g y = x `fatbar`
 714         --                         letrec h z = z + ...g...
 715         --                         in h (f (n-1) x)
 716         --      in ...
 717         -- In the initial iteration for f, f=Bot
 718         -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
 719         -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it
 720         -- places on its free variables.  Suppose it places none.  Then the
 721         --      x `fatbar` ...call to h...
 722         -- will give a x->V demand for x.  That turns into a L demand for x,
 723         -- which floats out of the defn for h.  Without the modifyEnv, that
 724         -- L demand doesn't get both'd with the Bot coming up from the inner
 725         -- call to f.  So we just get an L demand for x for g.
 726         --
 727         -- A better way to say this is that the lazy-fv filtering should give the
 728         -- same answer as putting the lazy fv demands in the function's type.
 729
 730 annotateBndr :: DmdType -> Var -> (DmdType, Var)
 731 -- The returned env has the var deleted
 732 -- The returned var is annotated with demand info
 733 -- No effect on the argument demands
 734 annotateBndr dmd_ty@(DmdType fv ds res) var
 735   | isTyVar var = (dmd_ty, var)
 736   | otherwise   = (DmdType fv' ds res, setIdNewDemandInfo var dmd)
 737   where
 738     (fv', dmd) = removeFV fv var res
 739
 740 annotateBndrs = mapAccumR annotateBndr
 741
 742 annotateLamIdBndr :: DmdType    -- Demand type of body
 743                   -> Id         -- Lambda binder
 744                   -> (DmdType,  -- Demand type of lambda
 745                       Id)       -- and binder annotated with demand
 746
 747 annotateLamIdBndr dmd_ty@(DmdType fv ds res) id
 748 -- For lambdas we add the demand to the argument demands
 749 -- Only called for Ids
 750   = ASSERT( isId id )
 751     (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)
 752   where
 753     (fv', dmd) = removeFV fv id res
 754     hacked_dmd = argDemand dmd
 755         -- This call to argDemand is vital, because otherwise we label
 756         -- a lambda binder with demand 'B'.  But in terms of calling
 757         -- conventions that's Abs, because we don't pass it.  But
 758         -- when we do a w/w split we get
 759         --      fw x = (\x y:B -> ...) x (error "oops")
 760         -- And then the simplifier things the 'B' is a strict demand
 761         -- and evaluates the (error "oops").  Sigh
 762
 763 removeFV fv id res = (fv', zapUnlifted id dmd)
 764                 where
 765                   fv' = fv `delVarEnv` id
 766                   dmd = lookupVarEnv fv id `orElse` deflt
 767                   deflt | isBotRes res = Bot
 768                         | otherwise    = Abs
 769
 770 -- For unlifted-type variables, we are only
 771 -- interested in Bot/Abs/Box Abs
 772 zapUnlifted is Bot = Bot
 773 zapUnlifted id Abs = Abs
 774 zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
 775                    | otherwise                  = dmd
 776 \end{code}
 777
 778 %************************************************************************
 779 %*                                                                      *
 780 \subsection{Strictness signatures}
 781 %*                                                                      *
 782 %************************************************************************
 783
 784 \begin{code}
 785 type SigEnv  = VarEnv (StrictSig, TopLevelFlag)
 786         -- We use the SigEnv to tell us whether to
 787         -- record info about a variable in the DmdEnv
 788         -- We do so if it's a LocalId, but not top-level
 789         --
 790         -- The DmdEnv gives the demand on the free vars of the function
 791         -- when it is given enough args to satisfy the strictness signature
 792
 793 emptySigEnv  = emptyVarEnv
 794
 795 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
 796 extendSigEnv top_lvl env var sig = extendVarEnv env var (sig, top_lvl)
 797
 798 extendSigEnvList = extendVarEnvList
 799
 800 extendSigsWithLam :: SigEnv -> Id -> SigEnv
 801 -- Extend the SigEnv when we meet a lambda binder
 802 -- If the binder is marked demanded with a product demand, then give it a CPR
 803 -- signature, because in the likely event that this is a lambda on a fn defn
 804 -- [we only use this when the lambda is being consumed with a call demand],
 805 -- it'll be w/w'd and so it will be CPR-ish.  E.g.
 806 --      f = \x::(Int,Int).  if ...strict in x... then
 807 --                              x
 808 --                          else
 809 --                              (a,b)
 810 -- We want f to have the CPR property because x does, by the time f has been w/w'd
 811 --
 812 -- Also note that we only want to do this for something that
 813 -- definitely has product type, else we may get over-optimistic
 814 -- CPR results (e.g. from \x -> x!).
 815
 816 extendSigsWithLam sigs id
 817   = case idNewDemandInfo_maybe id of
 818         Nothing               -> extendVarEnv sigs id (cprSig, NotTopLevel)
 819                 -- Optimistic in the Nothing case;
 820                 -- See notes [CPR-AND-STRICTNESS]
 821         Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel)
 822         other                 -> sigs
 823
 824
 825 dmdTransform :: SigEnv          -- The strictness environment
 826              -> Id              -- The function
 827              -> Demand          -- The demand on the function
 828              -> DmdType         -- The demand type of the function in this context
 829         -- Returned DmdEnv includes the demand on
 830         -- this function plus demand on its free variables
 831
 832 dmdTransform sigs var dmd
 833
 834 ------  DATA CONSTRUCTOR
 835   | isDataConWorkId var         -- Data constructor
 836   = let
 837         StrictSig dmd_ty    = idNewStrictness var       -- It must have a strictness sig
 838         DmdType _ _ con_res = dmd_ty
 839         arity               = idArity var
 840     in
 841     if arity == call_depth then         -- Saturated, so unleash the demand
 842         let
 843                 -- Important!  If we Keep the constructor application, then
 844                 -- we need the demands the constructor places (always lazy)
 845                 -- If not, we don't need to.  For example:
 846                 --      f p@(x,y) = (p,y)       -- S(AL)
 847                 --      g a b     = f (a,b)
 848                 -- It's vital that we don't calculate Absent for a!
 849            dmd_ds = case res_dmd of
 850                         Box (Eval ds) -> mapDmds box ds
 851                         Eval ds       -> ds
 852                         other         -> Poly Top
 853
 854                 -- ds can be empty, when we are just seq'ing the thing
 855                 -- If so we must make up a suitable bunch of demands
 856            arg_ds = case dmd_ds of
 857                       Poly d  -> replicate arity d
 858                       Prod ds -> ASSERT( ds `lengthIs` arity ) ds
 859
 860         in
 861         mkDmdType emptyDmdEnv arg_ds con_res
 862                 -- Must remember whether it's a product, hence con_res, not TopRes
 863     else
 864         topDmdType
 865
 866 ------  IMPORTED FUNCTION
 867   | isGlobalId var,             -- Imported function
 868     let StrictSig dmd_ty = idNewStrictness var
 869   = if dmdTypeDepth dmd_ty <= call_depth then   -- Saturated, so unleash the demand
 870         dmd_ty
 871     else
 872         topDmdType
 873
 874 ------  LOCAL LET/REC BOUND THING
 875   | Just (StrictSig dmd_ty, top_lvl) <- lookupVarEnv sigs var
 876   = let
 877         fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty
 878               | otherwise                         = deferType dmd_ty
 879         -- NB: it's important to use deferType, and not just return topDmdType
 880         -- Consider     let { f x y = p + x } in f 1
 881         -- The application isn't saturated, but we must nevertheless propagate
 882         --      a lazy demand for p!
 883     in
 884     addVarDmd top_lvl fn_ty var dmd
 885
 886 ------  LOCAL NON-LET/REC BOUND THING
 887   | otherwise                   -- Default case
 888   = unitVarDmd var dmd
 889
 890   where
 891     (call_depth, res_dmd) = splitCallDmd dmd
 892 \end{code}
 893
 894
 895 %************************************************************************
 896 %*                                                                      *
 897 \subsection{Demands}
 898 %*                                                                      *
 899 %************************************************************************
 900
 901 \begin{code}
 902 splitDmdTy :: DmdType -> (Demand, DmdType)
 903 -- Split off one function argument
 904 -- We already have a suitable demand on all
 905 -- free vars, so no need to add more!
 906 splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
 907 splitDmdTy ty@(DmdType fv [] res_ty)      = (resTypeArgDmd res_ty, ty)
 908
 909 splitCallDmd :: Demand -> (Int, Demand)
 910 splitCallDmd (Call d) = case splitCallDmd d of
 911                           (n, r) -> (n+1, r)
 912 splitCallDmd d        = (0, d)
 913
 914 vanillaCall :: Arity -> Demand
 915 vanillaCall 0 = evalDmd
 916 vanillaCall n = Call (vanillaCall (n-1))
 917
 918 deferType :: DmdType -> DmdType
 919 deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] TopRes
 920         -- Notice that we throw away info about both arguments and results
 921         -- For example,   f = let ... in \x -> x
 922         -- We don't want to get a stricness type V->T for f.
 923
 924 deferEnv :: DmdEnv -> DmdEnv
 925 deferEnv fv = mapVarEnv defer fv
 926
 927
 928 ----------------
 929 argDemand :: Demand -> Demand
 930 -- The 'Defer' demands are just Lazy at function boundaries
 931 -- Ugly!  Ask John how to improve it.
 932 argDemand Top       = lazyDmd
 933 argDemand (Defer d) = lazyDmd
 934 argDemand (Eval ds) = Eval (mapDmds argDemand ds)
 935 argDemand (Box Bot) = evalDmd
 936 argDemand (Box d)   = box (argDemand d)
 937 argDemand Bot       = Abs       -- Don't pass args that are consumed (only) by bottom
 938 argDemand d         = d
 939 \end{code}
 940
 941 \begin{code}
 942 -------------------------
 943 -- Consider (if x then y else []) with demand V
 944 -- Then the first branch gives {y->V} and the second
 945 --  *implicitly* has {y->A}.  So we must put {y->(V `lub` A)}
 946 -- in the result env.
 947 lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
 948   = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)
 949   where
 950     lub_fv  = plusUFM_C lub fv1 fv2
 951     lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv
 952     lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1
 953         -- lub is the identity for Bot
 954
 955         -- Extend the shorter argument list to match the longer
 956     lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2
 957     lub_ds []       []       = []
 958     lub_ds ds1      []       = map (`lub` resTypeArgDmd r2) ds1
 959     lub_ds []       ds2      = map (resTypeArgDmd r1 `lub`) ds2
 960
 961 -----------------------------------
 962 -- (t1 `bothType` t2) takes the argument/result info from t1,
 963 -- using t2 just for its free-var info
 964 -- NB: Don't forget about r2!  It might be BotRes, which is
 965 --     a bottom demand on all the in-scope variables.
 966 -- Peter: can this be done more neatly?
 967 bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
 968   = DmdType both_fv2 ds1 (r1 `bothRes` r2)
 969   where
 970     both_fv  = plusUFM_C both fv1 fv2
 971     both_fv1 = modifyEnv (isBotRes r1) (`both` Bot) fv2 fv1 both_fv
 972     both_fv2 = modifyEnv (isBotRes r2) (`both` Bot) fv1 fv2 both_fv1
 973         -- both is the identity for Abs
 974 \end{code}
 975
 976
 977 \begin{code}
 978 lubRes BotRes r      = r
 979 lubRes r      BotRes = r
 980 lubRes RetCPR RetCPR = RetCPR
 981 lubRes r1     r2     = TopRes
 982
 983 -- If either diverges, the whole thing does
 984 -- Otherwise take CPR info from the first
 985 bothRes r1 BotRes = BotRes
 986 bothRes r1 r2     = r1
 987 \end{code}
 988
 989 \begin{code}
 990 modifyEnv :: Bool                       -- No-op if False
 991           -> (Demand -> Demand)         -- The zapper
 992           -> DmdEnv -> DmdEnv           -- Env1 and Env2
 993           -> DmdEnv -> DmdEnv           -- Transform this env
 994         -- Zap anything in Env1 but not in Env2
 995         -- Assume: dom(env) includes dom(Env1) and dom(Env2)
 996
 997 modifyEnv need_to_modify zapper env1 env2 env
 998   | need_to_modify = foldr zap env (keysUFM (env1 `minusUFM` env2))
 999   | otherwise      = env
1000   where
1001     zap uniq env = addToUFM_Directly env uniq (zapper current_val)
1002                  where
1003                    current_val = expectJust "modifyEnv" (lookupUFM_Directly env uniq)
1004 \end{code}
1005
1006
1007 %************************************************************************
1008 %*                                                                      *
1009 \subsection{LUB and BOTH}
1010 %*                                                                      *
1011 %************************************************************************
1012
1013 \begin{code}
1014 lub :: Demand -> Demand -> Demand
1015
1016 lub Bot         d2 = d2
1017 lub Abs         d2 = absLub d2
1018 lub Top         d2 = Top
1019 lub (Defer ds1) d2 = defer (Eval ds1 `lub` d2)
1020
1021 lub (Call d1)   (Call d2)    = Call (d1 `lub` d2)
1022 lub d1@(Call _) (Box d2)     = d1 `lub` d2      -- Just strip the box
1023 lub d1@(Call _) d2@(Eval _)  = d2               -- Presumably seq or vanilla eval
1024 lub d1@(Call _) d2           = d2 `lub` d1      -- Bot, Abs, Top
1025
1026 -- For the Eval case, we use these approximation rules
1027 -- Box Bot       <= Eval (Box Bot ...)
1028 -- Box Top       <= Defer (Box Bot ...)
1029 -- Box (Eval ds) <= Eval (map Box ds)
1030 lub (Eval ds1)  (Eval ds2)        = Eval (ds1 `lubs` ds2)
1031 lub (Eval ds1)  (Box Bot)         = Eval (mapDmds (`lub` Box Bot) ds1)
1032 lub (Eval ds1)  (Box (Eval ds2)) = Eval (ds1 `lubs` mapDmds box ds2)
1033 lub (Eval ds1)  (Box Abs)        = deferEval (mapDmds (`lub` Box Bot) ds1)
1034 lub d1@(Eval _) d2                = d2 `lub` d1 -- Bot,Abs,Top,Call,Defer
1035
1036 lub (Box d1)   (Box d2) = box (d1 `lub` d2)
1037 lub d1@(Box _)  d2      = d2 `lub` d1
1038
1039 lubs ds1 ds2 = zipWithDmds lub ds1 ds2
1040
1041 ---------------------
1042 -- box is the smart constructor for Box
1043 -- It computes <B,bot> & d
1044 -- INVARIANT: (Box d) => d = Bot, Abs, Eval
1045 -- Seems to be no point in allowing (Box (Call d))
1046 box (Call d)  = Call d  -- The odd man out.  Why?
1047 box (Box d)   = Box d
1048 box (Defer _) = lazyDmd
1049 box Top       = lazyDmd -- Box Abs and Box Top
1050 box Abs       = lazyDmd -- are the same <B,L>
1051 box d         = Box d   -- Bot, Eval
1052
1053 ---------------
1054 defer :: Demand -> Demand
1055
1056 -- defer is the smart constructor for Defer
1057 -- The idea is that (Defer ds) = <U(ds), L>
1058 --
1059 -- It specifies what happens at a lazy function argument
1060 -- or a lambda; the L* operator
1061 -- Set the strictness part to L, but leave
1062 -- the boxity side unaffected
1063 -- It also ensures that Defer (Eval [LLLL]) = L
1064
1065 defer Bot        = Abs
1066 defer Abs        = Abs
1067 defer Top        = Top
1068 defer (Call _)   = lazyDmd      -- Approximation here?
1069 defer (Box _)    = lazyDmd
1070 defer (Defer ds) = Defer ds
1071 defer (Eval ds)  = deferEval ds
1072
1073 -- deferEval ds = defer (Eval ds)
1074 deferEval ds | allTop ds = Top
1075              | otherwise  = Defer ds
1076
1077 ---------------------
1078 absLub :: Demand -> Demand
1079 -- Computes (Abs `lub` d)
1080 -- For the Bot case consider
1081 --      f x y = if ... then x else error x
1082 --   Then for y we get Abs `lub` Bot, and we really
1083 --   want Abs overall
1084 absLub Bot        = Abs
1085 absLub Abs        = Abs
1086 absLub Top        = Top
1087 absLub (Call _)   = Top
1088 absLub (Box _)    = Top
1089 absLub (Eval ds)  = Defer (absLubs ds)  -- Or (Defer ds)?
1090 absLub (Defer ds) = Defer (absLubs ds)  -- Or (Defer ds)?
1091
1092 absLubs = mapDmds absLub
1093
1094 ---------------
1095 both :: Demand -> Demand -> Demand
1096
1097 both Abs d2 = d2
1098
1099 both Bot Bot       = Bot
1100 both Bot Abs       = Bot
1101 both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds)
1102         -- Consider
1103         --      f x = error x
1104         -- From 'error' itself we get demand Bot on x
1105         -- From the arg demand on x we get
1106         --      x :-> evalDmd = Box (Eval (Poly Abs))
1107         -- So we get  Bot `both` Box (Eval (Poly Abs))
1108         --          = Seq Keep (Poly Bot)
1109         --
1110         -- Consider also
1111         --      f x = if ... then error (fst x) else fst x
1112         -- Then we get (Eval (Box Bot, Bot) `lub` Eval (SA))
1113         --      = Eval (SA)
1114         -- which is what we want.
1115 both Bot d = errDmd
1116
1117 both Top Bot         = errDmd
1118 both Top Abs         = Top
1119 both Top Top         = Top
1120 both Top (Box d)    = Box d
1121 both Top (Call d)   = Call d
1122 both Top (Eval ds)  = Eval (mapDmds (`both` Top) ds)
1123 both Top (Defer ds)     -- = defer (Top `both` Eval ds)
1124                         -- = defer (Eval (mapDmds (`both` Top) ds))
1125                      = deferEval (mapDmds (`both` Top) ds)
1126
1127
1128 both (Box d1)   (Box d2)    = box (d1 `both` d2)
1129 both (Box d1)   d2@(Call _) = box (d1 `both` d2)
1130 both (Box d1)   d2@(Eval _) = box (d1 `both` d2)
1131 both (Box d1)   (Defer d2)  = Box d1
1132 both d1@(Box _) d2          = d2 `both` d1
1133
1134 both (Call d1)   (Call d2)   = Call (d1 `both` d2)
1135 both (Call d1)   (Eval ds2)  = Call d1  -- Could do better for (Poly Bot)?
1136 both (Call d1)   (Defer ds2) = Call d1  -- Ditto
1137 both d1@(Call _) d2          = d1 `both` d1
1138
1139 both (Eval ds1)    (Eval  ds2) = Eval (ds1 `boths` ds2)
1140 both (Eval ds1)    (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2)
1141 both d1@(Eval ds1) d2          = d2 `both` d1
1142
1143 both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2)
1144 both d1@(Defer ds1) d2       = d2 `both` d1
1145
1146 boths ds1 ds2 = zipWithDmds both ds1 ds2
1147 \end{code}
1148
1149
1150
1151 %************************************************************************
1152 %*                                                                      *
1153 \subsection{Miscellaneous
1154 %*                                                                      *
1155 %************************************************************************
1156
1157
1158 \begin{code}
1159 #ifdef OLD_STRICTNESS
1160 get_changes binds = vcat (map get_changes_bind binds)
1161
1162 get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
1163 get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
1164
1165 get_changes_pr (id,rhs)
1166   = get_changes_var id $$ get_changes_expr rhs
1167
1168 get_changes_var var
1169   | isId var  = get_changes_str var $$ get_changes_dmd var
1170   | otherwise = empty
1171
1172 get_changes_expr (Type t)     = empty
1173 get_changes_expr (Var v)      = empty
1174 get_changes_expr (Lit l)      = empty
1175 get_changes_expr (Note n e)   = get_changes_expr e
1176 get_changes_expr (App e1 e2)  = get_changes_expr e1 $$ get_changes_expr e2
1177 get_changes_expr (Lam b e)    = {- get_changes_var b $$ -} get_changes_expr e
1178 get_changes_expr (Let b e)    = get_changes_bind b $$ get_changes_expr e
1179 get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a)
1180
1181 get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs
1182
1183 get_changes_str id
1184   | new_better && old_better = empty
1185   | new_better               = message "BETTER"
1186   | old_better               = message "WORSE"
1187   | otherwise                = message "INCOMPARABLE"
1188   where
1189     message word = text word <+> text "strictness for" <+> ppr id <+> info
1190     info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
1191     new = squashSig (idNewStrictness id)        -- Don't report spurious diffs that the old
1192                                                 -- strictness analyser can't track
1193     old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id)
1194     old_better = old `betterStrictness` new
1195     new_better = new `betterStrictness` old
1196
1197 get_changes_dmd id
1198   | isUnLiftedType (idType id) = empty  -- Not useful
1199   | new_better && old_better = empty
1200   | new_better               = message "BETTER"
1201   | old_better               = message "WORSE"
1202   | otherwise                = message "INCOMPARABLE"
1203   where
1204     message word = text word <+> text "demand for" <+> ppr id <+> info
1205     info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
1206     new = squashDmd (argDemand (idNewDemandInfo id))    -- To avoid spurious improvements
1207                                                         -- A bit of a hack
1208     old = newDemand (idDemandInfo id)
1209     new_better = new `betterDemand` old
1210     old_better = old `betterDemand` new
1211
1212 betterStrictness :: StrictSig -> StrictSig -> Bool
1213 betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2
1214
1215 betterDmdType t1 t2 = (t1 `lubType` t2) == t2
1216
1217 betterDemand :: Demand -> Demand -> Bool
1218 -- If d1 `better` d2, and d2 `better` d2, then d1==d2
1219 betterDemand d1 d2 = (d1 `lub` d2) == d2
1220
1221 squashSig (StrictSig (DmdType fv ds res))
1222   = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res)
1223   where
1224         -- squash just gets rid of call demands
1225         -- which the old analyser doesn't track
1226 squashDmd (Call d)   = evalDmd
1227 squashDmd (Box d)    = Box (squashDmd d)
1228 squashDmd (Eval ds)  = Eval (mapDmds squashDmd ds)
1229 squashDmd (Defer ds) = Defer (mapDmds squashDmd ds)
1230 squashDmd d          = d
1231 #endif
1232 \end{code}