[commit: ghc] cardinality: and ad-hoc fix fo splitting environment problem (b93d8ed)

[Ilya Sergey]

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

On branch  : cardinality

http://hackage.haskell.org/trac/ghc/changeset/b93d8ed23ae74f5271e930d1a7a3a410cdc335b1

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

commit b93d8ed23ae74f5271e930d1a7a3a410cdc335b1
Author: Ilya Sergey <Ilya.Sergey at cs.kuleuven.be>
Date:   Wed Sep 19 20:01:59 2012 +0100

    and ad-hoc fix fo splitting environment problem

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

 compiler/basicTypes/Demand.lhs |   15 ++++++++-------
 compiler/stranal/DmdAnal.lhs   |   15 ++++++++++-----
 2 files changed, 18 insertions(+), 12 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index a809371..23483af 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -30,7 +30,7 @@ module Demand (
         isProdDmd, isPolyDmd, replicateDmd, splitProdDmd, peelCallDmd, mkCallDmd,
         isProdUsage, 
         -- cardinality stuff
-        markAsUsedType, isSingleUsed, isUsageCallDmd
+        markAsUsedType, markAsUsedEnv, isSingleUsed, isUsageCallDmd
      ) where
 
 #include "HsVersions.h"
@@ -246,10 +246,12 @@ usedMany :: AbsDmd
 usedMany = (Used Many)
 
 isUsedOnce :: AbsDmd -> Bool
-isUsedOnce Abs           = True
-isUsedOnce a 
-         | One <- card a = True
-isUsedOnce _             = False
+isUsedOnce Abs            = True
+isUsedOnce (Used One)     = True 
+isUsedOnce (UHead One)    = True 
+isUsedOnce (UCall One _)  = True
+isUsedOnce (UProd One ux) = all isUsedOnce ux
+isUsedOnce _              = False
 
 absCall :: Count -> AbsDmd -> AbsDmd
 absCall _ Abs  = Abs 
@@ -331,7 +333,7 @@ markAsUsed Abs         = Abs
 markAsUsed (Used _)    = Used Many
 markAsUsed (UHead _)   = UHead Many
 markAsUsed (UProd _ x) = UProd Many $ map markAsUsed x
-markAsUsed (UCall _ x) = markAsUsed x
+markAsUsed (UCall _ x) = UCall Many $ markAsUsed x
 
 seqAbsDmd :: AbsDmd -> ()
 seqAbsDmd (Used c)     = c `seq` ()
@@ -539,7 +541,6 @@ peelCallDmd (JD {strd = Str, absd = UCall c a})      = Just (mkJointDmd Lazy a,
 peelCallDmd (JD {strd = SCall d, absd = Used _})     = Just (mkJointDmd d top, Many)
 peelCallDmd _                                        = Nothing 
 
-
 splitCallDmd :: JointDmd -> (Int, JointDmd)
 splitCallDmd (JD {strd = SCall d, absd = UCall _ a}) 
   = case splitCallDmd (mkJointDmd d a) of
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 1abc92b..f8f4256 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -664,7 +664,7 @@ annotateLamIdBndr env (DmdType fv ds res) id
 mkSigTy :: TopLevelFlag -> RecFlag -> AnalEnv -> Id -> 
            CoreExpr -> DmdType -> (DmdEnv, StrictSig)
 mkSigTy top_lvl rec_flag env id rhs dmd_ty 
-  = mk_sig_ty thunk_cpr_ok rhs dmd_ty
+  = mk_sig_ty thunk_cpr_ok rec_flag rhs dmd_ty
   where
     id_dmd = idDemandInfo id
 
@@ -679,18 +679,23 @@ mkSigTy top_lvl rec_flag env id rhs dmd_ty
 	| isStrictDmd id_dmd       = True
 	| otherwise 		   = False	
 
-mk_sig_ty :: Bool -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
-mk_sig_ty thunk_cpr_ok rhs (DmdType fv dmds res) 
-  = (lazy_fv, mkStrictSig dmd_ty)
+mk_sig_ty :: Bool ->  RecFlag -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
+mk_sig_ty thunk_cpr_ok rec_flag rhs (DmdType fv dmds res) 
+  = (lazy_no_card, mkStrictSig dmd_ty)
 	-- Re unused never_inline, see Note [NOINLINE and strictness]
   where
     dmd_ty = mkDmdType unleashed_fv dmds res'
 
-    -- See Note [Lazy and unleasheable free variables]
     lazy_fv      = filterUFM (not . can_be_unleahsed) fv
     unleashed_fv = filterUFM can_be_unleahsed         fv
     can_be_unleahsed d = isStrictDmd d
 
+    -- [TODO]: discuss if it is a good idea
+    -- A trade-off do not include lazy-single-used guys 
+    lazy_no_card = case rec_flag of 
+                     Recursive    -> markAsUsedEnv lazy_fv
+                     NonRecursive -> lazy_fv
+
         -- final_dmds = setUnpackStrategy dmds
 	-- Set the unpacking strategy