never executed always true always false
1
2 {-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*]
3
4 -- | Functions for converting Core things to interface file things.
5 module GHC.CoreToIface
6 ( -- * Binders
7 toIfaceTvBndr
8 , toIfaceTvBndrs
9 , toIfaceIdBndr
10 , toIfaceBndr
11 , toIfaceForAllBndr
12 , toIfaceTyCoVarBinders
13 , toIfaceTyVar
14 -- * Types
15 , toIfaceType, toIfaceTypeX
16 , toIfaceKind
17 , toIfaceTcArgs
18 , toIfaceTyCon
19 , toIfaceTyCon_name
20 , toIfaceTyLit
21 -- * Tidying types
22 , tidyToIfaceType
23 , tidyToIfaceContext
24 , tidyToIfaceTcArgs
25 -- * Coercions
26 , toIfaceCoercion, toIfaceCoercionX
27 -- * Pattern synonyms
28 , patSynToIfaceDecl
29 -- * Expressions
30 , toIfaceExpr
31 , toIfaceBang
32 , toIfaceSrcBang
33 , toIfaceLetBndr
34 , toIfaceIdDetails
35 , toIfaceIdInfo
36 , toIfUnfolding
37 , toIfaceTickish
38 , toIfaceBind
39 , toIfaceAlt
40 , toIfaceCon
41 , toIfaceApp
42 , toIfaceVar
43 -- * Other stuff
44 , toIfaceLFInfo
45 ) where
46
47 import GHC.Prelude
48
49 import GHC.StgToCmm.Types
50
51 import GHC.Core
52 import GHC.Core.TyCon hiding ( pprPromotionQuote )
53 import GHC.Core.Coercion.Axiom
54 import GHC.Core.DataCon
55 import GHC.Core.Type
56 import GHC.Core.Multiplicity
57 import GHC.Core.PatSyn
58 import GHC.Core.TyCo.Rep
59 import GHC.Core.TyCo.Tidy ( tidyCo )
60
61 import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon )
62 import GHC.Builtin.Types ( heqTyCon )
63 import GHC.Builtin.Names
64
65 import GHC.Iface.Syntax
66 import GHC.Data.FastString
67
68 import GHC.Types.Id
69 import GHC.Types.Id.Info
70 import GHC.Types.Id.Make ( noinlineIdName )
71 import GHC.Types.Literal
72 import GHC.Types.Name
73 import GHC.Types.Basic
74 import GHC.Types.Var
75 import GHC.Types.Var.Env
76 import GHC.Types.Var.Set
77 import GHC.Types.Tickish
78 import GHC.Types.Demand ( isTopSig )
79 import GHC.Types.Cpr ( topCprSig )
80
81 import GHC.Utils.Outputable
82 import GHC.Utils.Panic
83 import GHC.Utils.Misc
84 import GHC.Utils.Trace
85
86 import Data.Maybe ( catMaybes )
87
88 {- Note [Avoiding space leaks in toIface*]
89 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
90
91 Building a interface file depends on the output of the simplifier.
92 If we build these lazily this would mean keeping the Core AST alive
93 much longer than necessary causing a space "leak".
94
95 This happens for example when we only write the interface file to disk
96 after code gen has run, in which case we might carry megabytes of core
97 AST in the heap which is no longer needed.
98
99 We avoid this in two ways.
100 * First we use -XStrict in GHC.CoreToIface which avoids many thunks
101 to begin with.
102 * Second we define NFData instance for Iface syntax and use them to
103 force any remaining thunks.
104
105 -XStrict is not sufficient as patterns of the form `f (g x)` would still
106 result in a thunk being allocated for `g x`.
107
108 NFData is sufficient for the space leak, but using -XStrict reduces allocation
109 by ~0.1% when compiling with -O. (nofib/spectral/simple, T10370).
110 It's essentially free performance hence we use -XStrict on top of NFData.
111
112 MR !1633 on gitlab, has more discussion on the topic.
113 -}
114
115 ----------------
116 toIfaceTvBndr :: TyVar -> IfaceTvBndr
117 toIfaceTvBndr = toIfaceTvBndrX emptyVarSet
118
119 toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
120 toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
121 , toIfaceTypeX fr (tyVarKind tyvar)
122 )
123
124 toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr]
125 toIfaceTvBndrs = map toIfaceTvBndr
126
127 toIfaceIdBndr :: Id -> IfaceIdBndr
128 toIfaceIdBndr = toIfaceIdBndrX emptyVarSet
129
130 toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr
131 toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar)
132 , occNameFS (getOccName covar)
133 , toIfaceTypeX fr (varType covar)
134 )
135
136 toIfaceBndr :: Var -> IfaceBndr
137 toIfaceBndr var
138 | isId var = IfaceIdBndr (toIfaceIdBndr var)
139 | otherwise = IfaceTvBndr (toIfaceTvBndr var)
140
141 toIfaceBndrX :: VarSet -> Var -> IfaceBndr
142 toIfaceBndrX fr var
143 | isId var = IfaceIdBndr (toIfaceIdBndrX fr var)
144 | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var)
145
146 toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis
147 toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis
148
149 toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis]
150 toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder
151
152 {-
153 ************************************************************************
154 * *
155 Conversion from Type to IfaceType
156 * *
157 ************************************************************************
158 -}
159
160 toIfaceKind :: Type -> IfaceType
161 toIfaceKind = toIfaceType
162
163 ---------------------
164 toIfaceType :: Type -> IfaceType
165 toIfaceType = toIfaceTypeX emptyVarSet
166
167 toIfaceTypeX :: VarSet -> Type -> IfaceType
168 -- (toIfaceTypeX free ty)
169 -- translates the tyvars in 'free' as IfaceFreeTyVars
170 --
171 -- Synonyms are retained in the interface type
172 toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in GHC.Iface.Type
173 | tv `elemVarSet` fr = IfaceFreeTyVar tv
174 | otherwise = IfaceTyVar (toIfaceTyVar tv)
175 toIfaceTypeX fr ty@(AppTy {}) =
176 -- Flatten as many argument AppTys as possible, then turn them into an
177 -- IfaceAppArgs list.
178 -- See Note [Suppressing invisible arguments] in GHC.Iface.Type.
179 let (head, args) = splitAppTys ty
180 in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args)
181 toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n)
182 toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b)
183 (toIfaceTypeX (fr `delVarSet` binderVar b) t)
184 toIfaceTypeX fr (FunTy { ft_arg = t1, ft_mult = w, ft_res = t2, ft_af = af })
185 = IfaceFunTy af (toIfaceTypeX fr w) (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
186 toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co)
187 toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co)
188
189 toIfaceTypeX fr (TyConApp tc tys)
190 -- tuples
191 | Just sort <- tyConTuple_maybe tc
192 , n_tys == arity
193 = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys)
194
195 | Just dc <- isPromotedDataCon_maybe tc
196 , isBoxedTupleDataCon dc
197 , n_tys == 2*arity
198 = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))
199
200 | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]
201 , (k1:k2:_) <- tys
202 = let info = mkIfaceTyConInfo NotPromoted sort
203 sort | k1 `eqType` k2 = IfaceEqualityTyCon
204 | otherwise = IfaceNormalTyCon
205 in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)
206
207 -- other applications
208 | otherwise
209 = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys)
210 where
211 arity = tyConArity tc
212 n_tys = length tys
213
214 toIfaceTyVar :: TyVar -> FastString
215 toIfaceTyVar = occNameFS . getOccName
216
217 toIfaceCoVar :: CoVar -> FastString
218 toIfaceCoVar = occNameFS . getOccName
219
220 toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag)
221 toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet
222
223 toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag)
224 toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis
225
226 ----------------
227 toIfaceTyCon :: TyCon -> IfaceTyCon
228 toIfaceTyCon tc
229 = IfaceTyCon tc_name info
230 where
231 tc_name = tyConName tc
232 info = mkIfaceTyConInfo promoted sort
233 promoted | isPromotedDataCon tc = IsPromoted
234 | otherwise = NotPromoted
235
236 tupleSort :: TyCon -> Maybe IfaceTyConSort
237 tupleSort tc' =
238 case tyConTuple_maybe tc' of
239 Just UnboxedTuple -> let arity = tyConArity tc' `div` 2
240 in Just $ IfaceTupleTyCon arity UnboxedTuple
241 Just sort -> let arity = tyConArity tc'
242 in Just $ IfaceTupleTyCon arity sort
243 Nothing -> Nothing
244
245 sort
246 | Just tsort <- tupleSort tc = tsort
247
248 | Just dcon <- isPromotedDataCon_maybe tc
249 , let tc' = dataConTyCon dcon
250 , Just tsort <- tupleSort tc' = tsort
251
252 | isUnboxedSumTyCon tc
253 , Just cons <- tyConDataCons_maybe tc = IfaceSumTyCon (length cons)
254
255 | otherwise = IfaceNormalTyCon
256
257
258 toIfaceTyCon_name :: Name -> IfaceTyCon
259 toIfaceTyCon_name n = IfaceTyCon n info
260 where info = mkIfaceTyConInfo NotPromoted IfaceNormalTyCon
261 -- Used for the "rough-match" tycon stuff,
262 -- where pretty-printing is not an issue
263
264 toIfaceTyLit :: TyLit -> IfaceTyLit
265 toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
266 toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
267 toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x
268
269 ----------------
270 toIfaceCoercion :: Coercion -> IfaceCoercion
271 toIfaceCoercion = toIfaceCoercionX emptyVarSet
272
273 toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
274 -- (toIfaceCoercionX free ty)
275 -- translates the tyvars in 'free' as IfaceFreeTyVars
276 toIfaceCoercionX fr co
277 = go co
278 where
279 go_mco MRefl = IfaceMRefl
280 go_mco (MCo co) = IfaceMCo $ go co
281
282 go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty)
283 go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco)
284 go (CoVarCo cv)
285 -- See [TcTyVars in IfaceType] in GHC.Iface.Type
286 | cv `elemVarSet` fr = IfaceFreeCoVar cv
287 | otherwise = IfaceCoVarCo (toIfaceCoVar cv)
288 go (HoleCo h) = IfaceHoleCo (coHoleCoVar h)
289
290 go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2)
291 go (SymCo co) = IfaceSymCo (go co)
292 go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2)
293 go (NthCo _r d co) = IfaceNthCo d (go co)
294 go (LRCo lr co) = IfaceLRCo lr (go co)
295 go (InstCo co arg) = IfaceInstCo (go co) (go arg)
296 go (KindCo c) = IfaceKindCo (go c)
297 go (SubCo co) = IfaceSubCo (go co)
298 go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs)
299 go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs)
300 go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r
301 (toIfaceTypeX fr t1)
302 (toIfaceTypeX fr t2)
303 go (TyConAppCo r tc cos)
304 | tc `hasKey` funTyConKey
305 , [_,_,_,_, _] <- cos = panic "toIfaceCoercion"
306 | otherwise =
307 IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)
308 go (FunCo r w co1 co2) = IfaceFunCo r (go w) (go co1) (go co2)
309
310 go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv)
311 (toIfaceCoercionX fr' k)
312 (toIfaceCoercionX fr' co)
313 where
314 fr' = fr `delVarSet` tv
315
316 go_prov :: UnivCoProvenance -> IfaceUnivCoProv
317 go_prov (PhantomProv co) = IfacePhantomProv (go co)
318 go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
319 go_prov (PluginProv str) = IfacePluginProv str
320 go_prov (CorePrepProv b) = IfaceCorePrepProv b
321
322 toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
323 toIfaceTcArgs = toIfaceTcArgsX emptyVarSet
324
325 toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs
326 toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args
327
328 toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs
329 toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args
330
331 toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs
332 -- See Note [Suppressing invisible arguments] in GHC.Iface.Type
333 -- We produce a result list of args describing visibility
334 -- The awkward case is
335 -- T :: forall k. * -> k
336 -- And consider
337 -- T (forall j. blah) * blib
338 -- Is 'blib' visible? It depends on the visibility flag on j,
339 -- so we have to substitute for k. Annoying!
340 toIfaceAppArgsX fr kind ty_args
341 = go (mkEmptyTCvSubst in_scope) kind ty_args
342 where
343 in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
344
345 go _ _ [] = IA_Nil
346 go env ty ts
347 | Just ty' <- coreView ty
348 = go env ty' ts
349 go env (ForAllTy (Bndr tv vis) res) (t:ts)
350 = IA_Arg t' vis ts'
351 where
352 t' = toIfaceTypeX fr t
353 ts' = go (extendTCvSubst env tv t) res ts
354
355 go env (FunTy { ft_af = af, ft_res = res }) (t:ts)
356 = IA_Arg (toIfaceTypeX fr t) argf (go env res ts)
357 where
358 argf = case af of
359 VisArg -> Required
360 InvisArg -> Inferred
361 -- It's rare for a kind to have a constraint argument, but
362 -- it can happen. See Note [AnonTCB InvisArg] in GHC.Core.TyCon.
363
364 go env ty ts@(t1:ts1)
365 | not (isEmptyTCvSubst env)
366 = go (zapTCvSubst env) (substTy env ty) ts
367 -- See Note [Care with kind instantiation] in GHC.Core.Type
368
369 | otherwise
370 = -- There's a kind error in the type we are trying to print
371 -- e.g. kind = k, ty_args = [Int]
372 -- This is probably a compiler bug, so we print a trace and
373 -- carry on as if it were FunTy. Without the test for
374 -- isEmptyTCvSubst we'd get an infinite loop (#15473)
375 warnPprTrace True (ppr kind $$ ppr ty_args) $
376 IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1)
377
378 tidyToIfaceType :: TidyEnv -> Type -> IfaceType
379 tidyToIfaceType env ty = toIfaceType (tidyType env ty)
380
381 tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs
382 tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)
383
384 tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
385 tidyToIfaceContext env theta = map (tidyToIfaceType env) theta
386
387 {-
388 ************************************************************************
389 * *
390 Conversion of pattern synonyms
391 * *
392 ************************************************************************
393 -}
394
395 patSynToIfaceDecl :: PatSyn -> IfaceDecl
396 patSynToIfaceDecl ps
397 = IfacePatSyn { ifName = getName $ ps
398 , ifPatMatcher = to_if_pr (patSynMatcher ps)
399 , ifPatBuilder = fmap to_if_pr (patSynBuilder ps)
400 , ifPatIsInfix = patSynIsInfix ps
401 , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs'
402 , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs'
403 , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta
404 , ifPatReqCtxt = tidyToIfaceContext env2 req_theta
405 , ifPatArgs = map (tidyToIfaceType env2 . scaledThing) args
406 , ifPatTy = tidyToIfaceType env2 rhs_ty
407 , ifFieldLabels = (patSynFieldLabels ps)
408 }
409 where
410 (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
411 univ_bndrs = patSynUnivTyVarBinders ps
412 ex_bndrs = patSynExTyVarBinders ps
413 (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs
414 (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs
415 to_if_pr (name, _type, needs_dummy) = (name, needs_dummy)
416
417 {-
418 ************************************************************************
419 * *
420 Conversion of other things
421 * *
422 ************************************************************************
423 -}
424
425 toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
426 toIfaceBang _ HsLazy = IfNoBang
427 toIfaceBang _ (HsUnpack Nothing) = IfUnpack
428 toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
429 toIfaceBang _ HsStrict = IfStrict
430
431 toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
432 toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
433
434 toIfaceLetBndr :: Id -> IfaceLetBndr
435 toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
436 (toIfaceType (idType id))
437 (toIfaceIdInfo (idInfo id))
438 (toIfaceJoinInfo (isJoinId_maybe id))
439 -- Put into the interface file any IdInfo that GHC.Core.Tidy.tidyLetBndr
440 -- has left on the Id. See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax
441
442 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
443 toIfaceIdDetails VanillaId = IfVanillaId
444 toIfaceIdDetails (DFunId {}) = IfDFunId
445 toIfaceIdDetails (RecSelId { sel_naughty = n
446 , sel_tycon = tc }) =
447 let iface = case tc of
448 RecSelData ty_con -> Left (toIfaceTyCon ty_con)
449 RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn)
450 in IfRecSelId iface n
451
452 -- The remaining cases are all "implicit Ids" which don't
453 -- appear in interface files at all
454 toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
455 IfVanillaId -- Unexpected; the other
456
457 toIfaceIdInfo :: IdInfo -> IfaceIdInfo
458 toIfaceIdInfo id_info
459 = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo,
460 inline_hsinfo, unfold_hsinfo, levity_hsinfo]
461 -- NB: strictness and arity must appear in the list before unfolding
462 -- See GHC.IfaceToCore.tcUnfolding
463 where
464 ------------ Arity --------------
465 arity_info = arityInfo id_info
466 arity_hsinfo | arity_info == 0 = Nothing
467 | otherwise = Just (HsArity arity_info)
468
469 ------------ Caf Info --------------
470 caf_info = cafInfo id_info
471 caf_hsinfo = case caf_info of
472 NoCafRefs -> Just HsNoCafRefs
473 _other -> Nothing
474
475 ------------ Strictness --------------
476 -- No point in explicitly exporting TopSig
477 sig_info = dmdSigInfo id_info
478 strict_hsinfo | not (isTopSig sig_info) = Just (HsDmdSig sig_info)
479 | otherwise = Nothing
480
481 ------------ CPR --------------
482 cpr_info = cprSigInfo id_info
483 cpr_hsinfo | cpr_info /= topCprSig = Just (HsCprSig cpr_info)
484 | otherwise = Nothing
485 ------------ Unfolding --------------
486 unfold_hsinfo = toIfUnfolding loop_breaker (realUnfoldingInfo id_info)
487 loop_breaker = isStrongLoopBreaker (occInfo id_info)
488
489 ------------ Inline prag --------------
490 inline_prag = inlinePragInfo id_info
491 inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
492 | otherwise = Just (HsInline inline_prag)
493
494 ------------ Representation polymorphism ----------
495 levity_hsinfo | isNeverRepPolyIdInfo id_info = Just HsLevity
496 | otherwise = Nothing
497
498 toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo
499 toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar
500 toIfaceJoinInfo Nothing = IfaceNotJoinPoint
501
502 --------------------------
503 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
504 toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
505 , uf_src = src
506 , uf_guidance = guidance })
507 = Just $ HsUnfold lb $
508 case src of
509 InlineStable
510 -> case guidance of
511 UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
512 -> IfInlineRule arity unsat_ok boring_ok if_rhs
513 _other -> IfCoreUnfold True if_rhs
514 InlineCompulsory -> IfCompulsory if_rhs
515 InlineRhs -> IfCoreUnfold False if_rhs
516 -- Yes, even if guidance is UnfNever, expose the unfolding
517 -- If we didn't want to expose the unfolding, GHC.Iface.Tidy would
518 -- have stuck in NoUnfolding. For supercompilation we want
519 -- to see that unfolding!
520 where
521 if_rhs = toIfaceExpr rhs
522
523 toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
524 = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))
525 -- No need to serialise the data constructor;
526 -- we can recover it from the type of the dfun
527
528 toIfUnfolding _ (OtherCon {}) = Nothing
529 -- The binding site of an Id doesn't have OtherCon, except perhaps
530 -- where we have called zapUnfolding; and that evald'ness info is
531 -- not needed by importing modules
532
533 toIfUnfolding _ BootUnfolding = Nothing
534 -- Can't happen; we only have BootUnfolding for imported binders
535
536 toIfUnfolding _ NoUnfolding = Nothing
537
538 {-
539 ************************************************************************
540 * *
541 Conversion of expressions
542 * *
543 ************************************************************************
544 -}
545
546 toIfaceExpr :: CoreExpr -> IfaceExpr
547 toIfaceExpr (Var v) = toIfaceVar v
548 toIfaceExpr (Lit (LitRubbish r)) = IfaceLitRubbish (toIfaceType r)
549 toIfaceExpr (Lit l) = IfaceLit l
550 toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
551 toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co)
552 toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)
553 toIfaceExpr (App f a) = toIfaceApp f [a]
554 toIfaceExpr (Case s x ty as)
555 | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty)
556 | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as)
557 toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
558 toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)
559 toIfaceExpr (Tick t e)
560 | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)
561 | otherwise = toIfaceExpr e
562
563 toIfaceOneShot :: Id -> IfaceOneShot
564 toIfaceOneShot id | isId id
565 , OneShotLam <- oneShotInfo (idInfo id)
566 = IfaceOneShot
567 | otherwise
568 = IfaceNoOneShot
569
570 ---------------------
571 toIfaceTickish :: CoreTickish -> Maybe IfaceTickish
572 toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)
573 toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix)
574 toIfaceTickish (SourceNote src names) = Just (IfaceSource src names)
575 toIfaceTickish (Breakpoint {}) = Nothing
576 -- Ignore breakpoints, since they are relevant only to GHCi, and
577 -- should not be serialised (#8333)
578
579 ---------------------
580 toIfaceBind :: Bind Id -> IfaceBinding
581 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
582 toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
583
584 ---------------------
585 toIfaceAlt :: CoreAlt -> IfaceAlt
586 toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r)
587
588 ---------------------
589 toIfaceCon :: AltCon -> IfaceConAlt
590 toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)
591 toIfaceCon (LitAlt l) = assertPpr (not (isLitRubbish l)) (ppr l) $
592 -- assert: see Note [Rubbish literals] wrinkle (b)
593 IfaceLitAlt l
594 toIfaceCon DEFAULT = IfaceDefault
595
596 ---------------------
597 toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
598 toIfaceApp (App f a) as = toIfaceApp f (a:as)
599 toIfaceApp (Var v) as
600 = case isDataConWorkId_maybe v of
601 -- We convert the *worker* for tuples into IfaceTuples
602 Just dc | saturated
603 , Just tup_sort <- tyConTuple_maybe tc
604 -> IfaceTuple tup_sort tup_args
605 where
606 val_args = dropWhile isTypeArg as
607 saturated = val_args `lengthIs` idArity v
608 tup_args = map toIfaceExpr val_args
609 tc = dataConTyCon dc
610
611 _ -> mkIfaceApps (toIfaceVar v) as
612
613 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
614
615 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
616 mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
617
618 ---------------------
619 toIfaceVar :: Id -> IfaceExpr
620 toIfaceVar v
621 | isBootUnfolding (idUnfolding v)
622 = -- See Note [Inlining and hs-boot files]
623 IfaceApp (IfaceApp (IfaceExt noinlineIdName)
624 (IfaceType (toIfaceType (idType v))))
625 (IfaceExt name) -- don't use mkIfaceApps, or infinite loop
626
627 | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
628 -- Foreign calls have special syntax
629
630 | isExternalName name = IfaceExt name
631 | otherwise = IfaceLcl (getOccFS name)
632 where name = idName v
633
634
635 ---------------------
636 toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo
637 toIfaceLFInfo nm lfi = case lfi of
638 LFReEntrant top_lvl arity no_fvs _arg_descr ->
639 -- Exported LFReEntrant closures are top level, and top-level closures
640 -- don't have free variables
641 assertPpr (isTopLevel top_lvl) (ppr nm) $
642 assertPpr no_fvs (ppr nm) $
643 IfLFReEntrant arity
644 LFThunk top_lvl no_fvs updatable sfi mb_fun ->
645 -- Exported LFThunk closures are top level (which don't have free
646 -- variables) and non-standard (see cgTopRhsClosure)
647 assertPpr (isTopLevel top_lvl) (ppr nm) $
648 assertPpr no_fvs (ppr nm) $
649 assertPpr (sfi == NonStandardThunk) (ppr nm) $
650 IfLFThunk updatable mb_fun
651 LFCon dc ->
652 IfLFCon (dataConName dc)
653 LFUnknown mb_fun ->
654 IfLFUnknown mb_fun
655 LFUnlifted ->
656 IfLFUnlifted
657 LFLetNoEscape ->
658 panic "toIfaceLFInfo: LFLetNoEscape"
659
660 {- Note [Inlining and hs-boot files]
661 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
662 Consider this example (#10083, #12789):
663
664 ---------- RSR.hs-boot ------------
665 module RSR where
666 data RSR
667 eqRSR :: RSR -> RSR -> Bool
668
669 ---------- SR.hs ------------
670 module SR where
671 import {-# SOURCE #-} RSR
672 data SR = MkSR RSR
673 eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2
674
675 ---------- RSR.hs ------------
676 module RSR where
677 import SR
678 data RSR = MkRSR SR -- deriving( Eq )
679 eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)
680 foo x y = not (eqRSR x y)
681
682 When compiling RSR we get this code
683
684 RSR.eqRSR :: RSR -> RSR -> Bool
685 RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) ->
686 case ds1 of _ { RSR.MkRSR s1 ->
687 case ds2 of _ { RSR.MkRSR s2 ->
688 SR.eqSR s1 s2 }}
689
690 RSR.foo :: RSR -> RSR -> Bool
691 RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y)
692
693 Now, when optimising foo:
694 Inline eqRSR (small, non-rec)
695 Inline eqSR (small, non-rec)
696 but the result of inlining eqSR from SR is another call to eqRSR, so
697 everything repeats. Neither eqSR nor eqRSR are (apparently) loop
698 breakers.
699
700 Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR
701 with `noinline eqRSR`, so that eqRSR doesn't get inlined. This means
702 that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly
703 as would have been the case if `foo` had been defined in SR.hs (and
704 marked as a loop-breaker).
705
706 But how do we arrange for this to happen? There are two ingredients:
707
708 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar),
709 for every variable reference we see if we are referring to an
710 'Id' that came from an hs-boot file. If so, we add a `noinline`
711 to the reference.
712
713 2. But how do we know if a reference came from an hs-boot file
714 or not? We could record this directly in the 'IdInfo', but
715 actually we deduce this by looking at the unfolding: 'Id's
716 that come from boot files are given a special unfolding
717 (upon typechecking) 'BootUnfolding' which say that there is
718 no unfolding, and the reason is because the 'Id' came from
719 a boot file.
720
721 Here is a solution that doesn't work: when compiling RSR,
722 add a NOINLINE pragma to every function exported by the boot-file
723 for RSR (if it exists). Doing so makes the bootstrapped GHC itself
724 slower by 8% overall (on #9872a-d, and T1969: the reason
725 is that these NOINLINE'd functions now can't be profitably inlined
726 outside of the hs-boot loop.
727
728 -}