Make types of bothDmdType more precise

by only passing the demand on the free variables, and whether the
argument (resp. scrunitee) may or will diverge.

2 files changed, 39 insertions, 25 deletions

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 3281332966..d408e6d2a9 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -21,6 +21,7 @@ module Demand (
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
         nopDmdType, botDmdType, mkDmdType,
         addDemand,
+        BothDmdArg, mkBothDmdArg, toBothDmdArg,
 
         DmdEnv, emptyDmdEnv,
         peelFV,
@@ -709,14 +710,15 @@ We have lubs, but not glbs; but that is ok.
 -- Constructed Product Result                                             
 ------------------------------------------------------------------------
 
-data CPRResult = NoCPR                -- Top of the lattice
-               | RetProd              -- Returns a constructor from a product type
-               | RetSum ConTag        -- Returns a constructor from a sum type with this tag
+data Termination r = Diverges    -- Definitely diverges
+                   | Dunno r     -- Might diverge or converge
                deriving( Eq, Show )
 
-data DmdResult = Diverges              -- Definitely diverges
-               | Dunno CPRResult       -- Might diverge or converge, but in the latter case the
-                                       -- result shape is described by CPRResult
+type DmdResult = Termination CPRResult
+
+data CPRResult = NoCPR          -- Top of the lattice
+               | RetProd        -- Returns a constructor from a product type
+               | RetSum ConTag  -- Returns a constructor from a data type
                deriving( Eq, Show )
 
 lubCPR :: CPRResult -> CPRResult -> CPRResult
@@ -733,7 +735,7 @@ lubDmdResult (Dunno c1)     (Dunno c2)     = Dunno (c1 `lubCPR` c2)
 -- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
 -- (See Note [Default demand on free variables] for why)
 
-bothDmdResult :: DmdResult -> DmdResult -> DmdResult
+bothDmdResult :: DmdResult -> Termination () -> DmdResult
 -- See Note [Asymmetry of 'both' for DmdType and DmdResult]
 bothDmdResult _              Diverges   = Diverges
 bothDmdResult r              _          = r
@@ -1024,13 +1026,25 @@ lubDmdType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
     lub_ds ds1    []       = map (`lubDmd` resTypeArgDmd r2) ds1
     lub_ds []     ds2      = map (resTypeArgDmd r1 `lubDmd`) ds2
 
-bothDmdType :: DmdType -> DmdType -> DmdType
-bothDmdType (DmdType fv1 ds1 r1) (DmdType fv2 _ r2)
+
+type BothDmdArg = (DmdEnv, Termination ())
+
+mkBothDmdArg :: DmdEnv -> BothDmdArg
+mkBothDmdArg env = (env, Dunno ())
+
+toBothDmdArg :: DmdType -> BothDmdArg
+toBothDmdArg (DmdType fv _ r) = (fv, go r)
+  where
+  go (Dunno {})     = Dunno ()
+  go Diverges       = Diverges
+
+bothDmdType :: DmdType -> BothDmdArg -> DmdType
+bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)
     -- See Note [Asymmetry of 'both' for DmdType and DmdResult]
     -- 'both' takes the argument/result info from its *first* arg,
     -- using its second arg just for its free-var info.
-  = DmdType both_fv ds1 (r1 `bothDmdResult` r2)
-  where both_fv = plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)
+  = DmdType both_fv ds1 (r1 `bothDmdResult` t2)
+  where both_fv = plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)
 
 instance Outputable DmdType where
   ppr (DmdType fv ds res) 
@@ -1126,17 +1140,18 @@ toCleanDmd (JD { strd = s, absd = u })
 -- This is used in dmdAnalStar when post-processing
 -- a function's argument demand. So we only care about what
 -- does to free variables, and whether it terminates.
-postProcessDmdTypeM :: DeferAndUseM -> DmdType -> DmdType
-postProcessDmdTypeM Nothing   _  = nopDmdType
+postProcessDmdTypeM :: DeferAndUseM -> DmdType -> BothDmdArg
+postProcessDmdTypeM Nothing   _  = (emptyDmdEnv, Dunno ())
   -- Incoming demand was Absent, so just discard all usage information
   -- We only processed the thing at all to analyse the body
   -- See Note [Always analyse in virgin pass]
 postProcessDmdTypeM (Just du) (DmdType fv _ res_ty)
-    = DmdType (postProcessDmdEnv du fv) [] (postProcessDmdResult du res_ty)
+    = (postProcessDmdEnv du fv, postProcessDmdResult du res_ty)
 
-postProcessDmdResult :: DeferAndUse -> DmdResult -> DmdResult
-postProcessDmdResult (True,_)  r = topRes
-postProcessDmdResult (False,_) r = r
+postProcessDmdResult :: DeferAndUse -> DmdResult -> Termination ()
+postProcessDmdResult (True,_)  _          = Dunno ()
+postProcessDmdResult (False,_) (Dunno {}) = Dunno ()
+postProcessDmdResult (False,_) Diverges   = Diverges
 
 postProcessDmdEnv :: DeferAndUse -> DmdEnv -> DmdEnv
 postProcessDmdEnv (True,  Many) env = deferReuseEnv env
@@ -1246,9 +1261,9 @@ peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
   -- See note [Default demand on free variables]
   dmd  = lookupVarEnv fv id `orElse` defaultDmd res
 
-defaultDmd :: DmdResult -> Demand
-defaultDmd res | isBotRes res = botDmd
-               | otherwise    = absDmd
+defaultDmd :: Termination r -> Demand
+defaultDmd Diverges = botDmd
+defaultDmd _        = absDmd
 
 addDemand :: Demand -> DmdType -> DmdType
 addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index cbdcc67736..a942c4eab6 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -115,7 +115,7 @@ dmdTransformThunkDmd e
 -- See |-* relation in the companion paper
 dmdAnalStar :: AnalEnv 
             -> Demand 	-- This one takes a *Demand*
-            -> CoreExpr -> (DmdType, CoreExpr)
+            -> CoreExpr -> (BothDmdArg, CoreExpr)
 dmdAnalStar env dmd e 
   | (cd, defer_and_use) <- toCleanDmd dmd
   , (dmd_ty, e')        <- dmdAnal env cd e
@@ -255,7 +255,7 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
         scrut_dmd  = scrut_dmd1 `bothCleanDmd` scrut_dmd2
 
 	(scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
-        res_ty             = alt_ty1 `bothDmdType` scrut_ty
+        res_ty             = alt_ty1 `bothDmdType` toBothDmdArg scrut_ty
     in
 --    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
 --                                   , text "dmd" <+> ppr dmd
@@ -271,7 +271,7 @@ dmdAnal env dmd (Case scrut case_bndr ty alts)
 	(alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd) alts
 	(scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut
 	(alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
-        res_ty               = alt_ty `bothDmdType` scrut_ty
+        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty
     in
 --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
 --                                   , text "scrut_ty" <+> ppr scrut_ty
@@ -509,7 +509,6 @@ dmdTransform env var dmd
 
   | otherwise	 		                 -- Local non-letrec-bound thing
   = unitVarDmd var (mkOnceUsedDmd dmd)
-
 \end{code}
 
 %************************************************************************
@@ -698,7 +697,7 @@ addVarDmd (DmdType fv ds res) var dmd
 
 addLazyFVs :: DmdType -> DmdEnv -> DmdType
 addLazyFVs dmd_ty lazy_fvs
-  = dmd_ty `bothDmdType` mkDmdType lazy_fvs [] topRes
+  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs
 	-- Using bothDmdType (rather than just both'ing the envs)
         -- is vital.  Consider
 	--	let f = \x -> (x,y)