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