GHC/Types/Cpr.hs

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

    pattern ConCpr :: ConTag -> [Cpr] -> Cpr
    pattern ConCpr t cs <- ConCpr_ t cs where
      ConCpr t cs
        | all (== TopCpr) cs = FlatConCpr t
        | otherwise          = ConCpr_ t cs
    {-# COMPLETE BotCpr, TopCpr, FlatConCpr, ConCpr #-}

    viewConTag :: Cpr -> Maybe ConTag
    viewConTag (FlatConCpr t) = Just t
    viewConTag (ConCpr t _)   = Just t
    viewConTag _              = Nothing
    {-# INLINE viewConTag #-}

    lubCpr :: Cpr -> Cpr -> Cpr
    lubCpr BotCpr      cpr     = cpr
    lubCpr cpr         BotCpr  = cpr
    lubCpr (FlatConCpr t1) (viewConTag -> Just t2)
      | t1 == t2 = FlatConCpr t1
    lubCpr (viewConTag -> Just t1) (FlatConCpr t2)
      | t1 == t2 = FlatConCpr t2
    lubCpr (ConCpr t1 cs1) (ConCpr t2 cs2)
      | t1 == t2 = ConCpr t1 (lubFieldCprs cs1 cs2)
    lubCpr _           _       = TopCpr

    lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]
    lubFieldCprs as bs
      | as `equalLength` bs = zipWith lubCpr as bs
      | otherwise           = []

    topCpr :: Cpr
    topCpr = TopCpr

    botCpr :: Cpr
    botCpr = BotCpr

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

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

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

    seqCpr :: Cpr -> ()
    seqCpr (ConCpr _ cs) = foldr (seq . seqCpr) () cs
    seqCpr _             = ()

    --
    -- * CprType
    --

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

    instance Eq CprType where
      a == b =  ct_cpr a == ct_cpr b
             && (ct_arty a == ct_arty b || ct_cpr a == topCpr)

    topCprType :: CprType
    topCprType = CprType 0 topCpr

    botCprType :: CprType
    botCprType = CprType 0 botCpr

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

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

    applyCprTy :: CprType -> Arity -> CprType
    applyCprTy (CprType n res) k
      | n >= k        = CprType (n-k) res
      | res == botCpr = botCprType
      | otherwise     = topCprType

    abstractCprTy :: CprType -> CprType
    abstractCprTy (CprType n res)
      | res == topCpr = topCprType
      | otherwise     = CprType (n+1) res

    trimCprTy :: CprType -> CprType
    trimCprTy (CprType arty res) = CprType arty (trimCpr 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 dc (ConCpr t cs)
      | t == dataConTag dc, cs `lengthIs` dataConRepArity dc
      = ForeachField cs
    unpackConFieldsCpr _  BotCpr = AllFieldsSame BotCpr
    unpackConFieldsCpr _  _      = AllFieldsSame TopCpr
    {-# INLINE unpackConFieldsCpr #-}

    seqCprTy :: CprType -> ()
    seqCprTy (CprType _ cpr) = seqCpr 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 { getCprSig :: CprType }
      deriving (Eq, 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 arty ty@(CprType n cpr)
      | arty /= n         = topCprSig
          -- Trim on arity mismatch
      | ConCpr t _ <- cpr = CprSig (CprType n (flatConCpr t))
          -- Flatten nested CPR info, we don't exploit it (yet)
      | otherwise         = CprSig ty

    topCprSig :: CprSig
    topCprSig = CprSig topCprType

    isTopCprSig :: CprSig -> Bool
    isTopCprSig (CprSig ty) = ct_cpr ty == topCpr

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

    seqCprSig :: CprSig -> ()
    seqCprSig (CprSig ty) = seqCprTy 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 TopCpr         = empty
      ppr (FlatConCpr n) = int n
      ppr (ConCpr n cs)  = int n <> parens (pprWithCommas ppr cs)
      ppr BotCpr         = char 'b'

    instance Outputable CprType where
      ppr (CprType arty res) = ppr arty <> ppr res

    -- | Only print the CPR result
    instance Outputable CprSig where
      ppr (CprSig ty) = ppr (ct_cpr ty)

    instance Binary Cpr where
      put_ bh TopCpr         = putByte bh 0
      put_ bh BotCpr         = putByte bh 1
      put_ bh (FlatConCpr n) = putByte bh 2 *> put_ bh n
      put_ bh (ConCpr n cs)  = putByte bh 3 *> put_ bh n *> put_ bh cs
      get  bh = do
        h <- getByte bh
        case h of
          0 -> return TopCpr
          1 -> return BotCpr
          2 -> FlatConCpr <$> get bh
          3 -> ConCpr <$> get bh <*> get bh
          _ -> pprPanic "Binary Cpr: Invalid tag" (int (fromIntegral h))

    instance Binary CprType where
      put_ bh (CprType arty cpr) = put_ bh arty *> put_ bh cpr
      get  bh                    = CprType <$> get bh <*> get bh