module GHC.Types.Id.Info (
IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,
JoinArity, isJoinIdDetails_maybe,
RecSelParent(..),
IdInfo,
vanillaIdInfo, noCafIdInfo,
OneShotInfo(..),
oneShotInfo, noOneShotInfo, hasNoOneShotInfo,
setOneShotInfo,
zapLamInfo, zapFragileInfo,
zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
zapTailCallInfo, zapCallArityInfo, zapUnfolding,
ArityInfo,
unknownArity,
arityInfo, setArityInfo, ppArityInfo,
callArityInfo, setCallArityInfo,
strictnessInfo, setStrictnessInfo,
cprInfo, setCprInfo,
demandInfo, setDemandInfo, pprStrictness,
unfoldingInfo, setUnfoldingInfo,
InlinePragInfo,
inlinePragInfo, setInlinePragInfo,
OccInfo(..),
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,
occInfo, setOccInfo,
InsideLam(..), BranchCount,
TailCallInfo(..),
tailCallInfo, isAlwaysTailCalled,
RuleInfo(..),
emptyRuleInfo,
isEmptyRuleInfo, ruleInfoFreeVars,
ruleInfoRules, setRuleInfoHead,
ruleInfo, setRuleInfo,
CafInfo(..),
ppCafInfo, mayHaveCafRefs,
cafInfo, setCafInfo,
LambdaFormInfo(..),
lfInfo, setLFInfo,
TickBoxOp(..), TickBoxId,
LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType,
isNeverLevPolyIdInfo
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Core hiding( hasCoreUnfolding )
import GHC.Core( hasCoreUnfolding )
import GHC.Core.Class
import GHC.Builtin.PrimOps (PrimOp)
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.PatSyn
import GHC.Core.Type
import GHC.Types.ForeignCall
import GHC.Utils.Outputable
import GHC.Unit.Module
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Utils.Misc
import Data.Word
import Data.Bits
import GHC.StgToCmm.Types (LambdaFormInfo (..))
infixl 1 `setRuleInfo`,
`setArityInfo`,
`setInlinePragInfo`,
`setUnfoldingInfo`,
`setOneShotInfo`,
`setOccInfo`,
`setCafInfo`,
`setStrictnessInfo`,
`setCprInfo`,
`setDemandInfo`,
`setNeverLevPoly`,
`setLevityInfoWithType`
data IdDetails
= VanillaId
| RecSelId
{ sel_tycon :: RecSelParent
, sel_naughty :: Bool
}
| DataConWorkId DataCon
| DataConWrapId DataCon
| ClassOpId Class
| PrimOpId PrimOp
| FCallId ForeignCall
| TickBoxOpId TickBoxOp
| DFunId Bool
| CoVarId
| JoinId JoinArity
data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq
instance Outputable RecSelParent where
ppr p = case p of
RecSelData ty_con -> ppr ty_con
RecSelPatSyn ps -> ppr ps
coVarDetails :: IdDetails
coVarDetails = CoVarId
isCoVarDetails :: IdDetails -> Bool
isCoVarDetails CoVarId = True
isCoVarDetails _ = False
isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity
isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity
isJoinIdDetails_maybe _ = Nothing
instance Outputable IdDetails where
ppr = pprIdDetails
pprIdDetails :: IdDetails -> SDoc
pprIdDetails VanillaId = empty
pprIdDetails other = brackets (pp other)
where
pp VanillaId = panic "pprIdDetails"
pp (DataConWorkId _) = text "DataCon"
pp (DataConWrapId _) = text "DataConWrapper"
pp (ClassOpId {}) = text "ClassOp"
pp (PrimOpId _) = text "PrimOp"
pp (FCallId _) = text "ForeignCall"
pp (TickBoxOpId _) = text "TickBoxOp"
pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)")
pp (RecSelId { sel_naughty = is_naughty })
= brackets $ text "RecSel" <>
ppWhen is_naughty (text "(naughty)")
pp CoVarId = text "CoVarId"
pp (JoinId arity) = text "JoinId" <> parens (int arity)
data IdInfo
= IdInfo {
ruleInfo :: RuleInfo,
unfoldingInfo :: Unfolding,
inlinePragInfo :: InlinePragma,
occInfo :: OccInfo,
strictnessInfo :: StrictSig,
cprInfo :: CprSig,
demandInfo :: Demand,
bitfield :: !BitField,
lfInfo :: !(Maybe LambdaFormInfo)
}
newtype BitField = BitField Word64
emptyBitField :: BitField
emptyBitField = BitField 0
bitfieldGetOneShotInfo :: BitField -> OneShotInfo
bitfieldGetOneShotInfo (BitField bits) =
if testBit bits 0 then OneShotLam else NoOneShotInfo
bitfieldGetCafInfo :: BitField -> CafInfo
bitfieldGetCafInfo (BitField bits) =
if testBit bits 1 then NoCafRefs else MayHaveCafRefs
bitfieldGetLevityInfo :: BitField -> LevityInfo
bitfieldGetLevityInfo (BitField bits) =
if testBit bits 2 then NeverLevityPolymorphic else NoLevityInfo
bitfieldGetCallArityInfo :: BitField -> ArityInfo
bitfieldGetCallArityInfo (BitField bits) =
fromIntegral (bits `shiftR` 3) .&. ((1 `shiftL` 30) 1)
bitfieldGetArityInfo :: BitField -> ArityInfo
bitfieldGetArityInfo (BitField bits) =
fromIntegral (bits `shiftR` 33)
bitfieldSetOneShotInfo :: OneShotInfo -> BitField -> BitField
bitfieldSetOneShotInfo info (BitField bits) =
case info of
NoOneShotInfo -> BitField (clearBit bits 0)
OneShotLam -> BitField (setBit bits 0)
bitfieldSetCafInfo :: CafInfo -> BitField -> BitField
bitfieldSetCafInfo info (BitField bits) =
case info of
MayHaveCafRefs -> BitField (clearBit bits 1)
NoCafRefs -> BitField (setBit bits 1)
bitfieldSetLevityInfo :: LevityInfo -> BitField -> BitField
bitfieldSetLevityInfo info (BitField bits) =
case info of
NoLevityInfo -> BitField (clearBit bits 2)
NeverLevityPolymorphic -> BitField (setBit bits 2)
bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField
bitfieldSetCallArityInfo info bf@(BitField bits) =
ASSERT(info < 2^(30 :: Int) 1)
bitfieldSetArityInfo (bitfieldGetArityInfo bf) $
BitField ((fromIntegral info `shiftL` 3) .|. (bits .&. 0b111))
bitfieldSetArityInfo :: ArityInfo -> BitField -> BitField
bitfieldSetArityInfo info (BitField bits) =
ASSERT(info < 2^(30 :: Int) 1)
BitField ((fromIntegral info `shiftL` 33) .|. (bits .&. ((1 `shiftL` 33) 1)))
levityInfo :: IdInfo -> LevityInfo
levityInfo = bitfieldGetLevityInfo . bitfield
oneShotInfo :: IdInfo -> OneShotInfo
oneShotInfo = bitfieldGetOneShotInfo . bitfield
arityInfo :: IdInfo -> ArityInfo
arityInfo = bitfieldGetArityInfo . bitfield
cafInfo :: IdInfo -> CafInfo
cafInfo = bitfieldGetCafInfo . bitfield
callArityInfo :: IdInfo -> ArityInfo
callArityInfo = bitfieldGetCallArityInfo . bitfield
setRuleInfo :: IdInfo -> RuleInfo -> IdInfo
setRuleInfo info sp = sp `seq` info { ruleInfo = sp }
setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
setOccInfo :: IdInfo -> OccInfo -> IdInfo
setOccInfo info oc = oc `seq` info { occInfo = oc }
setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo info uf
=
info { unfoldingInfo = uf }
setArityInfo :: IdInfo -> ArityInfo -> IdInfo
setArityInfo info ar =
info { bitfield = bitfieldSetArityInfo ar (bitfield info) }
setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo
setCallArityInfo info ar =
info { bitfield = bitfieldSetCallArityInfo ar (bitfield info) }
setCafInfo :: IdInfo -> CafInfo -> IdInfo
setCafInfo info caf =
info { bitfield = bitfieldSetCafInfo caf (bitfield info) }
setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo
setLFInfo info lf = info { lfInfo = Just lf }
setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo
setOneShotInfo info lb =
info { bitfield = bitfieldSetOneShotInfo lb (bitfield info) }
setDemandInfo :: IdInfo -> Demand -> IdInfo
setDemandInfo info dd = dd `seq` info { demandInfo = dd }
setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo
setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }
setCprInfo :: IdInfo -> CprSig -> IdInfo
setCprInfo info cpr = cpr `seq` info { cprInfo = cpr }
vanillaIdInfo :: IdInfo
vanillaIdInfo
= IdInfo {
ruleInfo = emptyRuleInfo,
unfoldingInfo = noUnfolding,
inlinePragInfo = defaultInlinePragma,
occInfo = noOccInfo,
demandInfo = topDmd,
strictnessInfo = nopSig,
cprInfo = topCprSig,
bitfield = bitfieldSetCafInfo vanillaCafInfo $
bitfieldSetArityInfo unknownArity $
bitfieldSetCallArityInfo unknownArity $
bitfieldSetOneShotInfo NoOneShotInfo $
bitfieldSetLevityInfo NoLevityInfo $
emptyBitField,
lfInfo = Nothing
}
noCafIdInfo :: IdInfo
noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
type ArityInfo = Arity
unknownArity :: Arity
unknownArity = 0
ppArityInfo :: Int -> SDoc
ppArityInfo 0 = empty
ppArityInfo n = hsep [text "Arity", int n]
type InlinePragInfo = InlinePragma
pprStrictness :: StrictSig -> SDoc
pprStrictness sig = ppr sig
data RuleInfo
= RuleInfo
[CoreRule]
DVarSet
emptyRuleInfo :: RuleInfo
emptyRuleInfo = RuleInfo [] emptyDVarSet
isEmptyRuleInfo :: RuleInfo -> Bool
isEmptyRuleInfo (RuleInfo rs _) = null rs
ruleInfoFreeVars :: RuleInfo -> DVarSet
ruleInfoFreeVars (RuleInfo _ fvs) = fvs
ruleInfoRules :: RuleInfo -> [CoreRule]
ruleInfoRules (RuleInfo rules _) = rules
setRuleInfoHead :: Name -> RuleInfo -> RuleInfo
setRuleInfoHead fn (RuleInfo rules fvs)
= RuleInfo (map (setRuleIdName fn) rules) fvs
data CafInfo
= MayHaveCafRefs
| NoCafRefs
deriving (Eq, Ord)
vanillaCafInfo :: CafInfo
vanillaCafInfo = MayHaveCafRefs
mayHaveCafRefs :: CafInfo -> Bool
mayHaveCafRefs MayHaveCafRefs = True
mayHaveCafRefs _ = False
instance Outputable CafInfo where
ppr = ppCafInfo
ppCafInfo :: CafInfo -> SDoc
ppCafInfo NoCafRefs = text "NoCafRefs"
ppCafInfo MayHaveCafRefs = empty
zapLamInfo :: IdInfo -> Maybe IdInfo
zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
| is_safe_occ occ && is_safe_dmd demand
= Nothing
| otherwise
= Just (info {occInfo = safe_occ, demandInfo = topDmd})
where
is_safe_occ occ | isAlwaysTailCalled occ = False
is_safe_occ (OneOcc { occ_in_lam = NotInsideLam }) = False
is_safe_occ _other = True
safe_occ = case occ of
OneOcc{} -> occ { occ_in_lam = IsInsideLam
, occ_tail = NoTailCallInfo }
IAmALoopBreaker{}
-> occ { occ_tail = NoTailCallInfo }
_other -> occ
is_safe_dmd dmd = not (isStrictDmd dmd)
zapDemandInfo :: IdInfo -> Maybe IdInfo
zapDemandInfo info = Just (info {demandInfo = topDmd})
zapUsageInfo :: IdInfo -> Maybe IdInfo
zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
zapUsageEnvInfo :: IdInfo -> Maybe IdInfo
zapUsageEnvInfo info
| hasDemandEnvSig (strictnessInfo info)
= Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)})
| otherwise
= Nothing
zapUsedOnceInfo :: IdInfo -> Maybe IdInfo
zapUsedOnceInfo info
= Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info)
, demandInfo = zapUsedOnceDemand (demandInfo info) }
zapFragileInfo :: IdInfo -> Maybe IdInfo
zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf })
= new_unf `seq`
Just (info `setRuleInfo` emptyRuleInfo
`setUnfoldingInfo` new_unf
`setOccInfo` zapFragileOcc occ)
where
new_unf = zapFragileUnfolding unf
zapFragileUnfolding :: Unfolding -> Unfolding
zapFragileUnfolding unf
| hasCoreUnfolding unf = noUnfolding
| otherwise = unf
zapUnfolding :: Unfolding -> Unfolding
zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding
| otherwise = noUnfolding
zapTailCallInfo :: IdInfo -> Maybe IdInfo
zapTailCallInfo info
= case occInfo info of
occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ)
| otherwise -> Nothing
where
safe_occ = occ { occ_tail = NoTailCallInfo }
zapCallArityInfo :: IdInfo -> IdInfo
zapCallArityInfo info = setCallArityInfo info 0
type TickBoxId = Int
data TickBoxOp
= TickBox Module !TickBoxId
instance Outputable TickBoxOp where
ppr (TickBox mod n) = text "tick" <+> ppr (mod,n)
data LevityInfo = NoLevityInfo
| NeverLevityPolymorphic
deriving Eq
instance Outputable LevityInfo where
ppr NoLevityInfo = text "NoLevityInfo"
ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic"
setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo
setNeverLevPoly info ty
= ASSERT2( not (resultIsLevPoly ty), ppr ty )
info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) }
setLevityInfoWithType :: IdInfo -> Type -> IdInfo
setLevityInfoWithType info ty
| not (resultIsLevPoly ty)
= info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) }
| otherwise
= info
isNeverLevPolyIdInfo :: IdInfo -> Bool
isNeverLevPolyIdInfo info
| NeverLevityPolymorphic <- levityInfo info = True
| otherwise = False