{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
module GHC.Types.Cpr (
Cpr (ConCpr), topCpr, botCpr, flatConCpr, asConCpr,
CprType (..), topCprType, botCprType, flatConCprType,
lubCprType, applyCprTy, abstractCprTy, trimCprTy,
UnpackConFieldsResult (..), unpackConFieldsCpr,
CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, seqCprSig
) where
import GHC.Prelude
import GHC.Core.DataCon
import GHC.Types.Basic
import GHC.Utils.Binary
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
data Cpr
= BotCpr
| ConCpr_ !ConTag ![Cpr]
| FlatConCpr !ConTag
| TopCpr
deriving Cpr -> Cpr -> Bool
(Cpr -> Cpr -> Bool) -> (Cpr -> Cpr -> Bool) -> Eq Cpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cpr -> Cpr -> Bool
$c/= :: Cpr -> Cpr -> Bool
== :: Cpr -> Cpr -> Bool
$c== :: Cpr -> Cpr -> Bool
Eq
pattern ConCpr :: ConTag -> [Cpr] -> Cpr
pattern $bConCpr :: ConTag -> [Cpr] -> Cpr
$mConCpr :: forall r. Cpr -> (ConTag -> [Cpr] -> r) -> (Void# -> r) -> r
ConCpr t cs <- ConCpr_ t cs where
ConCpr ConTag
t [Cpr]
cs
| (Cpr -> Bool) -> [Cpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
TopCpr) [Cpr]
cs = ConTag -> Cpr
FlatConCpr ConTag
t
| Bool
otherwise = ConTag -> [Cpr] -> Cpr
ConCpr_ ConTag
t [Cpr]
cs
{-# COMPLETE BotCpr, TopCpr, FlatConCpr, ConCpr #-}
viewConTag :: Cpr -> Maybe ConTag
viewConTag :: Cpr -> Maybe ConTag
viewConTag (FlatConCpr ConTag
t) = ConTag -> Maybe ConTag
forall a. a -> Maybe a
Just ConTag
t
viewConTag (ConCpr ConTag
t [Cpr]
_) = ConTag -> Maybe ConTag
forall a. a -> Maybe a
Just ConTag
t
viewConTag Cpr
_ = Maybe ConTag
forall a. Maybe a
Nothing
{-# INLINE viewConTag #-}
lubCpr :: Cpr -> Cpr -> Cpr
lubCpr :: Cpr -> Cpr -> Cpr
lubCpr Cpr
BotCpr Cpr
cpr = Cpr
cpr
lubCpr Cpr
cpr Cpr
BotCpr = Cpr
cpr
lubCpr (FlatConCpr ConTag
t1) (Cpr -> Maybe ConTag
viewConTag -> Just ConTag
t2)
| ConTag
t1 ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
t2 = ConTag -> Cpr
FlatConCpr ConTag
t1
lubCpr (Cpr -> Maybe ConTag
viewConTag -> Just ConTag
t1) (FlatConCpr ConTag
t2)
| ConTag
t1 ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
t2 = ConTag -> Cpr
FlatConCpr ConTag
t2
lubCpr (ConCpr ConTag
t1 [Cpr]
cs1) (ConCpr ConTag
t2 [Cpr]
cs2)
| ConTag
t1 ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
t2 = ConTag -> [Cpr] -> Cpr
ConCpr ConTag
t1 ([Cpr] -> [Cpr] -> [Cpr]
lubFieldCprs [Cpr]
cs1 [Cpr]
cs2)
lubCpr Cpr
_ Cpr
_ = Cpr
TopCpr
lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]
lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]
lubFieldCprs [Cpr]
as [Cpr]
bs
| [Cpr]
as [Cpr] -> [Cpr] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Cpr]
bs = (Cpr -> Cpr -> Cpr) -> [Cpr] -> [Cpr] -> [Cpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Cpr -> Cpr -> Cpr
lubCpr [Cpr]
as [Cpr]
bs
| Bool
otherwise = []
topCpr :: Cpr
topCpr :: Cpr
topCpr = Cpr
TopCpr
botCpr :: Cpr
botCpr :: Cpr
botCpr = Cpr
BotCpr
flatConCpr :: ConTag -> Cpr
flatConCpr :: ConTag -> Cpr
flatConCpr ConTag
t = ConTag -> Cpr
FlatConCpr ConTag
t
trimCpr :: Cpr -> Cpr
trimCpr :: Cpr -> Cpr
trimCpr Cpr
BotCpr = Cpr
botCpr
trimCpr Cpr
_ = Cpr
topCpr
asConCpr :: Cpr -> Maybe (ConTag, [Cpr])
asConCpr :: Cpr -> Maybe (ConTag, [Cpr])
asConCpr (ConCpr ConTag
t [Cpr]
cs) = (ConTag, [Cpr]) -> Maybe (ConTag, [Cpr])
forall a. a -> Maybe a
Just (ConTag
t, [Cpr]
cs)
asConCpr (FlatConCpr ConTag
t) = (ConTag, [Cpr]) -> Maybe (ConTag, [Cpr])
forall a. a -> Maybe a
Just (ConTag
t, [])
asConCpr Cpr
TopCpr = Maybe (ConTag, [Cpr])
forall a. Maybe a
Nothing
asConCpr Cpr
BotCpr = Maybe (ConTag, [Cpr])
forall a. Maybe a
Nothing
seqCpr :: Cpr -> ()
seqCpr :: Cpr -> ()
seqCpr (ConCpr ConTag
_ [Cpr]
cs) = (Cpr -> () -> ()) -> () -> [Cpr] -> ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (() -> () -> ()
seq (() -> () -> ()) -> (Cpr -> ()) -> Cpr -> () -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cpr -> ()
seqCpr) () [Cpr]
cs
seqCpr Cpr
_ = ()
data CprType
= CprType
{ CprType -> ConTag
ct_arty :: !Arity
, CprType -> Cpr
ct_cpr :: !Cpr
}
instance Eq CprType where
CprType
a == :: CprType -> CprType -> Bool
== CprType
b = CprType -> Cpr
ct_cpr CprType
a Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== CprType -> Cpr
ct_cpr CprType
b
Bool -> Bool -> Bool
&& (CprType -> ConTag
ct_arty CprType
a ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== CprType -> ConTag
ct_arty CprType
b Bool -> Bool -> Bool
|| CprType -> Cpr
ct_cpr CprType
a Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
topCpr)
topCprType :: CprType
topCprType :: CprType
topCprType = ConTag -> Cpr -> CprType
CprType ConTag
0 Cpr
topCpr
botCprType :: CprType
botCprType :: CprType
botCprType = ConTag -> Cpr -> CprType
CprType ConTag
0 Cpr
botCpr
flatConCprType :: ConTag -> CprType
flatConCprType :: ConTag -> CprType
flatConCprType ConTag
con_tag = CprType :: ConTag -> Cpr -> CprType
CprType { ct_arty :: ConTag
ct_arty = ConTag
0, ct_cpr :: Cpr
ct_cpr = ConTag -> Cpr
flatConCpr ConTag
con_tag }
lubCprType :: CprType -> CprType -> CprType
lubCprType :: CprType -> CprType -> CprType
lubCprType ty1 :: CprType
ty1@(CprType ConTag
n1 Cpr
cpr1) ty2 :: CprType
ty2@(CprType ConTag
n2 Cpr
cpr2)
| Cpr
cpr1 Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
botCpr Bool -> Bool -> Bool
&& ConTag
n1 ConTag -> ConTag -> Bool
forall a. Ord a => a -> a -> Bool
<= ConTag
n2 = CprType
ty2
| Cpr
cpr2 Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
botCpr Bool -> Bool -> Bool
&& ConTag
n2 ConTag -> ConTag -> Bool
forall a. Ord a => a -> a -> Bool
<= ConTag
n1 = CprType
ty1
| ConTag
n1 ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
n2 = ConTag -> Cpr -> CprType
CprType ConTag
n1 (Cpr -> Cpr -> Cpr
lubCpr Cpr
cpr1 Cpr
cpr2)
| Bool
otherwise = CprType
topCprType
applyCprTy :: CprType -> Arity -> CprType
applyCprTy :: CprType -> ConTag -> CprType
applyCprTy (CprType ConTag
n Cpr
res) ConTag
k
| ConTag
n ConTag -> ConTag -> Bool
forall a. Ord a => a -> a -> Bool
>= ConTag
k = ConTag -> Cpr -> CprType
CprType (ConTag
nConTag -> ConTag -> ConTag
forall a. Num a => a -> a -> a
-ConTag
k) Cpr
res
| Cpr
res Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
botCpr = CprType
botCprType
| Bool
otherwise = CprType
topCprType
abstractCprTy :: CprType -> CprType
abstractCprTy :: CprType -> CprType
abstractCprTy (CprType ConTag
n Cpr
res)
| Cpr
res Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
topCpr = CprType
topCprType
| Bool
otherwise = ConTag -> Cpr -> CprType
CprType (ConTag
nConTag -> ConTag -> ConTag
forall a. Num a => a -> a -> a
+ConTag
1) Cpr
res
trimCprTy :: CprType -> CprType
trimCprTy :: CprType -> CprType
trimCprTy (CprType ConTag
arty Cpr
res) = ConTag -> Cpr -> CprType
CprType ConTag
arty (Cpr -> Cpr
trimCpr Cpr
res)
data UnpackConFieldsResult
= AllFieldsSame !Cpr
| ForeachField ![Cpr]
unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult
unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult
unpackConFieldsCpr DataCon
dc (ConCpr ConTag
t [Cpr]
cs)
| ConTag
t ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> ConTag
dataConTag DataCon
dc, [Cpr]
cs [Cpr] -> ConTag -> Bool
forall a. [a] -> ConTag -> Bool
`lengthIs` DataCon -> ConTag
dataConRepArity DataCon
dc
= [Cpr] -> UnpackConFieldsResult
ForeachField [Cpr]
cs
unpackConFieldsCpr DataCon
_ Cpr
BotCpr = Cpr -> UnpackConFieldsResult
AllFieldsSame Cpr
BotCpr
unpackConFieldsCpr DataCon
_ Cpr
_ = Cpr -> UnpackConFieldsResult
AllFieldsSame Cpr
TopCpr
{-# INLINE unpackConFieldsCpr #-}
seqCprTy :: CprType -> ()
seqCprTy :: CprType -> ()
seqCprTy (CprType ConTag
_ Cpr
cpr) = Cpr -> ()
seqCpr Cpr
cpr
newtype CprSig = CprSig { CprSig -> CprType
getCprSig :: CprType }
deriving (CprSig -> CprSig -> Bool
(CprSig -> CprSig -> Bool)
-> (CprSig -> CprSig -> Bool) -> Eq CprSig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CprSig -> CprSig -> Bool
$c/= :: CprSig -> CprSig -> Bool
== :: CprSig -> CprSig -> Bool
$c== :: CprSig -> CprSig -> Bool
Eq, BinHandle -> IO CprSig
BinHandle -> CprSig -> IO ()
BinHandle -> CprSig -> IO (Bin CprSig)
(BinHandle -> CprSig -> IO ())
-> (BinHandle -> CprSig -> IO (Bin CprSig))
-> (BinHandle -> IO CprSig)
-> Binary CprSig
forall a.
(BinHandle -> a -> IO ())
-> (BinHandle -> a -> IO (Bin a))
-> (BinHandle -> IO a)
-> Binary a
get :: BinHandle -> IO CprSig
$cget :: BinHandle -> IO CprSig
put :: BinHandle -> CprSig -> IO (Bin CprSig)
$cput :: BinHandle -> CprSig -> IO (Bin CprSig)
put_ :: BinHandle -> CprSig -> IO ()
$cput_ :: BinHandle -> CprSig -> IO ()
Binary)
mkCprSigForArity :: Arity -> CprType -> CprSig
mkCprSigForArity :: ConTag -> CprType -> CprSig
mkCprSigForArity ConTag
arty ty :: CprType
ty@(CprType ConTag
n Cpr
_)
| ConTag
arty ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
/= ConTag
n = CprSig
topCprSig
| Bool
otherwise = CprType -> CprSig
CprSig CprType
ty
topCprSig :: CprSig
topCprSig :: CprSig
topCprSig = CprType -> CprSig
CprSig CprType
topCprType
isTopCprSig :: CprSig -> Bool
isTopCprSig :: CprSig -> Bool
isTopCprSig (CprSig CprType
ty) = CprType -> Cpr
ct_cpr CprType
ty Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
topCpr
mkCprSig :: Arity -> Cpr -> CprSig
mkCprSig :: ConTag -> Cpr -> CprSig
mkCprSig ConTag
arty Cpr
cpr = CprType -> CprSig
CprSig (ConTag -> Cpr -> CprType
CprType ConTag
arty Cpr
cpr)
seqCprSig :: CprSig -> ()
seqCprSig :: CprSig -> ()
seqCprSig (CprSig CprType
ty) = CprType -> ()
seqCprTy CprType
ty
instance Outputable Cpr where
ppr :: Cpr -> SDoc
ppr Cpr
TopCpr = SDoc
empty
ppr (FlatConCpr ConTag
n) = ConTag -> SDoc
int ConTag
n
ppr (ConCpr ConTag
n [Cpr]
cs) = ConTag -> SDoc
int ConTag
n SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens ((Cpr -> SDoc) -> [Cpr] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Cpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Cpr]
cs)
ppr Cpr
BotCpr = Char -> SDoc
char Char
'b'
instance Outputable CprType where
ppr :: CprType -> SDoc
ppr (CprType ConTag
arty Cpr
res)
| ConTag
0 <- ConTag
arty = Cpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cpr
res
| Bool
otherwise = Char -> SDoc
char Char
'\\' SDoc -> SDoc -> SDoc
<> ConTag -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConTag
arty SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'.' SDoc -> SDoc -> SDoc
<> Cpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cpr
res
instance Outputable CprSig where
ppr :: CprSig -> SDoc
ppr (CprSig CprType
ty) = Cpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CprType -> Cpr
ct_cpr CprType
ty)
instance Binary Cpr where
put_ :: BinHandle -> Cpr -> IO ()
put_ BinHandle
bh Cpr
TopCpr = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
put_ BinHandle
bh Cpr
BotCpr = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
put_ BinHandle
bh (FlatConCpr ConTag
n) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2 IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> ConTag -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh ConTag
n
put_ BinHandle
bh (ConCpr ConTag
n [Cpr]
cs) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
3 IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> ConTag -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh ConTag
n IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> [Cpr] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Cpr]
cs
get :: BinHandle -> IO Cpr
get BinHandle
bh = do
Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
case Word8
h of
Word8
0 -> Cpr -> IO Cpr
forall (m :: * -> *) a. Monad m => a -> m a
return Cpr
TopCpr
Word8
1 -> Cpr -> IO Cpr
forall (m :: * -> *) a. Monad m => a -> m a
return Cpr
BotCpr
Word8
2 -> ConTag -> Cpr
FlatConCpr (ConTag -> Cpr) -> IO ConTag -> IO Cpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO ConTag
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Word8
3 -> ConTag -> [Cpr] -> Cpr
ConCpr (ConTag -> [Cpr] -> Cpr) -> IO ConTag -> IO ([Cpr] -> Cpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO ConTag
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO ([Cpr] -> Cpr) -> IO [Cpr] -> IO Cpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO [Cpr]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Word8
_ -> String -> SDoc -> IO Cpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Binary Cpr: Invalid tag" (ConTag -> SDoc
int (Word8 -> ConTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
h))
instance Binary CprType where
put_ :: BinHandle -> CprType -> IO ()
put_ BinHandle
bh (CprType ConTag
arty Cpr
cpr) = BinHandle -> ConTag -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh ConTag
arty IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> Cpr -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Cpr
cpr
get :: BinHandle -> IO CprType
get BinHandle
bh = ConTag -> Cpr -> CprType
CprType (ConTag -> Cpr -> CprType) -> IO ConTag -> IO (Cpr -> CprType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO ConTag
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (Cpr -> CprType) -> IO Cpr -> IO CprType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO Cpr
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh