-pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot
- where
- pp_bot | bot = ptext SLIT("B")
- | otherwise = empty
-
-
-pprDemand (WwLazy False) = char 'L'
-pprDemand (WwLazy True) = char 'A'
-pprDemand WwStrict = char 'S'
-pprDemand WwPrim = char 'P'
-pprDemand WwEnum = char 'E'
-pprDemand (WwUnpack wu args) = char ch <> parens (hcat (map pprDemand args))
- where
- ch = if wu then 'U' else 'u'
-
-instance Outputable Demand where
- ppr (WwLazy False) = empty
- ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand
-
-instance Show Demand where
- showsPrec p d = showsPrecSDoc p (ppr d)
-
--- Reading demands is done in Lex.lhs
+data DmdType = DmdType
+ DmdEnv -- Demand on explicitly-mentioned
+ -- free variables
+ [Demand] -- Demand on arguments
+ DmdResult -- Nature of result
+
+ -- IMPORTANT INVARIANT
+ -- The default demand on free variables not in the DmdEnv is:
+ -- DmdResult = BotRes <=> Bot
+ -- DmdResult = TopRes/ResCPR <=> Abs
+
+ -- ANOTHER IMPORTANT INVARIANT
+ -- The Demands in the argument list are never
+ -- Bot, Defer d
+ -- 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 :: DmdResult
+retCPR | opt_CprOff = TopRes
+ | otherwise = RetCPR
+
+seqDmdType :: DmdType -> ()
+seqDmdType (DmdType _env ds res) =
+ {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
+
+type DmdEnv = VarEnv Demand
+
+data DmdResult = TopRes -- Nothing known
+ | RetCPR -- Returns a constructed product
+ | BotRes -- Diverges or errors
+ deriving( Eq, Show )
+ -- Equality for fixpoints
+ -- Show needed for Show in Lex.Token (sigh)
+
+-- Equality needed for fixpoints in DmdAnal
+instance Eq DmdType where
+ (==) (DmdType fv1 ds1 res1)
+ (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
+ && ds1 == ds2 && res1 == res2
+
+instance Outputable DmdType where
+ ppr (DmdType fv ds res)
+ = hsep [text "DmdType",
+ hcat (map ppr ds) <> ppr res,
+ if null fv_elts then empty
+ else braces (fsep (map pp_elt fv_elts))]
+ where
+ pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
+ fv_elts = ufmToList fv
+
+instance Outputable DmdResult where
+ ppr TopRes = empty -- Keep these distinct from Demand letters
+ ppr RetCPR = char 'm' -- so that we can print strictness sigs as
+ ppr BotRes = char 'b' -- dddr
+ -- without ambiguity
+
+emptyDmdEnv :: VarEnv Demand
+emptyDmdEnv = emptyVarEnv
+
+topDmdType, botDmdType, cprDmdType :: DmdType
+topDmdType = DmdType emptyDmdEnv [] TopRes
+botDmdType = DmdType emptyDmdEnv [] BotRes
+cprDmdType = DmdType emptyVarEnv [] retCPR
+
+isTopDmdType :: DmdType -> Bool
+-- Only used on top-level types, hence the assert
+isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
+isTopDmdType _ = False
+
+isBotRes :: DmdResult -> Bool
+isBotRes BotRes = True
+isBotRes _ = False
+
+resTypeArgDmd :: DmdResult -> Demand
+-- TopRes and BotRes are polymorphic, so that
+-- 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
+
+returnsCPR :: DmdResult -> Bool
+returnsCPR RetCPR = True
+returnsCPR _ = False
+
+mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
+mkDmdType fv ds res = DmdType fv ds res
+
+mkTopDmdType :: [Demand] -> DmdResult -> DmdType
+mkTopDmdType ds res = DmdType emptyDmdEnv ds res
+
+dmdTypeDepth :: DmdType -> Arity
+dmdTypeDepth (DmdType _ ds _) = length ds