/compiler/basicTypes/Demand.lhs
Haskell | 346 lines | 225 code | 75 blank | 46 comment | 8 complexity | 77755a106ef8948552f4681025f02ada MD5 | raw file
- %
- % (c) The University of Glasgow 2006
- % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
- %
- \section[Demand]{@Demand@: the amount of demand on a value}
- \begin{code}
- {-# 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
- module Demand(
- 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,
- ) where
- #include "HsVersions.h"
- import StaticFlags
- import BasicTypes
- import VarEnv
- import UniqFM
- import Util
- import Outputable
- \end{code}
- %************************************************************************
- %* *
- \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 :: 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
- 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
- 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.]
- \end{code}
- %************************************************************************
- %* *
- \subsection{Demand types}
- %* *
- %************************************************************************
- \begin{code}
- 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
- \end{code}
- %************************************************************************
- %* *
- \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
- mkStrictSig :: DmdType -> StrictSig
- mkStrictSig dmd_ty = StrictSig dmd_ty
- splitStrictSig :: StrictSig -> ([Demand], DmdResult)
- splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
- 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)
- isTopSig :: StrictSig -> Bool
- isTopSig (StrictSig ty) = isTopDmdType ty
- topSig, botSig, cprSig :: StrictSig
- topSig = StrictSig topDmdType
- botSig = StrictSig botDmdType
- cprSig = StrictSig cprDmdType
-
- -- appIsBottom returns true if an application to n args would diverge
- appIsBottom :: StrictSig -> Int -> Bool
- appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
- appIsBottom _ _ = False
- isBottomingSig :: StrictSig -> Bool
- isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
- isBottomingSig _ = False
- 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
- \end{code}
-