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