Commit d8af6b8c authored by simonpj's avatar simonpj
Browse files

[project @ 2001-11-19 14:23:52 by simonpj]

--------------------------------------
	Yet another cut at the DmdAnal domains
	--------------------------------------

This version of the domain for demand analysis was developed
in discussion with Peter Sestoft, so I think it might at last
be more or less right!

Our idea is mentally to separate
	strictness analysis
from
	absence and boxity analysis

Then we combine them back into a single domain.  The latter
is all you see in the compiler (the Demand type, as before)
but we understand it better now.
parent 0a432d48
......@@ -55,7 +55,7 @@ module Id (
idArity,
idDemandInfo, idNewDemandInfo,
idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness,
idStrictness, idNewStrictness, idNewStrictness_maybe,
idTyGenInfo,
idWorkerInfo,
idUnfolding,
......@@ -318,11 +318,7 @@ setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
---------------------------------
-- STRICTNESS
idStrictness :: Id -> StrictnessInfo
idStrictness id = case strictnessInfo (idInfo id) of
NoStrictnessInfo -> case idNewStrictness_maybe id of
Just sig -> oldStrictnessFromNew sig
Nothing -> NoStrictnessInfo
strictness -> strictness
idStrictness id = strictnessInfo (idInfo id)
setIdStrictness :: Id -> StrictnessInfo -> Id
setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
......@@ -337,20 +333,6 @@ idNewStrictness :: Id -> StrictSig
idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
idNewStrictness id = idNewStrictness_maybe id `orElse` topSig
getNewStrictness :: Id -> StrictSig
-- First tries the "new-strictness" field, and then
-- reverts to the old one. This is just until we have
-- cross-module info for new strictness
getNewStrictness id = idNewStrictness_maybe id `orElse` newStrictnessFromOld id
newStrictnessFromOld :: Id -> StrictSig
newStrictnessFromOld id = mkNewStrictnessInfo id (idArity id) (idStrictness id) (idCprInfo id)
oldStrictnessFromNew :: StrictSig -> StrictnessInfo
oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
where
(dmds, res_info) = splitStrictSig sig
setIdNewStrictness :: Id -> StrictSig -> Id
setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
......@@ -431,11 +413,7 @@ idCafInfo id = cgCafInfo (idCgInfo id)
---------------------------------
-- CPR INFO
idCprInfo :: Id -> CprInfo
idCprInfo id = case cprInfo (idInfo id) of
NoCPRInfo -> case strictSigResInfo (idNewStrictness id) of
RetCPR -> ReturnsCPR
other -> NoCPRInfo
ReturnsCPR -> ReturnsCPR
idCprInfo id = cprInfo (idInfo id)
setIdCprInfo :: Id -> CprInfo -> Id
setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
......
......@@ -24,14 +24,15 @@ module IdInfo (
arityInfo, setArityInfo, ppArityInfo,
-- New demand and strictness info
newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo,
newStrictnessInfo, setNewStrictnessInfo,
newDemandInfo, setNewDemandInfo, newDemand, oldDemand,
-- Strictness; imported from Demand
StrictnessInfo(..),
mkStrictnessInfo, noStrictnessInfo,
ppStrictnessInfo,isBottomingStrictness,
strictnessInfo, setStrictnessInfo,
strictnessInfo, setStrictnessInfo, setAllStrictnessInfo,
oldStrictnessFromNew, newStrictnessFromOld, cprInfoFromNewStrictness,
-- Usage generalisation
TyGenInfo(..),
......@@ -96,9 +97,10 @@ import FieldLabel ( FieldLabel )
import Type ( usOnce, usMany )
import Demand hiding( Demand )
import qualified Demand
import NewDemand ( Demand(..), Keepity(..), DmdResult(..),
lazyDmd, topDmd, dmdTypeDepth, isStrictDmd,
StrictSig, mkStrictSig, mkTopDmdType
import NewDemand ( Demand(..), DmdResult(..), Demands(..),
lazyDmd, topDmd, dmdTypeDepth, isStrictDmd, isBotRes,
splitStrictSig, strictSigResInfo,
StrictSig, mkStrictSig, mkTopDmdType, evalDmd, lazyDmd
)
import Outputable
import Util ( seqList, listLengthCmp )
......@@ -118,6 +120,7 @@ infixl 1 `setDemandInfo`,
`setCgInfo`,
`setCafInfo`,
`setNewStrictnessInfo`,
`setAllStrictnessInfo`,
`setNewDemandInfo`
-- infixl so you can say (id `set` a `set` b)
\end{code}
......@@ -131,22 +134,43 @@ infixl 1 `setDemandInfo`,
To be removed later
\begin{code}
mkNewStrictnessInfo :: Id -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig
mkNewStrictnessInfo id arity (Demand.StrictnessInfo ds res) cpr
setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
-- Set old and new strictness info
setAllStrictnessInfo info Nothing
= info { newStrictnessInfo = Nothing,
strictnessInfo = NoStrictnessInfo,
cprInfo = NoCPRInfo }
setAllStrictnessInfo info (Just sig)
= info { newStrictnessInfo = Just sig,
strictnessInfo = oldStrictnessFromNew sig,
cprInfo = cprInfoFromNewStrictness sig }
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 id arity $
= mk_strict_sig name arity $
mkTopDmdType (map newDemand ds) (newRes res cpr)
mkNewStrictnessInfo id arity other 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 id arity $
mk_strict_sig name arity $
mkTopDmdType (replicate arity lazyDmd) (newRes False cpr)
mk_strict_sig id arity dmd_ty
= WARN( arity /= dmdTypeDepth dmd_ty, ppr id <+> (ppr arity $$ ppr dmd_ty) )
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
......@@ -155,20 +179,23 @@ newRes False NoCPRInfo = TopRes
newDemand :: Demand.Demand -> NewDemand.Demand
newDemand (WwLazy True) = Abs
newDemand (WwLazy False) = Lazy
newDemand WwStrict = Eval
newDemand (WwUnpack unpk ds) = Seq Drop (map newDemand ds)
newDemand WwPrim = Lazy
newDemand WwEnum = Eval
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 Lazy = WwLazy False
oldDemand Bot = WwStrict
oldDemand Err = WwStrict
oldDemand Eval = WwStrict
oldDemand (Seq _ ds) = WwUnpack True (map oldDemand ds)
oldDemand (Call _) = WwStrict
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
\end{code}
......@@ -300,7 +327,7 @@ setUnfoldingInfo info uf
-- let x = (a,b) in h a b x
-- and now x is not demanded (I'm assuming h is lazy)
-- This really happens. The solution here is a bit ad hoc...
= info { unfoldingInfo = uf, newDemandInfo = Lazy }
= info { unfoldingInfo = uf, newDemandInfo = Top }
| otherwise
-- We do *not* seq on the unfolding info, For some reason, doing so
......@@ -717,7 +744,7 @@ zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand})
= Nothing
| otherwise
= Just (info {occInfo = safe_occ,
newDemandInfo = Lazy})
newDemandInfo = Top})
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
......@@ -734,7 +761,7 @@ zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand})
zapDemandInfo :: IdInfo -> Maybe IdInfo
zapDemandInfo info@(IdInfo {newDemandInfo = demand})
| not (isStrictDmd demand) = Nothing
| otherwise = Just (info {newDemandInfo = Lazy})
| otherwise = Just (info {newDemandInfo = Top})
\end{code}
......
......@@ -72,12 +72,13 @@ import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
setUnfoldingInfo,
setArityInfo, setSpecInfo, setCgInfo, setCafInfo,
mkNewStrictnessInfo, setNewStrictnessInfo,
newStrictnessFromOld, setAllStrictnessInfo,
GlobalIdDetails(..), CafInfo(..), CprInfo(..),
CgInfo
)
import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) )
mkTopDmdType, topDmd, evalDmd, lazyDmd,
Demand(..), Demands(..) )
import FieldLabel ( mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
)
......@@ -147,7 +148,7 @@ mkDataConId work_name data_con
where
info = noCafNoTyGenIdInfo
`setArityInfo` arity
`setNewStrictnessInfo` Just strict_sig
`setAllStrictnessInfo` Just strict_sig
arity = dataConRepArity data_con
......@@ -238,15 +239,15 @@ mkDataConWrapId data_con
`setArityInfo` arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
`setNewStrictnessInfo` Just wrap_sig
`setAllStrictnessInfo` Just wrap_sig
wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info)
res_info = strictSigResInfo (idNewStrictness work_id)
arg_dmds = [Abs | d <- dict_args] ++ map mk_dmd strict_marks
mk_dmd str | isMarkedStrict str = Eval
| otherwise = Lazy
mk_dmd str | isMarkedStrict str = evalDmd
| otherwise = lazyDmd
-- The Cpr info can be important inside INLINE rhss, where the
-- wrapper constructor isn't inlined.
-- And the argument strictness can be important too; we
......@@ -444,7 +445,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
`setCafInfo` caf_info
`setArityInfo` arity
`setUnfoldingInfo` mkTopUnfolding rhs_w_str
`setNewStrictnessInfo` Just strict_sig
`setAllStrictnessInfo` Just strict_sig
-- Allocate Ids. We do it a funny way round because field_dict_tys is
-- almost always empty. Also note that we use length_tycon_theta
......@@ -588,7 +589,7 @@ mkDictSelId name clas
info = noCafNoTyGenIdInfo
`setArityInfo` 1
`setUnfoldingInfo` mkTopUnfolding rhs
`setNewStrictnessInfo` Just strict_sig
`setAllStrictnessInfo` Just strict_sig
-- We no longer use 'must-inline' on record selectors. They'll
-- inline like crazy if they scrutinise a constructor
......@@ -598,9 +599,9 @@ mkDictSelId name clas
-- It's worth giving one, so that absence info etc is generated
-- even if the selector isn't inlined
strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
arg_dmd | isNewTyCon tycon = Eval
| otherwise = Seq Drop [ if the_arg_id == id then Eval else Abs
| id <- arg_ids ]
arg_dmd | isNewTyCon tycon = evalDmd
| otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
| id <- arg_ids ])
tyvars = classTyVars clas
......@@ -648,7 +649,7 @@ mkPrimOpId prim_op
info = noCafNoTyGenIdInfo
`setSpecInfo` rules
`setArityInfo` arity
`setNewStrictnessInfo` Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
`setAllStrictnessInfo` Just (newStrictnessFromOld name arity strict_info NoCPRInfo)
-- Until we modify the primop generation code
rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
......@@ -678,7 +679,7 @@ mkFCallId uniq fcall ty
info = noCafNoTyGenIdInfo
`setArityInfo` arity
`setNewStrictnessInfo` Just strict_sig
`setAllStrictnessInfo` Just strict_sig
(_, tau) = tcSplitForAllTys ty
(arg_tys, _) = tcSplitFunTys tau
......@@ -939,7 +940,7 @@ pc_bottoming_Id key mod name ty
= pcMiscPrelId key mod name ty bottoming_info
where
strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig
bottoming_info = noCafNoTyGenIdInfo `setAllStrictnessInfo` Just strict_sig
-- these "bottom" out, no matter what their arguments
generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
......
......@@ -5,13 +5,16 @@
\begin{code}
module NewDemand(
Demand(..), Keepity(..),
mkSeq, topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd,
Demand(..),
topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd,
isTop, isAbsent,
DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
dmdTypeDepth, dmdTypeRes,
DmdEnv, emptyDmdEnv,
DmdResult(..), isBotRes, returnsCPR,
DmdResult(..), isBotRes, returnsCPR, resTypeArgDmd,
Demands(..), mapDmds, zipWithDmds, allTop,
StrictSig(..), mkStrictSig, topSig, botSig, isTopSig,
splitStrictSig, strictSigResInfo,
......@@ -23,11 +26,96 @@ module NewDemand(
import BasicTypes ( Arity )
import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv )
import UniqFM ( ufmToList )
import Util ( listLengthCmp )
import Util ( listLengthCmp, zipWithEqual )
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 (Poly d) = isTop d
allTop (Prod ds) = all isTop ds
isTop Top = True
isTop d = False
isAbsent Abs = True
isAbsent d = False
mapDmds :: (Demand -> Demand) -> Demands -> Demands
mapDmds f (Poly d) = Poly (f d)
mapDmds f (Prod ds) = Prod (map f ds)
zipWithDmds :: (Demand -> Demand -> Demand)
-> Demands -> Demands -> Demands
zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2)
zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1]
zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
zipWithDmds f (Prod ds1) (Prod ds2) = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
topDmd, lazyDmd, seqDmd :: Demand
topDmd = Top -- The most uninformative demand
lazyDmd = Box Abs
seqDmd = Eval (Poly Abs) -- Polymorphic seq demand
evalDmd = Box seqDmd -- Evaluate and return
errDmd = Box Bot -- This used to be called X
isStrictDmd :: Demand -> Bool
isStrictDmd Bot = True
isStrictDmd (Eval _) = True
isStrictDmd (Call _) = True
isStrictDmd (Box d) = isStrictDmd d
isStrictDmd other = False
instance Outputable Demand where
ppr Top = char 'T'
ppr Abs = char 'A'
ppr Bot = char 'B'
ppr (Defer ds) = char 'D' <> ppr ds
ppr (Eval ds) = char 'U' <> ppr ds
ppr (Box (Eval ds)) = char 'S' <> ppr ds
ppr (Box Abs) = char 'L'
ppr (Box Bot) = char 'X'
ppr (Call d) = char 'C' <> parens (ppr d)
instance Outputable Demands where
ppr (Poly Abs) = empty
ppr (Poly d) = parens (ppr d <> char '*')
ppr (Prod ds) | all isAbsent ds = empty
| otherwise = parens (hcat (map ppr ds))
\end{code}
%************************************************************************
%* *
\subsection{Demand types}
......@@ -48,7 +136,7 @@ data DmdType = DmdType
-- ANOTHER IMPORTANT INVARIANT
-- The Demands in the argument list are never
-- Bot, Err, Seq Defer ds
-- Bot, Defer d
-- Handwavey reason: these don't correspond to calling conventions
-- See DmdAnal.funArgDemand for details
......@@ -96,6 +184,15 @@ isBotRes :: DmdResult -> Bool
isBotRes BotRes = True
isBotRes other = False
resTypeArgDmd :: DmdResult -> Demand
-- TopRes and BotRes are polymorphic, so that
-- BotRes = Bot -> BotRes
-- TopRes = Top -> TopRes
-- This function makes that concrete
resTypeArgDmd TopRes = Top
resTypeArgDmd BotRes = Bot
resTypeArgDmd RetCPR = panic "resTypeArgDmd: RetCPR"
returnsCPR :: DmdResult -> Bool
returnsCPR RetCPR = True
returnsCPR other = False
......@@ -183,72 +280,3 @@ pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
\end{code}
%************************************************************************
%* *
\subsection{Demands}
%* *
%************************************************************************
\begin{code}
data Demand
= Lazy -- L; used for unlifted types too, so that
-- A `lub` L = L
| Abs -- A
| Call Demand -- C(d)
| Eval -- V
| Seq Keepity -- S/U/D(ds)
[Demand] -- S(ds) = L `both` U(ds)
-- D(ds) = A `lub` U(ds)
-- *** Invariant: these demands are never Bot or Abs
-- *** Invariant: if all demands are Abs, get []
| Err -- X
| Bot -- B
deriving( Eq )
-- Equality needed for fixpoints in DmdAnal
data Keepity = Keep -- Strict and I need the box
| Drop -- Strict, but I don't need the box
| Defer -- Lazy, if you *do* evaluate, I need
-- the components but not the box
deriving( Eq )
mkSeq :: Keepity -> [Demand] -> Demand
mkSeq k ds | all is_absent ds = Seq k []
| otherwise = Seq k ds
where
is_absent Abs = True
is_absent d = False
topDmd, lazyDmd, seqDmd :: Demand
topDmd = Lazy -- The most uninformative demand
lazyDmd = Lazy
seqDmd = Seq Keep [] -- Polymorphic seq demand
evalDmd = Eval
isStrictDmd :: Demand -> Bool
isStrictDmd Bot = True
isStrictDmd Err = True
isStrictDmd (Seq Drop _) = True -- But not Defer!
isStrictDmd (Seq Keep _) = True
isStrictDmd Eval = True
isStrictDmd (Call _) = True
isStrictDmd other = False
instance Outputable Demand where
ppr Lazy = char 'L'
ppr Abs = char 'A'
ppr Eval = char 'V'
ppr Err = char 'X'
ppr Bot = char 'B'
ppr (Call d) = char 'C' <> parens (ppr d)
ppr (Seq k []) = ppr k
ppr (Seq k ds) = ppr k <> parens (hcat (map ppr ds))
instance Outputable Keepity where
ppr Keep = char 'S'
ppr Drop = char 'U'
ppr Defer = char 'D'
\end{code}
......@@ -500,7 +500,7 @@ tidyTopIdInfo tidy_env is_external idinfo unfold_info arity cg_info
basic_info = vanillaIdInfo
`setCgInfo` cg_info
`setArityInfo` arity
`setNewStrictnessInfo` newStrictnessInfo idinfo
`setAllStrictnessInfo` newStrictnessInfo idinfo
-- This is where we set names to local/global based on whether they really are
-- externally visible (see comment at the top of this module). If the name
......@@ -663,7 +663,7 @@ tidyLetBndr env (id,rhs)
idinfo = idInfo id
new_info = vanillaIdInfo
`setArityInfo` exprArity rhs
`setNewStrictnessInfo` newStrictnessInfo idinfo
`setAllStrictnessInfo` newStrictnessInfo idinfo
`setNewDemandInfo` newDemandInfo idinfo
-- Override the env we get back from tidyId with the new IdInfo
......
......@@ -39,8 +39,8 @@ import List ( isSuffixOf )
import PrelNames ( mkTupNameStr )
import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck )
import ForeignCall ( Safety(..) )
import NewDemand ( StrictSig(..), Demand(..), Keepity(..),
DmdResult(..), mkTopDmdType )
import NewDemand ( StrictSig(..), Demand(..), Demands(..),
DmdResult(..), mkTopDmdType, evalDmd, lazyDmd )
import UniqFM ( listToUFM, lookupUFM )
import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
......@@ -838,30 +838,37 @@ lex_demand cont buf =
where
read_em acc buf =
case currentChar# buf of
'L'# -> read_em (Lazy : acc) (stepOn buf)
'A'# -> read_em (Abs : acc) (stepOn buf)
'V'# -> read_em (Eval : acc) (stepOn buf)
'X'# -> read_em (Err : acc) (stepOn buf)
'B'# -> read_em (Bot : acc) (stepOn buf)
')'# -> (reverse acc, stepOn buf)
'C'# -> do_call acc (stepOnBy# buf 2#)
'D'# -> do_unpack1 Defer acc (stepOnBy# buf 1#)
'U'# -> do_unpack1 Drop acc (stepOnBy# buf 1#)
'S'# -> do_unpack1 Keep acc (stepOnBy# buf 1#)
_ -> (reverse acc, buf)
'T'# -> read_em (Top : acc) (stepOn buf)
'L'# -> read_em (lazyDmd : acc) (stepOn buf)
'A'# -> read_em (Abs : acc) (stepOn buf)
'V'# -> read_em (evalDmd : acc) (stepOn buf) -- Temporary, until
-- we've recompiled prelude etc
'C'# -> do_unary Call acc (stepOnBy# buf 2#) -- Skip 'C('
do_unpack1 keepity acc buf
= case currentChar# buf of
'('# -> do_unpack2 keepity acc (stepOnBy# buf 1#)
_ -> read_em (Seq keepity [] : acc) buf
'U'# -> do_seq1 Eval acc (stepOnBy# buf 1#)
'D'# -> do_seq1 Defer acc (stepOnBy# buf 1#)
'S'# -> do_seq1 (Box . Eval) acc (stepOnBy# buf 1#)
do_unpack2 keepity acc buf
= case read_em [] buf of
(stuff, rest) -> read_em (Seq keepity stuff : acc) rest
_ -> (reverse acc, buf)
do_call acc buf
do_seq1 fn acc buf
= case currentChar# buf of
'('# -> do_seq2 fn acc (stepOnBy# buf 1#)
_ -> read_em (fn (Poly Abs) : acc) buf
do_seq2 fn acc buf
= case read_em [] buf of { (dmds, buf) ->
case currentChar# buf of
')'# -> read_em (fn (Prod dmds) : acc)
(stepOn buf)
'*'# -> ASSERT( length dmds == 1 )
read_em (fn (Poly (head dmds)) : acc)
(stepOnBy# buf 2#) -- Skip '*)'
}
do_unary fn acc buf
= case read_em [] buf of
([dmd], rest) -> read_em (Call dmd : acc) rest
([dmd], rest) -> read_em (fn dmd : acc) (stepOn rest) -- Skip ')'
------------------
lex_scc cont buf =
......
......@@ -897,7 +897,8 @@ completeCall env var occ_info cont
pprTrace "Rule fired" (vcat [
text "Rule:" <+> ptext rule_name,
text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
text "After: " <+> pprCoreExpr rule_rhs])
text "After: " <+> pprCoreExpr rule_rhs,
text "Cont: " <+> ppr call_cont])
else
id) $
simplExprF env rule_rhs call_cont ;
......
This diff is collapsed.
......@@ -20,8 +20,8 @@ import Type ( Type )
import IdInfo ( WorkerInfo(..), arityInfo,
newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo
)
import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), Keepity(..),
mkTopDmdType, isBotRes, returnsCPR, topSig
import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
)
import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import BasicTypes ( RecFlag(..), isNonRec, Activation(..) )
......@@ -343,9 +343,9 @@ worthSplittingFun ds res
-- [We don't do reboxing now, but in general it's better to pass
-- an unboxed thing to f, and have it reboxed in the error cases....]
where
worth_it Abs = True -- Absent arg
worth_it (Seq _ ds) = True -- Arg to evaluate
worth_it other = False
worth_it Abs = True -- Absent arg
worth_it (Eval (Prod ds)) = True -- Product arg to evaluate
worth_it other = False
worthSplittingThunk :: Demand -- Demand on the thunk
-> DmdResult -- CPR info for the thunk
......@@ -354,12 +354,8 @@ worthSplittingThunk dmd res
= worth_it dmd || returnsCPR res
where
-- Split if the thing is unpacked