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