\section[Demand]{@Demand@: the amount of demand on a value}
\begin{code}
-#ifndef OLD_STRICTNESS
-module Demand () where
-#else
-
module Demand(
- Demand(..),
-
- wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
- isStrict, isLazy, isPrim,
-
- pprDemands, seqDemand, seqDemands,
-
- StrictnessInfo(..),
- mkStrictnessInfo,
- noStrictnessInfo,
- ppStrictnessInfo, seqStrictnessInfo,
- isBottomingStrictness, appIsBottom,
-
+ 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 Outputable
+import StaticFlags
+import BasicTypes
+import VarEnv
+import UniqFM
import Util
+import Outputable
\end{code}
%************************************************************************
%* *
-\subsection{The @Demand@ data type}
+\subsection{Demands}
%* *
%************************************************************************
\begin{code}
data Demand
- = WwLazy -- Argument is lazy as far as we know
- MaybeAbsent -- (does not imply worker's existence [etc]).
- -- If MaybeAbsent == True, then it is
- -- *definitely* lazy. (NB: Absence implies
- -- a worker...)
-
- | WwStrict -- Argument is strict but that's all we know
- -- (does not imply worker's existence or any
- -- calling-convention magic)
-
- | WwUnpack -- Argument is strict & a single-constructor type
- Bool -- True <=> wrapper unpacks it; False <=> doesn't
- [Demand] -- Its constituent parts (whose StrictInfos
- -- are in the list) should be passed
- -- as arguments to the worker.
-
- | WwPrim -- Argument is of primitive type, therefore
- -- strict; doesn't imply existence of a worker;
- -- argument should be passed as is to worker.
-
- | WwEnum -- Argument is strict & an enumeration type;
- -- an Int# representing the tag (start counting
- -- at zero) should be passed to the worker.
- deriving( Eq )
+ = Top -- T; used for unlifted types too, so that
+ -- A `lub` T = T
+ | Abs -- A
-type MaybeAbsent = Bool -- True <=> not even used
+ | Call Demand -- C(d)
--- versions that don't worry about Absence:
-wwLazy, wwStrict, wwPrim, wwEnum :: Demand
-wwUnpack :: [Demand] -> Demand
+ | Eval Demands -- U(ds)
-wwLazy = WwLazy False
-wwStrict = WwStrict
-wwUnpack xs = WwUnpack False xs
-wwPrim = WwPrim
-wwEnum = WwEnum
+ | Defer Demands -- D(ds)
-seqDemand :: Demand -> ()
-seqDemand (WwLazy a) = a `seq` ()
-seqDemand (WwUnpack b ds) = b `seq` seqDemands ds
-seqDemand _ = ()
-
-seqDemands :: [Demand] -> ()
-seqDemands [] = ()
-seqDemands (d:ds) = seqDemand d `seq` seqDemands ds
-\end{code}
+ | 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
-%************************************************************************
-%* *
-\subsection{Functions over @Demand@}
-%* *
-%************************************************************************
+seqDemand :: Demand -> ()
+seqDemand (Call d) = seqDemand d
+seqDemand (Eval ds) = seqDemands ds
+seqDemand (Defer ds) = seqDemands ds
+seqDemand (Box d) = seqDemand d
+seqDemand _ = ()
-\begin{code}
-isLazy :: Demand -> Bool
-isLazy (WwLazy _) = True
-isLazy _ = False
+seqDemands :: Demands -> ()
+seqDemands (Poly d) = seqDemand d
+seqDemands (Prod ds) = seqDemandList ds
-isStrict :: Demand -> Bool
-isStrict d = not (isLazy d)
+seqDemandList :: [Demand] -> ()
+seqDemandList [] = ()
+seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
-isPrim :: Demand -> Bool
-isPrim WwPrim = True
-isPrim _ = False
+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{Instances}
+\subsection{Demand types}
%* *
%************************************************************************
-
\begin{code}
-pprDemands :: [Demand] -> Bool -> SDoc
-pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot
- where
- pp_bot | bot = ptext (sLit "B")
- | otherwise = empty
-
-
-pprDemand :: Demand -> SDoc
-pprDemand (WwLazy False) = char 'L'
-pprDemand (WwLazy True) = char 'A'
-pprDemand WwStrict = char 'S'
-pprDemand WwPrim = char 'P'
-pprDemand WwEnum = char 'E'
-pprDemand (WwUnpack wu args) = char ch <> parens (hcat (map pprDemand args))
- where
- ch = if wu then 'U' else 'u'
-
-instance Outputable Demand where
- ppr (WwLazy False) = empty
- ppr other_demand = ptext (sLit "__D") <+> pprDemand other_demand
-
-instance Show Demand where
- showsPrec p d = showsPrecSDoc p (ppr d)
-
--- Reading demands is done in Lex.lhs
+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-IdInfo]{Strictness info about an @Id@}
+\subsection{Strictness signature
%* *
%************************************************************************
-We specify the strictness of a function by giving information about
-each of the ``wrapper's'' arguments (see the description about
-worker/wrapper-style transformations in the PJ/Launchbury paper on
-unboxed types).
+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
-The list of @Demands@ specifies: (a)~the strictness properties of a
-function's arguments; and (b)~the type signature of that worker (if it
-exists); i.e. its calling convention.
+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.)
-Note that the existence of a worker function is now denoted by the Id's
-workerInfo field.
+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.
-\begin{code}
-data StrictnessInfo
- = NoStrictnessInfo
+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.
- | StrictnessInfo [Demand] -- Demands on the arguments.
+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.
- Bool -- True <=> the function diverges regardless of its arguments
- -- Useful for "error" and other disguised variants thereof.
- -- BUT NB: f = \x y. error "urk"
- -- will have info SI [SS] True
- -- but still (f) and (f 2) are not bot; only (f 3 2) is bot
- deriving( Eq )
+\begin{code}
+newtype StrictSig = StrictSig DmdType
+ deriving( Eq )
- -- NOTA BENE: if the arg demands are, say, [S,L], this means that
- -- (f bot) is not necy bot, only (f bot x) is bot
- -- We simply cannot express accurately the strictness of a function
- -- like f = \x -> case x of (a,b) -> \y -> ...
- -- The up-side is that we don't need to restrict the strictness info
- -- to the visible arity of the function.
+instance Outputable StrictSig where
+ ppr (StrictSig ty) = ppr ty
-seqStrictnessInfo :: StrictnessInfo -> ()
-seqStrictnessInfo (StrictnessInfo ds b) = b `seq` seqDemands ds
-seqStrictnessInfo _ = ()
-\end{code}
+instance Show StrictSig where
+ show (StrictSig ty) = showSDoc (ppr ty)
-\begin{code}
-mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo
+mkStrictSig :: DmdType -> StrictSig
+mkStrictSig dmd_ty = StrictSig dmd_ty
+
+splitStrictSig :: StrictSig -> ([Demand], DmdResult)
+splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
-mkStrictnessInfo (xs, is_bot)
- | all totally_boring xs && not is_bot = NoStrictnessInfo -- Uninteresting
- | otherwise = StrictnessInfo xs is_bot
- where
- totally_boring (WwLazy False) = True
- totally_boring _ = False
+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)
-noStrictnessInfo :: StrictnessInfo
-noStrictnessInfo = NoStrictnessInfo
+isTopSig :: StrictSig -> Bool
+isTopSig (StrictSig ty) = isTopDmdType ty
-isBottomingStrictness :: StrictnessInfo -> Bool
-isBottomingStrictness (StrictnessInfo _ bot) = bot
-isBottomingStrictness NoStrictnessInfo = False
+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 :: StrictnessInfo -> Int -> Bool
-appIsBottom (StrictnessInfo ds bot) n = bot && (listLengthCmp ds n /=GT) -- not more than 'n' elts in 'ds'.
-appIsBottom NoStrictnessInfo _ = False
+appIsBottom :: StrictSig -> Int -> Bool
+appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
+appIsBottom _ _ = False
-ppStrictnessInfo :: StrictnessInfo -> SDoc
-ppStrictnessInfo NoStrictnessInfo = empty
-ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot]
-\end{code}
+isBottomingSig :: StrictSig -> Bool
+isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
+isBottomingSig _ = False
-\begin{code}
-#endif /* OLD_STRICTNESS */
+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}
+
+
-- ** Reading 'IdInfo' fields
idArity,
- idNewDemandInfo, idNewDemandInfo_maybe,
- idNewStrictness, idNewStrictness_maybe,
+ idDemandInfo, idDemandInfo_maybe,
+ idStrictness, idStrictness_maybe,
idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo,
idLBVarInfo,
idOccInfo,
-#ifdef OLD_STRICTNESS
- idDemandInfo,
- idStrictness,
- idCprInfo,
-#endif
-
-- ** Writing 'IdInfo' fields
setIdUnfolding,
setIdArity,
- setIdNewDemandInfo,
- setIdNewStrictness, zapIdNewStrictness,
+ setIdDemandInfo,
+ setIdStrictness, zapIdStrictness,
setIdSpecialisation,
setIdCafInfo,
setIdOccInfo, zapIdOccInfo,
-#ifdef OLD_STRICTNESS
- setIdStrictness,
- setIdDemandInfo,
- setIdCprInfo,
-#endif
) where
#include "HsVersions.h"
import Type
import TcType
import TysPrim
-#ifdef OLD_STRICTNESS
-import qualified Demand
-#endif
import DataCon
-import NewDemand
+import Demand
import Name
import Module
import Class
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
`setIdArity`,
- `setIdNewDemandInfo`,
- `setIdNewStrictness`,
+ `setIdDemandInfo`,
+ `setIdStrictness`,
`setIdSpecialisation`,
`setInlinePragma`,
`idCafInfo`
-#ifdef OLD_STRICTNESS
- ,`idCprInfo`
- ,`setIdStrictness`
- ,`setIdDemandInfo`
-#endif
\end{code}
%************************************************************************
setIdArity :: Id -> Arity -> Id
setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
-#ifdef OLD_STRICTNESS
- ---------------------------------
- -- (OLD) STRICTNESS
-idStrictness :: Id -> StrictnessInfo
-idStrictness id = strictnessInfo (idInfo id)
-
-setIdStrictness :: Id -> StrictnessInfo -> Id
-setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
-#endif
-
-- | Returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
-isBottomingId id = isBottomingSig (idNewStrictness id)
+isBottomingId id = isBottomingSig (idStrictness id)
-idNewStrictness_maybe :: Id -> Maybe StrictSig
-idNewStrictness :: Id -> StrictSig
+idStrictness_maybe :: Id -> Maybe StrictSig
+idStrictness :: Id -> StrictSig
-idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
-idNewStrictness id = idNewStrictness_maybe id `orElse` topSig
+idStrictness_maybe id = strictnessInfo (idInfo id)
+idStrictness id = idStrictness_maybe id `orElse` topSig
-setIdNewStrictness :: Id -> StrictSig -> Id
-setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
+setIdStrictness :: Id -> StrictSig -> Id
+setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` Just sig) id
-zapIdNewStrictness :: Id -> Id
-zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id
+zapIdStrictness :: Id -> Id
+zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` Nothing) id
-- | This predicate says whether the 'Id' has a strict demand placed on it or
-- has a type such that it can always be evaluated strictly (e.g., an
isStrictId :: Id -> Bool
isStrictId id
= ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )
- (isStrictDmd (idNewDemandInfo id)) ||
+ (isStrictDmd (idDemandInfo id)) ||
(isStrictType (idType id))
---------------------------------
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
-#ifdef OLD_STRICTNESS
- ---------------------------------
- -- (OLD) DEMAND
-idDemandInfo :: Id -> Demand.Demand
-idDemandInfo id = demandInfo (idInfo id)
-
-setIdDemandInfo :: Id -> Demand.Demand -> Id
-setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
-#endif
-
-idNewDemandInfo_maybe :: Id -> Maybe NewDemand.Demand
-idNewDemandInfo :: Id -> NewDemand.Demand
+idDemandInfo_maybe :: Id -> Maybe Demand
+idDemandInfo :: Id -> Demand
-idNewDemandInfo_maybe id = newDemandInfo (idInfo id)
-idNewDemandInfo id = newDemandInfo (idInfo id) `orElse` NewDemand.topDmd
+idDemandInfo_maybe id = demandInfo (idInfo id)
+idDemandInfo id = demandInfo (idInfo id) `orElse` topDmd
-setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id
-setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id
+setIdDemandInfo :: Id -> Demand -> Id
+setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` Just dmd) id
---------------------------------
-- SPECIALISATION
---------------------------------
-- CAF INFO
idCafInfo :: Id -> CafInfo
-#ifdef OLD_STRICTNESS
-idCafInfo id = case cgInfo (idInfo id) of
- NoCgInfo -> pprPanic "idCafInfo" (ppr id)
- info -> cgCafInfo info
-#else
idCafInfo id = cafInfo (idInfo id)
-#endif
setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
---------------------------------
- -- CPR INFO
-#ifdef OLD_STRICTNESS
-idCprInfo :: Id -> CprInfo
-idCprInfo id = cprInfo (idInfo id)
-
-setIdCprInfo :: Id -> CprInfo -> Id
-setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
-#endif
-
- ---------------------------------
-- Occcurrence INFO
idOccInfo :: Id -> OccInfo
idOccInfo id = occInfo (idInfo id)
old_arity = arityInfo old_info
old_inline_prag = inlinePragInfo old_info
new_arity = old_arity + arity_increase
- old_strictness = newStrictnessInfo old_info
+ old_strictness = strictnessInfo old_info
new_strictness = fmap (increaseStrictSigArity arity_increase) old_strictness
- transfer new_info = new_info `setNewStrictnessInfo` new_strictness
+ transfer new_info = new_info `setStrictnessInfo` new_strictness
`setArityInfo` new_arity
`setInlinePragInfo` old_inline_prag
\end{code}
arityInfo, setArityInfo, ppArityInfo,
-- ** Demand and strictness Info
- newStrictnessInfo, setNewStrictnessInfo,
- newDemandInfo, setNewDemandInfo, pprNewStrictness,
- setAllStrictnessInfo,
-
-#ifdef OLD_STRICTNESS
- -- ** Old strictness Info
- StrictnessInfo(..),
- mkStrictnessInfo, noStrictnessInfo,
- ppStrictnessInfo, isBottomingStrictness,
- strictnessInfo, setStrictnessInfo,
-
- oldStrictnessFromNew, newStrictnessFromOld,
-
- -- ** Old demand Info
- demandInfo, setDemandInfo,
- oldDemand, newDemand,
-
- -- ** Old Constructed Product Result Info
- CprInfo(..),
- cprInfo, setCprInfo, ppCprInfo, noCprInfo,
- cprInfoFromNewStrictness,
-#endif
+ strictnessInfo, setStrictnessInfo,
+ demandInfo, setDemandInfo, pprStrictness,
-- ** Unfolding Info
unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily,
import DataCon
import TyCon
import ForeignCall
-import NewDemand
+import Demand
import Outputable
import Module
import FastString
import Data.Maybe
-#ifdef OLD_STRICTNESS
-import Demand
-import qualified Demand
-import Util
-import Data.List
-#endif
-
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setSpecInfo`,
`setArityInfo`,
`setLBVarInfo`,
`setOccInfo`,
`setCafInfo`,
- `setNewStrictnessInfo`,
- `setAllStrictnessInfo`,
- `setNewDemandInfo`
-#ifdef OLD_STRICTNESS
- , `setCprInfo`
- , `setDemandInfo`
- , `setStrictnessInfo`
-#endif
+ `setStrictnessInfo`,
+ `setDemandInfo`
\end{code}
%************************************************************************
%* *
-\subsection{New strictness info}
-%* *
-%************************************************************************
-
-To be removed later
-
-\begin{code}
--- | Set old and new strictness information together
-setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
-setAllStrictnessInfo info Nothing
- = info { newStrictnessInfo = Nothing
-#ifdef OLD_STRICTNESS
- , strictnessInfo = NoStrictnessInfo
- , cprInfo = NoCPRInfo
-#endif
- }
-
-setAllStrictnessInfo info (Just sig)
- = info { newStrictnessInfo = Just sig
-#ifdef OLD_STRICTNESS
- , strictnessInfo = oldStrictnessFromNew sig
- , cprInfo = cprInfoFromNewStrictness sig
-#endif
- }
-
-seqNewStrictnessInfo :: Maybe StrictSig -> ()
-seqNewStrictnessInfo Nothing = ()
-seqNewStrictnessInfo (Just ty) = seqStrictSig ty
-
-pprNewStrictness :: Maybe StrictSig -> SDoc
-pprNewStrictness Nothing = empty
-pprNewStrictness (Just sig) = ppr sig
-
-#ifdef OLD_STRICTNESS
-oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
-oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
- where
- (dmds, res_info) = splitStrictSig sig
-
-cprInfoFromNewStrictness :: StrictSig -> CprInfo
-cprInfoFromNewStrictness sig = case strictSigResInfo sig of
- RetCPR -> ReturnsCPR
- other -> NoCPRInfo
-
-newStrictnessFromOld :: Name -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig
-newStrictnessFromOld name arity (Demand.StrictnessInfo ds res) cpr
- | listLengthCmp ds arity /= GT -- length ds <= arity
- -- Sometimes the old strictness analyser has more
- -- demands than the arity justifies
- = mk_strict_sig name arity $
- mkTopDmdType (map newDemand ds) (newRes res cpr)
-
-newStrictnessFromOld name arity other cpr
- = -- Either no strictness info, or arity is too small
- -- In either case we can't say anything useful
- mk_strict_sig name arity $
- mkTopDmdType (replicate arity lazyDmd) (newRes False cpr)
-
-mk_strict_sig name arity dmd_ty
- = WARN( arity /= dmdTypeDepth dmd_ty, ppr name <+> (ppr arity $$ ppr dmd_ty) )
- mkStrictSig dmd_ty
-
-newRes True _ = BotRes
-newRes False ReturnsCPR = retCPR
-newRes False NoCPRInfo = TopRes
-
-newDemand :: Demand.Demand -> NewDemand.Demand
-newDemand (WwLazy True) = Abs
-newDemand (WwLazy False) = lazyDmd
-newDemand WwStrict = evalDmd
-newDemand (WwUnpack unpk ds) = Eval (Prod (map newDemand ds))
-newDemand WwPrim = lazyDmd
-newDemand WwEnum = evalDmd
-
-oldDemand :: NewDemand.Demand -> Demand.Demand
-oldDemand Abs = WwLazy True
-oldDemand Top = WwLazy False
-oldDemand Bot = WwStrict
-oldDemand (Box Bot) = WwStrict
-oldDemand (Box Abs) = WwLazy False
-oldDemand (Box (Eval _)) = WwStrict -- Pass box only
-oldDemand (Defer d) = WwLazy False
-oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds)
-oldDemand (Eval (Poly _)) = WwStrict
-oldDemand (Call _) = WwStrict
-
-#endif /* OLD_STRICTNESS */
-\end{code}
-
-
-\begin{code}
-seqNewDemandInfo :: Maybe Demand -> ()
-seqNewDemandInfo Nothing = ()
-seqNewDemandInfo (Just dmd) = seqDemand dmd
-\end{code}
-
-
-%************************************************************************
-%* *
IdDetails
%* *
%************************************************************************
arityInfo :: !ArityInfo, -- ^ 'Id' arity
specInfo :: SpecInfo, -- ^ Specialisations of the 'Id's function which exist
-- See Note [Specialisations and RULES in IdInfo]
-#ifdef OLD_STRICTNESS
- cprInfo :: CprInfo, -- ^ If the 'Id's function always constructs a product result
- demandInfo :: Demand.Demand, -- ^ Whether or not the 'Id' is definitely demanded
- strictnessInfo :: StrictnessInfo, -- ^ 'Id' strictness properties
-#endif
unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding
cafInfo :: CafInfo, -- ^ 'Id' CAF info
lbvarInfo :: LBVarInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one
inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id'
occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program
- newStrictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe:
+ strictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe:
-- the DmdAnal phase needs to know whether
-- this is the first visit, so it can assign botSig.
-- Other customers want topSig. So @Nothing@ is good.
- newDemandInfo :: Maybe Demand -- ^ Id demand information. Similarly we want to know
+ demandInfo :: Maybe Demand -- ^ Id demand information. Similarly we want to know
-- if there's no known demand yet, for when we are looking
-- for CPR info
}
-- some unfoldings are not calculated at all
-- seqUnfolding (unfoldingInfo info) `seq`
- seqNewDemandInfo (newDemandInfo info) `seq`
- seqNewStrictnessInfo (newStrictnessInfo info) `seq`
-
-#ifdef OLD_STRICTNESS
- Demand.seqDemand (demandInfo info) `seq`
- seqStrictnessInfo (strictnessInfo info) `seq`
- seqCpr (cprInfo info) `seq`
-#endif
+ seqDemandInfo (demandInfo info) `seq`
+ seqStrictnessInfo (strictnessInfo info) `seq`
seqCaf (cafInfo info) `seq`
seqLBVar (lbvarInfo info) `seq`
seqOccInfo (occInfo info)
+
+seqStrictnessInfo :: Maybe StrictSig -> ()
+seqStrictnessInfo Nothing = ()
+seqStrictnessInfo (Just ty) = seqStrictSig ty
+
+seqDemandInfo :: Maybe Demand -> ()
+seqDemandInfo Nothing = ()
+seqDemandInfo (Just dmd) = seqDemand dmd
\end{code}
Setters
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
setOccInfo :: IdInfo -> OccInfo -> IdInfo
setOccInfo info oc = oc `seq` info { occInfo = oc }
-#ifdef OLD_STRICTNESS
-setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
-#endif
-- Try to avoid spack leaks by seq'ing
setUnfoldingInfoLazily :: IdInfo -> Unfolding -> IdInfo
-- actually increases residency significantly.
= info { unfoldingInfo = uf }
-#ifdef OLD_STRICTNESS
-setDemandInfo info dd = info { demandInfo = dd }
-setCprInfo info cp = info { cprInfo = cp }
-#endif
-
setArityInfo :: IdInfo -> ArityInfo -> IdInfo
setArityInfo info ar = info { arityInfo = ar }
setCafInfo :: IdInfo -> CafInfo -> IdInfo
setLBVarInfo :: IdInfo -> LBVarInfo -> IdInfo
setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb }
-setNewDemandInfo :: IdInfo -> Maybe Demand -> IdInfo
-setNewDemandInfo info dd = dd `seq` info { newDemandInfo = dd }
-setNewStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
-setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd }
+setDemandInfo :: IdInfo -> Maybe Demand -> IdInfo
+setDemandInfo info dd = dd `seq` info { demandInfo = dd }
+
+setStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
+setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }
\end{code}
= IdInfo {
cafInfo = vanillaCafInfo,
arityInfo = unknownArity,
-#ifdef OLD_STRICTNESS
- cprInfo = NoCPRInfo,
- demandInfo = wwLazy,
- strictnessInfo = NoStrictnessInfo,
-#endif
specInfo = emptySpecInfo,
unfoldingInfo = noUnfolding,
lbvarInfo = NoLBVarInfo,
inlinePragInfo = defaultInlinePragma,
occInfo = NoOccInfo,
- newDemandInfo = Nothing,
- newStrictnessInfo = Nothing
+ demandInfo = Nothing,
+ strictnessInfo = Nothing
}
-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references
%************************************************************************
%* *
+ Strictness
+%* *
+%************************************************************************
+
+\begin{code}
+pprStrictness :: Maybe StrictSig -> SDoc
+pprStrictness Nothing = empty
+pprStrictness (Just sig) = ppr sig
+\end{code}
+
+
+%************************************************************************
+%* *
SpecInfo
%* *
%************************************************************************
%************************************************************************
%* *
-\subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef OLD_STRICTNESS
--- | If the @Id@ is a function then it may have Constructed Product Result
--- (CPR) info. A CPR analysis phase detects whether:
---
--- 1. The function's return value has a product type, i.e. an algebraic type
--- with a single constructor. Examples of such types are tuples and boxed
--- primitive values.
---
--- 2. The function always 'constructs' the value that it is returning. It
--- must do this on every path through, and it's OK if it calls another
--- function which constructs the result.
---
--- If this is the case then we store a template which tells us the
--- function has the CPR property and which components of the result are
--- also CPRs.
-data CprInfo
- = NoCPRInfo -- ^ No, this function does not return a constructed product
- | ReturnsCPR -- ^ Yes, this function returns a constructed product
-
- -- Implicitly, this means "after the function has been applied
- -- to all its arguments", so the worker\/wrapper builder in
- -- WwLib.mkWWcpr checks that that it is indeed saturated before
- -- making use of the CPR info
-
- -- We used to keep nested info about sub-components, but
- -- we never used it so I threw it away
-
--- | It's always safe to assume that an 'Id' does not have the CPR property
-noCprInfo :: CprInt
-noCprInfo = NoCPRInfo
-
-seqCpr :: CprInfo -> ()
-seqCpr ReturnsCPR = ()
-seqCpr NoCPRInfo = ()
-
-ppCprInfo NoCPRInfo = empty
-ppCprInfo ReturnsCPR = ptext (sLit "__M")
-
-instance Outputable CprInfo where
- ppr = ppCprInfo
-
-instance Show CprInfo where
- showsPrec p c = showsPrecSDoc p (ppr c)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
\subsection[lbvar-IdInfo]{Lambda-bound var info about an @Id@}
%* *
%************************************************************************
--
-- > (\x1. \x2. e) arg1
zapLamInfo :: IdInfo -> Maybe IdInfo
-zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand})
+zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
| is_safe_occ occ && is_safe_dmd demand
= Nothing
| otherwise
- = Just (info {occInfo = safe_occ, newDemandInfo = Nothing})
+ = Just (info {occInfo = safe_occ, demandInfo = Nothing})
where
-- The "unsafe" occ info is the ones that say I'm not in a lambda
-- because that might not be true for an unsaturated lambda
\begin{code}
-- | Remove demand info on the 'IdInfo' if it is present, otherwise return @Nothing@
zapDemandInfo :: IdInfo -> Maybe IdInfo
-zapDemandInfo info@(IdInfo {newDemandInfo = dmd})
- | isJust dmd = Just (info {newDemandInfo = Nothing})
+zapDemandInfo info@(IdInfo {demandInfo = dmd})
+ | isJust dmd = Just (info {demandInfo = Nothing})
| otherwise = Nothing
\end{code}
import Id
import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar )
import IdInfo
-import NewDemand
+import Demand
import CoreSyn
import Unique
import PrelNames
wkr_arity = dataConRepArity data_con
wkr_info = noCafIdInfo
`setArityInfo` wkr_arity
- `setAllStrictnessInfo` Just wkr_sig
+ `setStrictnessInfo` Just wkr_sig
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
-- It's important to specify the arity, so that partial
-- applications are treated as values
`setUnfoldingInfo` wrap_unf
- `setAllStrictnessInfo` Just wrap_sig
+ `setStrictnessInfo` Just wrap_sig
all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
base_info = noCafIdInfo
`setArityInfo` 1
- `setAllStrictnessInfo` Just strict_sig
+ `setStrictnessInfo` Just strict_sig
`setUnfoldingInfo` (if no_unf then noUnfolding
else mkImplicitUnfolding rhs)
-- In module where class op is defined, we must add
info = noCafIdInfo
`setSpecInfo` mkSpecInfo (primOpRules prim_op name)
`setArityInfo` arity
- `setAllStrictnessInfo` Just strict_sig
+ `setStrictnessInfo` Just strict_sig
-- For each ccall we manufacture a separate CCallOpId, giving it
-- a fresh unique, a type that is correct for this particular ccall,
info = noCafIdInfo
`setArityInfo` arity
- `setAllStrictnessInfo` Just strict_sig
+ `setStrictnessInfo` Just strict_sig
(_, tau) = tcSplitForAllTys ty
(arg_tys, _) = tcSplitFunTys tau
pc_bottoming_Id name ty
= pcMiscPrelId name ty bottoming_info
where
- bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
+ bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig
`setArityInfo` 1
-- Make arity and strictness agree
+++ /dev/null
-%
-% (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}
-module NewDemand(
- 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
-
-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)
-
-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}
-
-
import CoreSyn
import CoreFVs
import CoreUtils
-import NewDemand
+import Demand
import TyCon ( isRecursiveTyCon )
import qualified CoreSubst
import CoreSubst ( Subst, substBndr, substBndrs, substExpr
---------------------------
arityType :: Bool -> CoreExpr -> ArityType
arityType _ (Var v)
- | Just strict_sig <- idNewStrictness_maybe v
+ | Just strict_sig <- idStrictness_maybe v
, (ds, res) <- splitStrictSig strict_sig
, isBotRes res
= AT (length ds) ABot -- Function diverges
#include "HsVersions.h"
-import NewDemand
+import Demand
import CoreSyn
import CoreFVs
import CoreUtils
-- the unfolding is a SimplifiableCoreExpr. Give up for now.
where
binder_ty = idType binder
- maybeDmdTy = idNewStrictness_maybe binder
+ maybeDmdTy = idStrictness_maybe binder
bndr_vars = varSetElems (idFreeVars binder)
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| otherwise = return ()
mkStrictMsg binder
= vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
ppr binder],
- hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)]
+ hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)]
]
mkArityMsg :: Id -> Message
hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
]
- where (StrictSig dmd_ty) = idNewStrictness binder
+ where (StrictSig dmd_ty) = idStrictness binder
mkUnboxedTupleMsg :: Id -> Message
mkUnboxedTupleMsg binder
import Type
import Coercion
import TyCon
-import NewDemand
+import Demand
import Var
import VarSet
import VarEnv
-> UniqSM (CorePrepEnv, Floats)
cpeBind top_lvl env (NonRec bndr rhs)
= do { (_, bndr1) <- cloneBndr env bndr
- ; let is_strict = isStrictDmd (idNewDemandInfo bndr)
+ ; let is_strict = isStrictDmd (idDemandInfo bndr)
is_unlifted = isUnLiftedType (idType bndr)
; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
(is_strict || is_unlifted)
; let v2 = lookupCorePrepEnv env v1
; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
where
- stricts = case idNewStrictness v of
+ stricts = case idStrictness v of
StrictSig (DmdType _ demands _)
| listLengthCmp demands depth /= GT -> demands
-- length demands <= depth
idinfo = idInfo id
new_info = idInfo new_id
`setArityInfo` exprArity rhs
- `setAllStrictnessInfo` newStrictnessInfo idinfo
- `setNewDemandInfo` newDemandInfo idinfo
+ `setStrictnessInfo` strictnessInfo idinfo
+ `setDemandInfo` demandInfo idinfo
`setInlinePragInfo` inlinePragInfo idinfo
-- Override the env we get back from tidyId with the new IdInfo
import Var
import Id
import IdInfo
-import NewDemand
-#ifdef OLD_STRICTNESS
-import Id
-import IdInfo
-#endif
-
+import Demand
import DataCon
import TyCon
import Type
where
prag_info = inlinePragInfo info
occ_info = occInfo info
- dmd_info = newDemandInfo info
+ dmd_info = demandInfo info
lbv_info = lbvarInfo info
has_prag = not (isDefaultInlinePragma prag_info)
[ (True, pp_scope <> ppr (idDetails id))
, (has_arity, ptext (sLit "Arity=") <> int arity)
, (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info)
- , (has_strictness, ptext (sLit "Str=") <> pprNewStrictness str_info)
+ , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
, (has_unf, ptext (sLit "Unf=") <> ppr unf_info)
, (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
] -- Inline pragma, occ, demand, lbvar info
caf_info = cafInfo info
has_caf_info = not (mayHaveCafRefs caf_info)
- str_info = newStrictnessInfo info
+ str_info = strictnessInfo info
has_strictness = isJust str_info
unf_info = unfoldingInfo info
+++ /dev/null
-% (c) The University of Glasgow 2006
-
-\section[CprAnalyse]{Identify functions that always return a
-constructed product result}
-
-\begin{code}
-#ifndef OLD_STRICTNESS
-module CprAnalyse ( ) where
-
-#else
-
-module CprAnalyse ( cprAnalyse ) where
-
-#include "HsVersions.h"
-
-import DynFlags
-import CoreMonad
-import CoreSyn
-import CoreUtils
-import Id
-import IdInfo
-import Demand
-import VarEnv
-import Util
-import Outputable
-
-import Maybe
-\end{code}
-
-This module performs an analysis of a set of Core Bindings for the
-Constructed Product Result (CPR) transformation.
-
-It detects functions that always explicitly (manifestly?) construct a
-result value with a product type. A product type is a type which has
-only one constructor. For example, tuples and boxed primitive values
-have product type.
-
-We must also ensure that the function's body starts with sufficient
-manifest lambdas otherwise loss of sharing can occur. See the comment
-in @StrictAnal.lhs@.
-
-The transformation of bindings to worker/wrapper pairs is done by the
-worker-wrapper pass. The worker-wrapper pass splits bindings on the
-basis of both strictness and CPR info. If an id has both then it can
-combine the transformations so that only one pair is produced.
-
-The analysis here detects nested CPR information. For example, if a
-function returns a constructed pair, the first element of which is a
-constructed int, then the analysis will detect nested CPR information
-for the int as well. Unfortunately, the current transformations can't
-take advantage of the nested CPR information. They have (broken now,
-I think) code which will flatten out nested CPR components and rebuild
-them in the wrapper, but enabling this would lose laziness. It is
-possible to make use of the nested info: if we knew that a caller was
-strict in that position then we could create a specialized version of
-the function which flattened/reconstructed that position.
-
-It is not known whether this optimisation would be worthwhile.
-
-So we generate and carry round nested CPR information, but before
-using this info to guide the creation of workers and wrappers we map
-all components of a CPRInfo to NoCprInfo.
-
-
-Data types
-~~~~~~~~~~
-
-Within this module Id's CPR information is represented by
-``AbsVal''. When adding this information to the Id's pragma info field
-we convert the ``Absval'' to a ``CprInfo'' value.
-
-Abstract domains consist of a `no information' value (Top), a function
-value (Fun) which when applied to an argument returns a new AbsVal
-(note the argument is not used in any way), , for product types, a
-corresponding length tuple (Tuple) of abstract values. And finally,
-Bot. Bot is not a proper abstract value but a generic bottom is
-useful for calculating fixpoints and representing divergent
-computations. Note that we equate Bot and Fun^n Bot (n > 0), and
-likewise for Top. This saves a lot of delving in types to keep
-everything exactly correct.
-
-Since functions abstract to constant functions we could just
-represent them by the abstract value of their result. However, it
-turns out (I know - I tried!) that this requires a lot of type
-manipulation and the code is more straightforward if we represent
-functions by an abstract constant function.
-
-\begin{code}
-data AbsVal = Top -- Not a constructed product
-
- | Fun AbsVal -- A function that takes an argument
- -- and gives AbsVal as result.
-
- | Tuple -- A constructed product of values
-
- | Bot -- Bot'tom included for convenience
- -- we could use appropriate Tuple Vals
- deriving (Eq,Show)
-
--- For pretty debugging
-instance Outputable AbsVal where
- ppr Top = ptext (sLit "Top")
- ppr (Fun r) = ptext (sLit "Fun->") <> (parens.ppr) r
- ppr Tuple = ptext (sLit "Tuple ")
- ppr Bot = ptext (sLit "Bot")
-
-
--- lub takes the lowest upper bound of two abstract values, standard.
-lub :: AbsVal -> AbsVal -> AbsVal
-lub Bot a = a
-lub a Bot = a
-lub Top a = Top
-lub a Top = Top
-lub Tuple Tuple = Tuple
-lub (Fun l) (Fun r) = Fun (lub l r)
-lub l r = panic "CPR Analysis tried to take the lub of a function and a tuple"
-
-
-\end{code}
-
-The environment maps Ids to their abstract CPR value.
-
-\begin{code}
-
-type CPREnv = VarEnv AbsVal
-
-initCPREnv = emptyVarEnv
-
-\end{code}
-
-Programs
-~~~~~~~~
-
-Take a list of core bindings and return a new list with CPR function
-ids decorated with their CprInfo pragmas.
-
-\begin{code}
-
-cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind]
-cprAnalyse dflags binds
- = do {
- showPass dflags "Constructed Product analysis" ;
- let { binds_plus_cpr = do_prog binds } ;
- endPass dflags "Constructed Product analysis"
- Opt_D_dump_cpranal binds_plus_cpr []
- return binds_plus_cpr
- }
- where
- do_prog :: [CoreBind] -> [CoreBind]
- do_prog binds = snd $ mapAccumL cprAnalBind initCPREnv binds
-\end{code}
-
-The cprAnal functions take binds/expressions and an environment which
-gives CPR info for visible ids and returns a new bind/expression
-with ids decorated with their CPR info.
-
-\begin{code}
--- Return environment extended with info from this binding
-cprAnalBind :: CPREnv -> CoreBind -> (CPREnv, CoreBind)
-cprAnalBind rho (NonRec b e)
- | isImplicitId b -- Don't touch the CPR info on constructors, selectors etc
- = (rho, NonRec b e)
- | otherwise
- = (extendVarEnv rho b absval, NonRec b' e')
- where
- (e', absval) = cprAnalExpr rho e
- b' = addIdCprInfo b e' absval
-
-cprAnalBind rho (Rec prs)
- = (final_rho, Rec (map do_pr prs))
- where
- do_pr (b,e) = (b', e')
- where
- b' = addIdCprInfo b e' absval
- (e', absval) = cprAnalExpr final_rho e
-
- -- When analyzing mutually recursive bindings the iterations to find
- -- a fixpoint is bounded by the number of bindings in the group.
- -- for simplicity we just iterate that number of times.
- final_rho = nTimes (length prs) do_one_pass init_rho
- init_rho = rho `extendVarEnvList` [(b,Bot) | (b,e) <- prs]
-
- do_one_pass :: CPREnv -> CPREnv
- do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalExpr rho e)))
- rho prs
-
-
-cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal)
-
--- If Id will always diverge when given sufficient arguments then
--- we can just set its abs val to Bot. Any other CPR info
--- from other paths will then dominate, which is what we want.
--- Check in rho, if not there it must be imported, so check
--- the var's idinfo.
-cprAnalExpr rho e@(Var v)
- | isBottomingId v = (e, Bot)
- | otherwise = (e, case lookupVarEnv rho v of
- Just a_val -> a_val
- Nothing -> getCprAbsVal v)
-
--- Literals are unboxed
-cprAnalExpr rho (Lit l) = (Lit l, Top)
-
--- For apps we don't care about the argument's abs val. This
--- app will return a constructed product if the function does. We strip
--- a Fun from the functions abs val, unless the argument is a type argument
--- or it is already Top or Bot.
-cprAnalExpr rho (App fun arg@(Type _))
- = (App fun_cpr arg, fun_res)
- where
- (fun_cpr, fun_res) = cprAnalExpr rho fun
-
-cprAnalExpr rho (App fun arg)
- = (App fun_cpr arg_cpr, res_res)
- where
- (fun_cpr, fun_res) = cprAnalExpr rho fun
- (arg_cpr, _) = cprAnalExpr rho arg
- res_res = case fun_res of
- Fun res_res -> res_res
- Top -> Top
- Bot -> Bot
- Tuple -> WARN( True, ppr (App fun arg) ) Top
- -- This really should not happen!
-
-
--- Map arguments to Top (we aren't constructing them)
--- Return the abstract value of the body, since functions
--- are represented by the CPR value of their result, and
--- add a Fun for this lambda..
-cprAnalExpr rho (Lam b body) | isTyVar b = (Lam b body_cpr, body_aval)
- | otherwise = (Lam b body_cpr, Fun body_aval)
- where
- (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body
-
-cprAnalExpr rho (Let bind body)
- = (Let bind' body', body_aval)
- where
- (rho', bind') = cprAnalBind rho bind
- (body', body_aval) = cprAnalExpr rho' body
-
-cprAnalExpr rho (Case scrut bndr alts)
- = (Case scrut_cpr bndr alts_cpr, alts_aval)
- where
- (scrut_cpr, scrut_aval) = cprAnalExpr rho scrut
- (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts
-
-cprAnalExpr rho (Note n exp)
- = (Note n exp_cpr, expr_aval)
- where
- (exp_cpr, expr_aval) = cprAnalExpr rho exp
-
-cprAnalExpr rho (Type t)
- = (Type t, Top)
-
-cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
-cprAnalCaseAlts rho alts
- = foldr anal_alt ([], Bot) alts
- where
- anal_alt :: CoreAlt -> ([CoreAlt], AbsVal) -> ([CoreAlt], AbsVal)
- anal_alt (con, binds, exp) (done, aval)
- = ((con,binds,exp_cpr) : done, exp_aval `lub` aval)
- where (exp_cpr, exp_aval) = cprAnalExpr rho' exp
- rho' = rho `extendVarEnvList` (zip binds (repeat Top))
-
-
-addIdCprInfo :: Id -> CoreExpr -> AbsVal -> Id
-addIdCprInfo bndr rhs absval
- | useful_info && ok_to_add = setIdCprInfo bndr cpr_info
- | otherwise = bndr
- where
- cpr_info = absToCprInfo absval
- useful_info = case cpr_info of { ReturnsCPR -> True; NoCPRInfo -> False }
-
- ok_to_add = case absval of
- Fun _ -> idArity bndr >= n_fun_tys absval
- -- Enough visible lambdas
-
- Tuple -> exprIsHNF rhs || isStrict (idDemandInfo bndr)
- -- If the rhs is a value, and returns a constructed product,
- -- it will be inlined at usage sites, so we give it a Tuple absval
- -- If it isn't a value, we won't inline it (code/work dup worries), so
- -- we discard its absval.
- --
- -- Also, if the strictness analyser has figured out that it's strict,
- -- the let-to-case transformation will happen, so again it's good.
- -- (CPR analysis runs before the simplifier has had a chance to do
- -- the let-to-case transform.)
- -- This made a big difference to PrelBase.modInt, which had something like
- -- modInt = \ x -> let r = ... -> I# v in
- -- ...body strict in r...
- -- r's RHS isn't a value yet; but modInt returns r in various branches, so
- -- if r doesn't have the CPR property then neither does modInt
-
- _ -> False
-
- n_fun_tys :: AbsVal -> Int
- n_fun_tys (Fun av) = 1 + n_fun_tys av
- n_fun_tys other = 0
-
-
-absToCprInfo :: AbsVal -> CprInfo
-absToCprInfo Tuple = ReturnsCPR
-absToCprInfo (Fun r) = absToCprInfo r
-absToCprInfo _ = NoCPRInfo
-
-
--- Cpr Info doesn't store the number of arguments a function has, so the caller
--- must take care to add the appropriate number of Funs.
-getCprAbsVal v = case idCprInfo v of
- NoCPRInfo -> Top
- ReturnsCPR -> nTimes arity Fun Tuple
- where
- arity = idArity v
- -- Imported (non-nullary) constructors will have the CPR property
- -- in their IdInfo, so no need to look at their unfolding
-#endif /* OLD_STRICTNESS */
-\end{code}
Name
NameEnv
NameSet
- NewDemand
OccName
RdrName
SrcLoc
MkExternalCore
PprCore
PprExternalCore
- CprAnalyse
Check
Coverage
Desugar
StgLint
StgSyn
DmdAnal
- SaAbsInt
- SaLib
- StrictAnal
WorkWrap
WwLib
FamInst
import IfaceEnv
import HscTypes
import BasicTypes
-import NewDemand
+import Demand
import Annotations
import IfaceSyn
import Module
{-! for StrictnessMark derive: Binary !-}
{-! for Activation derive: Binary !-}
--- NewDemand
+-- Demand
{-! for Demand derive: Binary !-}
{-! for Demands derive: Binary !-}
{-! for DmdResult derive: Binary !-}
import IfaceType
-import NewDemand
+import Demand
import Annotations
import Class
import NameSet
import LoadIface
import Id
import IdInfo
-import NewDemand
+import Demand
import Annotations
import CoreSyn
import CoreFVs
------------ Strictness --------------
-- No point in explicitly exporting TopSig
- strict_hsinfo = case newStrictnessInfo id_info of
+ strict_hsinfo = case strictnessInfo id_info of
Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
_other -> Nothing
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
- tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str)
+ tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` Just str)
tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
-- The next two are lazy, so they don't transitively suck stuff in
-- We are relying here on strictness info always appearing
-- before worker info, fingers crossed ....
- strict_sig = case newStrictnessInfo info of
+ strict_sig = case strictnessInfo info of
Just sig -> sig
Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr)
tc_info [] = vanillaIdInfo
tc_info (HsInline p : i) = tc_info i `setInlinePragInfo` p
tc_info (HsArity a : i) = tc_info i `setArityInfo` a
- tc_info (HsStrictness s : i) = tc_info i `setAllStrictnessInfo` Just s
+ tc_info (HsStrictness s : i) = tc_info i `setStrictnessInfo` Just s
tc_info (other : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo"
(ppr other) (tc_info i)
-- Don't stop now!
simpl_phase 0 ["main"] (max max_iter 3),
-
-#ifdef OLD_STRICTNESS
- CoreDoOldStrictness,
-#endif
runWhen strictness (CoreDoPasses [
CoreDoStrictness,
CoreDoWorkerWrapper,
import Id
import IdInfo
import InstEnv
-import NewDemand
+import Demand
import BasicTypes
import Name hiding (varName)
import NameSet
idinfo = idInfo id
dont_inline = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
loop_breaker = isNonRuleLoopBreaker (occInfo idinfo)
- bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
+ bottoming_fn = isBottomingSig (strictnessInfo idinfo `orElse` topSig)
spec_ids = specInfoFreeVars (specInfo idinfo)
-- Stuff to do with the Id's unfolding
Nothing -> True
Just (arity, _) -> appIsBottom str arity
where
- str = newStrictnessInfo idinfo `orElse` topSig
+ str = strictnessInfo idinfo `orElse` topSig
bndr1 = mkGlobalId details name' ty' idinfo'
details = idDetails bndr -- Preserve the IdDetails
`setOccInfo` robust_occ_info
`setCafInfo` caf_info
`setArityInfo` arity
- `setAllStrictnessInfo` newStrictnessInfo idinfo
+ `setStrictnessInfo` strictnessInfo idinfo
| otherwise -- Externally-visible Ids get the whole lot
= vanillaIdInfo
`setOccInfo` robust_occ_info
`setCafInfo` caf_info
`setArityInfo` arity
- `setAllStrictnessInfo` newStrictnessInfo idinfo
+ `setStrictnessInfo` strictnessInfo idinfo
`setInlinePragInfo` inlinePragInfo idinfo
`setUnfoldingInfo` unfold_info
-- NB: we throw away the Rules
import TysPrim
import TysWiredIn
-import NewDemand
+import Demand
import Var ( TyVar )
import OccName ( OccName, pprOccName, mkVarOccFS )
import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) )
import Id ( idType, mkSysLocal, isOneShotLambda,
zapDemandIdInfo, transferPolyIdInfo,
idSpecialisation, idUnfolding, setIdInfo,
- setIdNewStrictness, setIdArity
+ setIdStrictness, setIdArity
)
import IdInfo
import Var
-- Note [Bottoming floats]
let var_w_str = case exprBotStrictness_maybe expr of
Just (arity,str) -> var `setIdArity` arity
- `setIdNewStrictness` str
+ `setIdStrictness` str
Nothing -> var
return (Let (NonRec (TB var_w_str dest_lvl) expr')
(mkVarApps (Var var_w_str) abs_vars))
import SpecConstr ( specConstrProgram)
import DmdAnal ( dmdAnalPgm )
import WorkWrap ( wwTopBinds )
-#ifdef OLD_STRICTNESS
-import StrictAnal ( saBinds )
-import CprAnalyse ( cprAnalyse )
-#endif
import Vectorise ( vectorise )
import FastString
import Util
doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
-#ifdef OLD_STRICTNESS
-doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} doOldStrictness
-#endif
-
doCorePass CoreDoNothing = return
doCorePass (CoreDoPasses passes) = doCorePasses passes
-
-#ifdef OLD_STRICTNESS
-doOldStrictness :: ModGuts -> CoreM ModGuts
-doOldStrictness guts
- = do dfs <- getDynFlags
- guts' <- describePass "Strictness analysis" Opt_D_dump_stranal $
- doPassM (saBinds dfs) guts
- guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $
- doPass cprAnalyse guts'
- return guts''
-#endif
-
\end{code}
%************************************************************************
= modifyIdInfo transfer exported_id
where
local_info = idInfo local_id
- transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
+ transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
`setUnfoldingInfo` unfoldingInfo local_info
`setInlinePragInfo` inlinePragInfo local_info
`setSpecInfo` addSpecInfo (specInfo exp_info) new_info
import Name
import Id
import Var ( isCoVar )
-import NewDemand
+import Demand
import SimplMonad
import Type hiding( substTy )
import Coercion ( coercionKind )
vanilla_stricts = repeat False
arg_stricts
- = case splitStrictSig (idNewStrictness fun) of
+ = case splitStrictSig (idStrictness fun) of
(demands, result_info)
| not (demands `lengthExceeds` n_val_args)
-> -- Enough args, use the strictness given.
import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
import CoreSyn
-import NewDemand ( isStrictDmd, splitStrictSig )
+import Demand ( isStrictDmd, splitStrictSig )
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule,
exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
= do { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs
; return (env', Cast rhs' co) }
where
- sanitised_info = vanillaIdInfo `setNewStrictnessInfo` newStrictnessInfo info
- `setNewDemandInfo` newDemandInfo info
+ sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
+ `setDemandInfo` demandInfo info
info = idInfo id
prepareRhs env0 _ rhs0
| otherwise = info2
final_id = new_bndr `setIdInfo` info3
- dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
+ dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr
in
ASSERT( isId new_bndr )
WARN( new_arity < old_arity || new_arity < dmd_arity,
where
-- The case binder is going to be evaluated later,
-- and the scrutinee is a simple variable
- var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
+ var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr)
&& not (isTickBoxOp v)
-- ugly hack; covering this case is what
-- exprOkForSpeculation was intended for.
import StaticFlags ( opt_SpecInlineJoinPoints )
import BasicTypes ( Activation(..) )
import Maybes ( orElse, catMaybes, isJust, isNothing )
-import NewDemand
+import Demand
import DmdAnal ( both )
import Serialized ( deserializeWithData )
import Util
spec_rhs = mkLams spec_lam_args spec_body
spec_str = calcSpecStrictness fn spec_lam_args pats
spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
- `setIdNewStrictness` spec_str -- See Note [Transfer strictness]
+ `setIdStrictness` spec_str -- See Note [Transfer strictness]
`setIdArity` count isId spec_lam_args
body_ty = exprType spec_body
rule_rhs = mkVarApps (Var spec_id) spec_call_args
= StrictSig (mkTopDmdType spec_dmds TopRes)
where
spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
- StrictSig (DmdType _ dmds _) = idNewStrictness fn
+ StrictSig (DmdType _ dmds _) = idStrictness fn
dmd_env = go emptyVarEnv dmds pats
import DynFlags ( DynFlags, DynFlag(..) )
import StaticFlags ( opt_MaxWorkerArgs )
-import NewDemand -- All of it
+import Demand -- All of it
import CoreSyn
import PprCore
import CoreUtils ( exprIsHNF, exprIsTrivial )
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idInlineActivation,
isDataConWorkId, isGlobalId, idArity,
-#ifdef OLD_STRICTNESS
- idDemandInfo, idStrictness, idCprInfo, idName,
-#endif
- idNewStrictness, idNewStrictness_maybe,
- setIdNewStrictness, idNewDemandInfo,
- idNewDemandInfo_maybe,
- setIdNewDemandInfo
+ idStrictness, idStrictness_maybe,
+ setIdStrictness, idDemandInfo,
+ idDemandInfo_maybe,
+ setIdDemandInfo
)
-#ifdef OLD_STRICTNESS
-import IdInfo ( newStrictnessFromOld, newDemand )
-#endif
import Var ( Var )
import VarEnv
import TysWiredIn ( unboxedPairDataCon )
dmdAnalPgm dflags binds
= do {
let { binds_plus_dmds = do_prog binds } ;
-#ifdef OLD_STRICTNESS
- -- Only if OLD_STRICTNESS is on, because only then is the old
- -- strictness analyser run
- let { dmd_changes = get_changes binds_plus_dmds } ;
- printDump (text "Changes in demands" $$ dmd_changes) ;
-#endif
return binds_plus_dmds
}
where
-- x = (a, absent-error)
-- and that'll crash.
-- So at one stage I had:
- -- dead_case_bndr = isAbsentDmd (idNewDemandInfo case_bndr')
+ -- dead_case_bndr = isAbsentDmd (idDemandInfo case_bndr')
-- keepity | dead_case_bndr = Drop
-- | otherwise = Keep
--
-- The insight is, of course, that a demand on y is a demand on the
-- scrutinee, so we need to `both` it with the scrut demand
- alt_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b])
+ alt_dmd = Eval (Prod [idDemandInfo b | b <- bndrs', isId b])
scrut_dmd = alt_dmd `both`
- idNewDemandInfo case_bndr'
+ idDemandInfo case_bndr'
(scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
in
-- of the fixpoint algorithm. (Cunning plan.)
-- Note that the cunning plan extends to the DmdEnv too,
-- since it is part of the strictness signature
-initialSig id = idNewStrictness_maybe id `orElse` botSig
+initialSig id = idStrictness_maybe id `orElse` botSig
dmdAnalRhs :: TopLevelFlag -> RecFlag
-> SigEnv -> (Id, CoreExpr)
-- The RHS can be eta-reduced to just a variable,
-- in which case we should not complain.
mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty
- id' = id `setIdNewStrictness` sig_ty
+ id' = id `setIdStrictness` sig_ty
sigs' = extendSigEnv top_lvl sigs id sig_ty
\end{code}
= mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty
where
never_inline = isNeverActive (idInlineActivation id)
- maybe_id_dmd = idNewDemandInfo_maybe id
+ maybe_id_dmd = idDemandInfo_maybe id
-- Is Nothing the first time round
thunk_cpr_ok
-- No effect on the argument demands
annotateBndr dmd_ty@(DmdType fv ds res) var
| isTyVar var = (dmd_ty, var)
- | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd)
+ | otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd)
where
(fv', dmd) = removeFV fv var res
-- For lambdas we add the demand to the argument demands
-- Only called for Ids
= ASSERT( isId id )
- (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)
+ (DmdType fv' (hacked_dmd:ds) res, setIdDemandInfo id hacked_dmd)
where
(fv', dmd) = removeFV fv id res
hacked_dmd = argDemand dmd
-- CPR results (e.g. from \x -> x!).
extendSigsWithLam sigs id
- = case idNewDemandInfo_maybe id of
+ = case idDemandInfo_maybe id of
Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel)
-- Optimistic in the Nothing case;
-- See notes [CPR-AND-STRICTNESS]
------ DATA CONSTRUCTOR
| isDataConWorkId var -- Data constructor
= let
- StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig
+ StrictSig dmd_ty = idStrictness var -- It must have a strictness sig
DmdType _ _ con_res = dmd_ty
arity = idArity var
in
------ IMPORTED FUNCTION
| isGlobalId var, -- Imported function
- let StrictSig dmd_ty = idNewStrictness var
+ let StrictSig dmd_ty = idStrictness var
= if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand
dmd_ty
else
boths ds1 ds2 = zipWithDmds both ds1 ds2
\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Miscellaneous
-%* *
-%************************************************************************
-
-
-\begin{code}
-#ifdef OLD_STRICTNESS
-get_changes binds = vcat (map get_changes_bind binds)
-
-get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
-get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
-
-get_changes_pr (id,rhs)
- = get_changes_var id $$ get_changes_expr rhs
-
-get_changes_var var
- | isId var = get_changes_str var $$ get_changes_dmd var
- | otherwise = empty
-
-get_changes_expr (Type t) = empty
-get_changes_expr (Var v) = empty
-get_changes_expr (Lit l) = empty
-get_changes_expr (Note n e) = get_changes_expr e
-get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2
-get_changes_expr (Lam b e) = {- get_changes_var b $$ -} get_changes_expr e
-get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e
-get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a)
-
-get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs
-
-get_changes_str id
- | new_better && old_better = empty
- | new_better = message "BETTER"
- | old_better = message "WORSE"
- | otherwise = message "INCOMPARABLE"
- where
- message word = text word <+> text "strictness for" <+> ppr id <+> info
- info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
- new = squashSig (idNewStrictness id) -- Don't report spurious diffs that the old
- -- strictness analyser can't track
- old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id)
- old_better = old `betterStrictness` new
- new_better = new `betterStrictness` old
-
-get_changes_dmd id
- | isUnLiftedType (idType id) = empty -- Not useful
- | new_better && old_better = empty
- | new_better = message "BETTER"
- | old_better = message "WORSE"
- | otherwise = message "INCOMPARABLE"
- where
- message word = text word <+> text "demand for" <+> ppr id <+> info
- info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
- new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements
- -- A bit of a hack
- old = newDemand (idDemandInfo id)
- new_better = new `betterDemand` old
- old_better = old `betterDemand` new
-
-betterStrictness :: StrictSig -> StrictSig -> Bool
-betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2
-
-betterDmdType t1 t2 = (t1 `lubType` t2) == t2
-
-betterDemand :: Demand -> Demand -> Bool
--- If d1 `better` d2, and d2 `better` d2, then d1==d2
-betterDemand d1 d2 = (d1 `lub` d2) == d2
-
-squashSig (StrictSig (DmdType fv ds res))
- = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res)
- where
- -- squash just gets rid of call demands
- -- which the old analyser doesn't track
-squashDmd (Call d) = evalDmd
-squashDmd (Box d) = Box (squashDmd d)
-squashDmd (Eval ds) = Eval (mapDmds squashDmd ds)
-squashDmd (Defer ds) = Defer (mapDmds squashDmd ds)
-squashDmd d = d
-#endif
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section[SaAbsInt]{Abstract interpreter for strictness analysis}
-
-\begin{code}
-{-# OPTIONS -w #-}
--- 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
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-#ifndef OLD_STRICTNESS
--- If OLD_STRICTNESS is off, omit all exports
-module SaAbsInt () where
-
-#else
-module SaAbsInt (
- findStrictness,
- findDemand, findDemandAlts,
- absEval,
- widen,
- fixpoint,
- isBot
- ) where
-
-#include "HsVersions.h"
-
-import StaticFlags ( opt_AllStrict, opt_NumbersStrict )
-import CoreSyn
-import CoreUnfold ( maybeUnfoldingTemplate )
-import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe,
- idStrictness,
- )
-import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
-import IdInfo ( StrictnessInfo(..) )
-import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
- mkStrictnessInfo, isLazy
- )
-import SaLib
-import TyCon ( isProductTyCon, isRecursiveTyCon )
-import Type ( splitTyConApp_maybe,
- isUnLiftedType, Type )
-import TyCon ( tyConUnique )
-import PrelInfo ( numericTyKeys )
-import Util ( isIn, nOfThem, zipWithEqual, equalLength )
-import Outputable
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsVal-ops]{Operations on @AbsVals@}
-%* *
-%************************************************************************
-
-Least upper bound, greatest lower bound.
-
-\begin{code}
-lub, glb :: AbsVal -> AbsVal -> AbsVal
-
-lub AbsBot val2 = val2
-lub val1 AbsBot = val1
-
-lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys)
-
-lub _ _ = AbsTop -- Crude, but conservative
- -- The crudity only shows up if there
- -- are functions involved
-
--- Slightly funny glb; for absence analysis only;
--- AbsBot is the safe answer.
---
--- Using anyBot rather than just testing for AbsBot is important.
--- Consider:
---
--- f = \a b -> ...
---
--- g = \x y z -> case x of
--- [] -> f x
--- (p:ps) -> f p
---
--- Now, the abstract value of the branches of the case will be an
--- AbsFun, but when testing for z's absence we want to spot that it's
--- an AbsFun which can't possibly return AbsBot. So when glb'ing we
--- mustn't be too keen to bale out and return AbsBot; the anyBot test
--- spots that (f x) can't possibly return AbsBot.
-
--- We have also tripped over the following interesting case:
--- case x of
--- [] -> \y -> 1
--- (p:ps) -> f
---
--- Now, suppose f is bound to AbsTop. Does this expression mention z?
--- Obviously not. But the case will take the glb of AbsTop (for f) and
--- an AbsFun (for \y->1). We should not bale out and give AbsBot, because
--- that would say that it *does* mention z (or anything else for that matter).
--- Nor can we always return AbsTop, because the AbsFun might be something
--- like (\y->z), which obviously does mention z. The point is that we're
--- glbing two functions, and AbsTop is not actually the top of the function
--- lattice. It is more like (\xyz -> x|y|z); that is, AbsTop returns
--- poison iff any of its arguments do.
-
--- Deal with functions specially, because AbsTop isn't the
--- top of their domain.
-
-glb v1 v2
- | is_fun v1 || is_fun v2
- = if not (anyBot v1) && not (anyBot v2)
- then
- AbsTop
- else
- AbsBot
- where
- is_fun (AbsFun _ _) = True
- is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok
- is_fun other = False
-
--- The non-functional cases are quite straightforward
-
-glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys)
-
-glb AbsTop v2 = v2
-glb v1 AbsTop = v1
-
-glb _ _ = AbsBot -- Be pessimistic
-\end{code}
-
-@isBot@ returns True if its argument is (a representation of) bottom. The
-``representation'' part is because we need to detect the bottom {\em function}
-too. To detect the bottom function, bind its args to top, and see if it
-returns bottom.
-
-Used only in strictness analysis:
-\begin{code}
-isBot :: AbsVal -> Bool
-
-isBot AbsBot = True
-isBot other = False -- Functions aren't bottom any more
-\end{code}
-
-Used only in absence analysis:
-
-\begin{code}
-anyBot :: AbsVal -> Bool
-
-anyBot AbsBot = True -- poisoned!
-anyBot AbsTop = False
-anyBot (AbsProd vals) = any anyBot vals
-anyBot (AbsFun bndr_ty abs_fn) = anyBot (abs_fn AbsTop)
-anyBot (AbsApproxFun _ val) = anyBot val
-\end{code}
-
-@widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is
-approximated by $val$. Furthermore, the result has no @AbsFun@s in
-it, so it can be compared for equality by @sameVal@.
-
-\begin{code}
-widen :: AnalysisKind -> AbsVal -> AbsVal
-
--- Widening is complicated by the fact that funtions are lifted
-widen StrAnal the_fn@(AbsFun bndr_ty _)
- = case widened_body of
- AbsApproxFun ds val -> AbsApproxFun (d : ds) val
- where
- d = findRecDemand str_fn abs_fn bndr_ty
- str_fn val = isBot (foldl (absApply StrAnal) the_fn
- (val : [AbsTop | d <- ds]))
-
- other -> AbsApproxFun [d] widened_body
- where
- d = findRecDemand str_fn abs_fn bndr_ty
- str_fn val = isBot (absApply StrAnal the_fn val)
- where
- widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop)
- abs_fn val = False -- Always says poison; so it looks as if
- -- nothing is absent; safe
-
-{- OLD comment...
- This stuff is now instead handled neatly by the fact that AbsApproxFun
- contains an AbsVal inside it. SLPJ Jan 97
-
- | isBot abs_body = AbsBot
- -- It's worth checking for a function which is unconditionally
- -- bottom. Consider
- --
- -- f x y = let g y = case x of ...
- -- in (g ..) + (g ..)
- --
- -- Here, when we are considering strictness of f in x, we'll
- -- evaluate the body of f with x bound to bottom. The current
- -- strategy is to bind g to its *widened* value; without the isBot
- -- (...) test above, we'd bind g to an AbsApproxFun, and deliver
- -- Top, not Bot as the value of f's rhs. The test spots the
- -- unconditional bottom-ness of g when x is bottom. (Another
- -- alternative here would be to bind g to its exact abstract
- -- value, but that entails lots of potential re-computation, at
- -- every application of g.)
--}
-
-widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
-widen StrAnal other_val = other_val
-
-
-widen AbsAnal the_fn@(AbsFun bndr_ty _)
- | anyBot widened_body = AbsBot
- -- In the absence-analysis case it's *essential* to check
- -- that the function has no poison in its body. If it does,
- -- anywhere, then the whole function is poisonous.
-
- | otherwise
- = case widened_body of
- AbsApproxFun ds val -> AbsApproxFun (d : ds) val
- where
- d = findRecDemand str_fn abs_fn bndr_ty
- abs_fn val = not (anyBot (foldl (absApply AbsAnal) the_fn
- (val : [AbsTop | d <- ds])))
-
- other -> AbsApproxFun [d] widened_body
- where
- d = findRecDemand str_fn abs_fn bndr_ty
- abs_fn val = not (anyBot (absApply AbsAnal the_fn val))
- where
- widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop)
- str_fn val = True -- Always says non-termination;
- -- that'll make findRecDemand peer into the
- -- structure of the value.
-
-widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
-
- -- It's desirable to do a good job of widening for product
- -- values. Consider
- --
- -- let p = (x,y)
- -- in ...(case p of (x,y) -> x)...
- --
- -- Now, is y absent in this expression? Currently the
- -- analyser widens p before looking at p's scope, to avoid
- -- lots of recomputation in the case where p is a function.
- -- So if widening doesn't have a case for products, we'll
- -- widen p to AbsBot (since when searching for absence in y we
- -- bind y to poison ie AbsBot), and now we are lost.
-
-widen AbsAnal other_val = other_val
-
--- WAS: if anyBot val then AbsBot else AbsTop
--- Nowadays widen is doing a better job on functions for absence analysis.
-\end{code}
-
-@crudeAbsWiden@ is used just for absence analysis, and always
-returns AbsTop or AbsBot, so it widens to a two-point domain
-
-\begin{code}
-crudeAbsWiden :: AbsVal -> AbsVal
-crudeAbsWiden val = if anyBot val then AbsBot else AbsTop
-\end{code}
-
-@sameVal@ compares two abstract values for equality. It can't deal with
-@AbsFun@, but that should have been removed earlier in the day by @widen@.
-
-\begin{code}
-sameVal :: AbsVal -> AbsVal -> Bool -- Can't handle AbsFun!
-
-#ifdef DEBUG
-sameVal (AbsFun _ _) _ = panic "sameVal: AbsFun: arg1"
-sameVal _ (AbsFun _ _) = panic "sameVal: AbsFun: arg2"
-#endif
-
-sameVal AbsBot AbsBot = True
-sameVal AbsBot other = False -- widen has reduced AbsFun bots to AbsBot
-
-sameVal AbsTop AbsTop = True
-sameVal AbsTop other = False -- Right?
-
-sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2)
-sameVal (AbsProd _) AbsTop = False
-sameVal (AbsProd _) AbsBot = False
-
-sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v2
-sameVal (AbsApproxFun _ _) AbsTop = False
-sameVal (AbsApproxFun _ _) AbsBot = False
-
-sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
-\end{code}
-
-
-@evalStrictness@ compares a @Demand@ with an abstract value, returning
-@True@ iff the abstract value is {\em less defined} than the demand.
-(@True@ is the exciting answer; @False@ is always safe.)
-
-\begin{code}
-evalStrictness :: Demand
- -> AbsVal
- -> Bool -- True iff the value is sure
- -- to be less defined than the Demand
-
-evalStrictness (WwLazy _) _ = False
-evalStrictness WwStrict val = isBot val
-evalStrictness WwEnum val = isBot val
-
-evalStrictness (WwUnpack _ demand_info) val
- = case val of
- AbsTop -> False
- AbsBot -> True
- AbsProd vals
- | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalStrictness" (ppr demand_info $$ ppr val)
- False
- | otherwise -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
-
- _ -> pprTrace "evalStrictness?" empty False
-
-evalStrictness WwPrim val
- = case val of
- AbsTop -> False
- AbsBot -> True -- Can happen: consider f (g x), where g is a
- -- recursive function returning an Int# that diverges
-
- other -> pprPanic "evalStrictness: WwPrim:" (ppr other)
-\end{code}
-
-For absence analysis, we're interested in whether "poison" in the
-argument (ie a bottom therein) can propagate to the result of the
-function call; that is, whether the specified demand can {\em
-possibly} hit poison.
-
-\begin{code}
-evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison
- -- with Absent demand
-
-evalAbsence (WwUnpack _ demand_info) val
- = case val of
- AbsTop -> False -- No poison in here
- AbsBot -> True -- Pure poison
- AbsProd vals
- | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalAbsence" (ppr demand_info $$ ppr val)
- True
- | otherwise -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
- _ -> pprTrace "TELL SIMON: evalAbsence"
- (ppr demand_info $$ ppr val)
- True
-
-evalAbsence other val = anyBot val
- -- The demand is conservative; even "Lazy" *might* evaluate the
- -- argument arbitrarily so we have to look everywhere for poison
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[absEval]{Evaluate an expression in the abstract domain}
-%* *
-%************************************************************************
-
-\begin{code}
--- The isBottomingId stuf is now dealt with via the Id's strictness info
--- absId anal var env | isBottomingId var
--- = case anal of
--- StrAnal -> AbsBot -- See discussion below
--- AbsAnal -> AbsTop -- Just want to see if there's any poison in
- -- error's arg
-
-absId anal var env
- = case (lookupAbsValEnv env var,
- isDataConWorkId_maybe var,
- idStrictness var,
- maybeUnfoldingTemplate (idUnfolding var)) of
-
- (Just abs_val, _, _, _) ->
- abs_val -- Bound in the environment
-
- (_, Just data_con, _, _) | isProductTyCon tycon &&
- not (isRecursiveTyCon tycon)
- -> -- A product. We get infinite loops if we don't
- -- check for recursive products!
- -- The strictness info on the constructor
- -- isn't expressive enough to contain its abstract value
- productAbsVal (dataConRepArgTys data_con) []
- where
- tycon = dataConTyCon data_con
-
- (_, _, NoStrictnessInfo, Just unfolding) ->
- -- We have an unfolding for the expr
- -- Assume the unfolding has no free variables since it
- -- came from inside the Id
- absEval anal unfolding env
- -- Notice here that we only look in the unfolding if we don't
- -- have strictness info (an unusual situation).
- -- We could have chosen to look in the unfolding if it exists,
- -- and only try the strictness info if it doesn't, and that would
- -- give more accurate results, at the cost of re-abstract-interpreting
- -- the unfolding every time.
- -- We found only one place where the look-at-unfolding-first
- -- method gave better results, which is in the definition of
- -- showInt in the Prelude. In its defintion, fromIntegral is
- -- not inlined (it's big) but ab-interp-ing its unfolding gave
- -- a better result than looking at its strictness only.
- -- showInt :: Integral a => a -> [Char] -> [Char]
- -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
- -- "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-}
- -- --- 42,44 ----
- -- showInt :: Integral a => a -> [Char] -> [Char]
- -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
- -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
-
-
- (_, _, strictness_info, _) ->
- -- Includes NoUnfolding
- -- Try the strictness info
- absValFromStrictness anal strictness_info
-
-productAbsVal [] rev_abs_args = AbsProd (reverse rev_abs_args)
-productAbsVal (arg_ty : arg_tys) rev_abs_args = AbsFun arg_ty (\ abs_arg -> productAbsVal arg_tys (abs_arg : rev_abs_args))
-\end{code}
-
-\begin{code}
-absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal
-
-absEval anal (Type ty) env = AbsTop
-absEval anal (Var var) env = absId anal var env
-\end{code}
-
-Discussion about error (following/quoting Lennart): Any expression
-'error e' is regarded as bottom (with HBC, with the -ffail-strict
-flag, on with -O).
-
-Regarding it as bottom gives much better strictness properties for
-some functions. E.g.
-
- f [x] y = x+y
- f (x:xs) y = f xs (x+y)
-i.e.
- f [] _ = error "no match"
- f [x] y = x+y
- f (x:xs) y = f xs (x+y)
-
-is strict in y, which you really want. But, it may lead to
-transformations that turn a call to \tr{error} into non-termination.
-(The odds of this happening aren't good.)
-
-Things are a little different for absence analysis, because we want
-to make sure that any poison (?????)
-
-\begin{code}
-absEval anal (Lit _) env = AbsTop
- -- Literals terminate (strictness) and are not poison (absence)
-\end{code}
-
-\begin{code}
-absEval anal (Lam bndr body) env
- | isTyVar bndr = absEval anal body env -- Type lambda
- | otherwise = AbsFun (idType bndr) abs_fn -- Value lambda
- where
- abs_fn arg = absEval anal body (addOneToAbsValEnv env bndr arg)
-
-absEval anal (App expr (Type ty)) env
- = absEval anal expr env -- Type appplication
-absEval anal (App f val_arg) env
- = absApply anal (absEval anal f env) -- Value applicationn
- (absEval anal val_arg env)
-\end{code}
-
-\begin{code}
-absEval anal expr@(Case scrut case_bndr alts) env
- = let
- scrut_val = absEval anal scrut env
- alts_env = addOneToAbsValEnv env case_bndr scrut_val
- in
- case (scrut_val, alts) of
- (AbsBot, _) -> AbsBot
-
- (AbsProd arg_vals, [(con, bndrs, rhs)])
- | con /= DEFAULT ->
- -- The scrutinee is a product value, so it must be of a single-constr
- -- type; so the constructor in this alternative must be the right one
- -- so we can go ahead and bind the constructor args to the components
- -- of the product value.
- ASSERT(equalLength arg_vals val_bndrs)
- absEval anal rhs rhs_env
- where
- val_bndrs = filter isId bndrs
- rhs_env = growAbsValEnvList alts_env (val_bndrs `zip` arg_vals)
-
- other -> absEvalAlts anal alts alts_env
-\end{code}
-
-For @Lets@ we widen the value we get. This is nothing to
-do with fixpointing. The reason is so that we don't get an explosion
-in the amount of computation. For example, consider:
-\begin{verbatim}
- let
- g a = case a of
- q1 -> ...
- q2 -> ...
- f x = case x of
- p1 -> ...g r...
- p2 -> ...g s...
- in
- f e
-\end{verbatim}
-If we bind @f@ and @g@ to their exact abstract value, then we'll
-``execute'' one call to @f@ and {\em two} calls to @g@. This can blow
-up exponentially. Widening cuts it off by making a fixed
-approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are
-not evaluated again at all when they are called.
-
-Of course, this can lose useful joint strictness, which is sad. An
-alternative approach would be to try with a certain amount of ``fuel''
-and be prepared to bale out.
-
-\begin{code}
-absEval anal (Let (NonRec binder e1) e2) env
- = let
- new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env))
- in
- -- The binder of a NonRec should *not* be of unboxed type,
- -- hence no need to strictly evaluate the Rhs.
- absEval anal e2 new_env
-
-absEval anal (Let (Rec pairs) body) env
- = let
- (binders,rhss) = unzip pairs
- rhs_vals = cheapFixpoint anal binders rhss env -- Returns widened values
- new_env = growAbsValEnvList env (binders `zip` rhs_vals)
- in
- absEval anal body new_env
-
-absEval anal (Note (Coerce _ _) expr) env = AbsTop
- -- Don't look inside coerces, becuase they
- -- are usually recursive newtypes
- -- (Could improve, for the error case, but we're about
- -- to kill this analyser anyway.)
-absEval anal (Note note expr) env = absEval anal expr env
-\end{code}
-
-\begin{code}
-absEvalAlts :: AnalysisKind -> [CoreAlt] -> AbsValEnv -> AbsVal
-absEvalAlts anal alts env
- = combine anal (map go alts)
- where
- combine StrAnal = foldr1 lub -- Diverge only if all diverge
- combine AbsAnal = foldr1 glb -- Find any poison
-
- go (con, bndrs, rhs)
- = absEval anal rhs rhs_env
- where
- rhs_env = growAbsValEnvList env (filter isId bndrs `zip` repeat AbsTop)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[absApply]{Apply an abstract function to an abstract argument}
-%* *
-%************************************************************************
-
-Easy ones first:
-
-\begin{code}
-absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal
-
-absApply anal AbsBot arg = AbsBot
- -- AbsBot represents the abstract bottom *function* too
-
-absApply StrAnal AbsTop arg = AbsTop
-absApply AbsAnal AbsTop arg = if anyBot arg
- then AbsBot
- else AbsTop
- -- To be conservative, we have to assume that a function about
- -- which we know nothing (AbsTop) might look at some part of
- -- its argument
-\end{code}
-
-An @AbsFun@ with only one more argument needed---bind it and eval the
-result. A @Lam@ with two or more args: return another @AbsFun@ with
-an augmented environment.
-
-\begin{code}
-absApply anal (AbsFun bndr_ty abs_fn) arg = abs_fn arg
-\end{code}
-
-\begin{code}
-absApply StrAnal (AbsApproxFun (d:ds) val) arg
- = case ds of
- [] -> val'
- other -> AbsApproxFun ds val' -- Result is non-bot if there are still args
- where
- val' | evalStrictness d arg = AbsBot
- | otherwise = val
-
-absApply AbsAnal (AbsApproxFun (d:ds) val) arg
- = if evalAbsence d arg
- then AbsBot -- Poison in arg means poison in the application
- else case ds of
- [] -> val
- other -> AbsApproxFun ds val
-
-#ifdef DEBUG
-absApply anal f@(AbsProd _) arg
- = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
-#endif
-\end{code}
-
-
-
-
-%************************************************************************
-%* *
-\subsection[findStrictness]{Determine some binders' strictness}
-%* *
-%************************************************************************
-
-\begin{code}
-findStrictness :: Id
- -> AbsVal -- Abstract strictness value of function
- -> AbsVal -- Abstract absence value of function
- -> StrictnessInfo -- Resulting strictness annotation
-
-findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _)
- -- You might think there's really no point in describing detailed
- -- strictness for a divergent function;
- -- If it's fully applied we get bottom regardless of the
- -- argument. If it's not fully applied we don't get bottom.
- -- Finally, we don't want to regard the args of a divergent function
- -- as 'interesting' for inlining purposes (see Simplify.prepareArgs)
- --
- -- HOWEVER, if we make diverging functions appear lazy, they
- -- don't get wrappers, and then we get dreadful reboxing.
- -- See notes with WwLib.worthSplitting
- = find_strictness id str_ds str_res abs_ds
-
-findStrictness id str_val abs_val
- | isBot str_val = mkStrictnessInfo ([], True)
- | otherwise = NoStrictnessInfo
-
--- The list of absence demands passed to combineDemands
--- can be shorter than the list of absence demands
---
--- lookup = \ dEq -> letrec {
--- lookup = \ key ds -> ...lookup...
--- }
--- in lookup
--- Here the strictness value takes three args, but the absence value
--- takes only one, for reasons I don't quite understand (see cheapFixpoint)
-
-find_strictness id orig_str_ds orig_str_res orig_abs_ds
- = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot)
- where
- res_bot = isBot orig_str_res
-
- go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy)
-
- mk_dmd str_dmd (WwLazy True)
- = WARN( not (res_bot || isLazy str_dmd),
- ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds )
- -- If the arg isn't used we jolly well don't expect the function
- -- to be strict in it. Unless the function diverges.
- WwLazy True -- Best of all
-
- mk_dmd (WwUnpack u str_ds)
- (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds)
-
- mk_dmd str_dmd abs_dmd = str_dmd
-\end{code}
-
-
-\begin{code}
-findDemand dmd str_env abs_env expr binder
- = findRecDemand str_fn abs_fn (idType binder)
- where
- str_fn val = evalStrictness dmd (absEval StrAnal expr (addOneToAbsValEnv str_env binder val))
- abs_fn val = not (evalAbsence dmd (absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)))
-
-findDemandAlts dmd str_env abs_env alts binder
- = findRecDemand str_fn abs_fn (idType binder)
- where
- str_fn val = evalStrictness dmd (absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val))
- abs_fn val = not (evalAbsence dmd (absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val)))
-\end{code}
-
-@findRecDemand@ is where we finally convert strictness/absence info
-into ``Demands'' which we can pin on Ids (etc.).
-
-NOTE: What do we do if something is {\em both} strict and absent?
-Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all
-strict (because of bottoming effect of \tr{error}) or all absent
-(because they're not used)?
-
-Well, for practical reasons, we prefer absence over strictness. In
-particular, it makes the ``default defaults'' for class methods (the
-ones that say \tr{defm.foo dict = error "I don't exist"}) come out
-nicely [saying ``the dict isn't used''], rather than saying it is
-strict in every component of the dictionary [massive gratuitious
-casing to take the dict apart].
-
-But you could have examples where going for strictness would be better
-than absence. Consider:
-\begin{verbatim}
- let x = something big
- in
- f x y z + g x
-\end{verbatim}
-
-If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is
-lazy, then the thunk for \tr{x} will be built. If \tr{f} was strict,
-then we'd let-to-case it:
-\begin{verbatim}
- case something big of
- x -> f x y z + g x
-\end{verbatim}
-Ho hum.
-
-\begin{code}
-findRecDemand :: (AbsVal -> Bool) -- True => function applied to this value yields Bot
- -> (AbsVal -> Bool) -- True => function applied to this value yields no poison
- -> Type -- The type of the argument
- -> Demand
-
-findRecDemand str_fn abs_fn ty
- = if isUnLiftedType ty then -- It's a primitive type!
- wwPrim
-
- else if abs_fn AbsBot then -- It's absent
- -- We prefer absence over strictness: see NOTE above.
- WwLazy True
-
- else if not (opt_AllStrict ||
- (opt_NumbersStrict && is_numeric_type ty) ||
- str_fn AbsBot) then
- WwLazy False -- It's not strict and we're not pretending
-
- else -- It's strict (or we're pretending it is)!
-
- case splitProductType_maybe ty of
-
- Nothing -> wwStrict -- Could have a test for wwEnum, but
- -- we don't exploit it yet, so don't bother
-
- Just (tycon,_,data_con,cmpnt_tys) -- Single constructor case
- | isRecursiveTyCon tycon -- Recursive data type; don't unpack
- -> wwStrict -- (this applies to newtypes too:
- -- e.g. data Void = MkVoid Void)
-
- | null compt_strict_infos -- A nullary data type
- -> wwStrict
-
- | otherwise -- Some other data type
- -> wwUnpack compt_strict_infos
-
- where
- prod_len = length cmpnt_tys
- compt_strict_infos
- = [ findRecDemand
- (\ cmpnt_val ->
- str_fn (mkMainlyTopProd prod_len i cmpnt_val)
- )
- (\ cmpnt_val ->
- abs_fn (mkMainlyTopProd prod_len i cmpnt_val)
- )
- cmpnt_ty
- | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
-
- where
- is_numeric_type ty
- = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above
- Nothing -> False
- Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys
- where
- is_elem = isIn "is_numeric_type"
-
- -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of
- -- them) except for a given value in the "i"th position.
-
- mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal
-
- mkMainlyTopProd n i val
- = let
- befores = nOfThem (i-1) AbsTop
- afters = nOfThem (n-i) AbsTop
- in
- AbsProd (befores ++ (val : afters))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[fixpoint]{Fixpointer for the strictness analyser}
-%* *
-%************************************************************************
-
-The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an
-environment, and returns the abstract value of each binder.
-
-The @cheapFixpoint@ function makes a conservative approximation,
-by binding each of the variables to Top in their own right hand sides.
-That allows us to make rapid progress, at the cost of a less-than-wonderful
-approximation.
-
-\begin{code}
-cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
-
-cheapFixpoint AbsAnal [id] [rhs] env
- = [crudeAbsWiden (absEval AbsAnal rhs new_env)]
- where
- new_env = addOneToAbsValEnv env id AbsTop -- Unsafe starting point!
- -- In the just-one-binding case, we guarantee to
- -- find a fixed point in just one iteration,
- -- because we are using only a two-point domain.
- -- This improves matters in cases like:
- --
- -- f x y = letrec g = ...g...
- -- in g x
- --
- -- Here, y isn't used at all, but if g is bound to
- -- AbsBot we simply get AbsBot as the next
- -- iteration too.
-
-cheapFixpoint anal ids rhss env
- = [widen anal (absEval anal rhs new_env) | rhs <- rhss]
- -- We do just one iteration, starting from a safe
- -- approximation. This won't do a good job in situations
- -- like:
- -- \x -> letrec f = ...g...
- -- g = ...f...x...
- -- in
- -- ...f...
- -- Here, f will end up bound to Top after one iteration,
- -- and hence we won't spot the strictness in x.
- -- (A second iteration would solve this. ToDo: try the effect of
- -- really searching for a fixed point.)
- where
- new_env = growAbsValEnvList env [(id,safe_val) | id <- ids]
-
- safe_val
- = case anal of -- The safe starting point
- StrAnal -> AbsTop
- AbsAnal -> AbsBot
-\end{code}
-
-\begin{code}
-fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
-
-fixpoint anal [] _ env = []
-
-fixpoint anal ids rhss env
- = fix_loop initial_vals
- where
- initial_val id
- = case anal of -- The (unsafe) starting point
- AbsAnal -> AbsTop
- StrAnal -> AbsBot
- -- At one stage for StrAnal we said:
- -- if (returnsRealWorld (idType id))
- -- then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
- -- but no one has the foggiest idea what this hack did,
- -- and returnsRealWorld was a stub that always returned False
- -- So this comment is all that is left of the hack!
-
- initial_vals = [ initial_val id | id <- ids ]
-
- fix_loop :: [AbsVal] -> [AbsVal]
-
- fix_loop current_widened_vals
- = let
- new_env = growAbsValEnvList env (ids `zip` current_widened_vals)
- new_vals = [ absEval anal rhs new_env | rhs <- rhss ]
- new_widened_vals = map (widen anal) new_vals
- in
- if (and (zipWith sameVal current_widened_vals new_widened_vals)) then
- current_widened_vals
-
- -- NB: I was too chicken to make that a zipWithEqual,
- -- lest I jump into a black hole. WDP 96/02
-
- -- Return the widened values. We might get a slightly
- -- better value by returning new_vals (which we used to
- -- do, see below), but alas that means that whenever the
- -- function is called we have to re-execute it, which is
- -- expensive.
-
- -- OLD VERSION
- -- new_vals
- -- Return the un-widened values which may be a bit better
- -- than the widened ones, and are guaranteed safe, since
- -- they are one iteration beyond current_widened_vals,
- -- which itself is a fixed point.
- else
- fix_loop new_widened_vals
-\end{code}
-
-For absence analysis, we make do with a very very simple approach:
-look for convergence in a two-point domain.
-
-We used to use just one iteration, starting with the variables bound
-to @AbsBot@, which is safe.
-
-Prior to that, we used one iteration starting from @AbsTop@ (which
-isn't safe). Why isn't @AbsTop@ safe? Consider:
-\begin{verbatim}
- letrec
- x = ...p..d...
- d = (x,y)
- in
- ...
-\end{verbatim}
-Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed
-point'' of @d@ being @(AbsTop, AbsTop)@! An @AbsBot@ initial value is
-safe because it gives poison more often than really necessary, and
-thus may miss some absence, but will never claim absence when it ain't
-so.
-
-Anyway, one iteration starting with everything bound to @AbsBot@ give
-bad results for
-
- f = \ x -> ...f...
-
-Here, f would always end up bound to @AbsBot@, which ain't very
-clever, because then it would introduce poison whenever it was
-applied. Much better to start with f bound to @AbsTop@, and widen it
-to @AbsBot@ if any poison shows up. In effect we look for convergence
-in the two-point @AbsTop@/@AbsBot@ domain.
-
-What we miss (compared with the cleverer strictness analysis) is
-spotting that in this case
-
- f = \ x y -> ...y...(f x y')...
-
-\tr{x} is actually absent, since it is only passed round the loop, never
-used. But who cares about missing that?
-
-NB: despite only having a two-point domain, we may still have many
-iterations, because there are several variables involved at once.
-
-\begin{code}
-#endif /* OLD_STRICTNESS */
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section[SaLib]{Basic datatypes, functions for the strictness analyser}
-
-See also: the ``library'' for the ``back end'' (@SaBackLib@).
-
-\begin{code}
-{-# OPTIONS -w #-}
--- 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
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-#ifndef OLD_STRICTNESS
-module SaLib () where
-#else
-
-module SaLib (
- AbsVal(..),
- AnalysisKind(..),
- AbsValEnv{-abstract-}, StrictEnv, AbsenceEnv,
- mkAbsApproxFun,
- nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList,
- lookupAbsValEnv,
- absValFromStrictness
- ) where
-
-#include "HsVersions.h"
-
-import Type ( Type )
-import VarEnv
-import IdInfo ( StrictnessInfo(..) )
-import Demand ( Demand )
-import Outputable
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsVal-datatype]{@AbsVal@: abstract values (and @AbsValEnv@)}
-%* *
-%************************************************************************
-
-@AnalysisKind@ tells what kind of analysis is being done.
-
-\begin{code}
-data AnalysisKind
- = StrAnal -- We're doing strictness analysis
- | AbsAnal -- We're doing absence analysis
- deriving Show
-\end{code}
-
-@AbsVal@ is the data type of HNF abstract values.
-
-\begin{code}
-data AbsVal
- = AbsTop -- AbsTop is the completely uninformative
- -- value
-
- | AbsBot -- An expression whose abstract value is
- -- AbsBot is sure to fail to terminate.
- -- AbsBot represents the abstract
- -- *function* bottom too.
-
- | AbsProd [AbsVal] -- (Lifted) product of abstract values
- -- "Lifted" means that AbsBot is *different* from
- -- AbsProd [AbsBot, ..., AbsBot]
-
- | AbsFun -- An abstract function, with the given:
- Type -- Type of the *argument* to the function
- (AbsVal -> AbsVal) -- The function
-
- | AbsApproxFun -- This is used to represent a coarse
- [Demand] -- approximation to a function value. It's an
- AbsVal -- abstract function which is strict in its
- -- arguments if the Demand so indicates.
- -- INVARIANT: the [Demand] is non-empty
-
- -- AbsApproxFun has to take a *list* of demands, no just one,
- -- because function spaces are now lifted. Hence, (f bot top)
- -- might be bot, but the partial application (f bot) is a *function*,
- -- not bot.
-
-mkAbsApproxFun :: Demand -> AbsVal -> AbsVal
-mkAbsApproxFun d (AbsApproxFun ds val) = AbsApproxFun (d:ds) val
-mkAbsApproxFun d val = AbsApproxFun [d] val
-
-instance Outputable AbsVal where
- ppr AbsTop = ptext (sLit "AbsTop")
- ppr AbsBot = ptext (sLit "AbsBot")
- ppr (AbsProd prod) = hsep [ptext (sLit "AbsProd"), ppr prod]
- ppr (AbsFun bndr_ty body) = ptext (sLit "AbsFun")
- ppr (AbsApproxFun demands val)
- = ptext (sLit "AbsApprox") <+> brackets (interpp'SP demands) <+> ppr val
-\end{code}
-
-%-----------
-
-An @AbsValEnv@ maps @Ids@ to @AbsVals@. Any unbound @Ids@ are
-implicitly bound to @AbsTop@, the completely uninformative,
-pessimistic value---see @absEval@ of a @Var@.
-
-\begin{code}
-newtype AbsValEnv = AbsValEnv (IdEnv AbsVal)
-
-type StrictEnv = AbsValEnv -- Environment for strictness analysis
-type AbsenceEnv = AbsValEnv -- Environment for absence analysis
-
-nullAbsValEnv -- this is the one and only way to create AbsValEnvs
- = AbsValEnv emptyVarEnv
-
-addOneToAbsValEnv (AbsValEnv idenv) y z = AbsValEnv (extendVarEnv idenv y z)
-growAbsValEnvList (AbsValEnv idenv) ys = AbsValEnv (extendVarEnvList idenv ys)
-
-lookupAbsValEnv (AbsValEnv idenv) y
- = lookupVarEnv idenv y
-\end{code}
-
-\begin{code}
-absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
-
-absValFromStrictness anal NoStrictnessInfo = AbsTop
-absValFromStrictness anal (StrictnessInfo args_info bot_result)
- = case args_info of -- Check the invariant that the arg list on
- [] -> res -- AbsApproxFun is non-empty
- _ -> AbsApproxFun args_info res
- where
- res | not bot_result = AbsTop
- | otherwise = case anal of
- StrAnal -> AbsBot
- AbsAnal -> AbsTop
-\end{code}
-
-\begin{code}
-#endif /* OLD_STRICTNESS */
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
-
-The original version(s) of all strictness-analyser code (except the
-Semantique analyser) was written by Andy Gill.
-
-\begin{code}
-{-# OPTIONS -w #-}
--- 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
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-#ifndef OLD_STRICTNESS
-module StrictAnal ( ) where
-
-#else
-
-module StrictAnal ( saBinds ) where
-
-#include "HsVersions.h"
-
-import DynFlags ( DynFlags, DynFlag(..) )
-import CoreSyn
-import Id ( setIdStrictness, setInlinePragma,
- idDemandInfo, setIdDemandInfo, isBottomingId,
- Id
- )
-import ErrUtils ( dumpIfSet_dyn )
-import SaAbsInt
-import SaLib
-import Demand ( Demand, wwStrict, isStrict, isLazy )
-import Util ( zipWith3Equal, stretchZipWith, compareLength )
-import BasicTypes ( Activation( NeverActive ) )
-import Outputable
-import FastTypes
-import State
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Thoughts]{Random thoughts}
-%* *
-%************************************************************************
-
-A note about worker-wrappering. If we have
-
- f :: Int -> Int
- f = let v = <expensive>
- in \x -> <body>
-
-and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
-
- f = \x -> case x of Int x# -> fw x#
- fw = \x# -> let x = Int x#
- in
- let v = <expensive>
- in <body>
-
-because this obviously loses laziness, since now <expensive>
-is done each time. Alas.
-
-WATCH OUT! This can mean that something is unboxed only to be
-boxed again. For example
-
- g x y = f x
-
-Here g is strict, and *will* split into worker-wrapper. A call to
-g, with the wrapper inlined will then be
-
- case arg of Int a# -> gw a#
-
-Now g calls f, which has no wrapper, so it has to box it.
-
- gw = \a# -> f (Int a#)
-
-Alas and alack.
-
-
-%************************************************************************
-%* *
-\subsection[iface-StrictAnal]{Interface to the outside world}
-%* *
-%************************************************************************
-
-@saBinds@ decorates bindings with strictness info. A later
-worker-wrapper pass can use this info to create wrappers and
-strict workers.
-
-\begin{code}
-saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
-saBinds dflags binds
- = do {
- -- Mark each binder with its strictness
-#ifndef OMIT_STRANAL_STATS
- let { (binds_w_strictness, sa_stats) = runState $ (saTopBinds binds) nullSaStats };
- dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
- (pp_stats sa_stats);
-#else
- let { binds_w_strictness = unSaM $ saTopBindsBinds binds };
-#endif
-
- return binds_w_strictness
- }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[saBinds]{Strictness analysis of bindings}
-%* *
-%************************************************************************
-
-[Some of the documentation about types, etc., in \tr{SaLib} may be
-helpful for understanding this module.]
-
-@saTopBinds@ tags each binder in the program with its @Demand@.
-That tells how each binder is {\em used}; if @Strict@, then the binder
-is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
-if @Absent@, then it certainly is not used. [DATED; ToDo: update]
-
-(The above info is actually recorded for posterity in each binder's
-IdInfo, notably its @DemandInfo@.)
-
-We proceed by analysing the bindings top-to-bottom, building up an
-environment which maps @Id@s to their abstract values (i.e., an
-@AbsValEnv@ maps an @Id@ to its @AbsVal@).
-
-\begin{code}
-saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
-
-saTopBinds binds
- = let
- starting_abs_env = nullAbsValEnv
- in
- do_it starting_abs_env starting_abs_env binds
- where
- do_it _ _ [] = return []
- do_it senv aenv (b:bs) = do
- (senv2, aenv2, new_b) <- saTopBind senv aenv b
- new_bs <- do_it senv2 aenv2 bs
- return (new_b : new_bs)
-\end{code}
-
-@saTopBind@ is only used for the top level. We don't add any demand
-info to these ids because we can't work it out. In any case, it
-doesn't do us any good to know whether top-level binders are sure to
-be used; we can't turn top-level @let@s into @case@s.
-
-\begin{code}
-saTopBind :: StrictEnv -> AbsenceEnv
- -> CoreBind
- -> SaM (StrictEnv, AbsenceEnv, CoreBind)
-
-saTopBind str_env abs_env (NonRec binder rhs) = do
- new_rhs <- saExpr minDemand str_env abs_env rhs
- let
- str_rhs = absEval StrAnal rhs str_env
- abs_rhs = absEval AbsAnal rhs abs_env
-
- widened_str_rhs = widen StrAnal str_rhs
- widened_abs_rhs = widen AbsAnal abs_rhs
- -- The widening above is done for efficiency reasons.
- -- See notes on Let case in SaAbsInt.lhs
-
- new_binder
- = addStrictnessInfoToTopId
- widened_str_rhs widened_abs_rhs
- binder
-
- -- Augment environments with a mapping of the
- -- binder to its abstract values, computed by absEval
- new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
- new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
-
- return (new_str_env, new_abs_env, NonRec new_binder new_rhs)
-
-saTopBind str_env abs_env (Rec pairs)
- = let
- (binders,rhss) = unzip pairs
- str_rhss = fixpoint StrAnal binders rhss str_env
- abs_rhss = fixpoint AbsAnal binders rhss abs_env
- -- fixpoint returns widened values
- new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
- new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
- new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId
- str_rhss abs_rhss binders
-
- new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss
- let
- new_pairs = new_binders `zip` new_rhss
-
- return (new_str_env, new_abs_env, Rec new_pairs)
-
--- Hack alert!
--- Top level divergent bindings are marked NOINLINE
--- This avoids fruitless inlining of top level error functions
-addStrictnessInfoToTopId str_val abs_val bndr
- = if isBottomingId new_id then
- new_id `setInlinePragma` NeverActive
- else
- new_id
- where
- new_id = addStrictnessInfoToId str_val abs_val bndr
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[saExpr]{Strictness analysis of an expression}
-%* *
-%************************************************************************
-
-@saExpr@ computes the strictness of an expression within a given
-environment.
-
-\begin{code}
-saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
- -- The demand is the least demand we expect on the
- -- expression. WwStrict is the least, because we're only
- -- interested in the expression at all if it's being evaluated,
- -- but the demand may be more. E.g.
- -- f E
- -- where f has strictness u(LL), will evaluate E with demand u(LL)
-
-minDemand = wwStrict
-minDemands = repeat minDemand
-
--- When we find an application, do the arguments
--- with demands gotten from the function
-saApp str_env abs_env (fun, args) = do
- args' <- sequence sa_args
- fun' <- saExpr minDemand str_env abs_env fun
- return (mkApps fun' args')
- where
- arg_dmds = case fun of
- Var var -> case lookupAbsValEnv str_env var of
- Just (AbsApproxFun ds _)
- | compareLength ds args /= LT
- -- 'ds' is at least as long as 'args'.
- -> ds ++ minDemands
- other -> minDemands
- other -> minDemands
-
- sa_args = stretchZipWith isTypeArg (error "saApp:dmd")
- sa_arg args arg_dmds
- -- The arg_dmds are for value args only, we need to skip
- -- over the type args when pairing up with the demands
- -- Hence the stretchZipWith
-
- sa_arg arg dmd = saExpr dmd' str_env abs_env arg
- where
- -- Bring arg demand up to minDemand
- dmd' | isLazy dmd = minDemand
- | otherwise = dmd
-
-saExpr _ _ _ e@(Var _) = return e
-saExpr _ _ _ e@(Lit _) = return e
-saExpr _ _ _ e@(Type _) = return e
-
-saExpr dmd str_env abs_env (Lam bndr body)
- = do -- Don't bother to set the demand-info on a lambda binder
- -- We do that only for let(rec)-bound functions
- new_body <- saExpr minDemand str_env abs_env body
- return (Lam bndr new_body)
-
-saExpr dmd str_env abs_env e@(App fun arg)
- = saApp str_env abs_env (collectArgs e)
-
-saExpr dmd str_env abs_env (Note note expr) = do
- new_expr <- saExpr dmd str_env abs_env expr
- return (Note note new_expr)
-
-saExpr dmd str_env abs_env (Case expr case_bndr alts) = do
- new_expr <- saExpr minDemand str_env abs_env expr
- new_alts <- mapM sa_alt alts
- let
- new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
- return (Case new_expr new_case_bndr new_alts)
- where
- sa_alt (con, binders, rhs) = do
- new_rhs <- saExpr dmd str_env abs_env rhs
- let
- new_binders = map add_demand_info binders
- add_demand_info bndr | isTyVar bndr = bndr
- | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr
-
- tickCases new_binders -- stats
- return (con, new_binders, new_rhs)
-
-saExpr dmd str_env abs_env (Let (NonRec binder rhs) body) = do
- -- Analyse the RHS in the environment at hand
- let
- -- Find the demand on the RHS
- rhs_dmd = findDemand dmd str_env abs_env body binder
-
- -- Bind this binder to the abstract value of the RHS; analyse
- -- the body of the `let' in the extended environment.
- str_rhs_val = absEval StrAnal rhs str_env
- abs_rhs_val = absEval AbsAnal rhs abs_env
-
- widened_str_rhs = widen StrAnal str_rhs_val
- widened_abs_rhs = widen AbsAnal abs_rhs_val
- -- The widening above is done for efficiency reasons.
- -- See notes on Let case in SaAbsInt.lhs
-
- new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
- new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
-
- -- Now determine the strictness of this binder; use that info
- -- to record DemandInfo/StrictnessInfo in the binder.
- new_binder = addStrictnessInfoToId
- widened_str_rhs widened_abs_rhs
- (binder `setIdDemandInfo` rhs_dmd)
-
- tickLet new_binder -- stats
- new_rhs <- saExpr rhs_dmd str_env abs_env rhs
- new_body <- saExpr dmd new_str_env new_abs_env body
- return (Let (NonRec new_binder new_rhs) new_body)
-
-saExpr dmd str_env abs_env (Let (Rec pairs) body) = do
- let
- (binders,rhss) = unzip pairs
- str_vals = fixpoint StrAnal binders rhss str_env
- abs_vals = fixpoint AbsAnal binders rhss abs_env
- -- fixpoint returns widened values
- new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
- new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
-
- new_body <- saExpr dmd new_str_env new_abs_env body
- new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss
- let
--- DON'T add demand info in a Rec!
--- a) it's useless: we can't do let-to-case
--- b) it's incorrect. Consider
--- letrec x = ...y...
--- y = ...x...
--- in ...x...
--- When we ask whether y is demanded we'll bind y to bottom and
--- evaluate the body of the letrec. But that will result in our
--- deciding that y is absent, which is plain wrong!
--- It's much easier simply not to do this.
-
- improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
- str_vals abs_vals binders
-
- new_pairs = improved_binders `zip` new_rhss
-
- return (Let (Rec new_pairs) new_body)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[computeInfos]{Add computed info to binders}
-%* *
-%************************************************************************
-
-Important note (Sept 93). @addStrictnessInfoToId@ is used only for
-let(rec) bound variables, and is use to attach the strictness (not
-demand) info to the binder. We are careful to restrict this
-strictness info to the lambda-bound arguments which are actually
-visible, at the top level, lest we accidentally lose laziness by
-eagerly looking for an "extra" argument. So we "dig for lambdas" in a
-rather syntactic way.
-
-A better idea might be to have some kind of arity analysis to
-tell how many args could safely be grabbed.
-
-\begin{code}
-addStrictnessInfoToId
- :: AbsVal -- Abstract strictness value
- -> AbsVal -- Ditto absence
- -> Id -- The id
- -> Id -- Augmented with strictness
-
-addStrictnessInfoToId str_val abs_val binder
- = binder `setIdStrictness` findStrictness binder str_val abs_val
-\end{code}
-
-\begin{code}
-addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
- -> CoreExpr -- The scope of the id
- -> Id
- -> Id -- Id augmented with Demand info
-
-addDemandInfoToId dmd str_env abs_env expr binder
- = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
-
-addDemandInfoToCaseBndr dmd str_env abs_env alts binder
- = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Monad used herein for stats}
-%* *
-%************************************************************************
-
-\begin{code}
-data SaStats
- = SaStats FastInt FastInt -- total/marked-demanded lambda-bound
- FastInt FastInt -- total/marked-demanded case-bound
- FastInt FastInt -- total/marked-demanded let-bound
- -- (excl. top-level; excl. letrecs)
-
-nullSaStats = SaStats
- (_ILIT(0)) (_ILIT(0))
- (_ILIT(0)) (_ILIT(0))
- (_ILIT(0)) (_ILIT(0))
-
-tickLambda :: Id -> SaM ()
-tickCases :: [CoreBndr] -> SaM ()
-tickLet :: Id -> SaM ()
-
-#ifndef OMIT_STRANAL_STATS
-type SaM a = State SaStats a
-
-tickLambda var = modify $ \(SaStats tlam dlam tc dc tlet dlet)
- -> case (tick_demanded var (0,0)) of { (totB, demandedB) ->
- let tot = iUnbox totB ; demanded = iUnbox demandedB
- in SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet)
-
-tickCases vars = modify $ \(SaStats tlam dlam tc dc tlet dlet)
- = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
- let tot = iUnbox totB ; demanded = iUnbox demandedB
- in SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet)
-
-tickLet var = modify $ \(SaStats tlam dlam tc dc tlet dlet)
- = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
- let tot = iUnbox totB ; demanded = iUnbox demandedB
- in SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded))
-
-tick_demanded var (tot, demanded)
- | isTyVar var = (tot, demanded)
- | otherwise
- = (tot + 1,
- if (isStrict (idDemandInfo var))
- then demanded + 1
- else demanded)
-
-pp_stats (SaStats tlam dlam tc dc tlet dlet)
- = hcat [ptext (sLit "Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
- ptext (sLit "; Case vars: "), int (iBox dc), char '/', int (iBox tc),
- ptext (sLit "; Let vars: "), int (iBox dlet), char '/', int (iBox tlet)
- ]
-
-#else /* OMIT_STRANAL_STATS */
--- identity monad
-newtype SaM a = SaM { unSaM :: a }
-
-instance Monad SaM where
- return x = SaM x
- SaM x >>= f = f x
-
-tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
-tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
-tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
-
-#endif /* OMIT_STRANAL_STATS */
-
-#endif /* OLD_STRICTNESS */
-\end{code}
import CoreArity ( exprArity )
import Var
import Id ( idType, isOneShotLambda, idUnfolding,
- setIdNewStrictness, mkWorkerId,
+ setIdStrictness, mkWorkerId,
setInlineActivation, setIdUnfolding,
setIdArity )
import Type ( Type )
import IdInfo
-import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
+import Demand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
)
import UniqSupply
where
fn_info = idInfo fn_id
- maybe_fn_dmd = newDemandInfo fn_info
+ maybe_fn_dmd = demandInfo fn_info
inline_act = inlinePragmaActivation (inlinePragInfo fn_info)
-- In practice it always will have a strictness
-- signature, even if it's a uninformative one
- strict_sig = newStrictnessInfo fn_info `orElse` topSig
+ strict_sig = strictnessInfo fn_info `orElse` topSig
StrictSig (DmdType env wrap_dmds res_info) = strict_sig
-- new_fn_id has the DmdEnv zapped.
-- (c) it becomes incorrect as things are cloned, because
-- we don't push the substitution into it
new_fn_id | isEmptyVarEnv env = fn_id
- | otherwise = fn_id `setIdNewStrictness`
+ | otherwise = fn_id `setIdStrictness`
StrictSig (mkTopDmdType wrap_dmds res_info)
is_fun = notNull wrap_dmds
-- can't think of a compelling reason. (In ptic, INLINE things are
-- not w/wd). However, the RuleMatchInfo is not transferred since
-- it does not make sense for workers to be constructorlike.
- `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
+ `setIdStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
-- Even though we may not be at top level,
-- it's ok to give it an empty DmdEnv
`setIdArity` (exprArity work_rhs)
import CoreSyn
import CoreUtils ( exprType )
-import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo,
+import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
isOneShotLambda, setOneShotLambda, setIdUnfolding,
setIdInfo
)
import IdInfo ( vanillaIdInfo )
import DataCon
-import NewDemand ( Demand(..), DmdResult(..), Demands(..) )
+import Demand ( Demand(..), DmdResult(..), Demands(..) )
import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID,
mkUnpackCase, mkProductBox )
import TysWiredIn ( tupleCon )
return (id, id, res_ty)
; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty
- ; return ([idNewDemandInfo v | v <- work_call_args, isId v],
+ ; return ([idDemandInfo v | v <- work_call_args, isId v],
wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) }
-- We use an INLINE unconditionally, even if the wrapper turns out to be
applyToVars :: [Var] -> CoreExpr -> CoreExpr
applyToVars vars fn = mkVarApps fn vars
-mk_wrap_arg :: Unique -> Type -> NewDemand.Demand -> Bool -> Id
+mk_wrap_arg :: Unique -> Type -> Demand -> Bool -> Id
mk_wrap_arg uniq ty dmd one_shot
- = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd)
+ = set_one_shot one_shot (setIdDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd)
where
set_one_shot True id = setOneShotLambda id
set_one_shot False id = id
= return ([arg], nop_fn, nop_fn)
| otherwise
- = case idNewDemandInfo arg of
+ = case idDemandInfo arg of
-- Absent case. We don't deal with absence for unlifted types,
-- though, because it's not so easy to manufacture a placeholder
-- If the wrapper argument is a one-shot lambda, then
-- so should (all) the corresponding worker arguments be
-- This bites when we do w/w on a case join point
- set_worker_arg_info worker_arg demand = set_one_shot (setIdNewDemandInfo worker_arg demand)
+ set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand)
set_one_shot | isOneShotLambda arg = setOneShotLambda
| otherwise = \x -> x
projects / ghc-hetmet.git / commitdiff