[commit: ghc] new-demand: a small bug in CPR glb computation fixed; pretty-printing of old demands in the new style (e50e67c)

[Ilya Sergey]

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

On branch  : new-demand

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

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

commit e50e67c785abb1cfc6a787aba7bd46d93266f966
Author: Ilya Sergey <Ilya.Sergey at cs.kuleuven.be>
Date:   Tue Jul 17 15:00:53 2012 +0100

    a small bug in CPR glb computation fixed; pretty-printing of old demands in the new style

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

 compiler/basicTypes/Demand.lhs    |   42 ++++++++++++++++++++++++++++++++++++-
 compiler/basicTypes/NewDemand.lhs |   22 ++++++++++--------
 2 files changed, 53 insertions(+), 11 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 7d6a093..d715706 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -38,6 +38,7 @@ import VarEnv
 import UniqFM
 import Util
 import Outputable
+import qualified NewDemand as ND
 \end{code}
 
 
@@ -303,7 +304,9 @@ newtype StrictSig = StrictSig DmdType
 		  deriving( Eq )
 
 instance Outputable StrictSig where
-   ppr (StrictSig ty) = ppr ty
+   ppr sig@(StrictSig ty) 
+     = text "   " <> ppr (toNewDmdSig sig) <> 
+       text " | " <> ppr ty 
 
 mkStrictSig :: DmdType -> StrictSig
 mkStrictSig dmd_ty = StrictSig dmd_ty
@@ -343,4 +346,41 @@ pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
   = hcat (map ppr dmds) <> ppr res
 \end{code}
     
+%************************************************************************
+%*									*
+\subsection{Translating old demands to new demands}
+%*									*
+%************************************************************************
 
+\begin{code}
+
+toNewDmd :: Demand -> ND.Demand
+toNewDmd Top          = ND.top
+toNewDmd Abs          = ND.absDmd
+toNewDmd Bot          = ND.bot
+toNewDmd (Call d)     = ND.mkCallDmd $ toNewDmd d
+toNewDmd (Box d)      = ND.use $ toNewDmd d
+toNewDmd (Defer ds)   = ND.defer $ ND.mkProdDmd $ dsToDmd ds
+toNewDmd (Eval ds)    = ND.mkProdDmd $ dsToDmd ds
+
+dsToDmd :: Demands -> [ND.Demand]
+dsToDmd (Prod ds)  = map toNewDmd ds
+dsToDmd (Poly d)   = [toNewDmd d]
+
+toNewRes :: DmdResult -> ND.DmdResult
+toNewRes d
+   | isBotRes d   = ND.botRes
+   | returnsCPR d = ND.cprRes
+   | otherwise    = ND.topRes
+
+toNewDmdTy :: DmdType -> ND.DmdType
+toNewDmdTy (DmdType env ds res)
+  = ND.DmdType (mapVarEnv toNewDmd env) 
+               (map toNewDmd ds) 
+               (toNewRes res)                           
+
+toNewDmdSig :: StrictSig -> ND.StrictSig
+toNewDmdSig (StrictSig dt) 
+  = ND.StrictSig $ toNewDmdTy dt
+
+\end{code}
diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs
index 2b928eb..6315a4a 100644
--- a/compiler/basicTypes/NewDemand.lhs
+++ b/compiler/basicTypes/NewDemand.lhs
@@ -23,9 +23,8 @@ module NewDemand (
         seqStrDmd, seqStrDmdList, seqAbsDmd, seqAbsDmdList,
         seqDemand, seqDemandList, seqDmdType, seqStrictSig, 
         evalDmd, vanillaCall, isStrictDmd, splitCallDmd, splitDmdTy,
-        defer, deferType, deferEnv, modifyEnv,
-        isProdDmd, isPolyDmd, replicateDmd, splitProdDmd, peelCallDmd, mkCallDmd
-
+        defer, use, deferType, deferEnv, modifyEnv,
+        isProdDmd, isPolyDmd, replicateDmd, splitProdDmd, peelCallDmd, mkCallDmd,
      ) where
 
 #include "HsVersions.h"
@@ -37,8 +36,7 @@ import UniqFM
 import Util
 import BasicTypes
 import Binary
-import Maybes		( expectJust )
-
+import Maybes		         ( expectJust )
 
 {-! for StrDmd derive: Binary !-}
 {-! for AbsDmd derive: Binary !-}
@@ -400,6 +398,9 @@ vanillaCall n =
 defer :: Demand -> Demand
 defer (JD _ a) = (JD top a)
 
+use :: Demand -> Demand
+use (JD d _) = (JD d top)
+
 \end{code}
 
 Note [Replicating polymorphic demands]
@@ -527,7 +528,8 @@ instance LatticeLike DmdResult where
   pre (DR s1 a1) (DR s2 a2)  = (pre s1 s2) && (pre a1 a2)
 
   lub  (DR s1 a1) (DR s2 a2) = mkDmdResult (lub s1 s2)  $ lub a1 a2            
-  both (DR s1 a1) (DR s2 a2) = mkDmdResult (both s1 s2) $ both a1 a2            
+  both _ r | isBotRes r = botRes
+  both r _              = r
 
 -- Pretty-printing
 instance Outputable DmdResult where
@@ -543,7 +545,7 @@ instance Binary DmdResult where
               return $ mkDmdResult x y
 
 mkDmdResult :: PureResult -> CPRResult -> DmdResult
-mkDmdResult BotRes NoCPR = topRes
+mkDmdResult BotRes RetCPR = botRes
 mkDmdResult x y = DR x y
 
 seqDmdResult :: DmdResult -> ()
@@ -555,8 +557,8 @@ seqDmdResult (DR x y) = x `seq` y `seq` ()
 -- They should onlyu use retCPR
 topRes, botRes, cprRes :: DmdResult
 topRes = DR TopRes NoCPR
-botRes = DR BotRes RetCPR
-cprRes | opt_CprOff = DR TopRes NoCPR
+botRes = DR BotRes NoCPR
+cprRes | opt_CprOff = topRes
        | otherwise  = DR TopRes RetCPR
 
 isTopRes :: DmdResult -> Bool
@@ -848,4 +850,4 @@ seqStrictSig (StrictSig ty) = seqDmdType ty
 pprIfaceStrictSig :: StrictSig -> SDoc
 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
   = hcat (map ppr dmds) <> ppr res
-\end{code}
+\end{code}
\ No newline at end of file