{-# 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

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
text String
"TagTagged"
  ppr TagInfo
TagDunno       = String -> SDoc
text String
"TagDunno"
  ppr TagInfo
TagProper      = String -> SDoc
text String
"TagProper"
  ppr (TagTuple [TagInfo]
tis) = String -> SDoc
text String
"TagTuple" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
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_ :: 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 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> [TagInfo] -> IO ()
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 -> 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
<$> BinHandle -> IO [TagInfo]
forall a. Binary a => BinHandle -> IO a
get BinHandle
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. 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)

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)

instance Outputable TagSig where
  ppr :: TagSig -> SDoc
ppr (TagSig TagInfo
ti) = Char -> SDoc
char Char
'<' SDoc -> SDoc -> SDoc
<> TagInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TagInfo
ti SDoc -> SDoc -> SDoc
<> Char -> SDoc
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_ :: BinHandle -> TagSig -> IO ()
put_ BinHandle
bh (TagSig TagInfo
sig) = BinHandle -> TagInfo -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh TagInfo
sig
  get :: BinHandle -> IO TagSig
get BinHandle
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
<*> BinHandle -> IO TagInfo
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