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

\begin{code}
8
{-# OPTIONS -w #-}
9 10 11
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
12
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
13 14
-- for details

15
module NewDemand(
16 17
	Demand(..), 
	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 28
	StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
        isTopSig,
29
	splitStrictSig,
30
	pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
31 32 33 34
     ) where

#include "HsVersions.h"

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


44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 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
%************************************************************************
%*									*
\subsection{Demands}
%*									*
%************************************************************************

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

  | Call Demand		-- C(d)

  | Eval Demands	-- U(ds)

  | Defer Demands	-- D(ds)

  | Box Demand		-- B(d)

  | Bot			-- B
  deriving( Eq )
	-- Equality needed for fixpoints in DmdAnal

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

allTop (Poly d)  = isTop d
allTop (Prod ds) = all isTop ds

isTop Top = True
isTop d   = False 

isAbsent Abs = True
isAbsent d   = 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]
90 91 92 93 94 95 96
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)!
97 98 99 100 101 102 103 104 105 106 107 108 109 110 111

topDmd, lazyDmd, seqDmd :: 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 other    = False

112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
seqDemand :: Demand -> ()
seqDemand (Call d)   = seqDemand d
seqDemand (Eval ds)  = seqDemands ds
seqDemand (Defer ds) = seqDemands ds
seqDemand (Box d)    = seqDemand d
seqDemand _          = ()

seqDemands :: Demands -> ()
seqDemands (Poly d)  = seqDemand d
seqDemands (Prod ds) = seqDemandList ds

seqDemandList :: [Demand] -> ()
seqDemandList [] = ()
seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds

127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
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 (Call d)	= char 'C' <> parens (ppr d)


instance Outputable Demands where
    ppr (Poly Abs) = empty
    ppr (Poly d)   = parens (ppr d <> char '*')
145 146 147 148 149 150
    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.]
151 152 153
\end{code}


154 155 156 157 158 159 160
%************************************************************************
%*									*
\subsection{Demand types}
%*									*
%************************************************************************

\begin{code}
161 162 163 164 165 166 167 168 169 170 171
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

172 173
	-- 		ANOTHER IMPORTANT INVARIANT
	-- The Demands in the argument list are never
174
	--	Bot, Defer d
175 176 177
	-- Handwavey reason: these don't correspond to calling conventions
	-- See DmdAnal.funArgDemand for details

178 179 180 181 182 183 184 185

-- 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 | opt_CprOff = TopRes
       | otherwise  = RetCPR

186 187 188
seqDmdType (DmdType env ds res) = 
  {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()

189 190 191 192 193
type DmdEnv = VarEnv Demand

data DmdResult = TopRes	-- Nothing known	
	       | RetCPR	-- Returns a constructed product
	       | BotRes	-- Diverges or errors
194 195 196
	       deriving( Eq, Show )
	-- Equality for fixpoints
	-- Show needed for Show in Lex.Token (sigh)
197

198 199 200 201 202
-- 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
203 204

instance Outputable DmdType where
205 206 207
  ppr (DmdType fv ds res) 
    = hsep [text "DmdType",
	    hcat (map ppr ds) <> ppr res,
208 209
	    if null fv_elts then empty
	    else braces (fsep (map pp_elt fv_elts))]
210 211
    where
      pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
212
      fv_elts = ufmToList fv
213

214
instance Outputable DmdResult where
215 216 217 218
  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
219

220
emptyDmdEnv = emptyVarEnv
221

222 223
topDmdType = DmdType emptyDmdEnv [] TopRes
botDmdType = DmdType emptyDmdEnv [] BotRes
224
cprDmdType = DmdType emptyVarEnv [] retCPR
225

226 227
isTopDmdType :: DmdType -> Bool
-- Only used on top-level types, hence the assert
228 229
isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True	
isTopDmdType other		     = False
230

231 232 233 234
isBotRes :: DmdResult -> Bool
isBotRes BotRes = True
isBotRes other  = False

235 236 237 238 239
resTypeArgDmd :: DmdResult -> Demand
-- TopRes and BotRes are polymorphic, so that
--	BotRes = Bot -> BotRes
--	TopRes = Top -> TopRes
-- This function makes that concrete
240 241 242
-- 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
243
resTypeArgDmd TopRes = Top
244
resTypeArgDmd RetCPR = Top
245 246
resTypeArgDmd BotRes = Bot

247 248 249 250
returnsCPR :: DmdResult -> Bool
returnsCPR RetCPR = True
returnsCPR other  = False

251 252 253 254 255
mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
mkDmdType fv ds res = DmdType fv ds res

mkTopDmdType :: [Demand] -> DmdResult -> DmdType
mkTopDmdType ds res = DmdType emptyDmdEnv ds res
256 257

dmdTypeDepth :: DmdType -> Arity
258
dmdTypeDepth (DmdType _ ds _) = length ds
259 260 261
\end{code}


262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302
%************************************************************************
%*									*
\subsection{Strictness signature
%*									*
%************************************************************************

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

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.)

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.

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.  

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.

\begin{code}
newtype StrictSig = StrictSig DmdType
		  deriving( Eq )

instance Outputable StrictSig where
   ppr (StrictSig ty) = ppr ty

instance Show StrictSig where
   show (StrictSig ty) = showSDoc (ppr ty)

303 304
mkStrictSig :: DmdType -> StrictSig
mkStrictSig dmd_ty = StrictSig dmd_ty
305 306 307 308

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

309 310
isTopSig (StrictSig ty) = isTopDmdType ty

311
topSig, botSig, cprSig :: StrictSig
312 313
topSig = StrictSig topDmdType
botSig = StrictSig botDmdType
314 315
cprSig = StrictSig cprDmdType
	
316 317

-- appIsBottom returns true if an application to n args would diverge
sof's avatar
sof committed
318
appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
319 320 321 322 323
appIsBottom _				      _ = False

isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
isBottomingSig _				= False

324 325
seqStrictSig (StrictSig ty) = seqDmdType ty

326 327 328 329 330 331 332
pprIfaceStrictSig :: StrictSig -> SDoc
-- Used for printing top-level strictness pragmas in interface files
pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
  = hcat (map ppr dmds) <> ppr res
\end{code}