never executed always true always false
    1 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
    2 {-# LANGUAGE ViewPatterns #-}
    3 {-# LANGUAGE PatternSynonyms #-}
    4 
    5 -- | Types for the Constructed Product Result lattice.
    6 -- "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils"
    7 -- are its primary customers via 'GHC.Types.Id.idCprSig'.
    8 module GHC.Types.Cpr (
    9     Cpr (ConCpr), topCpr, botCpr, flatConCpr, asConCpr,
   10     CprType (..), topCprType, botCprType, flatConCprType,
   11     lubCprType, applyCprTy, abstractCprTy, trimCprTy,
   12     UnpackConFieldsResult (..), unpackConFieldsCpr,
   13     CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, seqCprSig
   14   ) where
   15 
   16 import GHC.Prelude
   17 
   18 import GHC.Core.DataCon
   19 import GHC.Types.Basic
   20 import GHC.Utils.Binary
   21 import GHC.Utils.Misc
   22 import GHC.Utils.Outputable
   23 import GHC.Utils.Panic
   24 
   25 --
   26 -- * Cpr
   27 --
   28 
   29 data Cpr
   30   = BotCpr
   31   | ConCpr_ !ConTag ![Cpr]
   32   -- ^ The number of field Cprs equals 'dataConRepArity'.
   33   -- If all of them are top, better use 'FlatConCpr', as ensured by the pattern
   34   -- synonym 'ConCpr'.
   35   | FlatConCpr !ConTag
   36   -- ^ @FlatConCpr tag@ is an efficient encoding for @'ConCpr_' tag [TopCpr..]@.
   37   -- Purely for compiler perf. Can be constructed with 'ConCpr'.
   38   | TopCpr
   39   deriving Eq
   40 
   41 pattern ConCpr :: ConTag -> [Cpr] -> Cpr
   42 pattern ConCpr t cs <- ConCpr_ t cs where
   43   ConCpr t cs
   44     | all (== TopCpr) cs = FlatConCpr t
   45     | otherwise          = ConCpr_ t cs
   46 {-# COMPLETE BotCpr, TopCpr, FlatConCpr, ConCpr #-}
   47 
   48 viewConTag :: Cpr -> Maybe ConTag
   49 viewConTag (FlatConCpr t) = Just t
   50 viewConTag (ConCpr t _)   = Just t
   51 viewConTag _              = Nothing
   52 {-# INLINE viewConTag #-}
   53 
   54 lubCpr :: Cpr -> Cpr -> Cpr
   55 lubCpr BotCpr      cpr     = cpr
   56 lubCpr cpr         BotCpr  = cpr
   57 lubCpr (FlatConCpr t1) (viewConTag -> Just t2)
   58   | t1 == t2 = FlatConCpr t1
   59 lubCpr (viewConTag -> Just t1) (FlatConCpr t2)
   60   | t1 == t2 = FlatConCpr t2
   61 lubCpr (ConCpr t1 cs1) (ConCpr t2 cs2)
   62   | t1 == t2 = ConCpr t1 (lubFieldCprs cs1 cs2)
   63 lubCpr _           _       = TopCpr
   64 
   65 lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]
   66 lubFieldCprs as bs
   67   | as `equalLength` bs = zipWith lubCpr as bs
   68   | otherwise           = []
   69 
   70 topCpr :: Cpr
   71 topCpr = TopCpr
   72 
   73 botCpr :: Cpr
   74 botCpr = BotCpr
   75 
   76 flatConCpr :: ConTag -> Cpr
   77 flatConCpr t = FlatConCpr t
   78 
   79 trimCpr :: Cpr -> Cpr
   80 trimCpr BotCpr = botCpr
   81 trimCpr _      = topCpr
   82 
   83 asConCpr :: Cpr -> Maybe (ConTag, [Cpr])
   84 asConCpr (ConCpr t cs)  = Just (t, cs)
   85 asConCpr (FlatConCpr t) = Just (t, [])
   86 asConCpr TopCpr         = Nothing
   87 asConCpr BotCpr         = Nothing
   88 
   89 seqCpr :: Cpr -> ()
   90 seqCpr (ConCpr _ cs) = foldr (seq . seqCpr) () cs
   91 seqCpr _             = ()
   92 
   93 --
   94 -- * CprType
   95 --
   96 
   97 -- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper.
   98 data CprType
   99   = CprType
  100   { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression
  101                       --   eats before returning the 'ct_cpr'
  102   , ct_cpr  :: !Cpr   -- ^ 'Cpr' eventually unleashed when applied to
  103                       --   'ct_arty' arguments
  104   }
  105 
  106 instance Eq CprType where
  107   a == b =  ct_cpr a == ct_cpr b
  108          && (ct_arty a == ct_arty b || ct_cpr a == topCpr)
  109 
  110 topCprType :: CprType
  111 topCprType = CprType 0 topCpr
  112 
  113 botCprType :: CprType
  114 botCprType = CprType 0 botCpr
  115 
  116 flatConCprType :: ConTag -> CprType
  117 flatConCprType con_tag = CprType { ct_arty = 0, ct_cpr = flatConCpr con_tag }
  118 
  119 lubCprType :: CprType -> CprType -> CprType
  120 lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2)
  121   -- The arity of bottom CPR types can be extended arbitrarily.
  122   | cpr1 == botCpr && n1 <= n2 = ty2
  123   | cpr2 == botCpr && n2 <= n1 = ty1
  124   -- There might be non-bottom CPR types with mismatching arities.
  125   -- Consider test DmdAnalGADTs. We want to return top in these cases.
  126   | n1 == n2                   = CprType n1 (lubCpr cpr1 cpr2)
  127   | otherwise                  = topCprType
  128 
  129 applyCprTy :: CprType -> Arity -> CprType
  130 applyCprTy (CprType n res) k
  131   | n >= k        = CprType (n-k) res
  132   | res == botCpr = botCprType
  133   | otherwise     = topCprType
  134 
  135 abstractCprTy :: CprType -> CprType
  136 abstractCprTy (CprType n res)
  137   | res == topCpr = topCprType
  138   | otherwise     = CprType (n+1) res
  139 
  140 trimCprTy :: CprType -> CprType
  141 trimCprTy (CprType arty res) = CprType arty (trimCpr res)
  142 
  143 -- | The result of 'unpackConFieldsCpr'.
  144 data UnpackConFieldsResult
  145   = AllFieldsSame !Cpr
  146   | ForeachField ![Cpr]
  147 
  148 -- | Unpacks a 'ConCpr'-shaped 'Cpr' and returns the field 'Cpr's wrapped in a
  149 -- 'ForeachField'. Otherwise, it returns 'AllFieldsSame' with the appropriate
  150 -- 'Cpr' to assume for each field.
  151 --
  152 -- The use of 'UnpackConFieldsResult' allows O(1) space for the common,
  153 -- non-'ConCpr' case.
  154 unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult
  155 unpackConFieldsCpr dc (ConCpr t cs)
  156   | t == dataConTag dc, cs `lengthIs` dataConRepArity dc
  157   = ForeachField cs
  158 unpackConFieldsCpr _  BotCpr = AllFieldsSame BotCpr
  159 unpackConFieldsCpr _  _      = AllFieldsSame TopCpr
  160 {-# INLINE unpackConFieldsCpr #-}
  161 
  162 seqCprTy :: CprType -> ()
  163 seqCprTy (CprType _ cpr) = seqCpr cpr
  164 
  165 -- | The arity of the wrapped 'CprType' is the arity at which it is safe
  166 -- to unleash. See Note [Understanding DmdType and DmdSig] in "GHC.Types.Demand"
  167 newtype CprSig = CprSig { getCprSig :: CprType }
  168   deriving (Eq, Binary)
  169 
  170 -- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig'
  171 -- unleashable at that arity. See Note [Understanding DmdType and DmdSig] in
  172 -- "GHC.Types.Demand"
  173 mkCprSigForArity :: Arity -> CprType -> CprSig
  174 mkCprSigForArity arty ty@(CprType n _)
  175   | arty /= n = topCprSig -- Trim on arity mismatch
  176   | otherwise = CprSig ty
  177 
  178 topCprSig :: CprSig
  179 topCprSig = CprSig topCprType
  180 
  181 isTopCprSig :: CprSig -> Bool
  182 isTopCprSig (CprSig ty) = ct_cpr ty == topCpr
  183 
  184 mkCprSig :: Arity -> Cpr -> CprSig
  185 mkCprSig arty cpr = CprSig (CprType arty cpr)
  186 
  187 seqCprSig :: CprSig -> ()
  188 seqCprSig (CprSig ty) = seqCprTy ty
  189 
  190 -- | BNF:
  191 --
  192 -- > cpr ::= ''                               -- TopCpr
  193 -- >      |  n                                -- FlatConCpr n
  194 -- >      |  n '(' cpr1 ',' cpr2 ',' ... ')'  -- ConCpr n [cpr1,cpr2,...]
  195 -- >      |  'b'                              -- BotCpr
  196 --
  197 -- Examples:
  198 --   * `f x = f x` has result CPR `b`
  199 --   * `1(1,)` is a valid (nested) 'Cpr' denotation for `(I# 42#, f 42)`.
  200 instance Outputable Cpr where
  201   ppr TopCpr         = empty
  202   ppr (FlatConCpr n) = int n
  203   ppr (ConCpr n cs)  = int n <> parens (pprWithCommas ppr cs)
  204   ppr BotCpr         = char 'b'
  205 
  206 -- | BNF:
  207 --
  208 -- > cpr_ty ::= cpr               -- short form if arty == 0
  209 -- >         |  '\' arty '.' cpr  -- if arty > 0
  210 --
  211 -- Examples:
  212 --   * `f x y z = f x y z` has denotation `\3.b`
  213 --   * `g !x = (x+1, x+2)` has denotation `\1.1(1,1)`.
  214 instance Outputable CprType where
  215   ppr (CprType arty res)
  216     | 0 <- arty = ppr res
  217     | otherwise = char '\\' <> ppr arty <> char '.' <> ppr res
  218 
  219 -- | Only print the CPR result
  220 instance Outputable CprSig where
  221   ppr (CprSig ty) = ppr (ct_cpr ty)
  222 
  223 instance Binary Cpr where
  224   put_ bh TopCpr         = putByte bh 0
  225   put_ bh BotCpr         = putByte bh 1
  226   put_ bh (FlatConCpr n) = putByte bh 2 *> put_ bh n
  227   put_ bh (ConCpr n cs)  = putByte bh 3 *> put_ bh n *> put_ bh cs
  228   get  bh = do
  229     h <- getByte bh
  230     case h of
  231       0 -> return TopCpr
  232       1 -> return BotCpr
  233       2 -> FlatConCpr <$> get bh
  234       3 -> ConCpr <$> get bh <*> get bh
  235       _ -> pprPanic "Binary Cpr: Invalid tag" (int (fromIntegral h))
  236 
  237 instance Binary CprType where
  238   put_ bh (CprType arty cpr) = put_ bh arty *> put_ bh cpr
  239   get  bh                    = CprType <$> get bh <*> get bh