[commit: ghc] cardinality: product demand machinery adapted to handle cardinality (8adb606)

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

On branch  : cardinality

http://hackage.haskell.org/trac/ghc/changeset/8adb606c9c4bb139a76d1c2bd56b6004946ddf5a

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

commit 8adb606c9c4bb139a76d1c2bd56b6004946ddf5a
Author: ilyasergey <[email protected]>
Date:   Thu Nov 8 16:34:35 2012 +0100

    product demand machinery adapted to handle cardinality

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

 compiler/basicTypes/Demand.lhs     |   20 ++++++++++----------
 compiler/basicTypes/MkId.lhs       |    2 +-
 compiler/specialise/SpecConstr.lhs |    2 +-
 compiler/stranal/DmdAnal.lhs       |    5 +++--
 compiler/stranal/WwLib.lhs         |    2 +-
 5 files changed, 16 insertions(+), 15 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 6e333f2..2f29da5 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -242,7 +242,7 @@ isUsedOnce Abs            = True
 isUsedOnce (Used One)     = True 
 isUsedOnce (UHead One)    = True 
 isUsedOnce (UCall One _)  = True
-isUsedOnce (UProd One ux) = all isUsedOnce ux
+isUsedOnce (UProd One ux) = True
 isUsedOnce _              = False
 
 absCall :: Count -> AbsDmd -> AbsDmd
@@ -417,12 +417,12 @@ mkJointDmd s a
      (HyperStr, UProd c _) -> JD {strd = HyperStr, absd = Used c}
      _                     -> JD {strd = s, absd = a}
 
-mkProdDmd :: [JointDmd] -> JointDmd
-mkProdDmd dx 
+mkProdDmd :: Count -> [JointDmd] -> JointDmd
+mkProdDmd c dx 
   = mkJointDmd sp up 
   where
     sp = strProd $ map strd dx
-    up = absProd One $ map absd dx   
+    up = absProd c $ map absd dx   
      
 instance LatticeLike JointDmd where
   bot                        = mkJointDmd bot bot
@@ -621,15 +621,15 @@ isPolyDmd :: Demand -> Bool
 isPolyDmd (JD {strd=a, absd=b}) = isPolyStrDmd a && isPolyAbsDmd b
 
 -- Split a product to parameteres
-splitProdDmd :: Demand -> [Demand]
-splitProdDmd JD {strd=SProd sx, absd=UProd _ ux}
-  = ASSERT( sx `lengthIs` (length ux) ) zipWith mkJointDmd sx ux
+splitProdDmd :: Demand -> (Count, [Demand])
+splitProdDmd JD {strd=SProd sx, absd=UProd c ux}
+  = ASSERT( sx `lengthIs` (length ux) ) (c, zipWith mkJointDmd sx ux)
 splitProdDmd JD {strd=SProd sx, absd=u} 
   | isPolyAbsDmd u  
-  =  zipWith mkJointDmd sx (replicateAbsDmd (length sx) u)
-splitProdDmd (JD {strd=s, absd=UProd _ ux})
+  =  (card u, zipWith mkJointDmd sx (replicateAbsDmd (length sx) u))
+splitProdDmd (JD {strd=s, absd=UProd c ux})
   | isPolyStrDmd s  
-  =  zipWith mkJointDmd (replicateStrDmd (length ux) s) ux
+  =  (c, zipWith mkJointDmd (replicateStrDmd (length ux) s) ux)
 splitProdDmd d = pprPanic "splitProdDmd" (ppr d)
 
 \end{code}
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 05b45ab..25c7453 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -486,7 +486,7 @@ mkDictSelId dflags no_unf name clas
 
     strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] topRes)
     arg_dmd | new_tycon = evalDmd
-            | otherwise = mkProdDmd [ if the_arg_id == id then evalDmd else absDmd
+            | otherwise = mkProdDmd Many [ if the_arg_id == id then evalDmd else absDmd
                                           | id <- arg_ids ]
 
 
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 08d06ad..ab9ef85 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -1439,7 +1439,7 @@ calcSpecStrictness fn qvars pats
     go_one env d   (Var v) = extendVarEnv_C both env v d
     go_one env d e 
     	   | isProdDmd d
-           , ds <- splitProdDmd d
+           , (_, ds) <- splitProdDmd d
            , (Var _, args) <- collectArgs e = go env ds args
     go_one env _         _ = env
 
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 569c3ea..e6a1757 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -243,7 +243,8 @@ dmdAnal dflags _ env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
 	-- The insight is, of course, that a demand on y is a demand on the
 	-- scrutinee, so we need to `both` it with the scrut demand
 
-	alt_dmd 	   = mkProdDmd [idDemandInfo b | b <- bndrs', isId b]
+	alt_dmd 	   = mkProdDmd One [idDemandInfo b | b <- bndrs', isId b]
+                             -- the scrutinee is used just once
         scrut_dmd 	   = alt_dmd `both`
 			     idDemandInfo case_bndr'
 
@@ -561,7 +562,7 @@ dmdTransform env var dmd
            -- Invariant: res_dmd does not have call demand as its component
 	   arg_ds = if isPolyDmd res_dmd
                     then replicateDmd arity res_dmd
-                    else splitProdDmd res_dmd
+                    else snd $ splitProdDmd res_dmd
 	in
 	mkDmdType emptyDmdEnv arg_ds con_res
 		-- Must remember whether it's a product, hence con_res, not TopRes
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index 2ed5640..34312d3 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -432,7 +432,7 @@ mkWWstr_one dflags arg
         , isProdDmd d || isPolyDmd d
 	, Just (_arg_tycon, _tycon_arg_tys, data_con, inst_con_arg_tys) 
              <- deepSplitProductType_maybe (idType arg)
-        , cs <- if isProdDmd d then splitProdDmd d
+        , cs <- if isProdDmd d then snd $ splitProdDmd d
                   --  otherwise is polymorphic demand   
                 else replicateDmd (length inst_con_arg_tys) d 
 	-> do uniqs <- getUniquesM