Move peelFV from DmdAnal to Demand
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 4 Dec 2013 16:09:34 +0000 (16:09 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Thu, 12 Dec 2013 12:23:02 +0000 (12:23 +0000)
compiler/basicTypes/Demand.lhs
compiler/stranal/DmdAnal.lhs

index 33d4bb6..50b6f94 100644 (file)
@@ -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]
index 27d9112..8a2cf4c 100644 (file)
@@ -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]