\begin{code}
module NewDemand(
- Demand(..), Keepity(..), Deferredness(..), topDmd,
- StrictSig(..), topSig, botSig, mkStrictSig,
- DmdType(..), topDmdType, mkDmdType, mkTopDmdType,
+ Demand(..), Keepity(..),
+ mkSeq, topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd, defer,
+
+ DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
+ dmdTypeDepth, dmdTypeRes,
DmdEnv, emptyDmdEnv,
- DmdResult(..), isBotRes
+ DmdResult(..), isBotRes, returnsCPR,
+
+ StrictSig(..), mkStrictSig, topSig, botSig, isTopSig,
+ splitStrictSig, strictSigResInfo,
+ pprIfaceStrictSig, appIsBottom, isBottomingSig
) where
#include "HsVersions.h"
import BasicTypes ( Arity )
-import Var ( Id )
-import VarEnv ( VarEnv, emptyVarEnv )
+import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv )
import UniqFM ( ufmToList )
-import qualified Demand
import Outputable
\end{code}
%************************************************************************
%* *
-\subsection{Strictness signatures
-%* *
-%************************************************************************
-
-\begin{code}
-data StrictSig = StrictSig Arity DmdType
- deriving( Eq )
- -- Equality needed when comparing strictness
- -- signatures for fixpoint finding
-
-topSig = StrictSig 0 topDmdType
-botSig = StrictSig 0 botDmdType
-
-mkStrictSig :: Id -> Arity -> DmdType -> StrictSig
-mkStrictSig id arity ty
- = WARN( arity /= dmdTypeDepth ty, ppr id <+> (ppr arity $$ ppr ty) )
- StrictSig arity ty
-
-instance Outputable StrictSig where
- ppr (StrictSig arity ty) = ppr ty
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Demand types}
%* *
%************************************************************************
-- DmdResult = BotRes <=> Bot
-- DmdResult = TopRes/ResCPR <=> Abs
+ -- ANOTHER IMPORTANT INVARIANT
+ -- The Demands in the argument list are never
+ -- Bot, Err, Seq Defer ds
+ -- Handwavey reason: these don't correspond to calling conventions
+ -- See DmdAnal.funArgDemand for details
+
type DmdEnv = VarEnv Demand
data DmdResult = TopRes -- Nothing known
| RetCPR -- Returns a constructed product
| BotRes -- Diverges or errors
- deriving( Eq )
+ deriving( Eq, Show )
+ -- Equality for fixpoints
+ -- Show needed for Show in Lex.Token (sigh)
-- Equality needed for fixpoints in DmdAnal
instance Eq DmdType where
ppr (DmdType fv ds res)
= hsep [text "DmdType",
hcat (map ppr ds) <> ppr res,
- braces (fsep (map pp_elt (ufmToList fv)))]
+ 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 = char 'T'
- ppr RetCPR = char 'M'
- ppr BotRes = char 'X'
+ 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 = emptyVarEnv
topDmdType = DmdType emptyDmdEnv [] TopRes
botDmdType = DmdType emptyDmdEnv [] BotRes
+isTopDmdType :: DmdType -> Bool
+-- Only used on top-level types, hence the assert
+isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
+isTopDmdType other = False
+
isBotRes :: DmdResult -> Bool
isBotRes BotRes = True
isBotRes other = False
+returnsCPR :: DmdResult -> Bool
+returnsCPR RetCPR = True
+returnsCPR other = False
+
mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
mkDmdType fv ds res = DmdType fv ds res
dmdTypeDepth :: DmdType -> Arity
dmdTypeDepth (DmdType _ ds _) = length ds
+
+dmdTypeRes :: DmdType -> DmdResult
+dmdTypeRes (DmdType _ _ res_ty) = res_ty
\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
+
+instance Show StrictSig where
+ show (StrictSig ty) = showSDoc (ppr ty)
+
+mkStrictSig :: DmdType -> StrictSig
+mkStrictSig dmd_ty = StrictSig dmd_ty
+
+splitStrictSig :: StrictSig -> ([Demand], DmdResult)
+splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
+
+strictSigResInfo :: StrictSig -> DmdResult
+strictSigResInfo (StrictSig (DmdType _ _ res)) = res
+
+isTopSig (StrictSig ty) = isTopDmdType ty
+
+topSig = StrictSig topDmdType
+botSig = StrictSig botDmdType
+
+-- appIsBottom returns true if an application to n args would diverge
+appIsBottom (StrictSig (DmdType _ ds BotRes)) n = n >= length ds
+appIsBottom _ _ = False
+
+isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
+isBottomingSig _ = False
+
+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}
+
+
+%************************************************************************
+%* *
\subsection{Demands}
%* *
%************************************************************************
= Lazy -- L; used for unlifted types too, so that
-- A `lub` L = L
| Abs -- A
+
| Call Demand -- C(d)
| Eval -- V
- | Seq Keepity -- S/U(ds)
- Deferredness
- [Demand]
+ | Seq Keepity -- S/U/D(ds)
+ [Demand] -- S(ds) = L `both` U(ds)
+ -- D(ds) = A `lub` U(ds)
+ -- *** Invariant: these demands are never Bot or Abs
+ -- *** Invariant: if all demands are Abs, get []
+
| Err -- X
| Bot -- B
deriving( Eq )
-- Equality needed for fixpoints in DmdAnal
-data Deferredness = Now | Defer
- deriving( Eq )
-
-data Keepity = Keep | Drop
+data Keepity = Keep -- Strict and I need the box
+ | Drop -- Strict, but I don't need the box
+ | Defer -- Lazy, if you *do* evaluate, I need
+ -- the components but not the box
deriving( Eq )
-topDmd :: Demand -- The most uninformative demand
-topDmd = Lazy
+mkSeq :: Keepity -> [Demand] -> Demand
+mkSeq k ds | all is_absent ds = Seq k []
+ | otherwise = Seq k ds
+ where
+ is_absent Abs = True
+ is_absent d = False
+
+defer :: Demand -> Demand
+-- Computes (Abs `lub` d)
+-- For the Bot case consider
+-- f x y = if ... then x else error x
+-- Then for y we get Abs `lub` Bot, and we really
+-- want Abs overall
+defer Bot = Abs
+defer Abs = Abs
+defer (Seq Keep ds) = Lazy
+defer (Seq _ ds) = Seq Defer ds
+defer d = Lazy
+
+topDmd, lazyDmd, seqDmd :: Demand
+topDmd = Lazy -- The most uninformative demand
+lazyDmd = Lazy
+seqDmd = Seq Keep [] -- Polymorphic seq demand
+evalDmd = Eval
+
+isStrictDmd :: Demand -> Bool
+isStrictDmd Bot = True
+isStrictDmd Err = True
+isStrictDmd (Seq Drop _) = True -- But not Defer!
+isStrictDmd (Seq Keep _) = True
+isStrictDmd Eval = True
+isStrictDmd (Call _) = True
+isStrictDmd other = False
instance Outputable Demand where
- ppr Lazy = char 'L'
- ppr Abs = char 'A'
- ppr Eval = char 'V'
- ppr Err = char 'X'
- ppr Bot = char 'B'
- ppr (Call d) = char 'C' <> parens (ppr d)
- ppr (Seq k l ds) = ppr k <> ppr l <> parens (hcat (map ppr ds))
-
-instance Outputable Deferredness where
- ppr Now = empty
- ppr Defer = char '*'
+ ppr Lazy = char 'L'
+ ppr Abs = char 'A'
+ ppr Eval = char 'V'
+ ppr Err = char 'X'
+ ppr Bot = char 'B'
+ ppr (Call d) = char 'C' <> parens (ppr d)
+ ppr (Seq k []) = ppr k
+ ppr (Seq k ds) = ppr k <> parens (hcat (map ppr ds))
instance Outputable Keepity where
- ppr Keep = char 'S'
- ppr Drop = char 'U'
+ ppr Keep = char 'S'
+ ppr Drop = char 'U'
+ ppr Defer = char 'D'
\end{code}
projects / ghc-hetmet.git / blobdiff