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