2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Demand]{@Demand@: the amount of demand on a value}
9 topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd,
10 isTop, isAbsent, seqDemand,
12 DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
13 dmdTypeDepth, dmdTypeRes, seqDmdType,
15 DmdResult(..), isBotRes, returnsCPR, resTypeArgDmd,
17 Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
19 StrictSig(..), mkStrictSig, topSig, botSig, isTopSig,
20 splitStrictSig, strictSigResInfo,
21 pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
24 #include "HsVersions.h"
26 import BasicTypes ( Arity )
27 import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv )
28 import UniqFM ( ufmToList )
29 import Util ( listLengthCmp, zipWithEqual )
34 %************************************************************************
38 %************************************************************************
42 = Top -- T; used for unlifted types too, so that
48 | Eval Demands -- U(ds)
50 | Defer Demands -- D(ds)
56 -- Equality needed for fixpoints in DmdAnal
58 data Demands = Poly Demand -- Polymorphic case
59 | Prod [Demand] -- Product case
62 allTop (Poly d) = isTop d
63 allTop (Prod ds) = all isTop ds
71 mapDmds :: (Demand -> Demand) -> Demands -> Demands
72 mapDmds f (Poly d) = Poly (f d)
73 mapDmds f (Prod ds) = Prod (map f ds)
75 zipWithDmds :: (Demand -> Demand -> Demand)
76 -> Demands -> Demands -> Demands
77 zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2)
78 zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1]
79 zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
80 zipWithDmds f (Prod ds1) (Prod ds2) = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
82 topDmd, lazyDmd, seqDmd :: Demand
83 topDmd = Top -- The most uninformative demand
85 seqDmd = Eval (Poly Abs) -- Polymorphic seq demand
86 evalDmd = Box seqDmd -- Evaluate and return
87 errDmd = Box Bot -- This used to be called X
89 isStrictDmd :: Demand -> Bool
90 isStrictDmd Bot = True
91 isStrictDmd (Eval _) = True
92 isStrictDmd (Call _) = True
93 isStrictDmd (Box d) = isStrictDmd d
94 isStrictDmd other = False
96 seqDemand :: Demand -> ()
97 seqDemand (Call d) = seqDemand d
98 seqDemand (Eval ds) = seqDemands ds
99 seqDemand (Defer ds) = seqDemands ds
100 seqDemand (Box d) = seqDemand d
103 seqDemands :: Demands -> ()
104 seqDemands (Poly d) = seqDemand d
105 seqDemands (Prod ds) = seqDemandList ds
107 seqDemandList :: [Demand] -> ()
108 seqDemandList [] = ()
109 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
111 instance Outputable Demand where
116 ppr (Defer ds) = char 'D' <> ppr ds
117 ppr (Eval ds) = char 'U' <> ppr ds
119 ppr (Box (Eval ds)) = char 'S' <> ppr ds
120 ppr (Box Abs) = char 'L'
121 ppr (Box Bot) = char 'X'
123 ppr (Call d) = char 'C' <> parens (ppr d)
126 instance Outputable Demands where
127 ppr (Poly Abs) = empty
128 ppr (Poly d) = parens (ppr d <> char '*')
129 ppr (Prod ds) | all isAbsent ds = empty
130 | otherwise = parens (hcat (map ppr ds))
134 %************************************************************************
136 \subsection{Demand types}
138 %************************************************************************
141 data DmdType = DmdType
142 DmdEnv -- Demand on explicitly-mentioned
144 [Demand] -- Demand on arguments
145 DmdResult -- Nature of result
147 -- IMPORTANT INVARIANT
148 -- The default demand on free variables not in the DmdEnv is:
149 -- DmdResult = BotRes <=> Bot
150 -- DmdResult = TopRes/ResCPR <=> Abs
152 -- ANOTHER IMPORTANT INVARIANT
153 -- The Demands in the argument list are never
155 -- Handwavey reason: these don't correspond to calling conventions
156 -- See DmdAnal.funArgDemand for details
158 seqDmdType (DmdType env ds res) =
159 {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
161 type DmdEnv = VarEnv Demand
163 data DmdResult = TopRes -- Nothing known
164 | RetCPR -- Returns a constructed product
165 | BotRes -- Diverges or errors
167 -- Equality for fixpoints
168 -- Show needed for Show in Lex.Token (sigh)
170 -- Equality needed for fixpoints in DmdAnal
171 instance Eq DmdType where
172 (==) (DmdType fv1 ds1 res1)
173 (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
174 && ds1 == ds2 && res1 == res2
176 instance Outputable DmdType where
177 ppr (DmdType fv ds res)
178 = hsep [text "DmdType",
179 hcat (map ppr ds) <> ppr res,
180 if null fv_elts then empty
181 else braces (fsep (map pp_elt fv_elts))]
183 pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
184 fv_elts = ufmToList fv
186 instance Outputable DmdResult where
187 ppr TopRes = empty -- Keep these distinct from Demand letters
188 ppr RetCPR = char 'm' -- so that we can print strictness sigs as
189 ppr BotRes = char 'b' -- dddr
192 emptyDmdEnv = emptyVarEnv
193 topDmdType = DmdType emptyDmdEnv [] TopRes
194 botDmdType = DmdType emptyDmdEnv [] BotRes
196 isTopDmdType :: DmdType -> Bool
197 -- Only used on top-level types, hence the assert
198 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
199 isTopDmdType other = False
201 isBotRes :: DmdResult -> Bool
202 isBotRes BotRes = True
203 isBotRes other = False
205 resTypeArgDmd :: DmdResult -> Demand
206 -- TopRes and BotRes are polymorphic, so that
207 -- BotRes = Bot -> BotRes
208 -- TopRes = Top -> TopRes
209 -- This function makes that concrete
210 resTypeArgDmd TopRes = Top
211 resTypeArgDmd BotRes = Bot
212 resTypeArgDmd RetCPR = panic "resTypeArgDmd: RetCPR"
214 returnsCPR :: DmdResult -> Bool
215 returnsCPR RetCPR = True
216 returnsCPR other = False
218 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
219 mkDmdType fv ds res = DmdType fv ds res
221 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
222 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
224 dmdTypeDepth :: DmdType -> Arity
225 dmdTypeDepth (DmdType _ ds _) = length ds
227 dmdTypeRes :: DmdType -> DmdResult
228 dmdTypeRes (DmdType _ _ res_ty) = res_ty
232 %************************************************************************
234 \subsection{Strictness signature
236 %************************************************************************
238 In a let-bound Id we record its strictness info.
239 In principle, this strictness info is a demand transformer, mapping
240 a demand on the Id into a DmdType, which gives
241 a) the free vars of the Id's value
242 b) the Id's arguments
243 c) an indication of the result of applying
244 the Id to its arguments
246 However, in fact we store in the Id an extremely emascuated demand transfomer,
249 (Nevertheless we dignify StrictSig as a distinct type.)
251 This DmdType gives the demands unleashed by the Id when it is applied
252 to as many arguments as are given in by the arg demands in the DmdType.
254 For example, the demand transformer described by the DmdType
255 DmdType {x -> U(LL)} [V,A] Top
256 says that when the function is applied to two arguments, it
257 unleashes demand U(LL) on the free var x, V on the first arg,
260 If this same function is applied to one arg, all we can say is
261 that it uses x with U*(LL), and its arg with demand L.
264 newtype StrictSig = StrictSig DmdType
267 instance Outputable StrictSig where
268 ppr (StrictSig ty) = ppr ty
270 instance Show StrictSig where
271 show (StrictSig ty) = showSDoc (ppr ty)
273 mkStrictSig :: DmdType -> StrictSig
274 mkStrictSig dmd_ty = StrictSig dmd_ty
276 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
277 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
279 strictSigResInfo :: StrictSig -> DmdResult
280 strictSigResInfo (StrictSig (DmdType _ _ res)) = res
282 isTopSig (StrictSig ty) = isTopDmdType ty
284 topSig = StrictSig topDmdType
285 botSig = StrictSig botDmdType
287 -- appIsBottom returns true if an application to n args would diverge
288 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
289 appIsBottom _ _ = False
291 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
292 isBottomingSig _ = False
294 seqStrictSig (StrictSig ty) = seqDmdType ty
296 pprIfaceStrictSig :: StrictSig -> SDoc
297 -- Used for printing top-level strictness pragmas in interface files
298 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
299 = hcat (map ppr dmds) <> ppr res