{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
module GHC.Stg.InferTags.TagSig
where
import GHC.Prelude
import GHC.Types.Var
import GHC.Types.Name.Env( NameEnv )
import GHC.Utils.Outputable
import GHC.Utils.Binary
import GHC.Utils.Panic.Plain
import Data.Coerce
type StgCgInfos = NameEnv TagSig
newtype TagSig
= TagSig TagInfo
deriving (TagSig -> TagSig -> Bool
(TagSig -> TagSig -> Bool)
-> (TagSig -> TagSig -> Bool) -> Eq TagSig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TagSig -> TagSig -> Bool
== :: TagSig -> TagSig -> Bool
$c/= :: TagSig -> TagSig -> Bool
/= :: TagSig -> TagSig -> Bool
Eq)
data TagInfo
= TagDunno
| TagTuple [TagInfo]
| TagProper
| TagTagged
deriving (TagInfo -> TagInfo -> Bool
(TagInfo -> TagInfo -> Bool)
-> (TagInfo -> TagInfo -> Bool) -> Eq TagInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TagInfo -> TagInfo -> Bool
== :: TagInfo -> TagInfo -> Bool
$c/= :: TagInfo -> TagInfo -> Bool
/= :: TagInfo -> TagInfo -> Bool
Eq)
instance Outputable TagInfo where
ppr :: TagInfo -> SDoc
ppr TagInfo
TagTagged = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagTagged"
ppr TagInfo
TagDunno = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagDunno"
ppr TagInfo
TagProper = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagProper"
ppr (TagTuple [TagInfo]
tis) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagTuple" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets ((TagInfo -> SDoc) -> [TagInfo] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas TagInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TagInfo]
tis)
instance Binary TagInfo where
put_ :: WriteBinHandle -> TagInfo -> IO ()
put_ WriteBinHandle
bh TagInfo
TagDunno = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1
put_ WriteBinHandle
bh (TagTuple [TagInfo]
flds) = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
2 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> [TagInfo] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [TagInfo]
flds
put_ WriteBinHandle
bh TagInfo
TagProper = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
3
put_ WriteBinHandle
bh TagInfo
TagTagged = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
4
get :: ReadBinHandle -> IO TagInfo
get ReadBinHandle
bh = do tag <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
case tag of Word8
1 -> TagInfo -> IO TagInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TagInfo
TagDunno
Word8
2 -> [TagInfo] -> TagInfo
TagTuple ([TagInfo] -> TagInfo) -> IO [TagInfo] -> IO TagInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO [TagInfo]
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
Word8
3 -> TagInfo -> IO TagInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TagInfo
TagProper
Word8
4 -> TagInfo -> IO TagInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TagInfo
TagTagged
Word8
_ -> String -> IO TagInfo
forall a. HasCallStack => String -> a
panic (String
"get TagInfo " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
tag)
instance Outputable TagSig where
ppr :: TagSig -> SDoc
ppr (TagSig TagInfo
ti) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'<' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TagInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TagInfo
ti SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'>'
instance OutputableBndr (Id,TagSig) where
pprInfixOcc :: (Id, TagSig) -> SDoc
pprInfixOcc = (Id, TagSig) -> SDoc
forall a. Outputable a => a -> SDoc
ppr
pprPrefixOcc :: (Id, TagSig) -> SDoc
pprPrefixOcc = (Id, TagSig) -> SDoc
forall a. Outputable a => a -> SDoc
ppr
instance Binary TagSig where
put_ :: WriteBinHandle -> TagSig -> IO ()
put_ WriteBinHandle
bh (TagSig TagInfo
sig) = WriteBinHandle -> TagInfo -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh TagInfo
sig
get :: ReadBinHandle -> IO TagSig
get ReadBinHandle
bh = (TagInfo -> TagSig) -> IO (TagInfo -> TagSig)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TagInfo -> TagSig
TagSig IO (TagInfo -> TagSig) -> IO TagInfo -> IO TagSig
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO TagInfo
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
isTaggedSig :: TagSig -> Bool
isTaggedSig :: TagSig -> Bool
isTaggedSig (TagSig TagInfo
TagProper) = Bool
True
isTaggedSig (TagSig TagInfo
TagTagged) = Bool
True
isTaggedSig TagSig
_ = Bool
False
seqTagSig :: TagSig -> ()
seqTagSig :: TagSig -> ()
seqTagSig = (TagInfo -> ()) -> TagSig -> ()
forall a b. Coercible a b => a -> b
coerce TagInfo -> ()
seqTagInfo
seqTagInfo :: TagInfo -> ()
seqTagInfo :: TagInfo -> ()
seqTagInfo TagInfo
TagTagged = ()
seqTagInfo TagInfo
TagDunno = ()
seqTagInfo TagInfo
TagProper = ()
seqTagInfo (TagTuple [TagInfo]
tis) = (() -> TagInfo -> ()) -> () -> [TagInfo] -> ()
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\()
_unit TagInfo
sig -> TagSig -> ()
seqTagSig (TagInfo -> TagSig
forall a b. Coercible a b => a -> b
coerce TagInfo
sig)) () [TagInfo]
tis