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