Add mapOccEnv

[ghc-hetmet.git] / ghc / compiler / basicTypes / NewDemand.lhs

diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs
index ea314d5..8e68fd8 100644 (file)
--- 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 )
@@ -159,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` ()
 
@@ -194,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
@@ -211,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
@@ -227,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}
 
 
@@ -280,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