{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-- | Types for the Constructed Product Result lattice. "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils"
-- are its primary customers via 'GHC.Types.Id.idCprInfo'.
module GHC.Types.Cpr (
    CprResult, topCpr, botCpr, conCpr, asConCpr,
    CprType (..), topCprType, botCprType, conCprType,
    lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy,
    CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig
  ) where

import GHC.Prelude

import GHC.Types.Basic
import GHC.Utils.Outputable
import GHC.Utils.Binary

--
-- * CprResult
--

-- | The constructed product result lattice.
--
-- @
--                    NoCPR
--                      |
--                 ConCPR ConTag
--                      |
--                    BotCPR
-- @
data CprResult = NoCPR          -- ^ Top of the lattice
               | ConCPR !ConTag -- ^ Returns a constructor from a data type
               | BotCPR         -- ^ Bottom of the lattice
               deriving( CprResult -> CprResult -> Bool
(CprResult -> CprResult -> Bool)
-> (CprResult -> CprResult -> Bool) -> Eq CprResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CprResult -> CprResult -> Bool
$c/= :: CprResult -> CprResult -> Bool
== :: CprResult -> CprResult -> Bool
$c== :: CprResult -> CprResult -> Bool
Eq, Arity -> CprResult -> ShowS
[CprResult] -> ShowS
CprResult -> String
(Arity -> CprResult -> ShowS)
-> (CprResult -> String)
-> ([CprResult] -> ShowS)
-> Show CprResult
forall a.
(Arity -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CprResult] -> ShowS
$cshowList :: [CprResult] -> ShowS
show :: CprResult -> String
$cshow :: CprResult -> String
showsPrec :: Arity -> CprResult -> ShowS
$cshowsPrec :: Arity -> CprResult -> ShowS
Show )

lubCpr :: CprResult -> CprResult -> CprResult
lubCpr :: CprResult -> CprResult -> CprResult
lubCpr (ConCPR Arity
t1) (ConCPR Arity
t2)
  | Arity
t1 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
t2               = Arity -> CprResult
ConCPR Arity
t1
lubCpr CprResult
BotCPR      CprResult
cpr     = CprResult
cpr
lubCpr CprResult
cpr         CprResult
BotCPR  = CprResult
cpr
lubCpr CprResult
_           CprResult
_       = CprResult
NoCPR

topCpr :: CprResult
topCpr :: CprResult
topCpr = CprResult
NoCPR

botCpr :: CprResult
botCpr :: CprResult
botCpr = CprResult
BotCPR

conCpr :: ConTag -> CprResult
conCpr :: Arity -> CprResult
conCpr = Arity -> CprResult
ConCPR

trimCpr :: CprResult -> CprResult
trimCpr :: CprResult -> CprResult
trimCpr ConCPR{} = CprResult
NoCPR
trimCpr CprResult
cpr      = CprResult
cpr

asConCpr :: CprResult -> Maybe ConTag
asConCpr :: CprResult -> Maybe Arity
asConCpr (ConCPR Arity
t)  = Arity -> Maybe Arity
forall a. a -> Maybe a
Just Arity
t
asConCpr CprResult
NoCPR       = Maybe Arity
forall a. Maybe a
Nothing
asConCpr CprResult
BotCPR      = Maybe Arity
forall a. Maybe a
Nothing

--
-- * CprType
--

-- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper.
data CprType
  = CprType
  { CprType -> Arity
ct_arty :: !Arity     -- ^ Number of value arguments the denoted expression
                          --   eats before returning the 'ct_cpr'
  , CprType -> CprResult
ct_cpr  :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to
                          --   'ct_arty' arguments
  }

instance Eq CprType where
  CprType
a == :: CprType -> CprType -> Bool
== CprType
b =  CprType -> CprResult
ct_cpr CprType
a CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprType -> CprResult
ct_cpr CprType
b
         Bool -> Bool -> Bool
&& (CprType -> Arity
ct_arty CprType
a Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== CprType -> Arity
ct_arty CprType
b Bool -> Bool -> Bool
|| CprType -> CprResult
ct_cpr CprType
a CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprResult
topCpr)

topCprType :: CprType
topCprType :: CprType
topCprType = Arity -> CprResult -> CprType
CprType Arity
0 CprResult
topCpr

botCprType :: CprType
botCprType :: CprType
botCprType = Arity -> CprResult -> CprType
CprType Arity
0 CprResult
botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments

conCprType :: ConTag -> CprType
conCprType :: Arity -> CprType
conCprType Arity
con_tag = Arity -> CprResult -> CprType
CprType Arity
0 (Arity -> CprResult
conCpr Arity
con_tag)

lubCprType :: CprType -> CprType -> CprType
lubCprType :: CprType -> CprType -> CprType
lubCprType ty1 :: CprType
ty1@(CprType Arity
n1 CprResult
cpr1) ty2 :: CprType
ty2@(CprType Arity
n2 CprResult
cpr2)
  -- The arity of bottom CPR types can be extended arbitrarily.
  | CprResult
cpr1 CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprResult
botCpr Bool -> Bool -> Bool
&& Arity
n1 Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= Arity
n2 = CprType
ty2
  | CprResult
cpr2 CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprResult
botCpr Bool -> Bool -> Bool
&& Arity
n2 Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= Arity
n1 = CprType
ty1
  -- There might be non-bottom CPR types with mismatching arities.
  -- Consider test DmdAnalGADTs. We want to return top in these cases.
  | Arity
n1 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
n2                   = Arity -> CprResult -> CprType
CprType Arity
n1 (CprResult -> CprResult -> CprResult
lubCpr CprResult
cpr1 CprResult
cpr2)
  | Bool
otherwise                  = CprType
topCprType

applyCprTy :: CprType -> Arity -> CprType
applyCprTy :: CprType -> Arity -> CprType
applyCprTy (CprType Arity
n CprResult
res) Arity
k
  | Arity
n Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
>= Arity
k        = Arity -> CprResult -> CprType
CprType (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
k) CprResult
res
  | CprResult
res CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprResult
botCpr = CprType
botCprType
  | Bool
otherwise     = CprType
topCprType

abstractCprTy :: CprType -> CprType
abstractCprTy :: CprType -> CprType
abstractCprTy (CprType Arity
n CprResult
res)
  | CprResult
res CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprResult
topCpr = CprType
topCprType
  | Bool
otherwise     = Arity -> CprResult -> CprType
CprType (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) CprResult
res

ensureCprTyArity :: Arity -> CprType -> CprType
ensureCprTyArity :: Arity -> CprType -> CprType
ensureCprTyArity Arity
n ty :: CprType
ty@(CprType Arity
m CprResult
_)
  | Arity
n Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
m    = CprType
ty
  | Bool
otherwise = CprType
topCprType

trimCprTy :: CprType -> CprType
trimCprTy :: CprType -> CprType
trimCprTy (CprType Arity
arty CprResult
res) = Arity -> CprResult -> CprType
CprType Arity
arty (CprResult -> CprResult
trimCpr CprResult
res)

-- | The arity of the wrapped 'CprType' is the arity at which it is safe
-- to unleash. See Note [Understanding DmdType and StrictSig] in "GHC.Types.Demand"
newtype CprSig = CprSig { CprSig -> CprType
getCprSig :: CprType }
  deriving (CprSig -> CprSig -> Bool
(CprSig -> CprSig -> Bool)
-> (CprSig -> CprSig -> Bool) -> Eq CprSig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CprSig -> CprSig -> Bool
$c/= :: CprSig -> CprSig -> Bool
== :: CprSig -> CprSig -> Bool
$c== :: CprSig -> CprSig -> Bool
Eq, BinHandle -> IO CprSig
BinHandle -> CprSig -> IO ()
BinHandle -> CprSig -> IO (Bin CprSig)
(BinHandle -> CprSig -> IO ())
-> (BinHandle -> CprSig -> IO (Bin CprSig))
-> (BinHandle -> IO CprSig)
-> Binary CprSig
forall a.
(BinHandle -> a -> IO ())
-> (BinHandle -> a -> IO (Bin a))
-> (BinHandle -> IO a)
-> Binary a
get :: BinHandle -> IO CprSig
$cget :: BinHandle -> IO CprSig
put :: BinHandle -> CprSig -> IO (Bin CprSig)
$cput :: BinHandle -> CprSig -> IO (Bin CprSig)
put_ :: BinHandle -> CprSig -> IO ()
$cput_ :: BinHandle -> CprSig -> IO ()
Binary)

-- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig'
-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in
-- "GHC.Types.Demand"
mkCprSigForArity :: Arity -> CprType -> CprSig
mkCprSigForArity :: Arity -> CprType -> CprSig
mkCprSigForArity Arity
arty CprType
ty = CprType -> CprSig
CprSig (Arity -> CprType -> CprType
ensureCprTyArity Arity
arty CprType
ty)

topCprSig :: CprSig
topCprSig :: CprSig
topCprSig = CprType -> CprSig
CprSig CprType
topCprType

mkCprSig :: Arity -> CprResult -> CprSig
mkCprSig :: Arity -> CprResult -> CprSig
mkCprSig Arity
arty CprResult
cpr = CprType -> CprSig
CprSig (Arity -> CprResult -> CprType
CprType Arity
arty CprResult
cpr)

seqCprSig :: CprSig -> ()
seqCprSig :: CprSig -> ()
seqCprSig CprSig
sig = CprSig
sig CprSig -> () -> ()
`seq` ()

instance Outputable CprResult where
  ppr :: CprResult -> SDoc
ppr CprResult
NoCPR        = SDoc
empty
  ppr (ConCPR Arity
n)   = Char -> SDoc
char Char
'm' SDoc -> SDoc -> SDoc
<> Arity -> SDoc
int Arity
n
  ppr CprResult
BotCPR       = Char -> SDoc
char Char
'b'

instance Outputable CprType where
  ppr :: CprType -> SDoc
ppr (CprType Arity
arty CprResult
res) = Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
arty SDoc -> SDoc -> SDoc
<> CprResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr CprResult
res

-- | Only print the CPR result
instance Outputable CprSig where
  ppr :: CprSig -> SDoc
ppr (CprSig CprType
ty) = CprResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CprType -> CprResult
ct_cpr CprType
ty)

instance Binary CprResult where
  put_ :: BinHandle -> CprResult -> IO ()
put_ BinHandle
bh (ConCPR Arity
n)   = do { BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0; BinHandle -> Arity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Arity
n }
  put_ BinHandle
bh CprResult
NoCPR        = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
  put_ BinHandle
bh CprResult
BotCPR       = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2

  get :: BinHandle -> IO CprResult
get  BinHandle
bh = do
          Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
          case Word8
h of
            Word8
0 -> do { Arity
n <- BinHandle -> IO Arity
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; CprResult -> IO CprResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Arity -> CprResult
ConCPR Arity
n) }
            Word8
1 -> CprResult -> IO CprResult
forall (m :: * -> *) a. Monad m => a -> m a
return CprResult
NoCPR
            Word8
_ -> CprResult -> IO CprResult
forall (m :: * -> *) a. Monad m => a -> m a
return CprResult
BotCPR

instance Binary CprType where
  put_ :: BinHandle -> CprType -> IO ()
put_ BinHandle
bh (CprType Arity
arty CprResult
cpr) = do
    BinHandle -> Arity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Arity
arty
    BinHandle -> CprResult -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh CprResult
cpr
  get :: BinHandle -> IO CprType
get  BinHandle
bh = Arity -> CprResult -> CprType
CprType (Arity -> CprResult -> CprType)
-> IO Arity -> IO (CprResult -> CprType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Arity
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (CprResult -> CprType) -> IO CprResult -> IO CprType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO CprResult
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh