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