Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / basicTypes / Demand.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[Demand]{@Demand@: the amount of demand on a value}
6
7 \begin{code}
8 {-# OPTIONS -fno-warn-tabs #-}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and
11 -- detab the module (please do the detabbing in a separate patch). See
12 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
13 -- for details
14
15 module Demand(
16         Demand(..), 
17         topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd, 
18         isTop, isAbsent, seqDemand,
19
20         DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, 
21                 dmdTypeDepth, seqDmdType,
22         DmdEnv, emptyDmdEnv,
23         DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd,
24         
25         Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
26
27         StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
28         isTopSig,
29         splitStrictSig, increaseStrictSigArity,
30         pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
31      ) where
32
33 #include "HsVersions.h"
34
35 import StaticFlags
36 import BasicTypes
37 import VarEnv
38 import UniqFM
39 import Util
40 import Outputable
41 \end{code}
42
43
44 %************************************************************************
45 %*                                                                      *
46 \subsection{Demands}
47 %*                                                                      *
48 %************************************************************************
49
50 \begin{code}
51 data Demand
52   = Top                 -- T; used for unlifted types too, so that
53                         --      A `lub` T = T
54   | Abs                 -- A
55
56   | Call Demand         -- C(d)
57
58   | Eval Demands        -- U(ds)
59
60   | Defer Demands       -- D(ds)
61
62   | Box Demand          -- B(d)
63
64   | Bot                 -- B
65   deriving( Eq )
66         -- Equality needed for fixpoints in DmdAnal
67
68 data Demands = Poly Demand      -- Polymorphic case
69              | Prod [Demand]    -- Product case
70              deriving( Eq )
71
72 allTop :: Demands -> Bool
73 allTop (Poly d)  = isTop d
74 allTop (Prod ds) = all isTop ds
75
76 isTop :: Demand -> Bool
77 isTop Top = True
78 isTop _   = False 
79
80 isAbsent :: Demand -> Bool
81 isAbsent Abs = True
82 isAbsent _   = False 
83
84 mapDmds :: (Demand -> Demand) -> Demands -> Demands
85 mapDmds f (Poly d)  = Poly (f d)
86 mapDmds f (Prod ds) = Prod (map f ds)
87
88 zipWithDmds :: (Demand -> Demand -> Demand)
89             -> Demands -> Demands -> Demands
90 zipWithDmds f (Poly d1)  (Poly d2)  = Poly (d1 `f` d2)
91 zipWithDmds f (Prod ds1) (Poly d2)  = Prod [d1 `f` d2 | d1 <- ds1]
92 zipWithDmds f (Poly d1)  (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
93 zipWithDmds f (Prod ds1) (Prod ds2) 
94   | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
95   | otherwise                = Poly topDmd
96         -- This really can happen with polymorphism
97         -- \f. case f x of (a,b) -> ...
98         --     case f y of (a,b,c) -> ...
99         -- Here the two demands on f are C(LL) and C(LLL)!
100
101 topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand
102 topDmd  = Top                   -- The most uninformative demand
103 lazyDmd = Box Abs
104 seqDmd  = Eval (Poly Abs)       -- Polymorphic seq demand
105 evalDmd = Box seqDmd            -- Evaluate and return
106 errDmd  = Box Bot               -- This used to be called X
107
108 isStrictDmd :: Demand -> Bool
109 isStrictDmd Bot      = True
110 isStrictDmd (Eval _) = True
111 isStrictDmd (Call _) = True
112 isStrictDmd (Box d)  = isStrictDmd d
113 isStrictDmd _        = False
114
115 seqDemand :: Demand -> ()
116 seqDemand (Call d)   = seqDemand d
117 seqDemand (Eval ds)  = seqDemands ds
118 seqDemand (Defer ds) = seqDemands ds
119 seqDemand (Box d)    = seqDemand d
120 seqDemand _          = ()
121
122 seqDemands :: Demands -> ()
123 seqDemands (Poly d)  = seqDemand d
124 seqDemands (Prod ds) = seqDemandList ds
125
126 seqDemandList :: [Demand] -> ()
127 seqDemandList [] = ()
128 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
129
130 instance Outputable Demand where
131     ppr Top  = char 'T'
132     ppr Abs  = char 'A'
133     ppr Bot  = char 'B'
134
135     ppr (Defer ds)      = char 'D' <> ppr ds
136     ppr (Eval ds)       = char 'U' <> ppr ds
137                                       
138     ppr (Box (Eval ds)) = char 'S' <> ppr ds
139     ppr (Box Abs)       = char 'L'
140     ppr (Box Bot)       = char 'X'
141     ppr d@(Box _)       = pprPanic "ppr: Bad boxed demand" (ppr d)
142
143     ppr (Call d)        = char 'C' <> parens (ppr d)
144
145
146 instance Outputable Demands where
147     ppr (Poly Abs) = empty
148     ppr (Poly d)   = parens (ppr d <> char '*')
149     ppr (Prod ds)  = parens (hcat (map ppr ds))
150         -- At one time I printed U(AAA) as U, but that
151         -- confuses (Poly Abs) with (Prod AAA), and the
152         -- worker/wrapper generation differs slightly for these two
153         -- [Reason: in the latter case we can avoid passing the arg;
154         --  see notes with WwLib.mkWWstr_one.]
155 \end{code}
156
157
158 %************************************************************************
159 %*                                                                      *
160 \subsection{Demand types}
161 %*                                                                      *
162 %************************************************************************
163
164 \begin{code}
165 data DmdType = DmdType 
166                     DmdEnv      -- Demand on explicitly-mentioned 
167                                 --      free variables
168                     [Demand]    -- Demand on arguments
169                     DmdResult   -- Nature of result
170
171         --              IMPORTANT INVARIANT
172         -- The default demand on free variables not in the DmdEnv is:
173         -- DmdResult = BotRes        <=>  Bot
174         -- DmdResult = TopRes/ResCPR <=>  Abs
175
176         --              ANOTHER IMPORTANT INVARIANT
177         -- The Demands in the argument list are never
178         --      Bot, Defer d
179         -- Handwavey reason: these don't correspond to calling conventions
180         -- See DmdAnal.funArgDemand for details
181
182
183 -- This guy lets us switch off CPR analysis
184 -- by making sure that everything uses TopRes instead of RetCPR
185 -- Assuming, of course, that they don't mention RetCPR by name.
186 -- They should onlyu use retCPR
187 retCPR :: DmdResult
188 retCPR | opt_CprOff = TopRes
189        | otherwise  = RetCPR
190
191 seqDmdType :: DmdType -> ()
192 seqDmdType (DmdType _env ds res) = 
193   {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
194
195 type DmdEnv = VarEnv Demand
196
197 data DmdResult = TopRes -- Nothing known        
198                | RetCPR -- Returns a constructed product
199                | BotRes -- Diverges or errors
200                deriving( Eq, Show )
201         -- Equality for fixpoints
202         -- Show needed for Show in Lex.Token (sigh)
203
204 -- Equality needed for fixpoints in DmdAnal
205 instance Eq DmdType where
206   (==) (DmdType fv1 ds1 res1)
207        (DmdType fv2 ds2 res2) =  ufmToList fv1 == ufmToList fv2
208                               && ds1 == ds2 && res1 == res2
209
210 instance Outputable DmdType where
211   ppr (DmdType fv ds res) 
212     = hsep [text "DmdType",
213             hcat (map ppr ds) <> ppr res,
214             if null fv_elts then empty
215             else braces (fsep (map pp_elt fv_elts))]
216     where
217       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
218       fv_elts = ufmToList fv
219
220 instance Outputable DmdResult where
221   ppr TopRes = empty      -- Keep these distinct from Demand letters
222   ppr RetCPR = char 'm'   -- so that we can print strictness sigs as
223   ppr BotRes = char 'b'   --    dddr
224                           -- without ambiguity
225
226 emptyDmdEnv :: VarEnv Demand
227 emptyDmdEnv = emptyVarEnv
228
229 topDmdType, botDmdType, cprDmdType :: DmdType
230 topDmdType = DmdType emptyDmdEnv [] TopRes
231 botDmdType = DmdType emptyDmdEnv [] BotRes
232 cprDmdType = DmdType emptyVarEnv [] retCPR
233
234 isTopDmdType :: DmdType -> Bool
235 -- Only used on top-level types, hence the assert
236 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True  
237 isTopDmdType _                       = False
238
239 isBotRes :: DmdResult -> Bool
240 isBotRes BotRes = True
241 isBotRes _      = False
242
243 resTypeArgDmd :: DmdResult -> Demand
244 -- TopRes and BotRes are polymorphic, so that
245 --      BotRes = Bot -> BotRes
246 --      TopRes = Top -> TopRes
247 -- This function makes that concrete
248 -- We can get a RetCPR, because of the way in which we are (now)
249 -- giving CPR info to strict arguments.  On the first pass, when
250 -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
251 resTypeArgDmd TopRes = Top
252 resTypeArgDmd RetCPR = Top
253 resTypeArgDmd BotRes = Bot
254
255 returnsCPR :: DmdResult -> Bool
256 returnsCPR RetCPR = True
257 returnsCPR _      = False
258
259 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
260 mkDmdType fv ds res = DmdType fv ds res
261
262 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
263 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
264
265 dmdTypeDepth :: DmdType -> Arity
266 dmdTypeDepth (DmdType _ ds _) = length ds
267 \end{code}
268
269
270 %************************************************************************
271 %*                                                                      *
272 \subsection{Strictness signature
273 %*                                                                      *
274 %************************************************************************
275
276 In a let-bound Id we record its strictness info.  
277 In principle, this strictness info is a demand transformer, mapping
278 a demand on the Id into a DmdType, which gives
279         a) the free vars of the Id's value
280         b) the Id's arguments
281         c) an indication of the result of applying 
282            the Id to its arguments
283
284 However, in fact we store in the Id an extremely emascuated demand transfomer,
285 namely 
286                 a single DmdType
287 (Nevertheless we dignify StrictSig as a distinct type.)
288
289 This DmdType gives the demands unleashed by the Id when it is applied
290 to as many arguments as are given in by the arg demands in the DmdType.
291
292 For example, the demand transformer described by the DmdType
293                 DmdType {x -> U(LL)} [V,A] Top
294 says that when the function is applied to two arguments, it
295 unleashes demand U(LL) on the free var x, V on the first arg,
296 and A on the second.  
297
298 If this same function is applied to one arg, all we can say is
299 that it uses x with U*(LL), and its arg with demand L.
300
301 \begin{code}
302 newtype StrictSig = StrictSig DmdType
303                   deriving( Eq )
304
305 instance Outputable StrictSig where
306    ppr (StrictSig ty) = ppr ty
307
308 instance Show StrictSig where
309    show (StrictSig ty) = showSDoc (ppr ty)
310
311 mkStrictSig :: DmdType -> StrictSig
312 mkStrictSig dmd_ty = StrictSig dmd_ty
313
314 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
315 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
316
317 increaseStrictSigArity :: Int -> StrictSig -> StrictSig
318 -- Add extra arguments to a strictness signature
319 increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
320   = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
321
322 isTopSig :: StrictSig -> Bool
323 isTopSig (StrictSig ty) = isTopDmdType ty
324
325 topSig, botSig, cprSig :: StrictSig
326 topSig = StrictSig topDmdType
327 botSig = StrictSig botDmdType
328 cprSig = StrictSig cprDmdType
329         
330
331 -- appIsBottom returns true if an application to n args would diverge
332 appIsBottom :: StrictSig -> Int -> Bool
333 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
334 appIsBottom _                                 _ = False
335
336 isBottomingSig :: StrictSig -> Bool
337 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
338 isBottomingSig _                                = False
339
340 seqStrictSig :: StrictSig -> ()
341 seqStrictSig (StrictSig ty) = seqDmdType ty
342
343 pprIfaceStrictSig :: StrictSig -> SDoc
344 -- Used for printing top-level strictness pragmas in interface files
345 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
346   = hcat (map ppr dmds) <> ppr res
347 \end{code}
348     
349