Make the demand analyser sdd demands for strict constructors
authorsimonpj@microsoft.com <unknown>
Wed, 5 May 2010 20:09:36 +0000 (20:09 +0000)
committersimonpj@microsoft.com <unknown>
Wed, 5 May 2010 20:09:36 +0000 (20:09 +0000)
This opportunity was spotted by Roman, and is documented in
Note [Add demands for strict constructors] in DmdAnal.

compiler/stranal/DmdAnal.lhs

index e8aa22c..2a160cd 100644 (file)
@@ -7,27 +7,20 @@
                        -----------------
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs, 
                 both {- needed by WwLib -}
    ) where
 
 #include "HsVersions.h"
 
-import DynFlags                ( DynFlags, DynFlag(..) )
+import DynFlags                ( DynFlags )
 import StaticFlags     ( opt_MaxWorkerArgs )
 import Demand  -- All of it
 import CoreSyn
 import PprCore 
 import CoreUtils       ( exprIsHNF, exprIsTrivial )
 import CoreArity       ( exprArity )
-import DataCon         ( dataConTyCon )
+import DataCon         ( dataConTyCon, dataConRepStrictness )
 import TyCon           ( isProductTyCon, isRecursiveTyCon )
 import Id              ( Id, idType, idInlineActivation,
                          isDataConWorkId, isGlobalId, idArity,
@@ -40,17 +33,15 @@ import Var          ( Var )
 import VarEnv
 import TysWiredIn      ( unboxedPairDataCon )
 import TysPrim         ( realWorldStatePrimTy )
-import UniqFM          ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
-                         keysUFM, minusUFM, ufmToList, filterUFM )
+import UniqFM          ( addToUFM_Directly, lookupUFM_Directly,
+                         minusUFM, ufmToList, filterUFM )
 import Type            ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
 import Coercion         ( coercionKind )
-import Util            ( mapAndUnzip, lengthIs )
+import Util            ( mapAndUnzip, lengthIs, zipEqual )
 import BasicTypes      ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
-                         RecFlag(..), isRec )
+                         RecFlag(..), isRec, isMarkedStrict )
 import Maybes          ( orElse, expectJust )
-import ErrUtils                ( showPass )
 import Outputable
-
 import Data.List
 \end{code}
 
@@ -70,7 +61,7 @@ To think about
 
 \begin{code}
 dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
-dmdAnalPgm dflags binds
+dmdAnalPgm _ binds
   = do {
        let { binds_plus_dmds = do_prog binds } ;
        return binds_plus_dmds
@@ -130,7 +121,7 @@ dmdAnalTopRhs rhs
 \begin{code}
 dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr)
 
-dmdAnal sigs Abs  e = (topDmdType, e)
+dmdAnal _ Abs  e = (topDmdType, e)
 
 dmdAnal sigs dmd e 
   | not (isStrictDmd dmd)
@@ -153,8 +144,8 @@ dmdAnal sigs dmd e
        --    evaluation of f in a C(L) demand!
 
 
-dmdAnal sigs dmd (Lit lit)
-  = (topDmdType, Lit lit)
+dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit)
+dmdAnal _ _ (Type ty) = (topDmdType, Type ty)  -- Doesn't happen, in fact
 
 dmdAnal sigs dmd (Var var)
   = (dmdTransform sigs var dmd, Var var)
@@ -165,7 +156,7 @@ dmdAnal sigs dmd (Cast e co)
     (dmd_ty, e') = dmdAnal sigs dmd' e
     to_co        = snd (coercionKind co)
     dmd'
-      | Just (tc, args) <- splitTyConApp_maybe to_co
+      | Just (tc, _) <- splitTyConApp_maybe to_co
       , isRecursiveTyCon tc = evalDmd
       | otherwise           = dmd
        -- This coerce usually arises from a recursive
@@ -186,7 +177,7 @@ dmdAnal sigs dmd (App fun (Type ty))
 
 -- Lots of the other code is there to make this
 -- beautiful, compositional, application rule :-)
-dmdAnal sigs dmd e@(App fun arg)       -- Non-type arguments
+dmdAnal sigs dmd (App fun arg) -- Non-type arguments
   = let                                -- [Type arg handled above]
        (fun_ty, fun')    = dmdAnal sigs (Call dmd) fun
        (arg_ty, arg')    = dmdAnal sigs arg_dmd arg
@@ -216,7 +207,7 @@ dmdAnal sigs dmd (Lam var body)
     in
     (deferType lam_ty, Lam var' body')
 
-dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
+dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
   | let tycon = dataConTyCon dc
   , isProductTyCon tycon
   , not (isRecursiveTyCon tycon)
@@ -312,10 +303,12 @@ dmdAnal sigs dmd (Let (Rec pairs) body)
     (body_ty2,  Let (Rec pairs') body')
 
 
+dmdAnalAlt :: SigEnv -> Demand -> Alt Var -> (DmdType, Alt Var)
 dmdAnalAlt sigs dmd (con,bndrs,rhs) 
   = let 
        (rhs_ty, rhs')   = dmdAnal sigs dmd rhs
-       (alt_ty, bndrs') = annotateBndrs rhs_ty bndrs
+        rhs_ty'          = addDataConPatDmds con bndrs rhs_ty
+       (alt_ty, bndrs') = annotateBndrs rhs_ty' bndrs
        final_alt_ty | io_hack_reqd = alt_ty `lubType` topDmdType
                     | otherwise    = alt_ty
 
@@ -340,8 +333,53 @@ dmdAnalAlt sigs dmd (con,bndrs,rhs)
                       idType (head bndrs) `coreEqType` realWorldStatePrimTy
     in 
     (final_alt_ty, (con, bndrs', rhs'))
+
+addDataConPatDmds :: AltCon -> [Var] -> DmdType -> DmdType
+-- See Note [Add demands for strict constructors]
+addDataConPatDmds DEFAULT    _ dmd_ty = dmd_ty
+addDataConPatDmds (LitAlt _) _ dmd_ty = dmd_ty
+addDataConPatDmds (DataAlt con) bndrs dmd_ty
+  = foldr add dmd_ty str_bndrs 
+  where
+    add bndr dmd_ty = addVarDmd dmd_ty bndr seqDmd
+    str_bndrs = [ b | (b,s) <- zipEqual "addDataConPatBndrs"
+                                   (filter isId bndrs)
+                                   (dataConRepStrictness con)
+                    , isMarkedStrict s ]
 \end{code}
 
+Note [Add demands for strict constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this program (due to Roman):
+
+    data X a = X !a
+
+    foo :: X Int -> Int -> Int
+    foo (X a) n = go 0
+     where
+       go i | i < n     = a + go (i+1)
+            | otherwise = 0
+
+We want the worker for 'foo' too look like this:
+
+    $wfoo :: Int# -> Int# -> Int#
+
+with the first argument unboxed, so that it is not eval'd each time
+around the loop (which would otherwise happen, since 'foo' is not
+strict in 'a'.  It is sound for the wrapper to pass an unboxed arg
+because X is strict, so its argument must be evaluated.  And if we
+*don't* pass an unboxed argument, we can't even repair it by adding a
+`seq` thus:
+
+    foo (X a) n = a `seq` go 0
+
+because the seq is discarded (very early) since X is strict!
+
+There is the usual danger of reboxing, which as usual we ignore. But 
+if X is monomorphic, and has an UNPACK pragma, then this optimisation
+is even more important.  We don't want the wrapper to rebox an unboxed
+argument, and pass an Int to $wfoo!
+
 %************************************************************************
 %*                                                                     *
 \subsection{Bindings}
@@ -400,19 +438,21 @@ dmdFix top_lvl sigs orig_pairs
          --     )
        where
          (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive sigs (id,rhs)
-         lazy_fv'                 = plusUFM_C both lazy_fv lazy_fv1   
+         lazy_fv'                 = plusVarEnv_C both lazy_fv lazy_fv1   
          -- old_sig               = lookup sigs id
          -- new_sig               = lookup sigs' id
           
     same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
     lookup sigs var = case lookupVarEnv sigs var of
                        Just (sig,_) -> sig
+                        Nothing      -> pprPanic "dmdFix" (ppr var)
 
        -- Get an initial strictness signature from the Id
        -- itself.  That way we make use of earlier iterations
        -- of the fixpoint algorithm.  (Cunning plan.)
        -- Note that the cunning plan extends to the DmdEnv too,
        -- since it is part of the strictness signature
+initialSig :: Id -> StrictSig
 initialSig id = idStrictness_maybe id `orElse` botSig
 
 dmdAnalRhs :: TopLevelFlag -> RecFlag
@@ -590,7 +630,9 @@ in favour of error!
 
 
 \begin{code}
-mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res) 
+mk_sig_ty :: Bool -> Bool -> CoreExpr
+          -> DmdType -> (DmdEnv, StrictSig)
+mk_sig_ty _never_inline thunk_cpr_ok rhs (DmdType fv dmds res) 
   = (lazy_fv, mkStrictSig dmd_ty)
        -- Re unused never_inline, see Note [NOINLINE and strictness]
   where
@@ -633,7 +675,7 @@ mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res)
        
     res' = case res of
                RetCPR | ignore_cpr_info -> TopRes
-               other                    -> res
+               _                        -> res
     ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
 \end{code}
 
@@ -668,7 +710,7 @@ setUnpackStrategy ds
 nonAbsentArgs :: [Demand] -> Int
 nonAbsentArgs []        = 0
 nonAbsentArgs (Abs : ds) = nonAbsentArgs ds
-nonAbsentArgs (d   : ds) = 1 + nonAbsentArgs ds
+nonAbsentArgs (_   : ds) = 1 + nonAbsentArgs ds
 \end{code}
 
 
@@ -679,16 +721,18 @@ nonAbsentArgs (d   : ds) = 1 + nonAbsentArgs ds
 %************************************************************************
 
 \begin{code}
+unitVarDmd :: Var -> Demand -> DmdType
 unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes
 
-addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd
-  | isTopLevel top_lvl = dmd_ty                -- Don't record top level things
-  | otherwise         = DmdType (extendVarEnv fv var dmd) ds res
+addVarDmd :: DmdType -> Var -> Demand -> DmdType
+addVarDmd (DmdType fv ds res) var dmd
+  = DmdType (extendVarEnv_C both fv var dmd) ds res
 
+addLazyFVs :: DmdType -> DmdEnv -> DmdType
 addLazyFVs (DmdType fv ds res) lazy_fvs
   = DmdType both_fv1 ds res
   where
-    both_fv = (plusUFM_C both fv lazy_fvs)
+    both_fv = plusVarEnv_C both fv lazy_fvs
     both_fv1 = modifyEnv (isBotRes res) (`both` Bot) lazy_fvs fv both_fv
        -- This modifyEnv is vital.  Consider
        --      let f = \x -> (x,y)
@@ -726,6 +770,7 @@ annotateBndr dmd_ty@(DmdType fv ds res) var
   where
     (fv', dmd) = removeFV fv var res
 
+annotateBndrs :: DmdType -> [Var] -> (DmdType, [Var])
 annotateBndrs = mapAccumR annotateBndr
 
 annotateLamIdBndr :: SigEnv
@@ -734,7 +779,7 @@ annotateLamIdBndr :: SigEnv
                  -> (DmdType,  -- Demand type of lambda
                      Id)       -- and binder annotated with demand     
 
-annotateLamIdBndr sigs dmd_ty@(DmdType fv ds res) id
+annotateLamIdBndr sigs (DmdType fv ds res) id
 -- For lambdas we add the demand to the argument demands
 -- Only called for Ids
   = ASSERT( isId id )
@@ -759,6 +804,7 @@ annotateLamIdBndr sigs dmd_ty@(DmdType fv ds res) id
        -- And then the simplifier things the 'B' is a strict demand
        -- and evaluates the (error "oops").  Sigh
 
+removeFV :: DmdEnv -> Var -> DmdResult -> (DmdEnv, Demand)
 removeFV fv id res = (fv', zapUnlifted id dmd)
                where
                  fv' = fv `delVarEnv` id
@@ -766,10 +812,11 @@ removeFV fv id res = (fv', zapUnlifted id dmd)
                  deflt | isBotRes res = Bot
                        | otherwise    = Abs
 
+zapUnlifted :: Id -> Demand -> Demand
 -- For unlifted-type variables, we are only 
 -- interested in Bot/Abs/Box Abs
-zapUnlifted is Bot = Bot
-zapUnlifted id Abs = Abs
+zapUnlifted  Bot = Bot
+zapUnlifted  Abs = Abs
 zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
                   | otherwise                  = dmd
 \end{code}
@@ -799,11 +846,13 @@ type SigEnv  = VarEnv (StrictSig, TopLevelFlag)
        -- The DmdEnv gives the demand on the free vars of the function
        -- when it is given enough args to satisfy the strictness signature
 
+emptySigEnv :: SigEnv
 emptySigEnv  = emptyVarEnv
 
 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
 extendSigEnv top_lvl env var sig = extendVarEnv env var (sig, top_lvl)
 
+extendSigEnvList :: SigEnv -> [(Id, (StrictSig, TopLevelFlag))] -> SigEnv
 extendSigEnvList = extendVarEnvList
 
 extendSigsWithLam :: SigEnv -> Id -> SigEnv
@@ -824,11 +873,11 @@ extendSigsWithLam :: SigEnv -> Id -> SigEnv
 
 extendSigsWithLam sigs id
   = case idDemandInfo_maybe id of
-       Nothing               -> extendVarEnv sigs id (cprSig, NotTopLevel)
+       Nothing              -> extendVarEnv sigs id (cprSig, NotTopLevel)
                -- Optimistic in the Nothing case;
                -- See notes [CPR-AND-STRICTNESS]
-       Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel)
-       other                 -> sigs
+       Just (Eval (Prod _)) -> extendVarEnv sigs id (cprSig, NotTopLevel)
+       _                    -> sigs
 
 
 dmdTransform :: SigEnv         -- The strictness environment
@@ -858,7 +907,7 @@ dmdTransform sigs var dmd
           dmd_ds = case res_dmd of
                        Box (Eval ds) -> mapDmds box ds
                        Eval ds       -> ds
-                       other         -> Poly Top
+                       _             -> Poly Top
 
                -- ds can be empty, when we are just seq'ing the thing
                -- If so we must make up a suitable bunch of demands
@@ -890,7 +939,8 @@ dmdTransform sigs var dmd
        -- The application isn't saturated, but we must nevertheless propagate 
        --      a lazy demand for p!  
     in
-    addVarDmd top_lvl fn_ty var dmd
+    if isTopLevel top_lvl then fn_ty   -- Don't record top level things
+    else addVarDmd fn_ty var dmd
 
 ------         LOCAL NON-LET/REC BOUND THING
   | otherwise                  -- Default case
@@ -913,7 +963,7 @@ splitDmdTy :: DmdType -> (Demand, DmdType)
 -- We already have a suitable demand on all
 -- free vars, so no need to add more!
 splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
-splitDmdTy ty@(DmdType fv [] res_ty)      = (resTypeArgDmd res_ty, ty)
+splitDmdTy ty@(DmdType _ [] res_ty)       = (resTypeArgDmd res_ty, ty)
 
 splitCallDmd :: Demand -> (Int, Demand)
 splitCallDmd (Call d) = case splitCallDmd d of
@@ -939,7 +989,7 @@ argDemand :: Demand -> Demand
 -- The 'Defer' demands are just Lazy at function boundaries
 -- Ugly!  Ask John how to improve it.
 argDemand Top      = lazyDmd
-argDemand (Defer d) = lazyDmd
+argDemand (Defer _) = lazyDmd
 argDemand (Eval ds) = Eval (mapDmds argDemand ds)
 argDemand (Box Bot) = evalDmd
 argDemand (Box d)   = box (argDemand d)
@@ -949,6 +999,7 @@ argDemand d     = d
 
 \begin{code}
 -------------------------
+lubType :: DmdType -> DmdType -> DmdType
 -- Consider (if x then y else []) with demand V
 -- Then the first branch gives {y->V} and the second
 --  *implicitly* has {y->A}.  So we must put {y->(V `lub` A)}
@@ -956,7 +1007,7 @@ argDemand d            = d
 lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
   = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)
   where
-    lub_fv  = plusUFM_C lub fv1 fv2
+    lub_fv  = plusVarEnv_C lub fv1 fv2
     lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv
     lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1
        -- lub is the identity for Bot
@@ -968,15 +1019,16 @@ lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
     lub_ds []      ds2      = map (resTypeArgDmd r1 `lub`) ds2
 
 -----------------------------------
+bothType :: DmdType -> DmdType -> DmdType
 -- (t1 `bothType` t2) takes the argument/result info from t1,
 -- using t2 just for its free-var info
 -- NB: Don't forget about r2!  It might be BotRes, which is
 --     a bottom demand on all the in-scope variables.
 -- Peter: can this be done more neatly?
-bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
+bothType (DmdType fv1 ds1 r1) (DmdType fv2 _ r2)
   = DmdType both_fv2 ds1 (r1 `bothRes` r2)
   where
-    both_fv  = plusUFM_C both fv1 fv2
+    both_fv  = plusVarEnv_C both fv1 fv2
     both_fv1 = modifyEnv (isBotRes r1) (`both` Bot) fv2 fv1 both_fv
     both_fv2 = modifyEnv (isBotRes r2) (`both` Bot) fv1 fv2 both_fv1
        -- both is the identity for Abs
@@ -984,15 +1036,17 @@ bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
 
 
 \begin{code}
+lubRes :: DmdResult -> DmdResult -> DmdResult
 lubRes BotRes r      = r
 lubRes r      BotRes = r
 lubRes RetCPR RetCPR = RetCPR
-lubRes r1     r2     = TopRes
+lubRes _      _      = TopRes
 
+bothRes :: DmdResult -> DmdResult -> DmdResult
 -- If either diverges, the whole thing does
 -- Otherwise take CPR info from the first
-bothRes r1 BotRes = BotRes
-bothRes r1 r2     = r1
+bothRes  BotRes = BotRes
+bothRes r1      = r1
 \end{code}
 
 \begin{code}
@@ -1004,7 +1058,7 @@ modifyEnv :: Bool                 -- No-op if False
        -- Assume: dom(env) includes dom(Env1) and dom(Env2)
 
 modifyEnv need_to_modify zapper env1 env2 env
-  | need_to_modify = foldr zap env (keysUFM (env1 `minusUFM` env2))
+  | need_to_modify = foldr zap env (varEnvKeys (env1 `minusUFM` env2))
   | otherwise     = env
   where
     zap uniq env = addToUFM_Directly env uniq (zapper current_val)
@@ -1024,12 +1078,12 @@ lub :: Demand -> Demand -> Demand
 
 lub Bot        d2 = d2
 lub Abs        d2 = absLub d2
-lub Top        d2 = Top
+lub Top         = Top
 lub (Defer ds1) d2 = defer (Eval ds1 `lub` d2)
 
 lub (Call d1)   (Call d2)    = Call (d1 `lub` d2)
 lub d1@(Call _) (Box d2)     = d1 `lub` d2     -- Just strip the box
-lub d1@(Call _) d2@(Eval _)  = d2              -- Presumably seq or vanilla eval
+lub    (Call _) d2@(Eval _)  = d2              -- Presumably seq or vanilla eval
 lub d1@(Call _) d2          = d2 `lub` d1      -- Bot, Abs, Top
 
 -- For the Eval case, we use these approximation rules
@@ -1045,9 +1099,11 @@ lub d1@(Eval _) d2                 = d2 `lub` d1 -- Bot,Abs,Top,Call,Defer
 lub (Box d1)   (Box d2) = box (d1 `lub` d2)
 lub d1@(Box _)  d2     = d2 `lub` d1
 
+lubs :: Demands -> Demands -> Demands
 lubs ds1 ds2 = zipWithDmds lub ds1 ds2
 
 ---------------------
+box :: Demand -> Demand
 -- box is the smart constructor for Box
 -- It computes <B,bot> & d
 -- INVARIANT: (Box d) => d = Bot, Abs, Eval
@@ -1079,6 +1135,7 @@ defer (Box _)      = lazyDmd
 defer (Defer ds) = Defer ds
 defer (Eval ds)  = deferEval ds
 
+deferEval :: Demands -> Demand
 -- deferEval ds = defer (Eval ds)
 deferEval ds | allTop ds = Top
             | otherwise  = Defer ds
@@ -1098,6 +1155,7 @@ absLub (Box _)    = Top
 absLub (Eval ds)  = Defer (absLubs ds) -- Or (Defer ds)?
 absLub (Defer ds) = Defer (absLubs ds) -- Or (Defer ds)?
 
+absLubs :: Demands -> Demands
 absLubs = mapDmds absLub
 
 ---------------
@@ -1106,15 +1164,15 @@ both :: Demand -> Demand -> Demand
 both Abs d2 = d2
 
 -- Note [Bottom demands]
-both Bot Bot      = Bot
-both Bot Abs      = Bot 
-both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds)
+both Bot Bot       = Bot
+both Bot Abs       = Bot 
+both Bot (Eval ds)  = Eval (mapDmds (`both` Bot) ds)
 both Bot (Defer ds) = Eval (mapDmds (`both` Bot) ds)
-both Bot d = errDmd
+both Bot _          = errDmd
 
-both Top Bot        = errDmd
-both Top Abs        = Top
-both Top Top        = Top
+both Top Bot       = errDmd
+both Top Abs       = Top
+both Top Top       = Top
 both Top (Box d)    = Box d
 both Top (Call d)   = Call d
 both Top (Eval ds)  = Eval (mapDmds (`both` Top) ds)
@@ -1126,21 +1184,22 @@ both Top (Defer ds)     -- = defer (Top `both` Eval ds)
 both (Box d1)  (Box d2)    = box (d1 `both` d2)
 both (Box d1)  d2@(Call _) = box (d1 `both` d2)
 both (Box d1)  d2@(Eval _) = box (d1 `both` d2)
-both (Box d1)  (Defer d2)  = Box d1
+both (Box d1)  (Defer _)   = Box d1
 both d1@(Box _) d2         = d2 `both` d1
 
 both (Call d1)          (Call d2)   = Call (d1 `both` d2)
-both (Call d1)          (Eval ds2)  = Call d1  -- Could do better for (Poly Bot)?
-both (Call d1)          (Defer ds2) = Call d1  -- Ditto
-both d1@(Call _) d2         = d1 `both` d1
+both (Call d1)          (Eval _)    = Call d1  -- Could do better for (Poly Bot)?
+both (Call d1)          (Defer _)   = Call d1  -- Ditto
+both d1@(Call _) d2         = d2 `both` d1
 
-both (Eval ds1)    (Eval  ds2) = Eval (ds1 `boths` ds2)
-both (Eval ds1)    (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2)
-both d1@(Eval ds1) d2         = d2 `both` d1
+both (Eval ds1)  (Eval  ds2) = Eval (ds1 `boths` ds2)
+both (Eval ds1)  (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2)
+both d1@(Eval _) d2         = d2 `both` d1
 
-both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2)
-both d1@(Defer ds1) d2      = d2 `both` d1
+both (Defer ds1)  (Defer ds2) = deferEval (ds1 `boths` ds2)
+both d1@(Defer _) d2         = d2 `both` d1
  
+boths :: Demands -> Demands -> Demands
 boths ds1 ds2 = zipWithDmds both ds1 ds2
 \end{code}