-
Notifications
You must be signed in to change notification settings - Fork 4
/
Predicates.hs
284 lines (251 loc) · 10.6 KB
/
Predicates.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
{-|
Module : Foreign.Storable.Generic.Plugin.Internal.Predicates
Copyright : (c) Mateusz Kłoczko, 2016
License : MIT
Maintainer : mateusz.p.kloczko@gmail.com
Stability : experimental
Portability : GHC-only
Predicates for finding GStorable identifiers, plus some others.
-}
{-#LANGUAGE CPP#-}
module Foreign.Storable.Generic.Plugin.Internal.Predicates
(
-- Predicates on identifiers
isGStorableInstId
, isSizeOfId
, isAlignmentId
, isPeekId
, isPokeId
, isSpecGStorableInstId
, isSpecSizeOfId
, isSpecAlignmentId
, isSpecPeekId
, isSpecPokeId
, isChoiceSizeOfId
, isChoiceAlignmentId
, isChoicePeekId
, isChoicePokeId
, isOffsetsId
-- Groups of above
, isGStorableId
, isGStorableMethodId
-- Miscellanous
, isNonRecBind
, toIsBind
, withTypeCheck
)
where
-- -- Management of Core.
-- import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)
-- import Literal (Literal(..))
-- import Id (isLocalId, isGlobalId,Id)
-- import Var (Var(..))
-- import Name (getOccName,mkOccName)
-- import OccName (OccName(..), occNameString)
-- import qualified Name as N (varName, tcClsName)
-- import SrcLoc (noSrcSpan)
-- import Unique (getUnique)
-- -- Compilation pipeline stuff
-- import HscMain (hscCompileCoreExpr)
-- import HscTypes (HscEnv,ModGuts(..))
-- import CoreMonad (CoreM, CoreToDo(..), getHscEnv)
-- import BasicTypes (CompilerPhase(..))
-- -- Types
-- import Type (isAlgType, splitTyConApp_maybe)
-- import TyCon (TyCon,tyConName, algTyConRhs, visibleDataCons)
-- import TyCoRep (Type(..), TyBinder(..))
-- import TysWiredIn (intDataCon)
-- import DataCon (dataConWorkId,dataConOrigArgTys)
--
-- import MkCore (mkWildValBinder)
-- -- Printing
-- import Outputable (cat, ppr, SDoc, showSDocUnsafe)
-- import CoreMonad (putMsg, putMsgS)
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Core (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)
import GHC.Types.Literal (Literal(..))
import GHC.Types.Id (isLocalId, isGlobalId,Id)
import GHC.Types.Var (Var(..))
import GHC.Types.Name (getOccName,mkOccName)
import GHC.Types.Name.Occurrence (OccName(..), occNameString)
import qualified GHC.Types.Name as N (varName)
import GHC.Types.SrcLoc (noSrcSpan)
import GHC.Types.Unique (getUnique)
import GHC.Driver.Main (hscCompileCoreExpr, getHscEnv)
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
import GHC.Driver.Env.Types (HscEnv)
import GHC.Unit.Module.ModGuts (ModGuts(..))
#else
import GHC.Driver.Types (HscEnv,ModGuts(..))
#endif
import GHC.Core.Opt.Monad (CoreM,CoreToDo(..))
import GHC.Types.Basic (CompilerPhase(..))
import GHC.Core.Type (isAlgType, splitTyConApp_maybe)
import GHC.Core.TyCon (algTyConRhs, visibleDataCons)
import GHC.Builtin.Types (intDataCon)
import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys)
import GHC.Core.Make (mkWildValBinder)
import GHC.Utils.Outputable (cat, ppr, SDoc, showSDocUnsafe)
import GHC.Core.Opt.Monad (putMsg, putMsgS)
import GHC.Types.Name (nameStableString)
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)
import Literal (Literal(..))
import Id (isLocalId, isGlobalId,Id)
import Var (Var(..))
import Name (getOccName,mkOccName)
import OccName (OccName(..), occNameString)
import qualified Name as N (varName)
import SrcLoc (noSrcSpan)
import Unique (getUnique)
import HscMain (hscCompileCoreExpr)
import HscTypes (HscEnv,ModGuts(..))
import CoreMonad (CoreM,CoreToDo(..), getHscEnv)
import BasicTypes (CompilerPhase(..))
import Type (isAlgType, splitTyConApp_maybe)
import TyCon (algTyConRhs, visibleDataCons)
import TysWiredIn (intDataCon)
import DataCon (dataConWorkId,dataConOrigArgTys)
import MkCore (mkWildValBinder)
import Outputable (cat, ppr, SDoc, showSDocUnsafe)
import CoreMonad (putMsg, putMsgS)
import Name (nameStableString)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Types.Var (TyVarBinder(..), VarBndr(..))
import GHC.Core.TyCo.Rep (Type(..), TyBinder(..), TyCoBinder(..),scaledThing)
import GHC.Types.Var
#elif MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
import Var (TyVarBinder(..), VarBndr(..))
import TyCoRep (Type(..), TyBinder(..), TyCoBinder(..))
import Var
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
import Var (TyVarBndr(..), TyVarBinder)
import TyCoRep (Type(..), TyBinder(..))
import Var
#endif
import Data.Maybe
import Foreign.Storable.Generic.Plugin.Internal.Helpers
-- | Predicate used to find GStorable instances identifiers.
isGStorableInstId :: Id -> Bool
isGStorableInstId id = cutted_occ_name == gstorable_dict_name
&& cutted_occ_name2 /= gstorable'_dict_name
where cutted_occ_name = cutOccName 11 $ getOccName (varName id)
cutted_occ_name2 = cutOccName 12 $ getOccName (varName id)
gstorable_dict_name = mkOccName N.varName "$fGStorable"
gstorable'_dict_name = mkOccName N.varName "$fGStorable'"
-- | Predicate used to find gsizeOf identifiers
isSizeOfId :: Id -> Bool
isSizeOfId ident = getOccName (varName ident) == mkOccName N.varName "$cgsizeOf"
-- | Predicate used to find galignment identifiers
isAlignmentId :: Id -> Bool
isAlignmentId ident = getOccName (varName ident) == mkOccName N.varName "$cgalignment"
-- | Predicate used to find gpeekByteOff identifiers
isPeekId :: Id -> Bool
isPeekId id = occStr == compared1
where occStr = nameStableString $ varName id
compared1 = "$_in$$cgpeekByteOff"
-- | Predicate used to find gpeekByteOff identifiers
isPokeId :: Id -> Bool
isPokeId id = occStr == compared1
where occStr = nameStableString $ varName id
compared1 = "$_in$$cgpokeByteOff"
--------------------------------------------
--GStorableChoice methods' identifiers --
--------------------------------------------
-- | Predicate used to find chSizeOf identifiers
isChoiceSizeOfId :: Id -> Bool
isChoiceSizeOfId id = occStr == compared1 || occStr == compared2
where occStr = nameStableString $ varName id
compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchSizeOf"
compared2 = "$_in$$s$fGStorableChoice'Truea_$cchSizeOf"
-- | Predicate used to find chAlignment identifiers
isChoiceAlignmentId :: Id -> Bool
isChoiceAlignmentId id = occStr == compared1 || occStr == compared2
where occStr = nameStableString $ varName id
compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchAlignment"
compared2 = "$_in$$s$fGStorableChoice'Truea_$cchAlignment"
-- | Predicate used to find chPeekByteOff identifiers
isChoicePeekId :: Id -> Bool
isChoicePeekId id = compared1 == occStr || compared2 == occStr
where occStr = nameStableString $ varName id
compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchPeekByteOff"
compared2 = "$_in$$s$fGStorableChoice'Truea_$cchPeekByteOff"
-- | Predicate used to find chPokeByteOff identifiers
isChoicePokeId :: Id -> Bool
isChoicePokeId id = compared1 == occStr || compared2 == occStr
where occStr = nameStableString $ varName id
compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchPokeByteOff"
compared2 = "$_in$$s$fGStorableChoice'Truea_$cchPokeByteOff"
--------------------------------------------
--Specialized at instance definition site.--
--------------------------------------------
-- | Predicate used to find specialized GStorable instance identifiers
isSpecGStorableInstId :: Id -> Bool
isSpecGStorableInstId id = cutted_occ_name == gstorable_dict_name
&& cutted_occ_name2 /= gstorable'_dict_name
where cutted_occ_name = cutOccName 11 $ getOccName (varName id)
cutted_occ_name2 = cutOccName 12 $ getOccName (varName id)
gstorable_dict_name = mkOccName N.varName "$s$fGStorable"
gstorable'_dict_name = mkOccName N.varName "$s$fGStorable'"
-- | Predicate used to find specialized gsizeOf identifiers
isSpecSizeOfId :: Id -> Bool
isSpecSizeOfId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgsizeOf"
-- | Predicate used to find specialized galignment identifiers
isSpecAlignmentId :: Id -> Bool
isSpecAlignmentId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgalignment"
-- | Predicate used to find specialized gpeekByteOff identifiers
isSpecPeekId :: Id -> Bool
isSpecPeekId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgpeekByteOff"
-- | Predicate used to find specialized gpokeByteOff identifiers
isSpecPokeId :: Id -> Bool
isSpecPokeId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgpokeByteOff"
----------------------------
-- For offset calculation --
----------------------------
-- | Is offsets id.
isOffsetsId :: Id -> Bool
isOffsetsId id = getOccName (varName id) == mkOccName N.varName "offsets"
---------------------------
-- Groups of identifiers --
---------------------------
-- | Is a GStorable identifier
isGStorableId :: Id -> Bool
isGStorableId id = any ($id) [ isSizeOfId, isAlignmentId, isPeekId
, isPokeId, isGStorableInstId
, isSpecSizeOfId, isSpecAlignmentId
, isSpecPeekId, isSpecPokeId
, isSpecGStorableInstId
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
, isChoiceSizeOfId, isChoiceAlignmentId
, isChoicePeekId, isChoicePokeId
#endif
]
-- | Is the id an GStorable method.
isGStorableMethodId :: Id -> Bool
isGStorableMethodId id = any ($id) [isSizeOfId, isAlignmentId
, isPeekId, isPokeId
, isSpecSizeOfId, isSpecAlignmentId
, isSpecPeekId, isSpecPokeId
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
, isChoiceSizeOfId, isChoiceAlignmentId
, isChoicePeekId, isChoicePokeId
#endif
]
------------------
-- Miscellanous --
------------------
-- | Check if binding is non-recursive.
isNonRecBind :: CoreBind -> Bool
isNonRecBind (NonRec _ _) = True
isNonRecBind _ = False
-- | Lift the identifier predicate to work on a core binding.
toIsBind :: (Id -> Bool) -> CoreBind -> Bool
toIsBind pred (NonRec id rhs) = pred id
toIsBind pred (Rec bs) = any pred $ map fst bs
-- | Use both type getters and identifier predicate to create a predicate.
withTypeCheck :: (Type -> Maybe Type) -> (Id -> Bool) -> Id -> Bool
withTypeCheck ty_f id_f id = do
let ty_checked = ty_f $ varType id
id_checked = id_f id
and [isJust ty_checked, id_checked]