[commit: ghc] wip/nested-cpr: Move peelFV from DmdAnal to Demand (1d9620e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nested-cpr
Link       : http://ghc.haskell.org/trac/ghc/changeset/1d9620ea9b12b17f68014ec83ab336754a8c31e0/ghc

>---------------------------------------------------------------

commit 1d9620ea9b12b17f68014ec83ab336754a8c31e0
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Dec 4 16:09:34 2013 +0000

    Move peelFV from DmdAnal to Demand


>---------------------------------------------------------------

1d9620ea9b12b17f68014ec83ab336754a8c31e0
 compiler/basicTypes/Demand.lhs |   19 ++++++++++++++++++-
 compiler/stranal/DmdAnal.lhs   |   31 ++++++++++---------------------
 2 files changed, 28 insertions(+), 22 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index ea3719f..a2aa830 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -20,8 +20,10 @@ module Demand (
 
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdEnv, bothDmdType,
         topDmdType, botDmdType, mkDmdType, mkTopDmdType, 
+        addDemand,
 
         DmdEnv, emptyDmdEnv,
+        peelFV,
 
         DmdResult, CPRResult,
         isBotRes, isTopRes, resTypeArgDmd, 
@@ -54,12 +56,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 )
@@ -1133,6 +1136,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 ad3cf28..a3c7654 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 )
 \end{code}
@@ -719,16 +719,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]
@@ -754,11 +744,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
@@ -779,13 +769,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         -- 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 )
@@ -799,9 +789,8 @@ annotateLamIdBndr env arg_of_dfun _dmd_ty@(DmdType fv ds res) one_shot id
                           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]