{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}

-- We export this type from this module instead of GHC.Stg.EnforceEpt.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.EnforceEpt.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

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

-- Note [TagSig and TagInfo]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
-- 'TagSig' describes a *binding*; 'TagInfo' describes a *runtime value*.
--
-- A binding denotes either a value or a function:
--
--   * 'TagVal' i   — the binding holds a value whose runtime shape is 'i'.
--                    'i' covers thunks (TagDunno), evaluated/tagged heap
--                    pointers (TagEPT), unboxed tuples (TagTuple), and
--                    bottoming computations (TagBottoming).
--
--   * 'TagFun' i   — the binding is a function or join point. A function
--                    closure is always EPT. 'i' describes what a
--                    *saturated call* returns.
--                    See Note [TagInfo of functions] in GHC.Stg.EnforceEpt.
--
-- This split keeps 'combineAltInfo' at the value level: case alternatives
-- combine 'TagInfo', not 'TagSig'. An alternative that returns a function
-- closure gets 'TagEPT' (closure pointer is tagged) with no tracked return
-- info — the return info only matters once the function is applied, and at
-- that point it's looked up from the binding's 'TagSig' via
-- 'lookupReturnInfo'.

-- | The signature attached to a binding.
data TagSig
  = TagVal TagInfo        -- ^ A value binding (thunk, constructor, etc.)
  | TagFun TagInfo        -- ^ A function/join-point binding; carries the
                          -- TagInfo of saturated-call return values.
                          -- See Note [TagInfo of functions].
  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)

-- Note [TagInfo lattice]
-- ~~~~~~~~~~~~~~~~~~~~~~
-- The TagInfo lattice describes what we know about whether a runtime value
-- is properly tagged (pointer tag bits set for heap pointers):
--
--   TagBottoming (bottom) ⊑ {TagEPT, TagTuple _} ⊑ TagDunno (top)
--
-- TagBottoming is the identity element for 'combineAltInfo': it is used as
-- the initial signature in fixpoint loops and for dead-end (bottoming)
-- computations, since their return value can be given any tag — they never
-- actually return.

-- | What we know about a runtime value.
data TagInfo
  = TagDunno            -- ^ We don't know anything about the tag.
  | TagTuple [TagInfo]  -- ^ An unboxed tuple with taginfo for each element.
  | TagEPT              -- ^ An evaluated and properly tagged value.
                        -- See Note [Evaluated and Properly Tagged].
  | TagBottoming        -- ^ Bottom of the domain.
                        -- See Note [Bottom functions are TagBottoming] in GHC.Stg.EnforceEpt.
  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
TagBottoming      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagBottoming"
  ppr TagInfo
TagDunno          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagDunno"
  ppr TagInfo
TagEPT            = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagEPT"
  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
TagEPT          = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
3
  put_ WriteBinHandle
bh TagInfo
TagBottoming    = 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
[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
TagEPT
                          Word8
4 -> TagInfo -> IO TagInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TagInfo
TagBottoming
                          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 (TagVal TagInfo
ti) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'<' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagVal" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (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
'>'
  ppr (TagFun TagInfo
ti) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'<' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagFun" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (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 (TagVal TagInfo
ti) = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1 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
ti
  put_ WriteBinHandle
bh (TagFun TagInfo
ti) = 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
ti
  get :: ReadBinHandle -> IO TagSig
get ReadBinHandle
bh = do tag <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
              case tag of Word8
1 -> TagInfo -> TagSig
TagInfo -> TagSig
TagVal (TagInfo -> TagSig) -> IO TagInfo -> IO TagSig
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
2 -> TagInfo -> TagSig
TagInfo -> TagSig
TagFun (TagInfo -> TagSig) -> IO TagInfo -> IO TagSig
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
_ -> String -> IO TagSig
forall a. HasCallStack => String -> a
panic (String
"get TagSig " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
tag)

-- | Is the given binding known to be properly tagged (or irrelevant, as for
-- unboxed values and bottoming computations)?
isTaggedSig :: TagSig -> Bool
isTaggedSig :: TagSig -> Bool
isTaggedSig (TagFun TagInfo
_)  = Bool
True
isTaggedSig (TagVal TagInfo
ti) = TagInfo -> Bool
isTaggedInfo TagInfo
ti

-- | Is the given value-level tag known to be properly tagged?
-- NB: unboxed tuples are *not* treated as tagged here; they are handled
-- specially by the rewriter (which considers them already evaluated).
isTaggedInfo :: TagInfo -> Bool
isTaggedInfo :: TagInfo -> Bool
isTaggedInfo TagInfo
TagEPT       = Bool
True
isTaggedInfo TagInfo
TagBottoming = Bool
True
isTaggedInfo TagInfo
_            = Bool
False

seqTagSig :: TagSig -> ()
seqTagSig :: TagSig -> ()
seqTagSig (TagVal TagInfo
ti) = TagInfo -> ()
seqTagInfo TagInfo
ti
seqTagSig (TagFun TagInfo
ti) = TagInfo -> ()
seqTagInfo TagInfo
ti

seqTagInfo :: TagInfo -> ()
seqTagInfo :: TagInfo -> ()
seqTagInfo TagInfo
TagBottoming   = ()
seqTagInfo TagInfo
TagDunno       = ()
seqTagInfo TagInfo
TagEPT         = ()
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
info -> TagInfo -> ()
seqTagInfo TagInfo
info) () [TagInfo]
tis