2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 %************************************************************************
6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
8 %************************************************************************
10 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
11 @TyVars@ as well. Currently trying the former... MEGA SIGH.
15 module IfaceType, -- Re-export all this
17 IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
18 IfaceExpr(..), IfaceAlt, IfaceNote(..),
19 IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
20 IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
25 -- Converting things to IfaceSyn
26 tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule,
29 IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
30 eqIfDecl, eqIfInst, eqIfRule,
33 pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
36 #include "HsVersions.h"
41 import FunDeps ( pprFundeps )
42 import NewDemand ( StrictSig, pprIfaceStrictSig )
43 import TcType ( deNoteType, mkSigmaTy, tcSplitDFunTy, mkClassPred )
44 import Type ( TyThing(..), mkForAllTys, mkFunTys, splitForAllTys, funResultTy,
45 mkTyVarTys, mkTyConApp, mkTyVarTys, mkPredTy, tidyTopType )
46 import InstEnv ( DFunId )
47 import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe )
48 import NewDemand ( isTopSig )
49 import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
50 arityInfo, cafInfo, newStrictnessInfo,
51 workerInfo, unfoldingInfo, inlinePragInfo )
52 import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
53 isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
54 isTupleTyCon, tupleTyConBoxity,
55 tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn,
56 tyConArity, tyConTyVars, algTyConRhs, tyConExtName )
57 import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
58 dataConTyCon, dataConIsInfix )
59 import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
60 import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv,
61 lookupOccEnv, extendOccEnv, emptyOccEnv,
62 OccSet, unionOccSets, unitOccSet )
63 import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModuleName, isExternalName )
64 import NameSet ( NameSet, elemNameSet )
65 import Module ( ModuleName )
66 import CostCentre ( CostCentre, pprCostCentreCore )
67 import Literal ( Literal )
68 import ForeignCall ( ForeignCall )
69 import TysPrim ( alphaTyVars )
70 import BasicTypes ( Arity, Activation(..), StrictnessMark,
71 RecFlag(..), boolToRecFlag, Boxity(..),
75 import Maybes ( catMaybes )
76 import Util ( lengthIs )
79 infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
83 %************************************************************************
85 Data type declarations
87 %************************************************************************
91 = IfaceId { ifName :: OccName,
93 ifIdInfo :: IfaceIdInfo }
95 | IfaceData { ifCtxt :: IfaceContext, -- Context
96 ifName :: OccName, -- Type constructor
97 ifTyVars :: [IfaceTvBndr], -- Type variables
98 ifCons :: IfaceConDecls, -- Includes new/data info
99 ifRec :: RecFlag, -- Recursive or not?
101 ifGeneric :: Bool -- True <=> generic converter functions available
102 } -- We need this for imported data decls, since the
103 -- imported modules may have been compiled with
104 -- different flags to the current compilation unit
106 | IfaceSyn { ifName :: OccName, -- Type constructor
107 ifTyVars :: [IfaceTvBndr], -- Type variables
109 ifSynRhs :: IfaceType -- synonym expansion
112 | IfaceClass { ifCtxt :: IfaceContext, -- Context...
113 ifName :: OccName, -- Name of the class
114 ifTyVars :: [IfaceTvBndr], -- Type variables
115 ifFDs :: [FunDep OccName], -- Functional dependencies
116 ifSigs :: [IfaceClassOp], -- Method signatures
117 ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive?
118 ifVrcs :: ArgVrcs -- ... and what are its argument variances ...
121 | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET
122 ifExtName :: Maybe FastString }
124 data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
125 -- Nothing => no default method
126 -- Just False => ordinary polymorphic default method
127 -- Just True => generic default method
130 = IfAbstractTyCon -- No info
131 | IfDataTyCon [IfaceConDecl] -- data type decls
132 | IfNewTyCon IfaceConDecl -- newtype decls
134 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
135 visibleIfConDecls IfAbstractTyCon = []
136 visibleIfConDecls (IfDataTyCon cs) = cs
137 visibleIfConDecls (IfNewTyCon c) = [c]
140 = IfaceConDecl OccName -- Constructor name
141 Bool -- True <=> declared infix
142 [IfaceTvBndr] -- Existental tyvars
143 IfaceContext -- Existential context
144 [IfaceType] -- Arg types
145 [StrictnessMark] -- Empty (meaning all lazy), or 1-1 corresp with arg types
146 [OccName] -- ...ditto... (field labels)
148 data IfaceInst = IfaceInst { ifInstHead :: IfaceType, -- Just the instance head type, quantified
149 -- so that it'll compare alpha-wise
150 ifDFun :: OccName } -- And the dfun
151 -- There's always a separate IfaceDecl for the DFun, which gives
152 -- its IdInfo with its full type and version number.
153 -- The instance declarations taken together have a version number,
154 -- and we don't want that to wobble gratuitously
155 -- If this instance decl is *used*, we'll record a usage on the dfun;
156 -- and if the head does not change it won't be used if it wasn't before
160 ifRuleName :: RuleName,
161 ifActivation :: Activation,
162 ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
163 ifRuleHead :: IfaceExtName, -- Head of lhs
164 ifRuleArgs :: [IfaceExpr], -- Args of LHS
165 ifRuleRhs :: IfaceExpr
167 | IfaceBuiltinRule IfaceExtName CoreRule -- So that built-in rules can
168 -- wait in the RulePol
171 = NoInfo -- When writing interface file without -O
172 | HasInfo [IfaceInfoItem] -- Has info, and here it is
174 -- Here's a tricky case:
175 -- * Compile with -O module A, and B which imports A.f
176 -- * Change function f in A, and recompile without -O
177 -- * When we read in old A.hi we read in its IdInfo (as a thunk)
178 -- (In earlier GHCs we used to drop IdInfo immediately on reading,
179 -- but we do not do that now. Instead it's discarded when the
180 -- ModIface is read into the various decl pools.)
181 -- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
182 -- and so gives a new version.
186 | HsStrictness StrictSig
187 | HsUnfold Activation IfaceExpr
189 | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo
190 -- for why we want arity here.
191 -- NB: we need IfaceExtName (not just OccName) because the worker
192 -- can simplify to a function in another module.
193 -- NB: Specialisations and rules come in separately and are
194 -- only later attached to the Id. Partial reason: some are orphans.
196 --------------------------------
199 | IfaceExt IfaceExtName
200 | IfaceType IfaceType
201 | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
202 | IfaceLam IfaceBndr IfaceExpr
203 | IfaceApp IfaceExpr IfaceExpr
204 | IfaceCase IfaceExpr OccName [IfaceAlt]
205 | IfaceLet IfaceBinding IfaceExpr
206 | IfaceNote IfaceNote IfaceExpr
208 | IfaceFCall ForeignCall IfaceType
210 data IfaceNote = IfaceSCC CostCentre
211 | IfaceCoerce IfaceType
214 | IfaceCoreNote String
216 type IfaceAlt = (IfaceConAlt, [OccName], IfaceExpr)
217 -- Note: OccName, not IfaceBndr (and same with the case binder)
218 -- We reconstruct the kind/type of the thing from the context
219 -- thus saving bulk in interface files
221 data IfaceConAlt = IfaceDefault
222 | IfaceDataAlt OccName
223 | IfaceTupleAlt Boxity
224 | IfaceLitAlt Literal
227 = IfaceNonRec IfaceIdBndr IfaceExpr
228 | IfaceRec [(IfaceIdBndr, IfaceExpr)]
232 %************************************************************************
234 \subsection[HsCore-print]{Printing Core unfoldings}
236 %************************************************************************
238 ----------------------------- Printing IfaceDecl ------------------------------------
241 instance Outputable IfaceDecl where
244 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
245 = sep [ ppr var <+> dcolon <+> ppr ty,
248 pprIfaceDecl (IfaceForeign {ifName = tycon})
249 = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
251 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs})
252 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
253 4 (vcat [equals <+> ppr mono_ty,
256 pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen,
257 ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs})
258 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
259 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls])
261 pp_nd = case condecls of
262 IfAbstractTyCon -> ptext SLIT("data")
263 IfDataTyCon _ -> ptext SLIT("data")
264 IfNewTyCon _ -> ptext SLIT("newtype")
266 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
267 ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
268 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
269 4 (vcat [pprVrcs vrcs,
273 pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs
274 pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
275 pprGen True = ptext SLIT("Generics: yes")
276 pprGen False = ptext SLIT("Generics: no")
278 instance Outputable IfaceClassOp where
279 ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
281 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
282 pprIfaceDeclHead context thing tyvars
283 = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars]
285 pp_condecls IfAbstractTyCon = ptext SLIT("{- abstract -}")
286 pp_condecls (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
287 pp_condecls (IfNewTyCon c) = equals <+> ppr c
289 instance Outputable IfaceConDecl where
290 ppr (IfaceConDecl name is_infix ex_tvs ex_ctxt arg_tys strs fields)
291 = pprIfaceForAllPart ex_tvs ex_ctxt $
292 sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
293 if is_infix then ptext SLIT("Infix") else empty,
294 if null strs then empty
295 else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
296 if null fields then empty
297 else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
299 instance Outputable IfaceRule where
300 ppr (IfaceRule name act bndrs fn args rhs)
301 = sep [hsep [doubleQuotes (ftext name), ppr act,
302 ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
303 nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
304 ptext SLIT("=") <+> ppr rhs])
306 ppr (IfaceBuiltinRule name rule)
307 = ptext SLIT("Built-in rule for") <+> ppr name
309 instance Outputable IfaceInst where
310 ppr (IfaceInst {ifDFun = dfun_id, ifInstHead = ty})
311 = hang (ptext SLIT("instance") <+> ppr ty)
312 2 (equals <+> ppr dfun_id)
316 ----------------------------- Printing IfaceExpr ------------------------------------
319 instance Outputable IfaceExpr where
320 ppr e = pprIfaceExpr noParens e
322 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
323 -- The function adds parens in context that need
324 -- an atomic value (e.g. function args)
326 pprIfaceExpr add_par (IfaceLcl v) = ppr v
327 pprIfaceExpr add_par (IfaceExt v) = ppr v
328 pprIfaceExpr add_par (IfaceLit l) = ppr l
329 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
330 pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
332 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
333 pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as)
335 pprIfaceExpr add_par e@(IfaceLam _ _)
336 = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
337 pprIfaceExpr noParens body])
339 (bndrs,body) = collect [] e
340 collect bs (IfaceLam b e) = collect (b:bs) e
341 collect bs e = (reverse bs, e)
343 pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
344 = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
345 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
346 pprIfaceExpr noParens rhs <+> char '}'])
348 pprIfaceExpr add_par (IfaceCase scrut bndr alts)
349 = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
350 <+> ppr bndr <+> char '{',
351 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
353 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
354 = add_par (sep [ptext SLIT("let {"),
355 nest 2 (ppr_bind (b, rhs)),
357 pprIfaceExpr noParens body])
359 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
360 = add_par (sep [ptext SLIT("letrec {"),
361 nest 2 (sep (map ppr_bind pairs)),
363 pprIfaceExpr noParens body])
365 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
367 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
368 arrow <+> pprIfaceExpr noParens rhs]
370 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
371 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
373 ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
374 equals <+> pprIfaceExpr noParens rhs]
377 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
378 pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
381 instance Outputable IfaceNote where
382 ppr (IfaceSCC cc) = pprCostCentreCore cc
383 ppr (IfaceCoerce ty) = ptext SLIT("__coerce") <+> pprParendIfaceType ty
384 ppr IfaceInlineCall = ptext SLIT("__inline_call")
385 ppr IfaceInlineMe = ptext SLIT("__inline_me")
386 ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
388 instance Outputable IfaceConAlt where
389 ppr IfaceDefault = text "DEFAULT"
390 ppr (IfaceLitAlt l) = ppr l
391 ppr (IfaceDataAlt d) = ppr d
392 -- IfaceTupleAlt is handled by the case-alternative printer
395 instance Outputable IfaceIdInfo where
397 ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
399 ppr_hs_info (HsUnfold prag unf) = sep [ptext SLIT("Unfolding: ") <> ppr prag,
400 parens (pprIfaceExpr noParens unf)]
401 ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity
402 ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
403 ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs")
404 ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
408 %************************************************************************
410 Converting things to their Iface equivalents
412 %************************************************************************
416 tyThingToIfaceDecl :: Bool
417 -> NameSet -- Tycons and classes to export abstractly
418 -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl
419 tyThingToIfaceDecl discard_id_info _ ext (AnId id)
420 = IfaceId { ifName = getOccName id,
421 ifType = toIfaceType ext (idType id),
424 info | discard_id_info = NoInfo
425 | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id))
427 tyThingToIfaceDecl _ _ ext (AClass clas)
428 = IfaceClass { ifCtxt = toIfaceContext ext sc_theta,
429 ifName = getOccName clas,
430 ifTyVars = toIfaceTvBndrs clas_tyvars,
431 ifFDs = map toIfaceFD clas_fds,
432 ifSigs = map toIfaceClassOp op_stuff,
433 ifRec = boolToRecFlag (isRecursiveTyCon tycon),
434 ifVrcs = tyConArgVrcs tycon }
436 (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
437 tycon = classTyCon clas
439 toIfaceClassOp (sel_id, def_meth)
440 = ASSERT(sel_tyvars == clas_tyvars)
441 IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty)
443 -- Be careful when splitting the type, because of things
444 -- like class Foo a where
445 -- op :: (?x :: String) => a -> a
446 -- and class Baz a where
447 -- op :: (Ord a) => a -> a
448 (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
449 op_ty = funResultTy rho_ty
451 toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
453 tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon)
455 = IfaceSyn { ifName = getOccName tycon,
456 ifTyVars = toIfaceTvBndrs tyvars,
457 ifVrcs = tyConArgVrcs tycon,
458 ifSynRhs = toIfaceType ext syn_ty }
461 = IfaceData { ifCtxt = toIfaceContext ext (tyConTheta tycon),
462 ifName = getOccName tycon,
463 ifTyVars = toIfaceTvBndrs tyvars,
464 ifCons = ifaceConDecls (algTyConRhs tycon),
465 ifRec = boolToRecFlag (isRecursiveTyCon tycon),
466 ifVrcs = tyConArgVrcs tycon,
467 ifGeneric = tyConHasGenerics tycon }
469 | isForeignTyCon tycon
470 = IfaceForeign { ifName = getOccName tycon,
471 ifExtName = tyConExtName tycon }
473 | isPrimTyCon tycon || isFunTyCon tycon
474 -- Needed in GHCi for ':info Int#', for example
475 = IfaceData { ifCtxt = [],
476 ifName = getOccName tycon,
477 ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
478 ifCons = IfAbstractTyCon,
480 ifRec = NonRecursive,
481 ifVrcs = tyConArgVrcs tycon }
483 | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
485 tyvars = tyConTyVars tycon
486 (_, syn_ty) = getSynTyConDefn tycon
487 abstract = getName tycon `elemNameSet` abstract_tcs
489 ifaceConDecls _ | abstract = IfAbstractTyCon
490 ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con)
491 ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons)
492 ifaceConDecls AbstractTyCon = IfAbstractTyCon
493 -- The last case should never happen when we are generating an
494 -- interface file (we're exporting this thing, so it's locally defined
495 -- and should not be abstract). But tyThingToIfaceDecl is also used
496 -- in TcRnDriver for GHCi, when browsing a module, in which case the
497 -- AbstractTyCon case is perfectly sensible.
499 ifaceConDecl data_con
500 = IfaceConDecl (getOccName (dataConName data_con))
501 (dataConIsInfix data_con)
502 (toIfaceTvBndrs ex_tyvars)
503 (toIfaceContext ext ex_theta)
504 (map (toIfaceType ext) arg_tys)
506 (map getOccName field_labels)
508 (_, _, ex_tyvars, ex_theta, arg_tys, _) = dataConSig data_con
509 field_labels = dataConFieldLabels data_con
510 strict_marks = dataConStrictMarks data_con
512 tyThingToIfaceDecl dis abstr ext (ADataCon dc)
513 = pprPanic "toIfaceDecl" (ppr dc)
516 --------------------------
517 dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst
518 dfunToIfaceInst mod dfun_id
519 = IfaceInst { ifDFun = getOccName dfun_id,
520 ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty }
522 (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
523 head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys))
524 -- No need to record the instance context;
525 -- it's in the dfun anyway
527 tidy_ty = tidyTopType (deNoteType head_ty)
528 -- The deNoteType is very important. It removes all type
529 -- synonyms from the instance type in interface files.
530 -- That in turn makes sure that when reading in instance decls
531 -- from interface files that the 'gating' mechanism works properly.
532 -- Otherwise you could have
533 -- type Tibble = T Int
534 -- instance Foo Tibble where ...
535 -- and this instance decl wouldn't get imported into a module
536 -- that mentioned T but not Tibble.
539 --------------------------
540 toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem]
541 toIfaceIdInfo ext id_info
542 = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
543 wrkr_hsinfo, unfold_hsinfo]
545 ------------ Arity --------------
546 arity_info = arityInfo id_info
547 arity_hsinfo | arity_info == 0 = Nothing
548 | otherwise = Just (HsArity arity_info)
550 ------------ Caf Info --------------
551 caf_info = cafInfo id_info
552 caf_hsinfo = case caf_info of
553 NoCafRefs -> Just HsNoCafRefs
556 ------------ Strictness --------------
557 -- No point in explicitly exporting TopSig
558 strict_hsinfo = case newStrictnessInfo id_info of
559 Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
562 ------------ Worker --------------
563 work_info = workerInfo id_info
564 has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
565 wrkr_hsinfo = case work_info of
566 HasWorker work_id wrap_arity ->
567 Just (HsWorker (ext (idName work_id)) wrap_arity)
570 ------------ Unfolding --------------
571 -- The unfolding is redundant if there is a worker
572 unfold_info = unfoldingInfo id_info
573 inline_prag = inlinePragInfo id_info
574 rhs = unfoldingTemplate unfold_info
575 unfold_hsinfo | neverUnfold unfold_info
576 || has_worker = Nothing
577 | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs))
579 --------------------------
580 coreRuleToIfaceRule :: ModuleName -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule
581 coreRuleToIfaceRule mod ext (id, BuiltinRule _ _)
582 = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id)))
584 coreRuleToIfaceRule mod ext (id, Rule name act bndrs args rhs)
585 = IfaceRule { ifRuleName = name, ifActivation = act,
586 ifRuleBndrs = map (toIfaceBndr ext) bndrs,
587 ifRuleHead = ext (idName id),
588 ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args,
589 -- Use LHS name-fn for the args
590 ifRuleRhs = toIfaceExpr ext rhs }
592 bogusIfaceRule :: IfaceExtName -> IfaceRule
593 bogusIfaceRule id_name
594 = IfaceRule FSLIT("bogus") NeverActive [] id_name [] (IfaceExt id_name)
596 ---------------------
597 toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr
598 toIfaceExpr ext (Var v) = toIfaceVar ext v
599 toIfaceExpr ext (Lit l) = IfaceLit l
600 toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty)
601 toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
602 toIfaceExpr ext (App f a) = toIfaceApp ext f [a]
603 toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as)
604 toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
605 toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
607 ---------------------
608 toIfaceNote ext (SCC cc) = IfaceSCC cc
609 toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1)
610 toIfaceNote ext InlineCall = IfaceInlineCall
611 toIfaceNote ext InlineMe = IfaceInlineMe
612 toIfaceNote ext (CoreNote s) = IfaceCoreNote s
614 ---------------------
615 toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r)
616 toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
618 ---------------------
619 toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r)
621 ---------------------
622 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
623 | otherwise = IfaceDataAlt (getOccName dc)
627 toIfaceCon (LitAlt l) = IfaceLitAlt l
628 toIfaceCon DEFAULT = IfaceDefault
630 ---------------------
631 toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as)
632 toIfaceApp ext (Var v) as
633 = case isDataConWorkId_maybe v of
634 -- We convert the *worker* for tuples into IfaceTuples
635 Just dc | isTupleTyCon tc && saturated
636 -> IfaceTuple (tupleTyConBoxity tc) tup_args
638 val_args = dropWhile isTypeArg as
639 saturated = val_args `lengthIs` idArity v
640 tup_args = map (toIfaceExpr ext) val_args
643 other -> mkIfaceApps ext (toIfaceVar ext v) as
645 toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as
647 mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as
649 ---------------------
650 toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr
652 | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
653 -- Foreign calls have special syntax
654 | isExternalName name = IfaceExt (ext name)
655 | otherwise = IfaceLcl (nameOccName name)
659 ---------------------
660 -- mkLhsNameFn ignores versioning info altogether
661 -- Used for the LHS of instance decls and rules, where we
662 -- there's no point in recording version info
663 mkLhsNameFn :: ModuleName -> Name -> IfaceExtName
664 mkLhsNameFn this_mod name
665 | mod == this_mod = LocalTop occ
666 | otherwise = ExtPkg mod occ
668 mod = nameModuleName name
669 occ = nameOccName name
673 %************************************************************************
675 Equality, for interface file version generaion only
677 %************************************************************************
679 Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is
680 EqBut, which gives the set of *locally-defined* things whose version must be equal
681 for the whole thing to be equal. So the key function is eqIfExt, which compares
684 Of course, equality is also done modulo alpha conversion.
688 = Equal -- Definitely exactly the same
689 | NotEqual -- Definitely different
690 | EqBut OccSet -- The same provided these local things have not changed
692 bool :: Bool -> IfaceEq
694 bool False = NotEqual
696 zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
697 zapEq (EqBut _) = Equal
700 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
702 NotEqual &&& x = NotEqual
703 EqBut occs &&& Equal = EqBut occs
704 EqBut occs &&& NotEqual = NotEqual
705 EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
707 ---------------------
708 eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
709 -- This function is the core of the EqBut stuff
710 eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2)
711 eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
712 eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1)
713 eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1)
714 eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
715 eqIfExt n1 n2 = NotEqual
720 ---------------------
721 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
722 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
723 = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
725 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
726 = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
728 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
729 = bool (ifName d1 == ifName d2 &&
730 ifRec d1 == ifRec d2 &&
731 ifVrcs d1 == ifVrcs d2 &&
732 ifGeneric d1 == ifGeneric d2) &&&
733 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
734 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
735 eq_hsCD env (ifCons d1) (ifCons d2)
738 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
739 = bool (ifName d1 == ifName d2) &&&
740 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
741 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
744 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
745 = bool (ifName d1 == ifName d2 &&
746 ifRec d1 == ifRec d2 &&
747 ifVrcs d1 == ifVrcs d2) &&&
748 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
749 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
750 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
751 eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
754 eqIfDecl _ _ = NotEqual -- default case
757 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
758 eqWith = eq_ifTvBndrs emptyEqEnv
760 -----------------------
761 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) &&&
762 zapEq (ifInstHead d1 `eqIfType` ifInstHead d2)
763 -- zapEq: for instances, ignore the EqBut part
765 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1)
766 (IfaceRule n2 a2 bs2 f2 es2 rhs2)
767 = bool (n1==n2 && a1==a2) &&&
769 eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
770 zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
771 -- zapEq: for the LHSs, ignore the EqBut part
772 eq_ifaceExpr env rhs1 rhs2)
773 eqIfRule _ _ = NotEqual
775 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) = eqListBy (eq_ConDecl env) c1 c2
776 eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
777 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
778 eq_hsCD env d1 d2 = NotEqual
780 eq_ConDecl env (IfaceConDecl n1 inf1 tvs1 cxt1 args1 ss1 lbls1)
781 (IfaceConDecl n2 inf2 tvs2 cxt2 args2 ss2 lbls2)
782 = bool (n1 == n2 && inf1 == inf2 && ss1 == ss2 && lbls1 == lbls2) &&&
783 eq_ifTvBndrs env tvs1 tvs2 (\ env ->
784 eq_ifContext env cxt1 cxt2 &&&
785 eq_ifTypes env args1 args2)
787 eq_hsFD env (ns1,ms1) (ns2,ms2)
788 = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
790 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
791 = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
797 eqIfIdInfo NoInfo NoInfo = Equal
798 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
799 eqIfIdInfo i1 i2 = NotEqual
801 eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
802 eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
803 eq_item (HsUnfold a1 u1) (HsUnfold a2 u2) = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2
804 eq_item HsNoCafRefs HsNoCafRefs = Equal
805 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
806 eq_item _ _ = NotEqual
809 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
810 eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2
811 eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
812 eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
813 eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
814 eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
815 eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
816 eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
817 eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
818 eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
820 eq_ifaceExpr env (IfaceCase s1 b1 as1) (IfaceCase s2 b2 as2)
821 = eq_ifaceExpr env s1 s2 &&&
822 eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
824 eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
825 = bool (eq_ifaceConAlt c1 c2) &&&
826 eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
828 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
829 = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
831 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
832 = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
834 (bs1,rs1) = unzip as1
835 (bs2,rs2) = unzip as2
838 eq_ifaceExpr env _ _ = NotEqual
841 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
842 eq_ifaceConAlt IfaceDefault IfaceDefault = True
843 eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2
844 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2
845 eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2
846 eq_ifaceConAlt _ _ = False
849 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
850 eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
851 eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2) = eq_ifType env t1 t2
852 eq_ifaceNote env IfaceInlineCall IfaceInlineCall = Equal
853 eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
854 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
855 eq_ifaceNote env _ _ = NotEqual
859 ---------------------
860 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
863 eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2
864 eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
865 eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2
866 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
867 eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
868 eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
869 eq_ifType env _ _ = NotEqual
872 eq_ifTypes env = eqListBy (eq_ifType env)
875 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
878 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2
879 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2
880 eq_ifPredType env _ _ = NotEqual
883 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
884 eqIfTc IfaceIntTc IfaceIntTc = Equal
885 eqIfTc IfaceCharTc IfaceCharTc = Equal
886 eqIfTc IfaceBoolTc IfaceBoolTc = Equal
887 eqIfTc IfaceListTc IfaceListTc = Equal
888 eqIfTc IfacePArrTc IfacePArrTc = Equal
889 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
890 eqIfTc _ _ = NotEqual
893 -----------------------------------------------------------
894 Support code for equality checking
895 -----------------------------------------------------------
898 ------------------------------------
899 type EqEnv = OccEnv OccName -- Tracks the mapping from L-variables to R-variables
901 eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq
902 eqIfOcc env n1 n2 = case lookupOccEnv env n1 of
903 Just n1 -> bool (n1 == n2)
904 Nothing -> bool (n1 == n2)
906 extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv
907 extendEqEnv env n1 n2 | n1 == n2 = env
908 | otherwise = extendOccEnv env n1 n2
911 emptyEqEnv = emptyOccEnv
913 ------------------------------------
914 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
916 eq_ifNakedBndr :: ExtEnv OccName
917 eq_ifBndr :: ExtEnv IfaceBndr
918 eq_ifTvBndr :: ExtEnv IfaceTvBndr
919 eq_ifIdBndr :: ExtEnv IfaceIdBndr
921 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
923 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
924 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
925 eq_ifBndr _ _ _ _ = NotEqual
927 eq_ifTvBndr env (v1, k1) (v2, k2) k = bool (k1 == k2) &&& k (extendEqEnv env v1 v2)
928 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
930 eq_ifBndrs :: ExtEnv [IfaceBndr]
931 eq_ifIdBndrs :: ExtEnv [IfaceIdBndr]
932 eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
933 eq_ifNakedBndrs :: ExtEnv [OccName]
934 eq_ifBndrs = eq_bndrs_with eq_ifBndr
935 eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr
936 eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
937 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
939 eq_bndrs_with eq env [] [] k = k env
940 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
941 eq_bndrs_with eq env _ _ _ = NotEqual
945 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
946 eqListBy eq [] [] = Equal
947 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
948 eqListBy eq xs ys = NotEqual
950 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
951 eqMaybeBy eq Nothing Nothing = Equal
952 eqMaybeBy eq (Just x) (Just y) = eq x y
953 eqMaybeBy eq x y = NotEqual