Move peelFV from DmdAnal to Demand

2 files changed, 29 insertions, 23 deletions

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 33d4bb604b..50b6f94949 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -20,8 +20,10 @@ module Demand (
 
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdEnv, bothDmdType,
         nopDmdType, botDmdType, mkDmdType,
+        addDemand,
 
         DmdEnv, emptyDmdEnv,
+        peelFV,
 
         DmdResult, CPRResult,
         isBotRes, isTopRes, resTypeArgDmd, 
@@ -55,12 +57,13 @@ module Demand (
 import StaticFlags
 import DynFlags
 import Outputable
+import Var ( Var )
 import VarEnv
 import UniqFM
 import Util
 import BasicTypes
 import Binary
-import Maybes           ( isJust, expectJust )
+import Maybes           ( isJust, expectJust, orElse )
 
 import Type            ( Type )
 import TyCon           ( isNewTyCon, isClassTyCon )
@@ -1151,6 +1154,20 @@ peelManyCalls arg_ds (CD { sd = str, ud = abs })
     go_abs []      _             = One       --          one UCall Many in the demand
     go_abs (_:as) (UCall One d') = go_abs as d'
     go_abs _      _              = Many
+
+
+peelFV :: DmdType -> Var -> (DmdType, Demand)
+peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
+                               (DmdType fv' ds res, dmd)
+  where
+  fv' = fv `delVarEnv` id
+  dmd = lookupVarEnv fv id `orElse` deflt
+  -- See note [Default demand for variables]
+  deflt | isBotRes res = botDmd
+        | otherwise    = absDmd
+
+addDemand :: Demand -> DmdType -> DmdType
+addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res
 \end{code}
 
 Note [Always analyse in virgin pass]
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 27d9112733..8a2cf4c033 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -32,7 +32,7 @@ import Type		( eqType )
 -- import Pair
 -- import Coercion         ( coercionKind )
 import Util
-import Maybes		( isJust, orElse )
+import Maybes		( isJust )
 import TysWiredIn	( unboxedPairDataCon )
 import TysPrim		( realWorldStatePrimTy )
 import ErrUtils         ( dumpIfSet_dyn )
@@ -726,16 +726,6 @@ addLazyFVs dmd_ty lazy_fvs
 	-- which floats out of the defn for h.  Without the modifyEnv, that
 	-- L demand doesn't get both'd with the Bot coming up from the inner
 	-- call to f.  So we just get an L demand for x for g.
-
-peelFV :: DmdEnv -> Var -> DmdResult -> (DmdEnv, Demand)
-peelFV fv id res = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
-                     (fv', dmd)
-		where
-		  fv' = fv `delVarEnv` id
-		  dmd = lookupVarEnv fv id `orElse` deflt
-                  -- See note [Default demand for variables]
-	 	  deflt | isBotRes res = botDmd
-		        | otherwise    = absDmd
 \end{code}
 
 Note [Default demand for variables]
@@ -761,11 +751,11 @@ annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
 -- The returned var is annotated with demand info
 -- according to the result demand of the provided demand type
 -- No effect on the argument demands
-annotateBndr env dmd_ty@(DmdType fv ds res) var
+annotateBndr env dmd_ty var
   | isTyVar var = (dmd_ty, var)
-  | otherwise   = (DmdType fv' ds res, set_idDemandInfo env var dmd')
+  | otherwise   = (dmd_ty', set_idDemandInfo env var dmd')
   where
-    (fv', dmd) = peelFV fv var res
+    (dmd_ty', dmd) = peelFV dmd_ty var
 
     dmd' | gopt Opt_DictsStrict (ae_dflags env)
              -- We never want to strictify a recursive let. At the moment
@@ -786,13 +776,13 @@ annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs
 
 annotateLamIdBndr :: AnalEnv
                   -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?
-                  -> DmdType 	-- Demand type of body
+                  -> DmdType    -- Demand type of body
                   -> Count      -- One-shot-ness of the lambda
-		  -> Id 	-- Lambda binder
-		  -> (DmdType, 	-- Demand type of lambda
-		      Id)	-- and binder annotated with demand	
+		  -> Id         -- Lambda binder
+		  -> (DmdType,  -- Demand type of lambda
+		      Id)	-- and binder annotated with demand
 
-annotateLamIdBndr env arg_of_dfun _dmd_ty@(DmdType fv ds res) one_shot id
+annotateLamIdBndr env arg_of_dfun dmd_ty one_shot id
 -- For lambdas we add the demand to the argument demands
 -- Only called for Ids
   = ASSERT( isId id )
@@ -805,10 +795,9 @@ annotateLamIdBndr env arg_of_dfun _dmd_ty@(DmdType fv ds res) one_shot id
                  Just unf -> main_ty `bothDmdType` unf_ty
                           where
                              (unf_ty, _) = dmdAnalStar env dmd unf
-    
-    main_ty = DmdType fv' (dmd:ds) res
 
-    (fv', dmd) = peelFV fv id res
+    main_ty = addDemand dmd dmd_ty'
+    (dmd_ty', dmd) = peelFV dmd_ty id
 
     dmd' | gopt Opt_DictsStrict (ae_dflags env),
            -- see Note [do not strictify the argument dictionaries of a dfun]