Demand.lhs 10.3 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6
7
%
\section[Demand]{@Demand@: the amount of demand on a value}

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
8
9
10
11
12
13
14
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

sof's avatar
sof committed
15
module Demand(
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
	Demand(..), 
	topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd, 
	isTop, isAbsent, seqDemand,

	DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, 
		dmdTypeDepth, seqDmdType,
	DmdEnv, emptyDmdEnv,
	DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd,
	
	Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,

	StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
        isTopSig,
	splitStrictSig, increaseStrictSigArity,
	pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
sof's avatar
sof committed
31
32
     ) where

33
34
#include "HsVersions.h"

35
36
37
38
import StaticFlags
import BasicTypes
import VarEnv
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
39
import Util
40
import Outputable
41
42
43
44
45
\end{code}


%************************************************************************
%*									*
46
\subsection{Demands}
47
48
49
50
51
%*									*
%************************************************************************

\begin{code}
data Demand
52
53
54
  = Top			-- T; used for unlifted types too, so that
			--	A `lub` T = T
  | Abs			-- A
55

56
  | Call Demand		-- C(d)
57

58
  | Eval Demands	-- U(ds)
twanvl's avatar
twanvl committed
59

60
  | Defer Demands	-- D(ds)
61

62
  | Box Demand		-- B(d)
63

64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
  | Bot			-- B
  deriving( Eq )
	-- Equality needed for fixpoints in DmdAnal

data Demands = Poly Demand	-- Polymorphic case
	     | Prod [Demand]	-- Product case
	     deriving( Eq )

allTop :: Demands -> Bool
allTop (Poly d)  = isTop d
allTop (Prod ds) = all isTop ds

isTop :: Demand -> Bool
isTop Top = True
isTop _   = False 

isAbsent :: Demand -> Bool
isAbsent Abs = True
isAbsent _   = False 

mapDmds :: (Demand -> Demand) -> Demands -> Demands
mapDmds f (Poly d)  = Poly (f d)
mapDmds f (Prod ds) = Prod (map f ds)

zipWithDmds :: (Demand -> Demand -> Demand)
	    -> Demands -> Demands -> Demands
zipWithDmds f (Poly d1)  (Poly d2)  = Poly (d1 `f` d2)
zipWithDmds f (Prod ds1) (Poly d2)  = Prod [d1 `f` d2 | d1 <- ds1]
zipWithDmds f (Poly d1)  (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
zipWithDmds f (Prod ds1) (Prod ds2) 
  | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
  | otherwise		     = Poly topDmd
	-- This really can happen with polymorphism
	-- \f. case f x of (a,b) -> ...
	--     case f y of (a,b,c) -> ...
	-- Here the two demands on f are C(LL) and C(LLL)!

topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand
topDmd  = Top			-- The most uninformative demand
lazyDmd = Box Abs
seqDmd  = Eval (Poly Abs)	-- Polymorphic seq demand
evalDmd = Box seqDmd		-- Evaluate and return
errDmd  = Box Bot		-- This used to be called X

isStrictDmd :: Demand -> Bool
isStrictDmd Bot      = True
isStrictDmd (Eval _) = True
isStrictDmd (Call _) = True
isStrictDmd (Box d)  = isStrictDmd d
isStrictDmd _        = False
114

115
116
117
118
119
120
seqDemand :: Demand -> ()
seqDemand (Call d)   = seqDemand d
seqDemand (Eval ds)  = seqDemands ds
seqDemand (Defer ds) = seqDemands ds
seqDemand (Box d)    = seqDemand d
seqDemand _          = ()
121

122
123
124
seqDemands :: Demands -> ()
seqDemands (Poly d)  = seqDemand d
seqDemands (Prod ds) = seqDemandList ds
125

126
127
128
seqDemandList :: [Demand] -> ()
seqDemandList [] = ()
seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
129

130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
instance Outputable Demand where
    ppr Top  = char 'T'
    ppr Abs  = char 'A'
    ppr Bot  = char 'B'

    ppr (Defer ds)      = char 'D' <> ppr ds
    ppr (Eval ds)       = char 'U' <> ppr ds
				      
    ppr (Box (Eval ds)) = char 'S' <> ppr ds
    ppr (Box Abs)	= char 'L'
    ppr (Box Bot)	= char 'X'
    ppr d@(Box _)	= pprPanic "ppr: Bad boxed demand" (ppr d)

    ppr (Call d)	= char 'C' <> parens (ppr d)


instance Outputable Demands where
    ppr (Poly Abs) = empty
    ppr (Poly d)   = parens (ppr d <> char '*')
    ppr (Prod ds)  = parens (hcat (map ppr ds))
	-- At one time I printed U(AAA) as U, but that
	-- confuses (Poly Abs) with (Prod AAA), and the
	-- worker/wrapper generation differs slightly for these two
	-- [Reason: in the latter case we can avoid passing the arg;
	--  see notes with WwLib.mkWWstr_one.]
155
156
\end{code}

157
158
159

%************************************************************************
%*									*
160
\subsection{Demand types}
161
162
163
164
%*									*
%************************************************************************

\begin{code}
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
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
267
268
269
\end{code}


270
271
%************************************************************************
%*									*
272
\subsection{Strictness signature
273
274
275
%*									*
%************************************************************************

276
277
278
279
280
281
282
In a let-bound Id we record its strictness info.  
In principle, this strictness info is a demand transformer, mapping
a demand on the Id into a DmdType, which gives
	a) the free vars of the Id's value
	b) the Id's arguments
	c) an indication of the result of applying 
	   the Id to its arguments
283

284
285
286
287
However, in fact we store in the Id an extremely emascuated demand transfomer,
namely 
		a single DmdType
(Nevertheless we dignify StrictSig as a distinct type.)
288

289
290
This DmdType gives the demands unleashed by the Id when it is applied
to as many arguments as are given in by the arg demands in the DmdType.
291

292
293
294
295
296
For example, the demand transformer described by the DmdType
		DmdType {x -> U(LL)} [V,A] Top
says that when the function is applied to two arguments, it
unleashes demand U(LL) on the free var x, V on the first arg,
and A on the second.  
297

298
299
If this same function is applied to one arg, all we can say is
that it uses x with U*(LL), and its arg with demand L.
300

301
302
303
\begin{code}
newtype StrictSig = StrictSig DmdType
		  deriving( Eq )
304

305
306
instance Outputable StrictSig where
   ppr (StrictSig ty) = ppr ty
307

308
309
310
311
312
mkStrictSig :: DmdType -> StrictSig
mkStrictSig dmd_ty = StrictSig dmd_ty

splitStrictSig :: StrictSig -> ([Demand], DmdResult)
splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
313

314
315
316
317
increaseStrictSigArity :: Int -> StrictSig -> StrictSig
-- Add extra arguments to a strictness signature
increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
  = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
sof's avatar
sof committed
318

319
320
isTopSig :: StrictSig -> Bool
isTopSig (StrictSig ty) = isTopDmdType ty
321

322
323
324
325
326
topSig, botSig, cprSig :: StrictSig
topSig = StrictSig topDmdType
botSig = StrictSig botDmdType
cprSig = StrictSig cprDmdType
	
sof's avatar
sof committed
327

328
-- appIsBottom returns true if an application to n args would diverge
329
330
331
appIsBottom :: StrictSig -> Int -> Bool
appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
appIsBottom _				      _ = False
332

333
334
335
isBottomingSig :: StrictSig -> Bool
isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
isBottomingSig _				= False
336

337
338
339
340
341
342
343
seqStrictSig :: StrictSig -> ()
seqStrictSig (StrictSig ty) = seqDmdType ty

pprIfaceStrictSig :: StrictSig -> SDoc
-- Used for printing top-level strictness pragmas in interface files
pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
  = hcat (map ppr dmds) <> ppr res
344
\end{code}
345
346