{-# 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 it's own module we can avoid module loops.
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            -- 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagInfo -> TagInfo -> Bool
$c/= :: TagInfo -> TagInfo -> Bool
== :: TagInfo -> TagInfo -> Bool
$c== :: TagInfo -> TagInfo -> Bool
Eq)

instance Outputable TagInfo where
  ppr :: TagInfo -> SDoc
ppr TagInfo
TagTagged      = forall doc. IsLine doc => String -> doc
text String
"TagTagged"
  ppr TagInfo
TagDunno       = forall doc. IsLine doc => String -> doc
text String
"TagDunno"
  ppr TagInfo
TagProper      = forall doc. IsLine doc => String -> doc
text String
"TagProper"
  ppr (TagTuple [TagInfo]
tis) = forall doc. IsLine doc => String -> doc
text String
"TagTuple" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
brackets (forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. Outputable a => a -> SDoc
ppr [TagInfo]
tis)

instance Binary TagInfo where
  put_ :: BinHandle -> TagInfo -> IO ()
put_ BinHandle
bh TagInfo
TagDunno  = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
  put_ BinHandle
bh (TagTuple [TagInfo]
flds) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [TagInfo]
flds
  put_ BinHandle
bh TagInfo
TagProper = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
3
  put_ BinHandle
bh TagInfo
TagTagged = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
4

  get :: BinHandle -> IO TagInfo
get BinHandle
bh = do Word8
tag <- BinHandle -> IO Word8
getByte BinHandle
bh
              case Word8
tag of Word8
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return TagInfo
TagDunno
                          Word8
2 -> [TagInfo] -> TagInfo
TagTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                          Word8
3 -> forall (m :: * -> *) a. Monad m => a -> m a
return TagInfo
TagProper
                          Word8
4 -> forall (m :: * -> *) a. Monad m => a -> m a
return TagInfo
TagTagged
                          Word8
_ -> forall a. HasCallStack => String -> a
panic (String
"get TagInfo " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
tag)

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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagSig -> TagSig -> Bool
$c/= :: TagSig -> TagSig -> Bool
== :: TagSig -> TagSig -> Bool
$c== :: TagSig -> TagSig -> Bool
Eq)

instance Outputable TagSig where
  ppr :: TagSig -> SDoc
ppr (TagSig TagInfo
ti) = forall doc. IsLine doc => Char -> doc
char Char
'<' forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr TagInfo
ti forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => Char -> doc
char Char
'>'
instance OutputableBndr (Id,TagSig) where
  pprInfixOcc :: (Id, TagSig) -> SDoc
pprInfixOcc  = forall a. Outputable a => a -> SDoc
ppr
  pprPrefixOcc :: (Id, TagSig) -> SDoc
pprPrefixOcc = forall a. Outputable a => a -> SDoc
ppr

instance Binary TagSig where
  put_ :: BinHandle -> TagSig -> IO ()
put_ BinHandle
bh (TagSig TagInfo
sig) = forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh TagInfo
sig
  get :: BinHandle -> IO TagSig
get BinHandle
bh = forall (f :: * -> *) a. Applicative f => a -> f a
pure TagInfo -> TagSig
TagSig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Binary a => BinHandle -> IO a
get BinHandle
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 = coerce :: 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) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\()
_unit TagInfo
sig -> TagSig -> ()
seqTagSig (coerce :: forall a b. Coercible a b => a -> b
coerce TagInfo
sig)) () [TagInfo]
tis