[commit: ghc] cardinality: a bug with absent free variables fixed; first working cardinality analysis (54f3537)

[Ilya Sergey]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : cardinality

http://hackage.haskell.org/trac/ghc/changeset/54f353751e5c0d26ab62c744e1337eefc0f9d75d

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

commit 54f353751e5c0d26ab62c744e1337eefc0f9d75d
Author: Ilya Sergey <Ilya.Sergey at cs.kuleuven.be>
Date:   Thu Sep 27 23:22:39 2012 +0100

    a bug with absent free variables fixed; first working cardinality analysis

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

 compiler/basicTypes/Demand.lhs |    2 +-
 compiler/stranal/DmdAnal.lhs   |   20 +++++++++++++-------
 2 files changed, 14 insertions(+), 8 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 8e27004..6e333f2 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -934,7 +934,7 @@ trimFvUsageTy :: DmdType -> DmdType
 trimFvUsageTy (DmdType fv ds res_ty) = DmdType (trimFvUsageEnv fv) ds res_ty
 
 trimFvUsageEnv :: DmdEnv -> DmdEnv
-trimFvUsageEnv = mapVarEnv (\(JD {strd = s}) -> mkJointDmd s bot)
+trimFvUsageEnv = mapVarEnv (\(JD {strd = s}) -> mkJointDmd s Abs)
 
 modifyEnv :: Bool			-- No-op if False
 	  -> (Demand -> Demand)		-- The zapper
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index aaac680..2f3f405 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -278,8 +278,8 @@ dmdAnal _ env dmd (Let (NonRec id rhs) body)
         -- Add lazy free variables
 	body_ty2		   = addLazyFVs body_ty1 lazy_fv
         -- Add unleashed cardinality demands 
-        unleashed_fv               = unleash_card_dmds (id, id_dmd)
-        body_ty3                   = addLazyFVs body_ty2 unleashed_fv                      
+        unleashed_fv               = unleash_card_dmds (id2, id_dmd)
+        body_ty3                   = addNewFVs body_ty2 unleashed_fv                      
     in
 	-- If the actual demand is better than the vanilla call
 	-- demand, you might think that we might do better to re-analyse 
@@ -312,7 +312,7 @@ dmdAnal _ env dmd (Let (Rec pairs) body)
 		-- being recursive, we can't treat them strictly.
 		-- But we do need to remove the binders from the result demand env
         unleashed_envs       = map unleash_card_dmds var_dmds       
-        body_ty3             = foldl addLazyFVs body_ty2 unleashed_envs
+        body_ty3             = foldl addNewFVs body_ty2 unleashed_envs
     in
     (body_ty3,  Let (Rec pairs') body')
 
@@ -554,11 +554,11 @@ dmdTransform env var dmd
 
   where
     (call_depth, res_dmd) = splitCallDmd dmd
-    adjustCardinality dt  = if not_precise_call dt
-                            then markAsUsedType dt else dt
+    adjustCardinality dt  = if precise_call dt
+                            then dt else markAsUsedType dt 
     -- True is the demand is weaker than C1(C1(...)), where
     -- the number of C1 is taken from the transformer threshold                        
-    not_precise_call dt   = not $ allSingleCalls (dmdTypeDepth dt) dmd
+    precise_call dt       = allSingleCalls (dmdTypeDepth dt) dmd
 
 \end{code}
 
@@ -672,6 +672,12 @@ addVarDmd :: DmdType -> Var -> Demand -> DmdType
 addVarDmd (DmdType fv ds res) var dmd
   = DmdType (extendVarEnv_C both fv var dmd) ds res
 
+addNewFVs :: DmdType -> DmdEnv -> DmdType
+addNewFVs (DmdType fv ds res) new_fvs
+  = DmdType both_fv ds res
+  where
+    both_fv = plusVarEnv_C both fv new_fvs
+
 addLazyFVs :: DmdType -> DmdEnv -> DmdType
 addLazyFVs (DmdType fv ds res) lazy_fvs
   = DmdType both_fv1 ds res
@@ -734,7 +740,7 @@ is <L,A>).
 -- Recursive bindings are automaticaly marked as used
 unleash_card_dmds :: (Var, Demand) -> DmdEnv
 unleash_card_dmds (id, id_dmd)
-  | isAbs id_dmd
+  | Abs <- absd id_dmd
     -- do not unleash anything for absent demands
     = emptyDmdEnv
   | otherwise