    {-# 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
    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
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (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) = forall a. a -> Maybe a
    Just Arity
    t
    viewConTag (ConCpr Arity
    t [Cpr]
    _)   = forall a. a -> Maybe a
    Just Arity
    t
    viewConTag Cpr
    _              = 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 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 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 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 forall a b. [a] -> [b] -> Bool
    `equalLength` [Cpr]
    bs = 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)  = forall a. a -> Maybe a
    Just (Arity
    t, [Cpr]
    cs)
    asConCpr (FlatConCpr Arity
    t) = forall a. a -> Maybe a
    Just (Arity
    t, [])
    asConCpr Cpr
    TopCpr         = forall a. Maybe a
    Nothing
    asConCpr Cpr
    BotCpr         = forall a. Maybe a
    Nothing

    seqCpr :: Cpr -> ()
    seqCpr :: Cpr -> ()
    seqCpr (ConCpr Arity
    _ [Cpr]
    cs) = forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (seq :: forall a b. a -> b -> b
    seq 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 forall a. Eq a => a -> a -> Bool
    == CprType -> Cpr
    ct_cpr CprType
    b
             Bool -> Bool -> Bool
    && (CprType -> Arity
    ct_arty CprType
    a forall a. Eq a => a -> a -> Bool
    == CprType -> Arity
    ct_arty CprType
    b Bool -> Bool -> Bool
    || CprType -> Cpr
    ct_cpr CprType
    a 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 forall a. Eq a => a -> a -> Bool
    == Cpr
    botCpr Bool -> Bool -> Bool
    && Arity
    n1 forall a. Ord a => a -> a -> Bool
    <= Arity
    n2 = CprType
    ty2
      | Cpr
    cpr2 forall a. Eq a => a -> a -> Bool
    == Cpr
    botCpr Bool -> Bool -> Bool
    && Arity
    n2 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 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 forall a. Ord a => a -> a -> Bool
    >= Arity
    k        = Arity -> Cpr -> CprType
    CprType (Arity
    nforall a. Num a => a -> a -> a
    -Arity
    k) Cpr
    res
      | Cpr
    res 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 forall a. Eq a => a -> a -> Bool
    == Cpr
    topCpr = CprType
    topCprType
      | Bool
    otherwise     = Arity -> Cpr -> CprType
    CprType (Arity
    nforall 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 forall a. Eq a => a -> a -> Bool
    == DataCon -> Arity
    dataConTag DataCon
    dc, [Cpr]
    cs 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
    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)
    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 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 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 (forall a. (a -> SDoc) -> [a] -> SDoc
    pprWithCommas 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) = forall a. Outputable a => a -> SDoc
    ppr Arity
    arty SDoc -> SDoc -> 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) = 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> forall a. Binary a => BinHandle -> a -> IO ()
    put_ BinHandle
    bh Arity
    n forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
    return Cpr
    TopCpr
          Word8
    1 -> forall (m :: * -> *) a. Monad m => a -> m a
    return Cpr
    BotCpr
          Word8
    2 -> Arity -> Cpr
    FlatConCpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall a. Binary a => BinHandle -> IO a
    get BinHandle
    bh
          Word8
    3 -> Arity -> [Cpr] -> Cpr
    ConCpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall a. Binary a => BinHandle -> IO a
    get BinHandle
    bh forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> forall a. Binary a => BinHandle -> IO a
    get BinHandle
    bh
          Word8
    _ -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "Binary Cpr: Invalid tag" (Arity -> SDoc
    int (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) = forall a. Binary a => BinHandle -> a -> IO ()
    put_ BinHandle
    bh Arity
    arty forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> forall a. Binary a => BinHandle -> a -> IO ()
    put_ BinHandle
    bh Cpr
    cpr
      get :: BinHandle -> IO CprType
    get  BinHandle
    bh                    = Arity -> Cpr -> CprType
    CprType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall a. Binary a => BinHandle -> IO a
    get BinHandle
    bh forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> forall a. Binary a => BinHandle -> IO a
    get BinHandle
    bh