[commit: ghc] wip/nested-cpr: Do not export DmdResult constructors in Demand.lhs (ed35eb8)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nested-cpr
Link       : http://ghc.haskell.org/trac/ghc/changeset/ed35eb8d519901bf6186f74ce7f0db87e508a97c/ghc

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

commit ed35eb8d519901bf6186f74ce7f0db87e508a97c
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Mon Dec 9 16:56:32 2013 +0000

    Do not export DmdResult constructors in Demand.lhs


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

ed35eb8d519901bf6186f74ce7f0db87e508a97c
 compiler/basicTypes/Demand.lhs |   16 ++++++++--------
 compiler/basicTypes/MkId.lhs   |    2 +-
 compiler/stranal/DmdAnal.lhs   |    6 +++---
 3 files changed, 12 insertions(+), 12 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index fa1cfdc..61c503c 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -25,7 +25,7 @@ module Demand (
         DmdEnv, emptyDmdEnv,
         peelFV,
 
-        DmdResult(..), CPRResult(..),
+        DmdResult, CPRResult(..),
         isBotRes, isTopRes, getDmdResult, resTypeArgDmd,
         topRes, botRes, cprConRes, vanillaCprConRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig, 
@@ -837,20 +837,20 @@ forgetCPR Diverges = Diverges
 forgetCPR (Converges _) = Converges NoCPR
 forgetCPR (Dunno _) = Dunno NoCPR
 
-cprConRes :: ConTag -> [DmdResult] -> CPRResult
+cprConRes :: ConTag -> [DmdResult] -> DmdResult
 cprConRes tag arg_ress
-  | opt_CprOff       = NoCPR
-  | opt_NestedCprOff = cutCPRResult flatCPRDepth $ RetCon tag arg_ress
-  | otherwise        = cutCPRResult maxCPRDepth  $ RetCon tag arg_ress
+  | opt_CprOff       = topRes
+  | opt_NestedCprOff = Converges $ cutCPRResult flatCPRDepth $ RetCon tag arg_ress
+  | otherwise        = Converges $ cutCPRResult maxCPRDepth  $ RetCon tag arg_ress
 
 getDmdResult :: DmdType -> DmdResult
 getDmdResult (DmdType _ [] r) = r       -- Only for data-typed arguments!
 getDmdResult _                = topRes
 
-vanillaCprConRes :: ConTag -> Arity -> CPRResult
+vanillaCprConRes :: ConTag -> Arity -> DmdResult
 vanillaCprConRes tag arity
-  | opt_CprOff = NoCPR
-  | otherwise  = cutCPRResult maxCPRDepth $ RetCon tag (replicate arity topRes)
+  | opt_CprOff = topRes
+  | otherwise  = Converges $ cutCPRResult maxCPRDepth $ RetCon tag (replicate arity topRes)
 
 isTopRes :: DmdResult -> Bool
 isTopRes (Dunno NoCPR) = True
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 4dcd3fe..ddb59a9 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -419,7 +419,7 @@ dataConCPR con
   , isVanillaDataCon con  -- No existentials 
   , wkr_arity > 0
   , wkr_arity <= mAX_CPR_SIZE
-  = Converges (vanillaCprConRes (dataConTag con) (dataConRepArity con))
+  = vanillaCprConRes (dataConTag con) (dataConRepArity con)
   | otherwise
   = topRes
   where
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 712274a..3724f26 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -524,10 +524,10 @@ dmdAnalVarApp env dmd fun args
   , n_val_args == dataConRepArity con      -- Saturated
   , dataConRepArity con > 0
   , dataConRepArity con < 10 -- TODO: Sync with mAX_CPR_SIZE in MkId
-  , let cpr_info = Converges (cprConRes (dataConTag con) arg_rets)
-        res_ty = foldl bothDmdType (DmdType emptyDmdEnv [] cpr_info) arg_tys
+  , let dmd_res = cprConRes (dataConTag con) arg_rets
+        res_ty = foldl bothDmdType (DmdType emptyDmdEnv [] dmd_res) arg_tys
   = -- pprTrace "dmdAnalVarApp" (vcat [ ppr con, ppr args, ppr n_val_args, ppr cxt_ds
-    --                                , ppr arg_tys, ppr (Converges cpr_info), ppr res_ty]) $
+    --                                , ppr arg_tys, ppr dmd_res, ppr res_ty]) $
     ( res_ty
     , foldl App (Var fun) args')
   where