idArity,
idDemandInfo, idNewDemandInfo,
- idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness,
+ idStrictness, idNewStrictness, idNewStrictness_maybe,
idTyGenInfo,
idWorkerInfo,
idUnfolding,
---------------------------------
-- 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
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
---------------------------------
-- 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
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(..),
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 )
`setCgInfo`,
`setCafInfo`,
`setNewStrictnessInfo`,
+ `setAllStrictnessInfo`,
`setNewDemandInfo`
-- infixl so you can say (id `set` a `set` b)
\end{code}
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
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}
-- 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
= 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
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}
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
)
where
info = noCafNoTyGenIdInfo
`setArityInfo` arity
- `setNewStrictnessInfo` Just strict_sig
+ `setAllStrictnessInfo` Just strict_sig
arity = dataConRepArity 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
`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
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
-- 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
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)
info = noCafNoTyGenIdInfo
`setArityInfo` arity
- `setNewStrictnessInfo` Just strict_sig
+ `setAllStrictnessInfo` Just strict_sig
(_, tau) = tcSplitForAllTys ty
(arg_tys, _) = tcSplitFunTys tau
= 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
\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,
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}
%* *
%************************************************************************
-- 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
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
\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}
-
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
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
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,
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 =
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 ;
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idDemandInfo, idInlinePragma,
isDataConId, isGlobalId, idArity,
- idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness,
- idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld )
-import IdInfo ( newDemand )
+ idNewStrictness, idNewStrictness_maybe, setIdNewStrictness,
+ idNewDemandInfo, setIdNewDemandInfo, idName, idStrictness, idCprInfo )
+import IdInfo ( newDemand, newStrictnessFromOld )
import Var ( Var )
import VarEnv
import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr)
dmdAnal sigs Abs e = (topDmdType, e)
-dmdAnal sigs Bot e = (botDmdType, e)
-dmdAnal sigs Lazy e = let
- (res_ty, e') = dmdAnal sigs Eval e
- in
- (deferType res_ty, e')
+dmdAnal sigs dmd e
+ | not (isStrictDmd dmd)
+ = let
+ (res_ty, e') = dmdAnal sigs evalDmd e
+ in
+ (deferType res_ty, e')
-- It's important not to analyse e with a lazy demand because
-- a) When we encounter case s of (a,b) ->
-- we demand s with U(d1d2)... but if the overall demand is lazy
where
(dmd_ty, e') = dmdAnal sigs dmd' e
dmd' = case n of
- Coerce _ _ -> Eval -- This coerce usually arises from a recursive
- other -> dmd -- newtype, and we don't want to look inside them
- -- for exactly the same reason that we don't look
- -- inside recursive products -- we might not reach
- -- a fixpoint. So revert to a vanilla Eval demand
+ Coerce _ _ -> evalDmd -- This coerce usually arises from a recursive
+ other -> dmd -- newtype, and we don't want to look inside them
+ -- for exactly the same reason that we don't look
+ -- inside recursive products -- we might not reach
+ -- a fixpoint. So revert to a vanilla Eval demand
dmdAnal sigs dmd (App fun (Type ty))
= (fun_ty, App fun' (Type ty))
| otherwise -- Not enough demand on the lambda; but do the body
= let -- anyway to annotate it and gather free var info
- (body_ty, body') = dmdAnal sigs Eval body
+ (body_ty, body') = dmdAnal sigs evalDmd body
(lam_ty, var') = annotateLamIdBndr body_ty var
in
(deferType lam_ty, Lam var' body')
-- 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
- scrut_dmd = mkSeq Drop [idNewDemandInfo b | b <- bndrs', isId b]
+ scrut_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b])
`both`
idNewDemandInfo case_bndr'
dmdAnal sigs dmd (Case scrut case_bndr alts)
= let
(alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts
- (scrut_ty, scrut') = dmdAnal sigs Eval scrut
+ (scrut_ty, scrut') = dmdAnal sigs evalDmd scrut
(alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr
in
-- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys)
(body_ty1, id2) = annotateBndr body_ty id1
body_ty2 = addLazyFVs body_ty1 lazy_fv
in
+#ifdef DEBUG
+ -- If the actual demand is better than the vanilla
+ -- demand, we might do better to re-analyse with the
+ -- stronger demand.
(let vanilla_dmd = vanillaCall (idArity id)
actual_dmd = idNewDemandInfo id2
in
- if not (vanilla_dmd `betterDemand` actual_dmd) then
+ if actual_dmd `betterDemand` vanilla_dmd && actual_dmd /= vanilla_dmd then
pprTrace "dmdLet: better demand" (ppr id <+> vcat [text "vanilla" <+> ppr vanilla_dmd,
text "actual" <+> ppr actual_dmd])
else \x -> x)
+#endif
(body_ty2, Let (NonRec id2 rhs') body')
dmdAnal sigs dmd (Let (Rec pairs) body)
-> [Demand]
-> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked
- go n (Seq keep cs : ds)
- | n' >= 0 = Seq keep cs' `cons` go n'' ds
- | otherwise = Eval `cons` go n ds
+ go n (Eval (Prod cs) : ds)
+ | n' >= 0 = Eval (Prod cs') `cons` go n'' ds
+ | otherwise = Box (Eval (Prod cs)) `cons` go n ds
where
(n'',cs') = go n' cs
- n' = n + box - non_abs_args
- box = case keep of
- Keep -> 0
- Drop -> 1 -- Add one to the budget if we drop the top-level arg
+ n' = n + 1 - non_abs_args
+ -- Add one to the budget 'cos we drop the top-level arg
non_abs_args = nonAbsentArgs cs
-- Delete # of non-absent args to which we'll now be committed
-- We already have a suitable demand on all
-- free vars, so no need to add more!
splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
-splitDmdTy ty@(DmdType fv [] TopRes) = (Lazy, ty)
-splitDmdTy ty@(DmdType fv [] BotRes) = (Bot, ty)
- -- NB: Bot not Abs
-splitDmdTy ty@(DmdType fv [] RetCPR) = panic "splitDmdTy"
- -- We should not be applying a product as a function!
+splitDmdTy ty@(DmdType fv [] res_ty) = (resTypeArgDmd res_ty, ty)
\end{code}
\begin{code}
-- 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 (argDemand var dmd))
+ | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd)
where
(fv', dmd) = removeFV fv var res
(DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)
where
(fv', dmd) = removeFV fv id res
- hacked_dmd = argDemand id dmd
+ hacked_dmd = argDemand dmd
-- This call to argDemand is vital, because otherwise we label
-- a lambda binder with demand 'B'. But in terms of calling
-- conventions that's Abs, because we don't pass it. But
-- And then the simplifier things the 'B' is a strict demand
-- and evaluates the (error "oops"). Sigh
-removeFV fv var res = (fv', dmd)
+removeFV fv id res = (fv', zapUnlifted id dmd)
where
- fv' = fv `delVarEnv` var
- dmd = lookupVarEnv fv var `orElse` deflt
+ fv' = fv `delVarEnv` id
+ dmd = lookupVarEnv fv id `orElse` deflt
deflt | isBotRes res = Bot
| otherwise = Abs
+
+-- For unlifted-type variables, we are only
+-- interested in Bot/Abs/Box Abs
+zapUnlifted is Bot = Bot
+zapUnlifted id Abs = Abs
+zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
+ | otherwise = dmd
\end{code}
%************************************************************************
dmdTransform sigs var dmd
------ DATA CONSTRUCTOR
- | isDataConId var, -- Data constructor
- Seq k ds <- res_dmd -- and the demand looks inside its fields
+ | isDataConId var -- Data constructor
= let
StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig
DmdType _ _ con_res = dmd_ty
in
if arity == call_depth then -- Saturated, so unleash the demand
let
- -- ds can be empty, when we are just seq'ing the thing
- -- If so we must make up a suitable bunch of demands
- dmd_ds | null ds = replicate arity Abs
- | otherwise = ASSERT( ds `lengthIs` arity ) ds
-
- arg_ds = case k of
- Keep -> bothLazy_s dmd_ds
- Drop -> dmd_ds
- Defer -> pprTrace "dmdTransform: surprising!" (ppr var)
- -- I don't think this can happen
- dmd_ds
-- Important! If we Keep the constructor application, then
-- we need the demands the constructor places (always lazy)
-- If not, we don't need to. For example:
-- f p@(x,y) = (p,y) -- S(AL)
-- g a b = f (a,b)
-- It's vital that we don't calculate Absent for a!
+ dmd_ds = case res_dmd of
+ Box (Eval ds) -> mapDmds box ds
+ Eval ds -> ds
+ other -> Poly Top
+
+ -- ds can be empty, when we are just seq'ing the thing
+ -- If so we must make up a suitable bunch of demands
+ arg_ds = case dmd_ds of
+ Poly d -> replicate arity d
+ Prod ds -> ASSERT( ds `lengthIs` arity ) ds
+
in
mkDmdType emptyDmdEnv arg_ds con_res
-- Must remember whether it's a product, hence con_res, not TopRes
------ IMPORTED FUNCTION
| isGlobalId var, -- Imported function
- let StrictSig dmd_ty = getNewStrictness var
+ let StrictSig dmd_ty = idNewStrictness var
= if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand
dmd_ty
else
splitCallDmd d = (0, d)
vanillaCall :: Arity -> Demand
-vanillaCall 0 = Eval
+vanillaCall 0 = evalDmd
vanillaCall n = Call (vanillaCall (n-1))
deferType :: DmdType -> DmdType
deferEnv :: DmdEnv -> DmdEnv
deferEnv fv = mapVarEnv defer fv
----------------
-bothLazy :: Demand -> Demand
-bothLazy = both Lazy
-bothLazy_s :: [Demand] -> [Demand]
-bothLazy_s = map bothLazy
-
----------------
-argDemand :: Id -> Demand -> Demand
-argDemand id dmd | isUnLiftedType (idType id) = unliftedArgDemand dmd
- | otherwise = liftedArgDemand dmd
-
-liftedArgDemand :: Demand -> Demand
+argDemand :: Demand -> Demand
-- The 'Defer' demands are just Lazy at function boundaries
-- Ugly! Ask John how to improve it.
-liftedArgDemand (Seq Defer ds) = Lazy
-liftedArgDemand (Seq k ds) = Seq k (map liftedArgDemand ds)
- -- Urk! Don't have type info here
-liftedArgDemand Err = Eval -- Args passed to a bottoming function
-liftedArgDemand Bot = Abs -- Don't pass args that are consumed by bottom/err
-liftedArgDemand d = d
-
-unliftedArgDemand :: Demand -> Demand
--- Same idea, but for unlifted types the domain is much simpler:
--- Either we use it (Lazy) or we don't (Abs)
-unliftedArgDemand Bot = Abs
-unliftedArgDemand Abs = Abs
-unliftedArgDemand other = Lazy
+argDemand Top = lazyDmd
+argDemand (Defer d) = lazyDmd
+argDemand (Eval ds) = Eval (mapDmds argDemand ds)
+argDemand (Box Bot) = evalDmd
+argDemand (Box d) = box (argDemand d)
+argDemand Bot = Abs -- Don't pass args that are consumed by bottom/err
+argDemand d = d
\end{code}
\begin{code}
betterDemand :: Demand -> Demand -> Bool
-- If d1 `better` d2, and d2 `better` d2, then d1==d2
betterDemand d1 d2 = (d1 `lub` d2) == d2
-
-squashDmdEnv (StrictSig (DmdType fv ds res)) = StrictSig (DmdType emptyDmdEnv ds res)
\end{code}
\begin{code}
-- *implicitly* has {y->A}. So we must put {y->(V `lub` A)}
-- in the result env.
lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
- = DmdType lub_fv2 (zipWith lub ds1 ds2) (r1 `lubRes` r2)
+ = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)
where
lub_fv = plusUFM_C lub fv1 fv2
- lub_fv1 = modifyEnv (not (isBotRes r1)) defer fv2 fv1 lub_fv
- lub_fv2 = modifyEnv (not (isBotRes r2)) defer fv1 fv2 lub_fv1
+ lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv
+ lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1
-- lub is the identity for Bot
+ -- Extend the shorter argument list to match the longer
+ lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2
+ lub_ds [] [] = []
+ lub_ds ds1 [] = map (`lub` resTypeArgDmd r2) ds1
+ lub_ds [] ds2 = map (resTypeArgDmd r1 `lub`) ds2
+
-----------------------------------
-- (t1 `bothType` t2) takes the argument/result info from t1,
-- using t2 just for its free-var info
\end{code}
\begin{code}
--- A Seq can have an empty list of demands, in the polymorphic case.
-lubs [] ds2 = ds2
-lubs ds1 [] = ds1
-lubs ds1 ds2 = ASSERT( equalLength ds1 ds2 ) zipWith lub ds1 ds2
-
------------------------------------
--- A Seq can have an empty list of demands, in the polymorphic case.
-boths [] ds2 = ds2
-boths ds1 [] = ds1
-boths ds1 ds2 = ASSERT( equalLength ds1 ds2 ) zipWith both ds1 ds2
-\end{code}
-
-\begin{code}
modifyEnv :: Bool -- No-op if False
-> (Demand -> Demand) -- The zapper
-> DmdEnv -> DmdEnv -- Env1 and Env2
%* *
%************************************************************************
-
\begin{code}
lub :: Demand -> Demand -> Demand
-lub Bot d = d
-
-lub Err Bot = Err
-lub Err Abs = Lazy -- E.g. f x = if ... then True else error x
-lub Err (Seq k ds)
- | null ds = Seq (case k of { Drop -> Keep; other -> k }) []
- -- Yuk
- | not (null ds) = Seq k [Err `lub` d | d <- ds]
- -- E.g. f x = if ... then fst x else error x
- -- We *cannot* use the (lub Err d = d) case,
- -- else we'd get U(VA) for x's demand!!
-lub Err d = d
-
-lub Lazy d = Lazy
-
-lub Abs d = defer d
-
-lub Eval Abs = Lazy
-lub Eval Lazy = Lazy
-lub Eval (Seq Defer ds) = Lazy -- Essential!
-lub Eval (Seq Drop ds) | not (null ds) = Seq Drop [Lazy | d <- ds]
-lub Eval d = Eval
- -- For the Seq Drop case, consider
- -- f n [] = n
- -- f n (x:xs) = f (n+x) xs
- -- Here we want to do better than just V for n. It's
- -- unboxed in the (x:xs) case, and we might be prepared to
- -- rebox it in the [] case.
- -- But if we don't use *any* of the components, give up
- -- and revert to V
-
-lub (Call d1) (Call d2) = Call (lub d1 d2)
-lub d1@(Call _) d2 = d2 `lub` d1
-
-lub (Seq k1 ds1) (Seq k2 ds2)
- = Seq (k1 `lub_keep` k2) (lub_ds k1 ds1 k2 ds2)
- where
- ------------------
- lub_ds Keep ds1 Keep ds2 = ds1 `lubs` ds2
- lub_ds Keep ds1 non_keep ds2 | null ds1 = [Lazy | d <- ds2]
- | otherwise = bothLazy_s ds1 `lubs` ds2
-
- lub_ds non_keep ds1 Keep ds2 | null ds2 = [Lazy | d <- ds1]
- | otherwise = ds1 `lubs` bothLazy_s ds2
-
- lub_ds k1 ds1 k2 ds2 = ds1 `lubs` ds2
-
- ------------------
- -- Note that (Keep `lub` Drop) is Drop, not Keep
- -- Why not? See the example above with (lub Eval d).
- lub_keep Keep k = k
-
- lub_keep Drop Defer = Defer
- lub_keep Drop k = Drop
-
- lub_keep Defer k = Defer
-
-lub d1@(Seq _ _) d2 = d2 `lub` d1
-
+lub Bot d2 = d2
+lub Abs d2 = absLub d2
+lub Top d2 = Top
+lub (Defer ds1) d2 = defer (Eval ds1 `lub` d2)
+
+lub (Call d1) (Call d2) = Call (d1 `lub` d2)
+lub d1@(Call _) (Box d2) = d1 `lub` d2 -- Just strip the box
+lub d1@(Call _) d2@(Eval _) = d2 -- Presumably seq or vanilla eval
+lub d1@(Call _) d2 = d2 `lub` d1 -- Bot, Abs, Top
+
+-- For the Eval case, we use these approximation rules
+-- Box Bot <= Eval (Box Bot ...)
+-- Box Top <= Defer (Box Bot ...)
+-- Box (Eval ds) <= Eval (map Box ds)
+lub (Eval ds1) (Eval ds2) = Eval (ds1 `lubs` ds2)
+lub (Eval ds1) (Box Bot) = Eval (mapDmds (`lub` Box Bot) ds1)
+lub (Eval ds1) (Box (Eval ds2)) = Eval (ds1 `lubs` mapDmds box ds2)
+lub (Eval ds1) (Box Abs) = deferEval (mapDmds (`lub` Box Bot) ds1)
+lub d1@(Eval _) d2 = d2 `lub` d1 -- Bot,Abs,Top,Call,Defer
+
+lub (Box d1) (Box d2) = box (d1 `lub` d2)
+lub d1@(Box _) d2 = d2 `lub` d1
+
+lubs = zipWithDmds lub
+
+---------------------
+-- box is the smart constructor for Box
+-- It computes <B,bot> & d
+-- INVARIANT: (Box d) => d = Bot, Abs, Eval
+-- Seems to be no point in allowing (Box (Call d))
+box (Call d) = Call d -- The odd man out. Why?
+box (Box d) = Box d
+box (Defer _) = lazyDmd
+box Top = lazyDmd -- Box Abs and Box Top
+box Abs = lazyDmd -- are the same <B,L>
+box d = Box d -- Bot, Eval
+---------------
defer :: Demand -> Demand
+
+-- defer is the smart constructor for Defer
+-- The idea is that (Defer ds) = <U(ds), L>
+--
+-- It specifies what happens at a lazy function argument
+-- or a lambda; the L* operator
+-- Set the strictness part to L, but leave
+-- the boxity side unaffected
+-- It also ensures that Defer (Eval [LLLL]) = L
+
+defer Bot = Abs
+defer Abs = Abs
+defer Top = Top
+defer (Call _) = lazyDmd -- Approximation here?
+defer (Box _) = lazyDmd
+defer (Defer ds) = Defer ds
+defer (Eval ds) = deferEval ds
+
+-- deferEval ds = defer (Eval ds)
+deferEval ds | allTop ds = Top
+ | otherwise = Defer ds
+
+---------------------
+absLub :: Demand -> Demand
-- Computes (Abs `lub` d)
-- For the Bot case consider
-- f x y = if ... then x else error x
-- Then for y we get Abs `lub` Bot, and we really
-- want Abs overall
-defer Bot = Abs
-defer Abs = Abs
-defer (Seq Keep ds) = Lazy
-defer (Seq _ ds) = Seq Defer ds
-defer d = Lazy
+absLub Bot = Abs
+absLub Abs = Abs
+absLub Top = Top
+absLub (Call _) = Top
+absLub (Box _) = Top
+absLub (Eval ds) = Defer (absLubs ds) -- Or (Defer ds)?
+absLub (Defer ds) = Defer (absLubs ds) -- Or (Defer ds)?
+
+absLubs = mapDmds absLub
---------------
both :: Demand -> Demand -> Demand
-both Bot Bot = Bot
-both Bot Abs = Bot
-both Bot (Seq k ds)
- | not (null ds) = Seq (case k of { Defer -> Drop; other -> k })
- [both Bot d | d <- ds]
- -- E.g. f x = if ... then error (fst x) else fst x
- -- This equation helps results slightly,
- -- but is not necessary for soundness
-both Bot d = Err
-
-both Err d = Err
-
-both Abs d = d
-
-both Lazy Bot = Err
-both Lazy Err = Err
-both Lazy Eval = Eval
-both Lazy (Call d) = Call d
-both Lazy (Seq Defer ds) = Lazy
-both Lazy (Seq k ds) = Seq Keep ds
-both Lazy d = Lazy
-
--- For the (Eval `both` Bot) case, consider
--- f x = error x
--- From 'error' itself we get demand Bot on x
--- From the arg demand on x we get Eval
--- So we want Eval `both` Bot to be Err.
--- That's what Err is *for*
-both Eval Bot = Err
-both Eval Err = Err
-both Eval (Seq k ds) = Seq Keep ds
-both Eval d = Eval
-
-both (Call d1) (Call d2) = Call (d1 `both` d2)
-both d1@(Call _) d2 = d2 `both` d1
-
-both (Seq k1 ds1) (Seq k2 ds2)
- = Seq (k1 `both_keep` k2) (both_ds k1 ds1 k2 ds2)
- where
- ----------------
- both_keep Keep k2 = Keep
-
- both_keep Drop Keep = Keep
- both_keep Drop k2 = Drop
-
- both_keep Defer k2 = k2
-
- ----------------
- both_ds Defer ds1 Defer ds2 = ds1 `boths` ds2
- both_ds Defer ds1 non_defer ds2 = map defer ds1 `boths` ds2
-
- both_ds non_defer ds1 Defer ds2 = ds1 `boths` map defer ds2
-
- both_ds k1 ds1 k2 ds2 = ds1 `boths` ds2
-
-both d1@(Seq _ _) d2 = d2 `both` d1
+both Abs d2 = d2
+
+both Bot Bot = Bot
+both Bot Abs = Bot
+both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds)
+ -- Consider
+ -- f x = error x
+ -- From 'error' itself we get demand Bot on x
+ -- From the arg demand on x we get
+ -- x :-> evalDmd = Box (Eval (Poly Abs))
+ -- So we get Bot `both` Box (Eval (Poly Abs))
+ -- = Seq Keep (Poly Bot)
+ --
+ -- Consider also
+ -- f x = if ... then error (fst x) else fst x
+ -- Then we get (Eval (Box Bot, Bot) `lub` Eval (SA))
+ -- = Eval (SA)
+ -- which is what we want.
+both Bot d = errDmd
+
+both Top Bot = errDmd
+both Top Abs = Top
+both Top Top = Top
+both Top (Box d) = Box d
+both Top (Call d) = Call d
+both Top (Eval ds) = Eval (mapDmds (`both` Top) ds)
+both Top (Defer ds) -- = defer (Top `both` Eval ds)
+ -- = defer (Eval (mapDmds (`both` Top) ds))
+ = deferEval (mapDmds (`both` Top) ds)
+
+
+both (Box d1) (Box d2) = box (d1 `both` d2)
+both (Box d1) d2@(Call _) = box (d1 `both` d2)
+both (Box d1) d2@(Eval _) = box (d1 `both` d2)
+both (Box d1) (Defer d2) = Box d1
+both d1@(Box _) d2 = d2 `both` d1
+
+both (Call d1) (Call d2) = Call (d1 `both` d2)
+both (Call d1) (Eval ds2) = Call d1 -- Could do better for (Poly Bot)?
+both (Call d1) (Defer ds2) = Call d1 -- Ditto
+both d1@(Call _) d2 = d1 `both` d1
+
+both (Eval ds1) (Eval ds2) = Eval (ds1 `boths` ds2)
+both (Eval ds1) (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2)
+both d1@(Eval ds1) d2 = d2 `both` d1
+
+both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2)
+both d1@(Defer ds1) d2 = d2 `both` d1
+
+boths = zipWithDmds both
\end{code}
+
%************************************************************************
%* *
\subsection{Miscellaneous
where
message word = text word <+> text "strictness for" <+> ppr id <+> info
info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
- new = squashDmdEnv (idNewStrictness id) -- Don't report diffs in the env
- old = newStrictnessFromOld id
+ 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
where
message word = text word <+> text "demand for" <+> ppr id <+> info
info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
- new = liftedArgDemand (idNewDemandInfo id) -- To avoid spurious improvements
+ 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
+
+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
\end{code}
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(..) )
-- [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
= worth_it dmd || returnsCPR res
where
-- Split if the thing is unpacked
- worth_it (Seq Defer ds) = False
- worth_it (Seq _ ds) = any not_abs ds
- worth_it other = False
-
- not_abs Abs = False
- not_abs other = True
+ worth_it (Eval (Prod ds)) = not (all isAbsent ds)
+ worth_it other = False
\end{code}
)
import IdInfo ( vanillaIdInfo )
import DataCon ( splitProductType_maybe, splitProductType )
-import NewDemand ( Demand(..), Keepity(..), DmdResult(..) )
+import NewDemand ( Demand(..), DmdResult(..), Demands(..) )
import DmdAnal ( both )
import MkId ( realWorldPrimId, voidArgId, eRROR_CSTRING_ID )
import TysPrim ( realWorldStatePrimTy )
----------------------
+-- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn)
+-- * wrap_fn assumes wrap_arg is in scope,
+-- brings into scope work_args (via cases)
+-- * work_fn assumes work_args are in scope, a
+-- brings into scope wrap_arg (via lets)
+
mkWWstr_one arg
| isTyVar arg
= returnUs ([arg], nop_fn, nop_fn)
Abs | not (isUnLiftedType (idType arg)) ->
returnUs ([], nop_fn, mk_absent_let arg)
- -- Seq and keep
- Seq _ []
+ -- Unpack case
+ Eval (Prod cs)
+ | Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys)
+ <- splitProductType_maybe (idType arg)
+ -> getUniquesUs `thenUs` \ uniqs ->
+ let
+ unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
+ unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
+ unbox_fn = mk_unpk_case arg unpk_args data_con arg_tycon
+ rebox_fn = Let (NonRec arg con_app)
+ con_app = mkConApp data_con (map Type tycon_arg_tys ++ map Var unpk_args)
+ in
+ mkWWstr unpk_args_w_ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
+ -- Don't pass the arg, rebox instead
+
+ -- `seq` demand; evaluate in wrapper in the hope
+ -- of dropping seqs in the worker
+ Eval (Poly Abs)
-> let
arg_w_unf = arg `setIdUnfolding` mkOtherCon []
-- Tell the worker arg that it's sure to be evaluated
-- fw y = let x{Evald} = error "oops" in (x `seq` y)
-- If we don't pin on the "Evald" flag, the seq doesn't disappear, and
-- we end up evaluating the absent thunk.
- -- But the Evald flag is pretty wierd, and I worry that it might disappear
+ -- But the Evald flag is pretty weird, and I worry that it might disappear
-- during simplification, so for now I've just nuked this whole case
- -- Unpack case
- Seq keep cs
- | Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys)
- <- splitProductType_maybe (idType arg)
- -> getUniquesUs `thenUs` \ uniqs ->
- let
- unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
- unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs'
- unbox_fn = mk_unpk_case arg unpk_args data_con arg_tycon
- rebox_fn = Let (NonRec arg con_app)
- con_app = mkConApp data_con (map Type tycon_arg_tys ++ map Var unpk_args)
-
- cs' = case keep of
- Keep -> map (DmdAnal.both Lazy) cs -- Careful! Now we don't pass
- -- the box, we must pass all the
- -- components. In effect
- -- S(LA) --> U(LL)
- Drop -> cs
- Defer -> pprTrace "wwlib" (ppr arg) cs
- in
- mkWWstr unpk_args_w_ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
-
--- case keep of
--- Keep -> returnUs (arg : worker_args, unbox_fn . wrap_fn, work_fn)
--- -- Pass the arg, no need to rebox
--- Drop -> returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
--- -- Don't pass the arg, rebox instead
--- I used to be clever here, but consider
--- f n [] = n
--- f n (x:xs) = f (n+x) xs
--- Here n gets (Seq Keep [L]), but it's BAD BAD BAD to pass both n and n#
--- Needs more thought, but the simple thing to do is to accept the reboxing
--- stuff if there are any non-absent arguments (and that case is dealt with above):
-
- returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
- -- Don't pass the arg, rebox instead
-
- | otherwise ->
- WARN( True, ppr arg )
- returnUs ([arg], nop_fn, nop_fn)
-
-- Other cases
other_demand -> returnUs ([arg], nop_fn, nop_fn)
returnTc info2
tcPrag info (HsStrictness strict_info)
- = returnTc (info `setNewStrictnessInfo` Just strict_info)
+ = returnTc (info `setAllStrictnessInfo` Just strict_info)
tcPrag info (HsWorker nm arity)
= tcWorkerInfo unf_env ty info nm arity
projects / ghc-hetmet.git / commitdiff