Commit f6cd95ff authored by simonpj's avatar simonpj
Browse files

[project @ 2001-07-23 10:54:46 by simonpj]

---------------------------------
	Switch to the new demand analyser
	---------------------------------

This commit makes the new demand analyser the main beast,
with the old strictness analyser as a backup.  When
DEBUG is on, the old strictness analyser is run too, and the
results compared.

WARNING: this isn't thorougly tested yet, so expect glitches.
Delay updating for a few days if the HEAD is mission critical
for you.

But do try it out.  I'm away for 2.5 weeks from Thursday, so
it would be good to shake out any glaring bugs before then.
parent 9c220935
......@@ -36,7 +36,9 @@ module BasicTypes(
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch,
EP(..)
EP(..),
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict
) where
#include "HsVersions.h"
......@@ -304,3 +306,32 @@ instance Show OccInfo where
showsPrec p occ = showsPrecSDoc p (ppr occ)
\end{code}
%************************************************************************
%* *
\subsection{Strictness indication}
%* *
%************************************************************************
The strictness annotations on types in data type declarations
e.g. data T = MkT !Int !(Bool,Bool)
\begin{code}
data StrictnessMark
= MarkedUserStrict -- "!" in a source decl
| MarkedStrict -- "!" in an interface decl: strict but not unboxed
| MarkedUnboxed -- "!!" in an interface decl: unboxed
| NotMarkedStrict -- No annotation at all
deriving( Eq )
isMarkedUnboxed MarkedUnboxed = True
isMarkedUnboxed other = False
isMarkedStrict NotMarkedStrict = False
isMarkedStrict other = True -- All others are strict
instance Outputable StrictnessMark where
ppr MarkedUserStrict = ptext SLIT("!u")
ppr MarkedStrict = ptext SLIT("!")
ppr MarkedUnboxed = ptext SLIT("! !")
ppr NotMarkedStrict = empty
\end{code}
......@@ -36,8 +36,8 @@ import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id )
import FieldLabel ( FieldLabel )
import BasicTypes ( Arity )
import Demand ( Demand, StrictnessMark(..), wwStrict, wwLazy )
import BasicTypes ( Arity, StrictnessMark(..) )
import NewDemand ( Demand, lazyDmd, seqDmd )
import Outputable
import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
......@@ -443,15 +443,14 @@ chooseBoxingStrategy tycon arg_ty strict
Just (arg_tycon, _) -> isProductTyCon arg_tycon
unbox_strict_arg_ty
:: StrictnessMark -- After strategy choice; can't be MkaredUserStrict
:: StrictnessMark -- After strategy choice; can't be MarkedUserStrict
-> Type -- Source argument type
-> [(Demand,Type)] -- Representation argument types and demamds
unbox_strict_arg_ty NotMarkedStrict ty = [(wwLazy, ty)]
unbox_strict_arg_ty MarkedStrict ty = [(wwStrict, ty)]
unbox_strict_arg_ty NotMarkedStrict ty = [(lazyDmd, ty)]
unbox_strict_arg_ty MarkedStrict ty = [(seqDmd, ty)]
unbox_strict_arg_ty MarkedUnboxed ty
= zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys
where
(_, _, arg_data_con, arg_tys)
= splitProductType "unbox_strict_arg_ty" (repType ty)
(_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty)
\end{code}
......@@ -18,7 +18,6 @@ module Demand(
ppStrictnessInfo, seqStrictnessInfo,
isBottomingStrictness, appIsBottom,
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict
) where
#include "HsVersions.h"
......@@ -200,34 +199,5 @@ ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_ar
\end{code}
%************************************************************************
%* *
\subsection{Strictness indication}
%* *
%************************************************************************
The strictness annotations on types in data type declarations
e.g. data T = MkT !Int !(Bool,Bool)
\begin{code}
data StrictnessMark
= MarkedUserStrict -- "!" in a source decl
| MarkedStrict -- "!" in an interface decl: strict but not unboxed
| MarkedUnboxed -- "!!" in an interface decl: unboxed
| NotMarkedStrict -- No annotation at all
deriving( Eq )
isMarkedUnboxed MarkedUnboxed = True
isMarkedUnboxed other = False
isMarkedStrict NotMarkedStrict = False
isMarkedStrict other = True -- All others are strict
instance Outputable StrictnessMark where
ppr MarkedUserStrict = ptext SLIT("!u")
ppr MarkedStrict = ptext SLIT("!")
ppr MarkedUnboxed = ptext SLIT("! !")
ppr NotMarkedStrict = empty
\end{code}
......@@ -44,8 +44,8 @@ module Id (
-- IdInfo stuff
setIdUnfolding,
setIdArityInfo,
setIdDemandInfo,
setIdStrictness,
setIdDemandInfo, setIdNewDemandInfo,
setIdStrictness, setIdNewStrictness,
setIdTyGenInfo,
setIdWorkerInfo,
setIdSpecialisation,
......@@ -54,8 +54,8 @@ module Id (
setIdOccInfo,
idArity, idArityInfo,
idDemandInfo,
idStrictness,
idDemandInfo, idNewDemandInfo,
idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness,
idTyGenInfo,
idWorkerInfo,
idUnfolding,
......@@ -67,6 +67,8 @@ module Id (
idLBVarInfo,
idOccInfo,
newStrictnessFromOld -- Temporary
) where
#include "HsVersions.h"
......@@ -88,7 +90,10 @@ import Type ( Type, typePrimRep, addFreeTyVars,
import IdInfo
import Demand ( Demand )
import qualified Demand ( Demand )
import NewDemand ( Demand, DmdResult(..), StrictSig, topSig, isBotRes,
isBottomingSig, splitStrictSig, strictSigResInfo
)
import Name ( Name, OccName,
mkSysLocalName, mkLocalName,
getOccName, getSrcLoc
......@@ -97,6 +102,7 @@ import OccName ( UserFS, mkWorkerOcc )
import PrimRep ( PrimRep )
import TysPrim ( statePrimTyCon )
import FieldLabel ( FieldLabel )
import Maybes ( orElse )
import SrcLoc ( SrcLoc )
import Outputable
import Unique ( Unique, mkBuiltinUnique )
......@@ -105,6 +111,8 @@ infixl 1 `setIdUnfolding`,
`setIdArityInfo`,
`setIdDemandInfo`,
`setIdStrictness`,
`setIdNewDemandInfo`,
`setIdNewStrictness`,
`setIdTyGenInfo`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
......@@ -311,16 +319,43 @@ setIdArityInfo :: Id -> Arity -> Id
setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
---------------------------------
-- STRICTNESS
-- STRICTNESS
idStrictness :: Id -> StrictnessInfo
idStrictness id = strictnessInfo (idInfo id)
idStrictness id = case strictnessInfo (idInfo id) of
NoStrictnessInfo -> case idNewStrictness_maybe id of
Just sig -> oldStrictnessFromNew sig
Nothing -> NoStrictnessInfo
strictness -> strictness
setIdStrictness :: Id -> StrictnessInfo -> Id
setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
-- isBottomingId returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
isBottomingId id = isBottomingStrictness (idStrictness id)
isBottomingId id = isBottomingSig (idNewStrictness id)
idNewStrictness_maybe :: Id -> Maybe StrictSig
idNewStrictness :: Id -> StrictSig
idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
idNewStrictness id = idNewStrictness_maybe id `orElse` topSig
getNewStrictness :: Id -> StrictSig
-- First tries the "new-strictness" field, and then
-- reverts to the old one. This is just until we have
-- cross-module info for new strictness
getNewStrictness id = idNewStrictness_maybe id `orElse` newStrictnessFromOld id
newStrictnessFromOld :: Id -> StrictSig
newStrictnessFromOld id = mkNewStrictnessInfo id (idArity id) (idStrictness id) (idCprInfo id)
oldStrictnessFromNew :: StrictSig -> StrictnessInfo
oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
where
(dmds, res_info) = splitStrictSig sig
setIdNewStrictness :: Id -> StrictSig -> Id
setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
---------------------------------
-- TYPE GENERALISATION
......@@ -348,12 +383,18 @@ setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
---------------------------------
-- DEMAND
idDemandInfo :: Id -> Demand
idDemandInfo :: Id -> Demand.Demand
idDemandInfo id = demandInfo (idInfo id)
setIdDemandInfo :: Id -> Demand -> Id
setIdDemandInfo :: Id -> Demand.Demand -> Id
setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
idNewDemandInfo :: Id -> NewDemand.Demand
idNewDemandInfo id = newDemandInfo (idInfo id)
setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id
setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id
---------------------------------
-- SPECIALISATION
idSpecialisation :: Id -> CoreRules
......@@ -383,14 +424,17 @@ idCafInfo id = cgCafInfo (idCgInfo id)
---------------------------------
-- CG ARITY
idCgArity :: Id -> Arity
idCgArity id = cgArity (idCgInfo id)
---------------------------------
-- CPR INFO
idCprInfo :: Id -> CprInfo
idCprInfo id = cprInfo (idInfo id)
idCprInfo id = case cprInfo (idInfo id) of
NoCPRInfo -> case strictSigResInfo (idNewStrictness id) of
RetCPR -> ReturnsCPR
other -> NoCPRInfo
ReturnsCPR -> ReturnsCPR
setIdCprInfo :: Id -> CprInfo -> Id
setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
......
......@@ -19,13 +19,13 @@ module IdInfo (
shortableIdInfo, copyIdInfo,
-- Arity
ArityInfo(..),
ArityInfo,
exactArity, unknownArity, hasArity,
arityInfo, setArityInfo, ppArityInfo, arityLowerBound,
-- New demand and strictness info
newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo,
newDemandInfo, setNewDemandInfo, newDemand,
newDemandInfo, setNewDemandInfo, newDemand, oldDemand,
-- Strictness; imported from Demand
StrictnessInfo(..),
......@@ -95,8 +95,12 @@ import DataCon ( DataCon )
import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel )
import Type ( usOnce, usMany )
import Demand -- Lots of stuff
import qualified NewDemand
import Demand hiding( Demand )
import NewDemand ( Demand(..), Keepity(..), Deferredness(..), DmdResult(..),
lazyDmd, topDmd,
StrictSig, mkStrictSig,
DmdType, mkTopDmdType
)
import Outputable
import Util ( seqList )
import List ( replicate )
......@@ -129,30 +133,35 @@ infixl 1 `setDemandInfo`,
To be removed later
\begin{code}
mkNewStrictnessInfo :: Id -> Arity -> StrictnessInfo -> CprInfo -> NewDemand.StrictSig
mkNewStrictnessInfo id arity NoStrictnessInfo cpr
= NewDemand.mkStrictSig id
arity
(NewDemand.mkTopDmdType (replicate arity NewDemand.Lazy) (newRes False cpr))
mkNewStrictnessInfo id arity (StrictnessInfo ds res) cpr
= NewDemand.mkStrictSig id
arity
(NewDemand.mkTopDmdType (take arity (map newDemand ds)) (newRes res cpr))
mkNewStrictnessInfo :: Id -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig
mkNewStrictnessInfo id arity Demand.NoStrictnessInfo cpr
= mkStrictSig id arity $
mkTopDmdType (replicate arity lazyDmd) (newRes False cpr)
mkNewStrictnessInfo id arity (Demand.StrictnessInfo ds res) cpr
= mkStrictSig id arity $
mkTopDmdType (take arity (map newDemand ds)) (newRes res cpr)
-- Sometimes the old strictness analyser has more
-- demands than the arity justifies
newRes True _ = NewDemand.BotRes
newRes False ReturnsCPR = NewDemand.RetCPR
newRes False NoCPRInfo = NewDemand.TopRes
newDemand :: Demand -> NewDemand.Demand
newDemand (WwLazy True) = NewDemand.Abs
newDemand (WwLazy False) = NewDemand.Lazy
newDemand WwStrict = NewDemand.Eval
newDemand (WwUnpack unpk ds) = NewDemand.Seq NewDemand.Drop NewDemand.Now (map newDemand ds)
newDemand WwPrim = NewDemand.Lazy
newDemand WwEnum = NewDemand.Eval
newRes True _ = BotRes
newRes False ReturnsCPR = RetCPR
newRes False NoCPRInfo = TopRes
newDemand :: Demand.Demand -> NewDemand.Demand
newDemand (WwLazy True) = Abs
newDemand (WwLazy False) = Lazy
newDemand WwStrict = Eval
newDemand (WwUnpack unpk ds) = Seq Drop Now (map newDemand ds)
newDemand WwPrim = Lazy
newDemand WwEnum = Eval
oldDemand :: NewDemand.Demand -> Demand.Demand
oldDemand Abs = WwLazy True
oldDemand Lazy = WwLazy False
oldDemand Eval = WwStrict
oldDemand (Seq _ _ ds) = WwUnpack True (map oldDemand ds)
oldDemand (Call _) = WwStrict
\end{code}
......@@ -219,7 +228,7 @@ case. KSW 1999-04).
data IdInfo
= IdInfo {
arityInfo :: ArityInfo, -- Its arity
demandInfo :: Demand, -- Whether or not it is definitely demanded
demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded
specInfo :: CoreRules, -- Specialisations of this function which exist
tyGenInfo :: TyGenInfo, -- Restrictions on usage-generalisation of this Id
strictnessInfo :: StrictnessInfo, -- Strictness properties
......@@ -231,8 +240,8 @@ data IdInfo
inlinePragInfo :: InlinePragInfo, -- Inline pragma
occInfo :: OccInfo, -- How it occurs
newStrictnessInfo :: Maybe NewDemand.StrictSig,
newDemandInfo :: NewDemand.Demand
newStrictnessInfo :: Maybe StrictSig,
newDemandInfo :: Demand
}
seqIdInfo :: IdInfo -> ()
......@@ -295,7 +304,7 @@ setCprInfo info cp = info { cprInfo = cp }
setLBVarInfo info lb = info { lbvarInfo = lb }
setNewDemandInfo info dd = info { newDemandInfo = dd }
setNewStrictnessInfo info dd = info { newStrictnessInfo = Just dd }
setNewStrictnessInfo info dd = info { newStrictnessInfo = dd }
\end{code}
......@@ -315,7 +324,7 @@ vanillaIdInfo
lbvarInfo = NoLBVarInfo,
inlinePragInfo = NoInlinePragInfo,
occInfo = NoOccInfo,
newDemandInfo = NewDemand.topDmd,
newDemandInfo = topDmd,
newStrictnessInfo = Nothing
}
......
......@@ -31,7 +31,7 @@ module MkId (
#include "HsVersions.h"
import BasicTypes ( Arity )
import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
intPrimTy, realWorldStatePrimTy
)
......@@ -58,8 +58,6 @@ import Name ( mkWiredInName, mkFCallName, Name )
import OccName ( mkVarOcc )
import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
import ForeignCall ( ForeignCall )
import Demand ( wwStrict, wwPrim, mkStrictnessInfo, noStrictnessInfo,
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
import DataCon ( DataCon,
dataConFieldLabels, dataConRepArity, dataConTyCon,
dataConArgTys, dataConRepType, dataConRepStrictness,
......@@ -70,16 +68,17 @@ import DataCon ( DataCon,
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum,
mkTemplateLocal, idCprInfo, idName
mkTemplateLocal, idNewStrictness, idName
)
import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
exactArity, setUnfoldingInfo, setCprInfo,
setArityInfo, setSpecInfo, setCgInfo,
setStrictnessInfo,
mkNewStrictnessInfo, setNewStrictnessInfo,
GlobalIdDetails(..), CafInfo(..), CprInfo(..),
CgInfo(..), setCgArity
)
import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
mkTopDmdType, topDmd, evalDmd )
import FieldLabel ( mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
)
......@@ -143,22 +142,20 @@ mkDataConId work_name data_con
where
id = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
info = noCafNoTyGenIdInfo
`setCgArity` arity
`setArityInfo` arity
`setCprInfo` cpr_info
`setStrictnessInfo` strict_info
`setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info cpr_info
`setCgArity` arity
`setArityInfo` arity
`setNewStrictnessInfo` Just strict_sig
arity = dataConRepArity data_con
strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False)
strict_sig = mkStrictSig id arity (mkTopDmdType (dataConRepStrictness data_con) cpr_info)
tycon = dataConTyCon data_con
cpr_info | isProductTyCon tycon &&
isDataTyCon tycon &&
arity > 0 &&
arity <= mAX_CPR_SIZE = ReturnsCPR
| otherwise = NoCPRInfo
-- ReturnsCPR is only true for products that are real data types;
arity <= mAX_CPR_SIZE = RetCPR
| otherwise = TopRes
-- RetCPR is only true for products that are real data types;
-- that is, not unboxed tuples or [non-recursive] newtypes
mAX_CPR_SIZE :: Arity
......@@ -219,21 +216,23 @@ mkDataConWrapId data_con
info = noCafNoTyGenIdInfo
`setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs)
`setCprInfo` cpr_info
-- The Cpr info can be important inside INLINE rhss, where the
-- wrapper constructor isn't inlined
`setCgArity` arity
-- The NoCaf-ness is set by noCafNoTyGenIdInfo
`setArityInfo` arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
`setNewStrictnessInfo` mkNewStrictnessInfo wrap_id arity noStrictnessInfo cpr_info
`setNewStrictnessInfo` Just wrap_sig
wrap_ty = mkForAllTys all_tyvars $
mkFunTys all_arg_tys
result_ty
cpr_info = idCprInfo work_id
res_info = strictSigResInfo (idNewStrictness work_id)
wrap_sig = mkStrictSig wrap_id arity (mkTopDmdType (replicate arity topDmd) res_info)
-- The Cpr info can be important inside INLINE rhss, where the
-- wrapper constructor isn't inlined
-- But we are sloppy about the argument demands, because we expect
-- to inline the constructor very vigorously.
wrap_rhs | isNewTyCon tycon
= ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
......@@ -606,8 +605,8 @@ mkPrimOpId prim_op
`setSpecInfo` rules
`setCgArity` arity
`setArityInfo` arity
`setStrictnessInfo` strict_info
`setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info NoCPRInfo
`setNewStrictnessInfo` Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
-- Until we modify the primop generation code
rules = maybe emptyCoreRules (addRule emptyCoreRules id)
(primOpRule prim_op)
......@@ -637,15 +636,14 @@ mkFCallId uniq fcall ty
name = mkFCallName uniq occ_str
info = noCafNoTyGenIdInfo
`setCgArity` arity
`setArityInfo` arity
`setStrictnessInfo` strict_info
`setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info NoCPRInfo
`setCgArity` arity
`setArityInfo` arity
`setNewStrictnessInfo` Just strict_sig
(_, tau) = tcSplitForAllTys ty
(arg_tys, _) = tcSplitFunTys tau
arity = length arg_tys
strict_info = mkStrictnessInfo (take arity (repeat wwPrim), False)
strict_sig = mkStrictSig id arity (mkTopDmdType (replicate arity evalDmd) TopRes)
\end{code}
......@@ -838,12 +836,9 @@ pc_bottoming_Id key mod name ty
= id
where
id = pcMiscPrelId key mod name ty bottoming_info
strict_info = mkStrictnessInfo ([wwStrict], True)
bottoming_info = noCafNoTyGenIdInfo
`setStrictnessInfo` strict_info
`setNewStrictnessInfo` mkNewStrictnessInfo id 1 strict_info NoCPRInfo
arity = 1
strict_sig = mkStrictSig id arity (mkTopDmdType [evalDmd] BotRes)
bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig
-- these "bottom" out, no matter what their arguments
generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
......
......@@ -5,11 +5,17 @@
\begin{code}
module NewDemand(
Demand(..), Keepity(..), Deferredness(..), topDmd,
StrictSig(..), topSig, botSig, mkStrictSig,
DmdType(..), topDmdType, mkDmdType, mkTopDmdType,
Demand(..), Keepity(..), Deferredness(..),
topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd,
DmdType(..), topDmdType, mkDmdType, mkTopDmdType,
dmdTypeDepth, dmdTypeRes,
DmdEnv, emptyDmdEnv,
DmdResult(..), isBotRes
DmdResult(..), isBotRes, returnsCPR,
StrictSig(..), mkStrictSig, topSig, botSig,
splitStrictSig, strictSigResInfo,
pprIfaceStrictSig, appIsBottom, isBottomingSig
) where
#include "HsVersions.h"
......@@ -23,31 +29,6 @@ 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}
......@@ -71,7 +52,9 @@ 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
......@@ -88,7 +71,7 @@ instance Outputable DmdType where
pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
instance Outputable DmdResult where
ppr TopRes = char 'T'
ppr TopRes = empty
ppr RetCPR = char 'M'
ppr BotRes = char 'X'
......@@ -100,6 +83,10 @@ 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
......@@ -108,9 +95,81 @@ mkTopDmdType ds res = DmdType emptyDmdEnv 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