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