module GHC.Stg.InferTags.TagSig
where
import GHC.Prelude
import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Utils.Binary
import GHC.Utils.Panic.Plain
import Data.Coerce
data TagInfo
= TagDunno
| TagTuple [TagInfo]
| TagProper
| TagTagged
deriving (Eq)
instance Outputable TagInfo where
ppr TagTagged = text "TagTagged"
ppr TagDunno = text "TagDunno"
ppr TagProper = text "TagProper"
ppr (TagTuple tis) = text "TagTuple" <> brackets (pprWithCommas ppr tis)
instance Binary TagInfo where
put_ bh TagDunno = putByte bh 1
put_ bh (TagTuple flds) = putByte bh 2 >> put_ bh flds
put_ bh TagProper = putByte bh 3
put_ bh TagTagged = putByte bh 4
get bh = do tag <- getByte bh
case tag of 1 -> return TagDunno
2 -> TagTuple <$> get bh
3 -> return TagProper
4 -> return TagTagged
_ -> panic ("get TagInfo " ++ show tag)
newtype TagSig
= TagSig TagInfo
deriving (Eq)
instance Outputable TagSig where
ppr (TagSig ti) = char '<' <> ppr ti <> char '>'
instance OutputableBndr (Id,TagSig) where
pprInfixOcc = ppr
pprPrefixOcc = ppr
instance Binary TagSig where
put_ bh (TagSig sig) = put_ bh sig
get bh = pure TagSig <*> get bh
isTaggedSig :: TagSig -> Bool
isTaggedSig (TagSig TagProper) = True
isTaggedSig (TagSig TagTagged) = True
isTaggedSig _ = False
seqTagSig :: TagSig -> ()
seqTagSig = coerce seqTagInfo
seqTagInfo :: TagInfo -> ()
seqTagInfo TagTagged = ()
seqTagInfo TagDunno = ()
seqTagInfo TagProper = ()
seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis