X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FNewDemand.lhs;h=8e68fd87d23cd00495ee25ff460358cd903a8031;hb=98344985c816d0abe17192f38b1663d85d8d2f9b;hp=df46950d9ba0c2a7e39610cd3b961f684b5bd36f;hpb=9e94a1afb46c14539c6efa778541c17a1641d712;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs
index df46950..8e68fd8 100644
--- a/ghc/compiler/basicTypes/NewDemand.lhs
+++ b/ghc/compiler/basicTypes/NewDemand.lhs
@@ -10,19 +10,21 @@ module NewDemand(
 	isTop, isAbsent, seqDemand,
 
 	DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, 
-		dmdTypeDepth, dmdTypeRes, seqDmdType,
+		dmdTypeDepth, seqDmdType,
 	DmdEnv, emptyDmdEnv,
-	DmdResult(..), isBotRes, returnsCPR, resTypeArgDmd,
+	DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd,
 	
 	Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
 
-	StrictSig(..), mkStrictSig, topSig, botSig, isTopSig,
-	splitStrictSig, strictSigResInfo,
+	StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
+        isTopSig,
+	splitStrictSig,
 	pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
      ) where
 
 #include "HsVersions.h"
 
+import StaticFlags	( opt_CprOff )
 import BasicTypes	( Arity )
 import VarEnv		( VarEnv, emptyVarEnv, isEmptyVarEnv )
 import UniqFM		( ufmToList )
@@ -126,8 +128,12 @@ instance Outputable Demand where
 instance Outputable Demands where
     ppr (Poly Abs) = empty
     ppr (Poly d)   = parens (ppr d <> char '*')
-    ppr (Prod ds) | all isAbsent ds = empty
-		  | otherwise       = parens (hcat (map ppr ds))
+    ppr (Prod ds)  = parens (hcat (map ppr ds))
+	-- At one time I printed U(AAA) as U, but that
+	-- confuses (Poly Abs) with (Prod AAA), and the
+	-- worker/wrapper generation differs slightly for these two
+	-- [Reason: in the latter case we can avoid passing the arg;
+	--  see notes with WwLib.mkWWstr_one.]
 \end{code}
 
 
@@ -155,6 +161,14 @@ data DmdType = DmdType
 	-- Handwavey reason: these don't correspond to calling conventions
 	-- See DmdAnal.funArgDemand for details
 
+
+-- This guy lets us switch off CPR analysis
+-- by making sure that everything uses TopRes instead of RetCPR
+-- Assuming, of course, that they don't mention RetCPR by name.
+-- They should onlyu use retCPR
+retCPR | opt_CprOff = TopRes
+       | otherwise  = RetCPR
+
 seqDmdType (DmdType env ds res) = 
   {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
 
@@ -190,8 +204,10 @@ instance Outputable DmdResult where
 			  -- without ambiguity
 
 emptyDmdEnv = emptyVarEnv
+
 topDmdType = DmdType emptyDmdEnv [] TopRes
 botDmdType = DmdType emptyDmdEnv [] BotRes
+cprDmdType = DmdType emptyVarEnv [] retCPR
 
 isTopDmdType :: DmdType -> Bool
 -- Only used on top-level types, hence the assert
@@ -207,9 +223,12 @@ resTypeArgDmd :: DmdResult -> Demand
 --	BotRes = Bot -> BotRes
 --	TopRes = Top -> TopRes
 -- This function makes that concrete
+-- We can get a RetCPR, because of the way in which we are (now)
+-- giving CPR info to strict arguments.  On the first pass, when
+-- nothing has demand info, we optimistically give CPR info or RetCPR to all args
 resTypeArgDmd TopRes = Top
+resTypeArgDmd RetCPR = Top
 resTypeArgDmd BotRes = Bot
-resTypeArgDmd RetCPR = panic "resTypeArgDmd: RetCPR"
 
 returnsCPR :: DmdResult -> Bool
 returnsCPR RetCPR = True
@@ -223,9 +242,6 @@ mkTopDmdType ds res = DmdType emptyDmdEnv ds res
 
 dmdTypeDepth :: DmdType -> Arity
 dmdTypeDepth (DmdType _ ds _) = length ds
-
-dmdTypeRes :: DmdType -> DmdResult
-dmdTypeRes (DmdType _ _ res_ty) = res_ty
 \end{code}
 
 
@@ -276,13 +292,13 @@ mkStrictSig dmd_ty = StrictSig dmd_ty
 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 
-strictSigResInfo :: StrictSig -> DmdResult
-strictSigResInfo (StrictSig (DmdType _ _ res)) = res
-
 isTopSig (StrictSig ty) = isTopDmdType ty
 
+topSig, botSig, cprSig :: StrictSig
 topSig = StrictSig topDmdType
 botSig = StrictSig botDmdType
+cprSig = StrictSig cprDmdType
+	
 
 -- appIsBottom returns true if an application to n args would diverge
 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT