{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}

-- | 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 (
    Cpr (ConCpr), topCpr, botCpr, flatConCpr, asConCpr,
    CprType (..), topCprType, botCprType, flatConCprType,
    lubCprType, applyCprTy, abstractCprTy, trimCprTy,
    UnpackConFieldsResult (..), unpackConFieldsCpr,
    CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, seqCprSig
  ) where

import GHC.Prelude

import GHC.Core.DataCon
import GHC.Types.Basic
import GHC.Utils.Binary
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic

--
-- * Cpr
--

data Cpr
  = BotCpr
  | ConCpr_ !ConTag ![Cpr]
  -- ^ The number of field Cprs equals 'dataConRepArity'.
  -- If all of them are top, better use 'FlatConCpr', as ensured by the pattern
  -- synonym 'ConCpr'.
  | FlatConCpr !ConTag
  | TopCpr
  deriving Cpr -> Cpr -> Bool
(Cpr -> Cpr -> Bool) -> (Cpr -> Cpr -> Bool) -> Eq Cpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cpr -> Cpr -> Bool
$c/= :: Cpr -> Cpr -> Bool
== :: Cpr -> Cpr -> Bool
$c== :: Cpr -> Cpr -> Bool
Eq

pattern ConCpr :: ConTag -> [Cpr] -> Cpr
pattern $mConCpr :: forall {r}. Cpr -> (Arity -> [Cpr] -> r) -> ((# #) -> r) -> r
$bConCpr :: Arity -> [Cpr] -> Cpr
ConCpr t cs <- ConCpr_ t cs where
  ConCpr Arity
t [Cpr]
cs
    | (Cpr -> Bool) -> [Cpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
TopCpr) [Cpr]
cs = Arity -> Cpr
FlatConCpr Arity
t
    | Bool
otherwise          = Arity -> [Cpr] -> Cpr
ConCpr_ Arity
t [Cpr]
cs
{-# COMPLETE BotCpr, TopCpr, FlatConCpr, ConCpr #-}

viewConTag :: Cpr -> Maybe ConTag
viewConTag :: Cpr -> Maybe Arity
viewConTag (FlatConCpr Arity
t) = Arity -> Maybe Arity
forall a. a -> Maybe a
Just Arity
t
viewConTag (ConCpr Arity
t [Cpr]
_)   = Arity -> Maybe Arity
forall a. a -> Maybe a
Just Arity
t
viewConTag Cpr
_              = Maybe Arity
forall a. Maybe a
Nothing
{-# INLINE viewConTag #-}

lubCpr :: Cpr -> Cpr -> Cpr
lubCpr :: Cpr -> Cpr -> Cpr
lubCpr Cpr
BotCpr      Cpr
cpr     = Cpr
cpr
lubCpr Cpr
cpr         Cpr
BotCpr  = Cpr
cpr
lubCpr (FlatConCpr Arity
t1) (Cpr -> Maybe Arity
viewConTag -> Just Arity
t2)
  | Arity
t1 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
t2 = Arity -> Cpr
FlatConCpr Arity
t1
lubCpr (Cpr -> Maybe Arity
viewConTag -> Just Arity
t1) (FlatConCpr Arity
t2)
  | Arity
t1 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
t2 = Arity -> Cpr
FlatConCpr Arity
t2
lubCpr (ConCpr Arity
t1 [Cpr]
cs1) (ConCpr Arity
t2 [Cpr]
cs2)
  | Arity
t1 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
t2 = Arity -> [Cpr] -> Cpr
ConCpr Arity
t1 ([Cpr] -> [Cpr] -> [Cpr]
lubFieldCprs [Cpr]
cs1 [Cpr]
cs2)
lubCpr Cpr
_           Cpr
_       = Cpr
TopCpr

lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]
lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]
lubFieldCprs [Cpr]
as [Cpr]
bs
  | [Cpr]
as [Cpr] -> [Cpr] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Cpr]
bs = (Cpr -> Cpr -> Cpr) -> [Cpr] -> [Cpr] -> [Cpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Cpr -> Cpr -> Cpr
lubCpr [Cpr]
as [Cpr]
bs
  | Bool
otherwise           = []

topCpr :: Cpr
topCpr :: Cpr
topCpr = Cpr
TopCpr

botCpr :: Cpr
botCpr :: Cpr
botCpr = Cpr
BotCpr

flatConCpr :: ConTag -> Cpr
flatConCpr :: Arity -> Cpr
flatConCpr Arity
t = Arity -> Cpr
FlatConCpr Arity
t

trimCpr :: Cpr -> Cpr
trimCpr :: Cpr -> Cpr
trimCpr Cpr
BotCpr = Cpr
botCpr
trimCpr Cpr
_      = Cpr
topCpr

asConCpr :: Cpr -> Maybe (ConTag, [Cpr])
asConCpr :: Cpr -> Maybe (Arity, [Cpr])
asConCpr (ConCpr Arity
t [Cpr]
cs)  = (Arity, [Cpr]) -> Maybe (Arity, [Cpr])
forall a. a -> Maybe a
Just (Arity
t, [Cpr]
cs)
asConCpr (FlatConCpr Arity
t) = (Arity, [Cpr]) -> Maybe (Arity, [Cpr])
forall a. a -> Maybe a
Just (Arity
t, [])
asConCpr Cpr
TopCpr         = Maybe (Arity, [Cpr])
forall a. Maybe a
Nothing
asConCpr Cpr
BotCpr         = Maybe (Arity, [Cpr])
forall a. Maybe a
Nothing

seqCpr :: Cpr -> ()
seqCpr :: Cpr -> ()
seqCpr (ConCpr Arity
_ [Cpr]
cs) = (Cpr -> () -> ()) -> () -> [Cpr] -> ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (() -> () -> ()
seq (() -> () -> ()) -> (Cpr -> ()) -> Cpr -> () -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cpr -> ()
seqCpr) () [Cpr]
cs
seqCpr Cpr
_             = ()

--
-- * 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 -> Cpr
ct_cpr  :: !Cpr   -- ^ 'Cpr' eventually unleashed when applied to
                      --   'ct_arty' arguments
  }

instance Eq CprType where
  CprType
a == :: CprType -> CprType -> Bool
== CprType
b =  CprType -> Cpr
ct_cpr CprType
a Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== CprType -> Cpr
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 -> Cpr
ct_cpr CprType
a Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
topCpr)

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

botCprType :: CprType
botCprType :: CprType
botCprType = Arity -> Cpr -> CprType
CprType Arity
0 Cpr
botCpr

flatConCprType :: ConTag -> CprType
flatConCprType :: Arity -> CprType
flatConCprType Arity
con_tag = CprType { ct_arty :: Arity
ct_arty = Arity
0, ct_cpr :: Cpr
ct_cpr = Arity -> Cpr
flatConCpr Arity
con_tag }

lubCprType :: CprType -> CprType -> CprType
lubCprType :: CprType -> CprType -> CprType
lubCprType ty1 :: CprType
ty1@(CprType Arity
n1 Cpr
cpr1) ty2 :: CprType
ty2@(CprType Arity
n2 Cpr
cpr2)
  -- The arity of bottom CPR types can be extended arbitrarily.
  | Cpr
cpr1 Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
botCpr Bool -> Bool -> Bool
&& Arity
n1 Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= Arity
n2 = CprType
ty2
  | Cpr
cpr2 Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
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 -> Cpr -> CprType
CprType Arity
n1 (Cpr -> Cpr -> Cpr
lubCpr Cpr
cpr1 Cpr
cpr2)
  | Bool
otherwise                  = CprType
topCprType

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

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

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

-- | The result of 'unpackConFieldsCpr'.
data UnpackConFieldsResult
  = AllFieldsSame !Cpr
  | ForeachField ![Cpr]

-- | Unpacks a 'ConCpr'-shaped 'Cpr' and returns the field 'Cpr's wrapped in a
-- 'ForeachField'. Otherwise, it returns 'AllFieldsSame' with the appropriate
-- 'Cpr' to assume for each field.
--
-- The use of 'UnpackConFieldsResult' allows O(1) space for the common,
-- non-'ConCpr' case.
unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult
unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult
unpackConFieldsCpr DataCon
dc (ConCpr Arity
t [Cpr]
cs)
  | Arity
t Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Arity
dataConTag DataCon
dc, [Cpr]
cs [Cpr] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthIs` DataCon -> Arity
dataConRepArity DataCon
dc
  = [Cpr] -> UnpackConFieldsResult
ForeachField [Cpr]
cs
unpackConFieldsCpr DataCon
_  Cpr
BotCpr = Cpr -> UnpackConFieldsResult
AllFieldsSame Cpr
BotCpr
unpackConFieldsCpr DataCon
_  Cpr
_      = Cpr -> UnpackConFieldsResult
AllFieldsSame Cpr
TopCpr
{-# INLINE unpackConFieldsCpr #-}

seqCprTy :: CprType -> ()
seqCprTy :: CprType -> ()
seqCprTy (CprType Arity
_ Cpr
cpr) = Cpr -> ()
seqCpr Cpr
cpr

-- | 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 ty :: CprType
ty@(CprType Arity
n Cpr
cpr)
  | Arity
arty Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
/= Arity
n         = CprSig
topCprSig
      -- Trim on arity mismatch
  | ConCpr Arity
t [Cpr]
_ <- Cpr
cpr = CprType -> CprSig
CprSig (Arity -> Cpr -> CprType
CprType Arity
n (Arity -> Cpr
flatConCpr Arity
t))
      -- Flatten nested CPR info, we don't exploit it (yet)
  | Bool
otherwise         = CprType -> CprSig
CprSig CprType
ty

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

isTopCprSig :: CprSig -> Bool
isTopCprSig :: CprSig -> Bool
isTopCprSig (CprSig CprType
ty) = CprType -> Cpr
ct_cpr CprType
ty Cpr -> Cpr -> Bool
forall a. Eq a => a -> a -> Bool
== Cpr
topCpr

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

seqCprSig :: CprSig -> ()
seqCprSig :: CprSig -> ()
seqCprSig (CprSig CprType
ty) = CprType -> ()
seqCprTy CprType
ty

-- | BNF:
-- ```
--   cpr ::= ''                               -- TopCpr
--        |  n                                -- FlatConCpr n
--        |  n '(' cpr1 ',' cpr2 ',' ... ')'  -- ConCpr n [cpr1,cpr2,...]
--        |  'b'                              -- BotCpr
-- ```
-- Examples:
--   * `f x = f x` has denotation `b`
--   * `1(1,)` is a valid (nested) 'Cpr' denotation for `(I# 42#, f 42)`.
instance Outputable Cpr where
  ppr :: Cpr -> SDoc
ppr Cpr
TopCpr         = SDoc
empty
  ppr (FlatConCpr Arity
n) = Arity -> SDoc
int Arity
n
  ppr (ConCpr Arity
n [Cpr]
cs)  = Arity -> SDoc
int Arity
n SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens ((Cpr -> SDoc) -> [Cpr] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Cpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Cpr]
cs)
  ppr Cpr
BotCpr         = Char -> SDoc
char Char
'b'

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

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

instance Binary Cpr where
  put_ :: BinHandle -> Cpr -> IO ()
put_ BinHandle
bh Cpr
TopCpr         = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
  put_ BinHandle
bh Cpr
BotCpr         = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
  put_ BinHandle
bh (FlatConCpr Arity
n) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2 IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> Arity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Arity
n
  put_ BinHandle
bh (ConCpr Arity
n [Cpr]
cs)  = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
3 IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> Arity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Arity
n IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> [Cpr] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Cpr]
cs
  get :: BinHandle -> IO Cpr
get  BinHandle
bh = do
    Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
    case Word8
h of
      Word8
0 -> Cpr -> IO Cpr
forall (m :: * -> *) a. Monad m => a -> m a
return Cpr
TopCpr
      Word8
1 -> Cpr -> IO Cpr
forall (m :: * -> *) a. Monad m => a -> m a
return Cpr
BotCpr
      Word8
2 -> Arity -> Cpr
FlatConCpr (Arity -> Cpr) -> IO Arity -> IO Cpr
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
      Word8
3 -> Arity -> [Cpr] -> Cpr
ConCpr (Arity -> [Cpr] -> Cpr) -> IO Arity -> IO ([Cpr] -> Cpr)
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 ([Cpr] -> Cpr) -> IO [Cpr] -> IO Cpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO [Cpr]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
      Word8
_ -> String -> SDoc -> IO Cpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Binary Cpr: Invalid tag" (Arity -> SDoc
int (Word8 -> Arity
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
h))

instance Binary CprType where
  put_ :: BinHandle -> CprType -> IO ()
put_ BinHandle
bh (CprType Arity
arty Cpr
cpr) = BinHandle -> Arity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Arity
arty IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> Cpr -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Cpr
cpr
  get :: BinHandle -> IO CprType
get  BinHandle
bh                    = Arity -> Cpr -> CprType
CprType (Arity -> Cpr -> CprType) -> IO Arity -> IO (Cpr -> 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 (Cpr -> CprType) -> IO Cpr -> IO CprType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO Cpr
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh