    {-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE ConstraintKinds #-}

    -- We export this type from this module instead of GHC.Stg.InferTags.Types
    -- because it's used by more than the analysis itself. For example in interface
    -- files where we record a tag signature for bindings.
    -- By putting the sig into its own module we can avoid module loops.
    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

    -- | Information to be exposed in interface files which is produced
    -- by the stg2stg passes.
    type StgCgInfos = NameEnv TagSig

    newtype TagSig  -- The signature for each binding, this is a newtype as we might
                    -- want to track more information in the future.
      = 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            -- We don't know anything about the tag.
      | TagTuple [TagInfo]  -- Represents a function/thunk which when evaluated
                            -- will return a Unboxed tuple whos components have
                            -- the given TagInfos.
      | TagProper           -- Heap pointer to properly-tagged value
      | TagTagged           -- Bottom of the domain.
      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