-
Notifications
You must be signed in to change notification settings - Fork 10
/
Convert.hs
387 lines (349 loc) · 13.7 KB
/
Convert.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
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
{-# LANGUAGE CPP #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
module GhcDump.Convert (cvtModule) where
import Data.Bifunctor
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
#if MIN_VERSION_ghc(9,0,0)
import GHC.Types.Literal (Literal(..))
import qualified GHC.Types.Literal as Literal
import GHC.Types.Var (Var(..))
import qualified GHC.Types.Var as Var
import GHC.Types.Id (isFCallId)
import GHC.Unit.Module as Module (moduleName)
import GHC.Unit.Module.Name as Module (ModuleName, moduleNameFS)
import GHC.Types.Name (getOccName, occNameFS, OccName, getName, nameModule_maybe, getSrcSpan)
import qualified GHC.Types.Id.Info as IdInfo
import qualified GHC.Types.Basic as OccInfo (OccInfo(..), isStrongLoopBreaker)
import qualified GHC.Core.Stats as CoreStats
import qualified GHC.Core as CoreSyn
import GHC.Core (Expr(..), CoreExpr, Bind(..), CoreAlt, CoreBind, AltCon(..))
#if MIN_VERSION_ghc(9,2,0)
import GHC.Types.Tickish as CoreSyn (GenTickish(..))
import GHC.Unit.Module.ModGuts (ModGuts(..))
import GHC.Utils.Outputable (ppr, SDoc)
import GHC.Driver.Ppr (showSDoc)
#else
import GHC.Driver.Types (ModGuts(..))
import GHC.Utils.Outputable (ppr, showSDoc, SDoc)
#endif
import GHC.Data.FastString (FastString)
import qualified GHC.Data.FastString as FastString
import qualified GHC.Core.TyCo.Rep as Type
import GHC.Core.TyCon as TyCon (TyCon, tyConUnique)
import GHC.Types.Unique as Unique (Unique, getUnique, unpkUnique)
import GHC.Driver.Session (DynFlags)
import qualified GHC.Types.SrcLoc as SrcLoc
#else
import Literal (Literal(..))
#if MIN_VERSION_ghc(8,6,0)
import qualified Literal
#endif
import Var (Var)
import qualified Var
import Id (isFCallId)
import Module (ModuleName, moduleNameFS, moduleName)
import Unique (Unique, getUnique, unpkUnique)
import Name (getOccName, occNameFS, OccName, getName, nameModule_maybe, getSrcSpan)
import qualified SrcLoc
import qualified IdInfo
import qualified BasicTypes as OccInfo (OccInfo(..), isStrongLoopBreaker)
#if MIN_VERSION_ghc(8,0,0)
import qualified CoreStats
#else
import qualified CoreUtils as CoreStats
#endif
import qualified CoreSyn
import CoreSyn (Expr(..), CoreExpr, Bind(..), CoreAlt, CoreBind, AltCon(..), Tickish(..))
import HscTypes (ModGuts(..))
import FastString (FastString)
import qualified FastString
#if MIN_VERSION_ghc(8,2,0)
import TyCoRep as Type (Type(..))
#elif MIN_VERSION_ghc(8,0,0)
import TyCoRep as Type (Type(..), TyBinder(..))
#else
import TypeRep as Type (Type(..))
#endif
#if !(MIN_VERSION_ghc(8,2,0))
import Type (splitFunTy_maybe)
#endif
import TyCon (TyCon, tyConUnique)
import Outputable (ppr, showSDoc, SDoc)
import DynFlags (DynFlags)
#endif
import GhcDump.Ast as Ast
import Prelude hiding (span)
data Env = Env { dflags :: DynFlags }
type HasEnv = (?env :: Env)
cvtSDoc :: HasEnv => SDoc -> T.Text
cvtSDoc = T.pack . showSDoc (dflags ?env)
fastStringToText :: HasEnv => FastString -> T.Text
fastStringToText = TE.decodeUtf8
#if MIN_VERSION_ghc(8,10,0)
. FastString.bytesFS
#else
. FastString.fastStringToByteString
#endif
occNameToText :: HasEnv => OccName -> T.Text
occNameToText = fastStringToText . occNameFS
cvtUnique :: Unique.Unique -> Ast.Unique
cvtUnique u =
let (a,b) = unpkUnique u
in Ast.Unique a b
cvtVar :: Var -> BinderId
cvtVar = BinderId . cvtUnique . Var.varUnique
cvtBinder :: HasEnv => Var -> SBinder
cvtBinder v
| Var.isId v =
SBndr $ Binder { binderName = occNameToText $ getOccName v
, binderId = cvtVar v
, binderIdInfo = cvtIdInfo $ Var.idInfo v
, binderIdDetails = cvtIdDetails $ Var.idDetails v
, binderType = cvtType $ Var.varType v
, binderSrcSpan = cvtSrcSpan $ varSrcSpan v
}
| otherwise =
SBndr $ TyBinder { binderName = occNameToText $ getOccName v
, binderId = cvtVar v
, binderKind = cvtType $ Var.varType v
}
cvtIdInfo :: HasEnv => IdInfo.IdInfo -> Ast.IdInfo SBinder BinderId
cvtIdInfo i =
IdInfo { idiArity = IdInfo.arityInfo i
, idiIsOneShot = IdInfo.oneShotInfo i == IdInfo.OneShotLam
, idiUnfolding = cvtUnfolding $ IdInfo.unfoldingInfo i
, idiInlinePragma = cvtSDoc $ ppr $ IdInfo.inlinePragInfo i
, idiOccInfo = case IdInfo.occInfo i of
#if MIN_VERSION_ghc(8,2,0)
OccInfo.ManyOccs{} -> OccManyOccs
#else
OccInfo.NoOccInfo -> OccManyOccs
#endif
OccInfo.IAmDead -> OccDead
OccInfo.OneOcc{} -> OccOneOcc
oi@OccInfo.IAmALoopBreaker{} -> OccLoopBreaker (OccInfo.isStrongLoopBreaker oi)
, idiStrictnessSig = cvtSDoc $ ppr $ IdInfo.strictnessInfo i
, idiDemandSig = cvtSDoc $ ppr $ IdInfo.demandInfo i
, idiCallArity = IdInfo.callArityInfo i
}
cvtUnfolding :: HasEnv => CoreSyn.Unfolding -> Ast.Unfolding SBinder BinderId
cvtUnfolding CoreSyn.NoUnfolding = Ast.NoUnfolding
#if MIN_VERSION_ghc(8,2,0)
cvtUnfolding CoreSyn.BootUnfolding = Ast.BootUnfolding
#endif
cvtUnfolding (CoreSyn.OtherCon cons) = Ast.OtherCon (map cvtAltCon cons)
cvtUnfolding (CoreSyn.DFunUnfolding{}) = Ast.DFunUnfolding
cvtUnfolding u@(CoreSyn.CoreUnfolding{}) =
Ast.CoreUnfolding { unfTemplate = cvtExpr $ CoreSyn.uf_tmpl u
, unfIsValue = CoreSyn.uf_is_value u
, unfIsConLike = CoreSyn.uf_is_conlike u
, unfIsWorkFree = CoreSyn.uf_is_work_free u
, unfGuidance = cvtSDoc $ ppr $ CoreSyn.uf_guidance u
}
cvtIdDetails :: HasEnv => IdInfo.IdDetails -> Ast.IdDetails
cvtIdDetails d =
case d of
IdInfo.VanillaId -> Ast.VanillaId
IdInfo.RecSelId{} -> Ast.RecSelId
IdInfo.DataConWorkId{} -> Ast.DataConWorkId
IdInfo.DataConWrapId{} -> Ast.DataConWrapId
IdInfo.ClassOpId{} -> Ast.ClassOpId
IdInfo.PrimOpId{} -> Ast.PrimOpId
IdInfo.FCallId{} -> error "This shouldn't happen"
IdInfo.TickBoxOpId{} -> Ast.TickBoxOpId
IdInfo.DFunId{} -> Ast.DFunId
#if MIN_VERSION_ghc(8,0,0)
IdInfo.CoVarId{} -> Ast.CoVarId
#endif
#if MIN_VERSION_ghc(8,2,0)
IdInfo.JoinId n -> Ast.JoinId n
#endif
cvtCoreStats :: CoreStats.CoreStats -> Ast.CoreStats
cvtCoreStats stats =
Ast.CoreStats
{ csTerms = CoreStats.cs_tm stats
, csTypes = CoreStats.cs_ty stats
, csCoercions = CoreStats.cs_co stats
#if MIN_VERSION_ghc(8,2,0)
, csValBinds = CoreStats.cs_vb stats
, csJoinBinds = CoreStats.cs_jb stats
#else
, csValBinds = 0
, csJoinBinds = 0
#endif
}
exprStats :: CoreExpr -> CoreStats.CoreStats
#if MIN_VERSION_ghc(8,0,0)
exprStats = CoreStats.exprStats
#else
-- exprStats wasn't exported in 7.10
exprStats _ = CoreStats.CS 0 0 0
#endif
varSrcSpan :: Var -> SrcLoc.SrcSpan
#if MIN_VERSION_ghc(8,6,0)
varSrcSpan x = getSrcSpan x
#else
varSrcSpan _ = SrcLoc.mkGeneralSrcSpan (FastString.mkFastString "SrcSpan not available in GHC version")
#endif
cvtTopBind :: HasEnv => CoreBind -> STopBinding
cvtTopBind (NonRec b e) =
NonRecTopBinding (cvtBinder b) (cvtCoreStats $ exprStats e) (cvtExpr e)
cvtTopBind (Rec bs) =
RecTopBinding $ map to bs
where to (b, e) = (cvtBinder b, cvtCoreStats (exprStats e), cvtExpr e)
cvtExpr :: HasEnv => CoreExpr -> Ast.SExpr
cvtExpr expr =
case expr of
Var x
-- foreign calls are local but have no binding site.
-- TODO: use hasNoBinding here.
| isFCallId x -> EVarGlobal ForeignCall
| Just m <- nameModule_maybe $ getName x
-> EVarGlobal $ ExternalName (cvtModuleName $ Module.moduleName m)
(occNameToText $ getOccName x)
(cvtUnique $ getUnique x)
(cvtType $ Var.varType x)
| otherwise -> EVar (cvtVar x)
Lit l -> ELit (cvtLit l)
App x y -> EApp (cvtExpr x) (cvtExpr y)
Lam x e
| Var.isTyVar x -> ETyLam (cvtBinder x) (cvtExpr e)
| otherwise -> ELam (cvtBinder x) (cvtExpr e)
Let (NonRec b e) body -> ELet [(cvtBinder b, cvtExpr e)] (cvtExpr body)
Let (Rec bs) body -> ELet (map (bimap cvtBinder cvtExpr) bs) (cvtExpr body)
Case e x _ as -> ECase (cvtExpr e) (cvtBinder x) (map cvtAlt as)
Cast x _ -> cvtExpr x
Tick tick e
| CoreSyn.SourceNote sspan _name <- tick
-> ETick (Ast.SourceNote $ cvtRealSrcSpan sspan) (cvtExpr e)
| otherwise -> cvtExpr e
Type t -> EType $ cvtType t
Coercion _ -> ECoercion
cvtRealSrcSpan :: SrcLoc.RealSrcSpan -> SrcSpan
cvtRealSrcSpan span =
Ast.SrcSpan { spanFile = T.pack $ show $ SrcLoc.srcSpanFile span
, spanStart = LineCol (SrcLoc.srcSpanStartLine span) (SrcLoc.srcSpanStartCol span)
, spanEnd = LineCol (SrcLoc.srcSpanEndLine span) (SrcLoc.srcSpanEndCol span)
}
cvtSrcSpan :: SrcLoc.SrcSpan -> SrcSpan
#if MIN_VERSION_ghc(9,0,0)
cvtSrcSpan (SrcLoc.RealSrcSpan r _) = cvtRealSrcSpan r
#else
cvtSrcSpan (SrcLoc.RealSrcSpan r) = cvtRealSrcSpan r
#endif
cvtSrcSpan (SrcLoc.UnhelpfulSpan _) = NoSpan
cvtAlt :: HasEnv => CoreAlt -> Ast.SAlt
#if MIN_VERSION_ghc(9,2,0)
cvtAlt (CoreSyn.Alt con bs e) =
#else
cvtAlt (con, bs, e) =
#endif
Alt (cvtAltCon con) (map cvtBinder bs) (cvtExpr e)
cvtAltCon :: HasEnv => CoreSyn.AltCon -> Ast.AltCon
cvtAltCon (DataAlt altcon) = Ast.AltDataCon $ occNameToText $ getOccName altcon
cvtAltCon (LitAlt l) = Ast.AltLit $ cvtLit l
cvtAltCon DEFAULT = Ast.AltDefault
cvtLit :: HasEnv => Literal -> Ast.Lit
cvtLit l =
case l of
#if MIN_VERSION_ghc(8,8,0)
Literal.LitChar x -> Ast.MachChar x
Literal.LitString x -> Ast.MachStr x
Literal.LitNullAddr -> Ast.MachNullAddr
Literal.LitFloat x -> Ast.MachFloat x
Literal.LitDouble x -> Ast.MachDouble x
Literal.LitLabel x _ _ -> Ast.MachLabel $ fastStringToText x
Literal.LitRubbish{} -> Ast.LitRubbish
#else
Literal.MachChar x -> Ast.MachChar x
Literal.MachStr x -> Ast.MachStr x
Literal.MachNullAddr -> Ast.MachNullAddr
Literal.MachFloat x -> Ast.MachFloat x
Literal.MachDouble x -> Ast.MachDouble x
Literal.MachLabel x _ _ -> Ast.MachLabel $ fastStringToText x
#endif
#if MIN_VERSION_ghc(8,6,0)
#if MIN_VERSION_ghc(9,0,0)
Literal.LitNumber numty n ->
#else
Literal.LitNumber numty n _ ->
#endif
case numty of
Literal.LitNumInt -> Ast.MachInt n
Literal.LitNumInt64 -> Ast.MachInt64 n
Literal.LitNumWord -> Ast.MachWord n
Literal.LitNumWord64 -> Ast.MachWord64 n
Literal.LitNumInteger -> Ast.LitInteger n
Literal.LitNumNatural -> Ast.LitNatural n
#if MIN_VERSION_ghc(9,2,0)
-- Lossy
Literal.LitNumInt8 -> Ast.MachInt n
Literal.LitNumInt16 -> Ast.MachInt n
Literal.LitNumInt32 -> Ast.MachInt n
Literal.LitNumWord8 -> Ast.MachWord n
Literal.LitNumWord16 -> Ast.MachWord n
Literal.LitNumWord32 -> Ast.MachWord n
#endif
#else
Literal.MachInt x -> Ast.MachInt x
Literal.MachInt64 x -> Ast.MachInt64 x
Literal.MachWord x -> Ast.MachWord x
Literal.MachWord64 x -> Ast.MachWord64 x
Literal.LitInteger x _ -> Ast.LitInteger x
#endif
cvtModule :: DynFlags -> Int -> String -> ModGuts -> Ast.SModule
cvtModule dflags phaseId phase guts =
let ?env = Env {dflags}
in cvtModule' phaseId phase guts
cvtModule' :: HasEnv => Int -> String -> ModGuts -> Ast.SModule
cvtModule' phaseId phase guts =
Ast.Module name (T.pack phase) phaseId (map cvtTopBind $ mg_binds guts)
where
name = cvtModuleName $ Module.moduleName $ mg_module guts
cvtModuleName :: HasEnv => Module.ModuleName -> Ast.ModuleName
cvtModuleName = Ast.ModuleName . fastStringToText . moduleNameFS
#if MIN_VERSION_ghc(9,0,0)
cvtTyLit :: HasEnv => Type.TyLit -> Ast.TyLit
cvtTyLit (Type.NumTyLit n) = (Ast.NumTyLit (fromIntegral n))
cvtTyLit (Type.StrTyLit s) = (Ast.StrTyLit (T.pack (FastString.unpackFS s)))
#if MIN_VERSION_ghc(9,2,0)
cvtTyLit (Type.CharTyLit c) = (Ast.CharTyLit c)
#endif
#else
cvtTyLit :: HasEnv => a -> Ast.TyLit
cvtTyLit _ = Ast.UnknownLit
#endif
cvtType :: HasEnv => Type.Type -> Ast.SType
#if MIN_VERSION_ghc(9,0,0)
cvtType (Type.FunTy _flag _ a b) = Ast.FunTy (cvtType a) (cvtType b)
#elif MIN_VERSION_ghc(8,10,0)
cvtType (Type.FunTy _flag a b) = Ast.FunTy (cvtType a) (cvtType b)
#elif MIN_VERSION_ghc(8,2,0)
cvtType (Type.FunTy a b) = Ast.FunTy (cvtType a) (cvtType b)
#else
cvtType t
| Just (a,b) <- splitFunTy_maybe t = Ast.FunTy (cvtType a) (cvtType b)
#endif
cvtType (Type.TyVarTy v) = Ast.VarTy (cvtVar v)
cvtType (Type.AppTy a b) = Ast.AppTy (cvtType a) (cvtType b)
cvtType (Type.TyConApp tc tys) = Ast.TyConApp (cvtTyCon tc) (map cvtType tys)
#if MIN_VERSION_ghc(8,8,0)
cvtType (Type.ForAllTy (Var.Bndr b _) t) = Ast.ForAllTy (cvtBinder b) (cvtType t)
#elif MIN_VERSION_ghc(8,2,0)
cvtType (Type.ForAllTy (Var.TvBndr b _) t) = Ast.ForAllTy (cvtBinder b) (cvtType t)
#elif MIN_VERSION_ghc(8,0,0)
cvtType (Type.ForAllTy (Named b _) t) = Ast.ForAllTy (cvtBinder b) (cvtType t)
cvtType (Type.ForAllTy (Anon _) t) = cvtType t
#else
cvtType (Type.ForAllTy b t) = Ast.ForAllTy (cvtBinder b) (cvtType t)
#endif
cvtType (Type.LitTy tylit) = Ast.LitTy (cvtTyLit tylit)
#if MIN_VERSION_ghc(8,0,0)
cvtType (Type.CastTy t _) = cvtType t
cvtType (Type.CoercionTy _) = Ast.CoercionTy
#endif
cvtTyCon :: HasEnv => TyCon.TyCon -> Ast.TyCon
cvtTyCon tc = TyCon (occNameToText $ getOccName tc) (cvtUnique $ tyConUnique tc)