2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Demand]{@Demand@: the amount of demand on a value}
8 Demand(..), Keepity(..), Deferredness(..),
9 topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd, isAbsentDmd,
11 DmdType(..), topDmdType, mkDmdType, mkTopDmdType,
12 dmdTypeDepth, dmdTypeRes,
14 DmdResult(..), isBotRes, returnsCPR,
16 StrictSig(..), mkStrictSig, topSig, botSig,
17 splitStrictSig, strictSigResInfo,
18 pprIfaceStrictSig, appIsBottom, isBottomingSig
21 #include "HsVersions.h"
23 import BasicTypes ( Arity )
25 import VarEnv ( VarEnv, emptyVarEnv )
26 import UniqFM ( ufmToList )
27 import qualified Demand
32 %************************************************************************
34 \subsection{Demand types}
36 %************************************************************************
39 data DmdType = DmdType
40 DmdEnv -- Demand on explicitly-mentioned
42 [Demand] -- Demand on arguments
43 DmdResult -- Nature of result
45 -- IMPORTANT INVARIANT
46 -- The default demand on free variables not in the DmdEnv is:
47 -- DmdResult = BotRes <=> Bot
48 -- DmdResult = TopRes/ResCPR <=> Abs
50 type DmdEnv = VarEnv Demand
52 data DmdResult = TopRes -- Nothing known
53 | RetCPR -- Returns a constructed product
54 | BotRes -- Diverges or errors
56 -- Equality for fixpoints
57 -- Show needed for Show in Lex.Token (sigh)
59 -- Equality needed for fixpoints in DmdAnal
60 instance Eq DmdType where
61 (==) (DmdType fv1 ds1 res1)
62 (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
63 && ds1 == ds2 && res1 == res2
65 instance Outputable DmdType where
66 ppr (DmdType fv ds res)
67 = hsep [text "DmdType",
68 hcat (map ppr ds) <> ppr res,
69 if null fv_elts then empty
70 else braces (fsep (map pp_elt fv_elts))]
72 pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
73 fv_elts = ufmToList fv
75 instance Outputable DmdResult where
76 ppr TopRes = empty -- Keep these distinct from Demand letters
77 ppr RetCPR = char 'm' -- so that we can print strictness sigs as
78 ppr BotRes = char 'b' -- dddr
81 emptyDmdEnv = emptyVarEnv
82 topDmdType = DmdType emptyDmdEnv [] TopRes
83 botDmdType = DmdType emptyDmdEnv [] BotRes
85 isBotRes :: DmdResult -> Bool
86 isBotRes BotRes = True
87 isBotRes other = False
89 returnsCPR :: DmdResult -> Bool
90 returnsCPR RetCPR = True
91 returnsCPR other = False
93 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
94 mkDmdType fv ds res = DmdType fv ds res
96 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
97 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
99 dmdTypeDepth :: DmdType -> Arity
100 dmdTypeDepth (DmdType _ ds _) = length ds
102 dmdTypeRes :: DmdType -> DmdResult
103 dmdTypeRes (DmdType _ _ res_ty) = res_ty
107 %************************************************************************
109 \subsection{Strictness signature
111 %************************************************************************
113 In a let-bound Id we record its strictness info.
114 In principle, this strictness info is a demand transformer, mapping
115 a demand on the Id into a DmdType, which gives
116 a) the free vars of the Id's value
117 b) the Id's arguments
118 c) an indication of the result of applying
119 the Id to its arguments
121 However, in fact we store in the Id an extremely emascuated demand transfomer,
124 (Nevertheless we dignify StrictSig as a distinct type.)
126 This DmdType gives the demands unleashed by the Id when it is applied
127 to as many arguments as are given in by the arg demands in the DmdType.
129 For example, the demand transformer described by the DmdType
130 DmdType {x -> U(LL)} [V,A] Top
131 says that when the function is applied to two arguments, it
132 unleashes demand U(LL) on the free var x, V on the first arg,
135 If this same function is applied to one arg, all we can say is
136 that it uses x with U*(LL), and its arg with demand L.
139 newtype StrictSig = StrictSig DmdType
142 instance Outputable StrictSig where
143 ppr (StrictSig ty) = ppr ty
145 instance Show StrictSig where
146 show (StrictSig ty) = showSDoc (ppr ty)
148 mkStrictSig :: Id -> Arity -> DmdType -> StrictSig
149 mkStrictSig id arity dmd_ty
150 = WARN( arity /= dmdTypeDepth dmd_ty, ppr id <+> (ppr arity $$ ppr dmd_ty) )
153 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
154 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
156 strictSigResInfo :: StrictSig -> DmdResult
157 strictSigResInfo (StrictSig (DmdType _ _ res)) = res
159 topSig = StrictSig topDmdType
160 botSig = StrictSig botDmdType
162 -- appIsBottom returns true if an application to n args would diverge
163 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = n >= length ds
164 appIsBottom _ _ = False
166 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
167 isBottomingSig _ = False
169 pprIfaceStrictSig :: StrictSig -> SDoc
170 -- Used for printing top-level strictness pragmas in interface files
171 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
172 = hcat (map ppr dmds) <> ppr res
176 %************************************************************************
180 %************************************************************************
184 = Lazy -- L; used for unlifted types too, so that
187 | Call Demand -- C(d)
189 | Seq Keepity -- S/U(ds)
195 -- Equality needed for fixpoints in DmdAnal
197 data Deferredness = Now | Defer
200 data Keepity = Keep | Drop
203 topDmd, lazyDmd, seqDmd :: Demand
204 topDmd = Lazy -- The most uninformative demand
206 seqDmd = Seq Keep Now [] -- Polymorphic seq demand
209 isStrictDmd :: Demand -> Bool
210 isStrictDmd Bot = True
211 isStrictDmd Err = True
212 isStrictDmd (Seq _ Now _) = True
213 isStrictDmd Eval = True
214 isStrictDmd (Call _) = True
215 isStrictDmd other = False
217 isAbsentDmd :: Demand -> Bool
218 isAbsentDmd Bot = True
219 isAbsentDmd Err = True
220 isAbsentDmd Abs = True
221 isAbsentDmd other = False
223 instance Outputable Demand where
229 ppr (Call d) = char 'C' <> parens (ppr d)
230 ppr (Seq k l []) = ppr k <> ppr l
231 ppr (Seq k l ds) = ppr k <> ppr l <> parens (hcat (map ppr ds))
233 instance Outputable Deferredness where
237 instance Outputable Keepity where