[commit: ghc] cardinality: Crucial fixes (c78d511)

[Simon Peyton Jones]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : cardinality

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

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

commit c78d5113b05dc52b9edda0302252cc4607fe5711
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Mar 13 13:46:45 2013 +0000

    Crucial fixes
    
    * Bug in lubStr (made (SProd _ `lub` HyperStr) = HyperStr!!)
    
    * Bug in treatment of the scrut_dmd in dmdAnal (Case ...).
      I'd got the treatment of the case_bndr wrong.  Urk.

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

 compiler/basicTypes/Demand.lhs | 24 +++++++++++++++++-------
 compiler/stranal/DmdAnal.lhs   | 13 +++++++------
 2 files changed, 24 insertions(+), 13 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 1f43644..816e792 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -36,7 +36,7 @@ module Demand (
         evalDmd, cleanEvalDmd, vanillaCall, isStrictDmd, splitDmdTy,
         deferDmd, deferType, deferAndUse, deferEnv, modifyEnv,
 
-        splitProdDmd_maybe, peelCallDmd, mkCallDmd,
+        splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd,
         dmdTransformSig, dmdTransformDataConSig,
 
         -- cardinality unleashing stuff (perhaps, redundant)
@@ -67,7 +67,7 @@ import Maybes           ( isJust, expectJust )
 
         Lazy
          |
-        Str
+      HeadStr
       /     \
   SCall      SProd
       \      /
@@ -136,7 +136,7 @@ lubStr (SCall s1) HyperStr     = SCall s1
 lubStr (SCall _)  HeadStr      = HeadStr
 lubStr (SCall s1) (SCall s2)   = SCall (s1 `lubStr` s2)
 lubStr (SCall _)  (SProd _)    = HeadStr
-lubStr (SProd _)  HyperStr     = HyperStr
+lubStr (SProd sx) HyperStr     = SProd sx
 lubStr (SProd _)  HeadStr      = HeadStr
 lubStr (SProd s1) (SProd s2)
     | length s1 == length s2   = SProd (zipWith lubMaybeStr s1 s2)
@@ -520,6 +520,9 @@ should be: <L,C(U(AU))>m
 data CleanDemand = CD { sd :: StrDmd, ud :: UseDmd } 
   deriving ( Eq, Show )
 
+instance Outputable CleanDemand where
+  ppr (CD {sd = s, ud = a}) = angleBrackets (ppr s <> comma <> ppr a)
+
 mkCleanDmd :: StrDmd -> UseDmd -> CleanDemand
 mkCleanDmd s a = CD { sd = s, ud = a }
 
@@ -637,6 +640,16 @@ can be expanded to saturate a callee's arity.
 
 
 \begin{code}
+splitProdDmd :: Arity -> JointDmd -> [JointDmd]
+splitProdDmd n (JD {strd = s, absd = u})
+  = mkJointDmds (split_str s) (split_abs u)
+  where
+    split_str Lazy    = replicate n Lazy
+    split_str (Str s) = splitStrProdDmd n s
+
+    split_abs Abs       = replicate n Abs
+    split_abs (Use _ u) = splitUseProdDmd n u
+
 splitProdDmd_maybe :: JointDmd -> Maybe [JointDmd]
 -- Split a product into its components, iff there is any
 -- useful information to be extracted thereby
@@ -1180,10 +1193,6 @@ dmdTransformSig :: StrictSig -> CleanDemand -> DmdType
 -- that the function places on its context (eg its args)
 dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) 
                 (CD { sd = str, ud = abs })
-  | HyperStr <- str
-  = botDmdType  -- Transform bottom demand to bottom type
-                -- Seems a bit ad hoc
-  | otherwise
   = dmd_ty2
   where
     dmd_ty1 | str_sat   = dmd_ty
@@ -1195,6 +1204,7 @@ dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _))
     abs_sat = go_abs arg_ds abs
 
     go_str [] _              = True
+    go_str (_:_)  HyperStr   = True         -- HyperStr = Call(HyperStr)
     go_str (_:as) (SCall d') = go_str as d'
     go_str _      _          = False
 
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index f52d059..b8aba86 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -252,13 +252,11 @@ 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
         
-        
 	scrut_dmds1 = [idDemandInfo b | b <- bndrs', isId b]
-        scrut_dmds = case splitProdDmd_maybe (idDemandInfo case_bndr') of
-                        Nothing -> scrut_dmds1
-                        Just ds -> zipWithEqual "scrut_dmds" bothDmd scrut_dmds1 ds
+        scrut_dmds2 = splitProdDmd (length scrut_dmds1) (idDemandInfo case_bndr')
+        scrut_dmd   = mkProdDmd (zipWithEqual "scrut_dmds" bothDmd scrut_dmds1 scrut_dmds2)
 
-	(scrut_ty, scrut') = dmdAnal dflags env (mkProdDmd scrut_dmds) scrut
+	(scrut_ty, scrut') = dmdAnal dflags env scrut_dmd scrut
         res_ty             = alt_ty1 `bothDmdType` scrut_ty
     in
 --    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
@@ -565,7 +563,9 @@ dmdTransform env var dmd
        (idArity var) (idStrictness var) dmd
 
   | isGlobalId var	                         -- Imported function
-  = dmdTransformSig (idStrictness var) dmd
+  = let res = dmdTransformSig (idStrictness var) dmd in
+    -- pprTrace "dmdTransform" (vcat [ppr var, ppr dmd, ppr res]) 
+    res
 
   | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing
   , let 
@@ -781,6 +781,7 @@ annotateLamIdBndr dflags env (DmdType fv ds res) one_shot id
 -- For lambdas we add the demand to the argument demands
 -- Only called for Ids
   = ASSERT( isId id )
+    -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty]) $
     (final_ty, setOneShotness one_shot (setIdDemandInfo id dmd))
   where
       -- Watch out!  See note [Lambda-bound unfoldings]