2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Demand]{@Demand@: the amount of demand on a value}
8 Demand(..), Keepity(..),
9 mkSeq, topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd,
11 DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
12 dmdTypeDepth, dmdTypeRes,
14 DmdResult(..), isBotRes, returnsCPR,
16 StrictSig(..), mkStrictSig, topSig, botSig, isTopSig,
17 splitStrictSig, strictSigResInfo,
18 pprIfaceStrictSig, appIsBottom, isBottomingSig
21 #include "HsVersions.h"
23 import BasicTypes ( Arity )
24 import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv )
25 import UniqFM ( ufmToList )
26 import Util ( listLengthCmp )
31 %************************************************************************
33 \subsection{Demand types}
35 %************************************************************************
38 data DmdType = DmdType
39 DmdEnv -- Demand on explicitly-mentioned
41 [Demand] -- Demand on arguments
42 DmdResult -- Nature of result
44 -- IMPORTANT INVARIANT
45 -- The default demand on free variables not in the DmdEnv is:
46 -- DmdResult = BotRes <=> Bot
47 -- DmdResult = TopRes/ResCPR <=> Abs
49 -- ANOTHER IMPORTANT INVARIANT
50 -- The Demands in the argument list are never
51 -- Bot, Err, Seq Defer ds
52 -- Handwavey reason: these don't correspond to calling conventions
53 -- See DmdAnal.funArgDemand for details
55 type DmdEnv = VarEnv Demand
57 data DmdResult = TopRes -- Nothing known
58 | RetCPR -- Returns a constructed product
59 | BotRes -- Diverges or errors
61 -- Equality for fixpoints
62 -- Show needed for Show in Lex.Token (sigh)
64 -- Equality needed for fixpoints in DmdAnal
65 instance Eq DmdType where
66 (==) (DmdType fv1 ds1 res1)
67 (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
68 && ds1 == ds2 && res1 == res2
70 instance Outputable DmdType where
71 ppr (DmdType fv ds res)
72 = hsep [text "DmdType",
73 hcat (map ppr ds) <> ppr res,
74 if null fv_elts then empty
75 else braces (fsep (map pp_elt fv_elts))]
77 pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
78 fv_elts = ufmToList fv
80 instance Outputable DmdResult where
81 ppr TopRes = empty -- Keep these distinct from Demand letters
82 ppr RetCPR = char 'm' -- so that we can print strictness sigs as
83 ppr BotRes = char 'b' -- dddr
86 emptyDmdEnv = emptyVarEnv
87 topDmdType = DmdType emptyDmdEnv [] TopRes
88 botDmdType = DmdType emptyDmdEnv [] BotRes
90 isTopDmdType :: DmdType -> Bool
91 -- Only used on top-level types, hence the assert
92 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
93 isTopDmdType other = False
95 isBotRes :: DmdResult -> Bool
96 isBotRes BotRes = True
97 isBotRes other = False
99 returnsCPR :: DmdResult -> Bool
100 returnsCPR RetCPR = True
101 returnsCPR other = False
103 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
104 mkDmdType fv ds res = DmdType fv ds res
106 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
107 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
109 dmdTypeDepth :: DmdType -> Arity
110 dmdTypeDepth (DmdType _ ds _) = length ds
112 dmdTypeRes :: DmdType -> DmdResult
113 dmdTypeRes (DmdType _ _ res_ty) = res_ty
117 %************************************************************************
119 \subsection{Strictness signature
121 %************************************************************************
123 In a let-bound Id we record its strictness info.
124 In principle, this strictness info is a demand transformer, mapping
125 a demand on the Id into a DmdType, which gives
126 a) the free vars of the Id's value
127 b) the Id's arguments
128 c) an indication of the result of applying
129 the Id to its arguments
131 However, in fact we store in the Id an extremely emascuated demand transfomer,
134 (Nevertheless we dignify StrictSig as a distinct type.)
136 This DmdType gives the demands unleashed by the Id when it is applied
137 to as many arguments as are given in by the arg demands in the DmdType.
139 For example, the demand transformer described by the DmdType
140 DmdType {x -> U(LL)} [V,A] Top
141 says that when the function is applied to two arguments, it
142 unleashes demand U(LL) on the free var x, V on the first arg,
145 If this same function is applied to one arg, all we can say is
146 that it uses x with U*(LL), and its arg with demand L.
149 newtype StrictSig = StrictSig DmdType
152 instance Outputable StrictSig where
153 ppr (StrictSig ty) = ppr ty
155 instance Show StrictSig where
156 show (StrictSig ty) = showSDoc (ppr ty)
158 mkStrictSig :: DmdType -> StrictSig
159 mkStrictSig dmd_ty = StrictSig dmd_ty
161 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
162 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
164 strictSigResInfo :: StrictSig -> DmdResult
165 strictSigResInfo (StrictSig (DmdType _ _ res)) = res
167 isTopSig (StrictSig ty) = isTopDmdType ty
169 topSig = StrictSig topDmdType
170 botSig = StrictSig botDmdType
172 -- appIsBottom returns true if an application to n args would diverge
173 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
174 appIsBottom _ _ = False
176 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
177 isBottomingSig _ = False
179 pprIfaceStrictSig :: StrictSig -> SDoc
180 -- Used for printing top-level strictness pragmas in interface files
181 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
182 = hcat (map ppr dmds) <> ppr res
186 %************************************************************************
190 %************************************************************************
194 = Lazy -- L; used for unlifted types too, so that
198 | Call Demand -- C(d)
200 | Seq Keepity -- S/U/D(ds)
201 [Demand] -- S(ds) = L `both` U(ds)
202 -- D(ds) = A `lub` U(ds)
203 -- *** Invariant: these demands are never Bot or Abs
204 -- *** Invariant: if all demands are Abs, get []
209 -- Equality needed for fixpoints in DmdAnal
211 data Keepity = Keep -- Strict and I need the box
212 | Drop -- Strict, but I don't need the box
213 | Defer -- Lazy, if you *do* evaluate, I need
214 -- the components but not the box
217 mkSeq :: Keepity -> [Demand] -> Demand
218 mkSeq k ds | all is_absent ds = Seq k []
219 | otherwise = Seq k ds
224 topDmd, lazyDmd, seqDmd :: Demand
225 topDmd = Lazy -- The most uninformative demand
227 seqDmd = Seq Keep [] -- Polymorphic seq demand
230 isStrictDmd :: Demand -> Bool
231 isStrictDmd Bot = True
232 isStrictDmd Err = True
233 isStrictDmd (Seq Drop _) = True -- But not Defer!
234 isStrictDmd (Seq Keep _) = True
235 isStrictDmd Eval = True
236 isStrictDmd (Call _) = True
237 isStrictDmd other = False
239 instance Outputable Demand where
245 ppr (Call d) = char 'C' <> parens (ppr d)
246 ppr (Seq k []) = ppr k
247 ppr (Seq k ds) = ppr k <> parens (hcat (map ppr ds))
249 instance Outputable Keepity where