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