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(..),
18 IfaceExpr(..), IfaceAlt, IfaceNote(..),
19 IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
20 IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
22 -- Converting things to IfaceSyn
23 tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule,
26 IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
27 eqIfDecl, eqIfInst, eqIfRule,
30 pprIfaceExpr, pprIfaceDecl
33 #include "HsVersions.h"
38 import FunDeps ( pprFundeps )
39 import NewDemand ( StrictSig, pprIfaceStrictSig )
40 import TcType ( deNoteType, mkSigmaTy, tcSplitDFunTy, mkClassPred )
41 import Type ( TyThing(..), mkForAllTys, mkFunTys, splitForAllTys, funResultTy,
42 mkTyVarTys, mkTyConApp, mkTyVarTys, mkPredTy, tidyTopType )
43 import InstEnv ( DFunId )
44 import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe )
45 import NewDemand ( isTopSig )
46 import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
47 arityInfo, cafInfo, newStrictnessInfo,
48 workerInfo, unfoldingInfo, inlinePragInfo )
49 import TyCon ( ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon,
50 isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
51 isTupleTyCon, tupleTyConBoxity,
52 tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn,
53 tyConArity, tyConTyVars, tyConDataConDetails, tyConExtName )
54 import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
56 import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
57 import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv,
58 lookupOccEnv, extendOccEnv, emptyOccEnv,
59 OccSet, unionOccSets, unitOccSet )
60 import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModuleName, isExternalName )
61 import Module ( ModuleName )
62 import CostCentre ( CostCentre, pprCostCentreCore )
63 import Literal ( Literal )
64 import ForeignCall ( ForeignCall )
65 import TysPrim ( alphaTyVars )
66 import BasicTypes ( Arity, Activation(..), StrictnessMark, NewOrData(..),
67 RecFlag(..), boolToRecFlag, Boxity(..),
71 import Maybes ( catMaybes )
72 import Util ( lengthIs )
75 infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
79 %************************************************************************
81 Data type declarations
83 %************************************************************************
87 = IfaceId { ifName :: OccName,
89 ifIdInfo :: IfaceIdInfo }
91 | IfaceData { ifND :: NewOrData,
92 ifCtxt :: IfaceContext, -- Context
93 ifName :: OccName, -- Type constructor
94 ifTyVars :: [IfaceTvBndr], -- Type variables
95 ifCons :: DataConDetails IfaceConDecl,
96 ifRec :: RecFlag, -- Recursive or not?
98 ifGeneric :: Bool -- True <=> generic converter functions available
99 } -- We need this for imported data decls, since the
100 -- imported modules may have been compiled with
101 -- different flags to the current compilation unit
103 | IfaceSyn { ifName :: OccName, -- Type constructor
104 ifTyVars :: [IfaceTvBndr], -- Type variables
106 ifSynRhs :: IfaceType -- synonym expansion
109 | IfaceClass { ifCtxt :: IfaceContext, -- Context...
110 ifName :: OccName, -- Name of the class
111 ifTyVars :: [IfaceTvBndr], -- Type variables
112 ifFDs :: [FunDep OccName], -- Functional dependencies
113 ifSigs :: [IfaceClassOp], -- Method signatures
114 ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive?
115 ifVrcs :: ArgVrcs -- ... and what are its argument variances ...
118 | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET
119 ifExtName :: Maybe FastString }
121 data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
122 -- Nothing => no default method
123 -- Just False => ordinary polymorphic default method
124 -- Just True => generic default method
127 = IfaceConDecl OccName -- Constructor name
128 [IfaceTvBndr] -- Existental tyvars
129 IfaceContext -- Existential context
130 [IfaceType] -- Arg types
131 [StrictnessMark] -- Empty (meaning all lazy), or 1-1 corresp with arg types
132 [OccName] -- ...ditto... (field labels)
134 data IfaceInst = IfaceInst { ifInstHead :: IfaceType, -- Just the instance head type, quantified
135 -- so that it'll compare alpha-wise
136 ifDFun :: OccName } -- And the dfun
137 -- There's always a separate IfaceDecl for the DFun, which gives
138 -- its IdInfo with its full type and version number.
139 -- The instance declarations taken together have a version number,
140 -- and we don't want that to wobble gratuitously
141 -- If this instance decl is *used*, we'll record a usage on the dfun;
142 -- and if the head does not change it won't be used if it wasn't before
146 ifRuleName :: RuleName,
147 ifActivation :: Activation,
148 ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
149 ifRuleHead :: IfaceExtName, -- Head of lhs
150 ifRuleArgs :: [IfaceExpr], -- Args of LHS
151 ifRuleRhs :: IfaceExpr
153 | IfaceBuiltinRule IfaceExtName CoreRule -- So that built-in rules can
154 -- wait in the RulePol
157 = NoInfo -- When writing interface file without -O
158 | HasInfo [IfaceInfoItem] -- Has info, and here it is
159 | DiscardedInfo -- HasInfo in the .hi file, but discarded
160 -- when it was read in
161 -- Here's why we need this NoInfo/DiscardedInfo stuff
162 -- * Compile with -O module A, and B which imports A.f
163 -- * Change function f in A, and recompile without -O
164 -- * If we read in A.hi and discard IdInfo, the
165 -- new (empty) IdInfo for f looks like the
166 -- old (discarded) IdInfo for f
167 -- => no new version # for f
168 -- * But that might mean that we fail to recompile B, when
169 -- actually we should
171 -- * We also want to ensure that if A.hi was *already* compiled
172 -- without -O we *don't* then recompile B
174 -- When we discard IdInfo on *reading* we make it into DiscardedInfo
175 -- On *writing* we make it NoInfo
176 -- DiscardedInfo is never written into a file
180 | HsStrictness StrictSig
181 | HsUnfold Activation IfaceExpr
183 | HsWorker OccName Arity -- Worker, if any see IdInfo.WorkerInfo
184 -- for why we want arity here.
185 -- NB: Specialisations and rules come in separately and are
186 -- only later attached to the Id. Partial reason: some are orphans.
188 --------------------------------
191 | IfaceExt IfaceExtName
192 | IfaceType IfaceType
193 | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
194 | IfaceLam IfaceBndr IfaceExpr
195 | IfaceApp IfaceExpr IfaceExpr
196 | IfaceCase IfaceExpr OccName [IfaceAlt]
197 | IfaceLet IfaceBinding IfaceExpr
198 | IfaceNote IfaceNote IfaceExpr
200 | IfaceFCall ForeignCall IfaceType
202 data IfaceNote = IfaceSCC CostCentre
203 | IfaceCoerce IfaceType
206 | IfaceCoreNote String
208 type IfaceAlt = (IfaceConAlt, [OccName], IfaceExpr)
209 -- Note: OccName, not IfaceBndr (and same with the case binder)
210 -- We reconstruct the kind/type of the thing from the context
211 -- thus saving bulk in interface files
213 data IfaceConAlt = IfaceDefault
214 | IfaceDataAlt OccName
215 | IfaceTupleAlt Boxity
216 | IfaceLitAlt Literal
219 = IfaceNonRec IfaceIdBndr IfaceExpr
220 | IfaceRec [(IfaceIdBndr, IfaceExpr)]
224 %************************************************************************
226 \subsection[HsCore-print]{Printing Core unfoldings}
228 %************************************************************************
230 ----------------------------- Printing IfaceDecl ------------------------------------
233 instance Outputable IfaceDecl where
236 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
237 = sep [ ppr var <+> dcolon <+> ppr ty,
240 pprIfaceDecl (IfaceForeign {ifName = tycon})
241 = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
243 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs})
244 = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars)
245 4 (vcat [equals <+> ppr mono_ty,
248 pprIfaceDecl (IfaceData {ifND = new_or_data, ifCtxt = context, ifName = tycon, ifGeneric = gen,
249 ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs})
250 = hang (ppr new_or_data <+> pp_decl_head context tycon tyvars)
251 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls])
253 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
254 ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
255 = hang (ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds)
256 4 (vcat [pprVrcs vrcs,
260 pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs
261 pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
262 pprGen True = ptext SLIT("Generics: yes")
263 pprGen False = ptext SLIT("Generics: no")
265 instance Outputable IfaceClassOp where
266 ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
268 pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
269 pp_decl_head context thing tyvars
270 = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars]
272 pp_condecls Unknown = ptext SLIT("{- abstract -}")
273 pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
275 instance Outputable IfaceConDecl where
276 ppr (IfaceConDecl name ex_tvs ex_ctxt arg_tys strs fields)
277 = pprIfaceForAllPart ex_tvs ex_ctxt $
278 sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
279 if null strs then empty
280 else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
281 if null fields then empty
282 else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
284 instance Outputable IfaceRule where
285 ppr (IfaceRule name act bndrs fn args rhs)
286 = sep [hsep [doubleQuotes (ftext name), ppr act,
287 ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
288 nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
289 ptext SLIT("=") <+> ppr rhs])
291 ppr (IfaceBuiltinRule name rule)
292 = ptext SLIT("Built-in rule for") <+> ppr name
294 instance Outputable IfaceInst where
295 ppr (IfaceInst {ifDFun = dfun_id, ifInstHead = ty})
296 = hang (ptext SLIT("instance") <+> ppr ty)
297 2 (equals <+> ppr dfun_id)
301 ----------------------------- Printing IfaceExpr ------------------------------------
304 instance Outputable IfaceExpr where
305 ppr e = pprIfaceExpr noParens e
307 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
308 -- The function adds parens in context that need
309 -- an atomic value (e.g. function args)
311 pprIfaceExpr add_par (IfaceLcl v) = ppr v
312 pprIfaceExpr add_par (IfaceExt v) = ppr v
313 pprIfaceExpr add_par (IfaceLit l) = ppr l
314 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
315 pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
317 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
318 pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as)
320 pprIfaceExpr add_par e@(IfaceLam _ _)
321 = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
322 pprIfaceExpr noParens body])
324 (bndrs,body) = collect [] e
325 collect bs (IfaceLam b e) = collect (b:bs) e
326 collect bs e = (reverse bs, e)
328 pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
329 = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
330 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
331 pprIfaceExpr noParens rhs <+> char '}'])
333 pprIfaceExpr add_par (IfaceCase scrut bndr alts)
334 = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
335 <+> ppr bndr <+> char '{',
336 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
338 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
339 = add_par (sep [ptext SLIT("let {"),
340 nest 2 (ppr_bind (b, rhs)),
342 pprIfaceExpr noParens body])
344 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
345 = add_par (sep [ptext SLIT("letrec {"),
346 nest 2 (sep (map ppr_bind pairs)),
348 pprIfaceExpr noParens body])
350 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
352 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
353 arrow <+> pprIfaceExpr noParens rhs]
355 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
356 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
358 ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
359 equals <+> pprIfaceExpr noParens rhs]
362 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
363 pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
366 instance Outputable IfaceNote where
367 ppr (IfaceSCC cc) = pprCostCentreCore cc
368 ppr (IfaceCoerce ty) = ptext SLIT("__coerce") <+> pprParendIfaceType ty
369 ppr IfaceInlineCall = ptext SLIT("__inline_call")
370 ppr IfaceInlineMe = ptext SLIT("__inline_me")
371 ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
373 instance Outputable IfaceConAlt where
374 ppr IfaceDefault = text "DEFAULT"
375 ppr (IfaceLitAlt l) = ppr l
376 ppr (IfaceDataAlt d) = ppr d
377 -- IfaceTupleAlt is handled by the case-alternative printer
380 instance Outputable IfaceIdInfo where
382 ppr DiscardedInfo = ptext SLIT("<discarded>")
383 ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
385 ppr_hs_info (HsUnfold prag unf) = sep [ptext SLIT("Unfolding: ") <> ppr prag,
386 parens (pprIfaceExpr noParens unf)]
387 ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity
388 ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
389 ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs")
390 ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
394 %************************************************************************
396 Converting things to their Iface equivalents
398 %************************************************************************
402 tyThingToIfaceDecl :: Bool -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl
403 tyThingToIfaceDecl discard_prags ext (AnId id)
404 = IfaceId { ifName = getOccName id,
405 ifType = toIfaceType ext (idType id),
408 info | discard_prags = NoInfo
409 | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id))
411 tyThingToIfaceDecl _ ext (AClass clas)
412 = IfaceClass { ifCtxt = toIfaceContext ext sc_theta,
413 ifName = getOccName clas,
414 ifTyVars = toIfaceTvBndrs clas_tyvars,
415 ifFDs = map toIfaceFD clas_fds,
416 ifSigs = map toIfaceClassOp op_stuff,
417 ifRec = boolToRecFlag (isRecursiveTyCon tycon),
418 ifVrcs = tyConArgVrcs tycon }
420 (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
421 tycon = classTyCon clas
423 toIfaceClassOp (sel_id, def_meth)
424 = ASSERT(sel_tyvars == clas_tyvars)
425 IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty)
427 -- Be careful when splitting the type, because of things
428 -- like class Foo a where
429 -- op :: (?x :: String) => a -> a
430 -- and class Baz a where
431 -- op :: (Ord a) => a -> a
432 (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
433 op_ty = funResultTy rho_ty
435 toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
437 tyThingToIfaceDecl _ ext (ATyCon tycon)
439 = IfaceSyn { ifName = getOccName tycon,
440 ifTyVars = toIfaceTvBndrs tyvars,
441 ifVrcs = tyConArgVrcs tycon,
442 ifSynRhs = toIfaceType ext syn_ty }
445 = IfaceData { ifND = new_or_data,
446 ifCtxt = toIfaceContext ext (tyConTheta tycon),
447 ifName = getOccName tycon,
448 ifTyVars = toIfaceTvBndrs tyvars,
449 ifCons = ifaceConDecls (tyConDataConDetails tycon),
450 ifRec = boolToRecFlag (isRecursiveTyCon tycon),
451 ifVrcs = tyConArgVrcs tycon,
452 ifGeneric = tyConHasGenerics tycon }
454 | isForeignTyCon tycon
455 = IfaceForeign { ifName = getOccName tycon,
456 ifExtName = tyConExtName tycon }
458 | isPrimTyCon tycon || isFunTyCon tycon
459 -- Needed in GHCi for ':info Int#', for example
460 = IfaceData { ifND = DataType,
462 ifName = getOccName tycon,
463 ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
466 ifRec = NonRecursive,
467 ifVrcs = tyConArgVrcs tycon }
469 | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
471 tyvars = tyConTyVars tycon
472 (_, syn_ty) = getSynTyConDefn tycon
473 new_or_data | isNewTyCon tycon = NewType
474 | otherwise = DataType
476 ifaceConDecls Unknown = Unknown
477 ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
479 ifaceConDecl data_con
480 = IfaceConDecl (getOccName (dataConName data_con))
481 (toIfaceTvBndrs ex_tyvars)
482 (toIfaceContext ext ex_theta)
483 (map (toIfaceType ext) arg_tys)
485 (map getOccName field_labels)
487 (_, _, ex_tyvars, ex_theta, arg_tys, _) = dataConSig data_con
488 field_labels = dataConFieldLabels data_con
489 strict_marks = dataConStrictMarks data_con
491 -- This case only happens in the call to ifaceThing in InteractiveUI
492 -- Otherwise DataCons are filtered out in ifaceThing_acc
493 tyThingToIfaceDecl _ ext (ADataCon dc)
494 = IfaceId { ifName = getOccName dc,
495 ifType = toIfaceType ext full_ty,
498 (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc
500 -- The "stupid context" isn't part of the wrapper-Id type
501 -- (for better or worse -- see note in DataCon.lhs), so we
502 -- have to make it up here
503 full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta)
504 (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs)))
506 --------------------------
507 dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst
508 dfunToIfaceInst mod dfun_id
509 = IfaceInst { ifDFun = getOccName dfun_id,
510 ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty }
512 (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
513 head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys))
514 -- No need to record the instance context;
515 -- it's in the dfun anyway
517 tidy_ty = tidyTopType (deNoteType head_ty)
518 -- The deNoteType is very important. It removes all type
519 -- synonyms from the instance type in interface files.
520 -- That in turn makes sure that when reading in instance decls
521 -- from interface files that the 'gating' mechanism works properly.
522 -- Otherwise you could have
523 -- type Tibble = T Int
524 -- instance Foo Tibble where ...
525 -- and this instance decl wouldn't get imported into a module
526 -- that mentioned T but not Tibble.
529 --------------------------
530 toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem]
531 toIfaceIdInfo ext id_info
532 = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
533 wrkr_hsinfo, unfold_hsinfo]
535 ------------ Arity --------------
536 arity_info = arityInfo id_info
537 arity_hsinfo | arity_info == 0 = Nothing
538 | otherwise = Just (HsArity arity_info)
540 ------------ Caf Info --------------
541 caf_info = cafInfo id_info
542 caf_hsinfo = case caf_info of
543 NoCafRefs -> Just HsNoCafRefs
546 ------------ Strictness --------------
547 -- No point in explicitly exporting TopSig
548 strict_hsinfo = case newStrictnessInfo id_info of
549 Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
552 ------------ Worker --------------
553 work_info = workerInfo id_info
554 has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
555 wrkr_hsinfo = case work_info of
556 HasWorker work_id wrap_arity ->
557 Just (HsWorker (getOccName work_id) wrap_arity)
560 ------------ Unfolding --------------
561 -- The unfolding is redundant if there is a worker
562 unfold_info = unfoldingInfo id_info
563 inline_prag = inlinePragInfo id_info
564 rhs = unfoldingTemplate unfold_info
565 unfold_hsinfo | neverUnfold unfold_info
566 || has_worker = Nothing
567 | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs))
569 --------------------------
570 coreRuleToIfaceRule :: ModuleName -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule
571 coreRuleToIfaceRule mod ext (id, BuiltinRule _ _)
572 = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id)))
574 coreRuleToIfaceRule mod ext (id, Rule name act bndrs args rhs)
575 = IfaceRule { ifRuleName = name, ifActivation = act,
576 ifRuleBndrs = map (toIfaceBndr ext) bndrs,
577 ifRuleHead = ext (getName id),
578 ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args,
579 -- Use LHS name-fn for the args
580 ifRuleRhs = toIfaceExpr ext rhs }
582 bogusIfaceRule :: IfaceExtName -> IfaceRule
583 bogusIfaceRule id_name
584 = IfaceRule FSLIT("bogus") NeverActive [] id_name [] (IfaceExt id_name)
586 ---------------------
587 toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr
588 toIfaceExpr ext (Var v) = toIfaceVar ext v
589 toIfaceExpr ext (Lit l) = IfaceLit l
590 toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty)
591 toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
592 toIfaceExpr ext (App f a) = toIfaceApp ext f [a]
593 toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as)
594 toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
595 toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
597 ---------------------
598 toIfaceNote ext (SCC cc) = IfaceSCC cc
599 toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1)
600 toIfaceNote ext InlineCall = IfaceInlineCall
601 toIfaceNote ext InlineMe = IfaceInlineMe
602 toIfaceNote ext (CoreNote s) = IfaceCoreNote s
604 ---------------------
605 toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r)
606 toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
608 ---------------------
609 toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r)
611 ---------------------
612 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
613 | otherwise = IfaceDataAlt (getOccName dc)
617 toIfaceCon (LitAlt l) = IfaceLitAlt l
618 toIfaceCon DEFAULT = IfaceDefault
620 ---------------------
621 toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as)
622 toIfaceApp ext (Var v) as
623 = case isDataConWorkId_maybe v of
624 -- We convert the *worker* for tuples into IfaceTuples
625 Just dc | isTupleTyCon tc && saturated
626 -> IfaceTuple (tupleTyConBoxity tc) tup_args
628 val_args = dropWhile isTypeArg as
629 saturated = val_args `lengthIs` idArity v
630 tup_args = map (toIfaceExpr ext) val_args
633 other -> mkIfaceApps ext (toIfaceVar ext v) as
635 toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as
637 mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as
639 ---------------------
640 toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr
642 | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
643 -- Foreign calls have special syntax
644 | isExternalName name = IfaceExt (ext name)
645 | otherwise = IfaceLcl (nameOccName name)
649 ---------------------
650 -- mkLhsNameFn ignores versioning info altogether
651 -- Used for the LHS of instance decls and rules, where we
652 -- there's no point in recording version info
653 mkLhsNameFn :: ModuleName -> Name -> IfaceExtName
654 mkLhsNameFn this_mod name
655 | mod == this_mod = LocalTop occ
656 | otherwise = ExtPkg mod occ
658 mod = nameModuleName name
659 occ = nameOccName name
663 %************************************************************************
665 Equality, for interface file version generaion only
667 %************************************************************************
669 Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is
670 EqBut, which gives the set of *locally-defined* things whose version must be equal
671 for the whole thing to be equal. So the key function is eqIfExt, which compares
674 Of course, equality is also done modulo alpha conversion.
678 = Equal -- Definitely exactly the same
679 | NotEqual -- Definitely different
680 | EqBut OccSet -- The same provided these local things have not changed
682 bool :: Bool -> IfaceEq
684 bool False = NotEqual
686 zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
687 zapEq (EqBut _) = Equal
690 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
692 NotEqual &&& x = NotEqual
693 EqBut occs &&& Equal = EqBut occs
694 EqBut occs &&& NotEqual = NotEqual
695 EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
697 ---------------------
698 eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
699 -- This function is the core of the EqBut stuff
700 eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2)
701 eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
702 eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1)
703 eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1)
704 eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
705 eqIfExt n1 n2 = NotEqual
710 ---------------------
711 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
712 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
713 = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
715 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
716 = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
718 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
719 = bool (ifName d1 == ifName d2 &&
720 ifND d1 == ifND d2 &&
721 ifRec d1 == ifRec d2 &&
722 ifVrcs d1 == ifVrcs d2 &&
723 ifGeneric d1 == ifGeneric d2) &&&
724 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
725 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
726 eq_hsCD env (ifCons d1) (ifCons d2)
729 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
730 = bool (ifName d1 == ifName d2) &&&
731 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
732 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
735 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
736 = bool (ifName d1 == ifName d2 &&
737 ifRec d1 == ifRec d2 &&
738 ifVrcs d1 == ifVrcs d2) &&&
739 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
740 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
741 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
742 eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
745 eqIfDecl _ _ = NotEqual -- default case
748 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
749 eqWith = eq_ifTvBndrs emptyEqEnv
751 -----------------------
752 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) &&&
753 zapEq (ifInstHead d1 `eqIfType` ifInstHead d2)
754 -- zapEq: for instances, ignore the EqBut part
756 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1)
757 (IfaceRule n2 a2 bs2 f2 es2 rhs2)
758 = bool (n1==n2 && a1==a2) &&&
760 eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
761 zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
762 -- zapEq: for the LHSs, ignore the EqBut part
763 eq_ifaceExpr env rhs1 rhs2)
764 eqIfRule _ _ = NotEqual
766 eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2
767 eq_hsCD env Unknown Unknown = Equal
768 eq_hsCD env d1 d2 = NotEqual
770 eq_ConDecl env (IfaceConDecl n1 tvs1 cxt1 args1 ss1 lbls1)
771 (IfaceConDecl n2 tvs2 cxt2 args2 ss2 lbls2)
772 = bool (n1 == n2 && ss1 == ss2 && lbls1 == lbls2) &&&
773 eq_ifTvBndrs env tvs1 tvs2 (\ env ->
774 eq_ifContext env cxt1 cxt2 &&&
775 eq_ifTypes env args1 args2)
777 eq_hsFD env (ns1,ms1) (ns2,ms2)
778 = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
780 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
781 = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
787 eqIfIdInfo NoInfo NoInfo = Equal
788 eqIfIdInfo DiscardedInfo DiscardedInfo = Equal -- Should not happen?
789 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
790 eqIfIdInfo i1 i2 = NotEqual
792 eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
793 eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
794 eq_item (HsUnfold a1 u1) (HsUnfold a2 u2) = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2
795 eq_item HsNoCafRefs HsNoCafRefs = Equal
796 eq_item (HsWorker occ1 a1) (HsWorker occ2 a2) = bool (a1==a2 && occ1==occ2)
797 eq_item _ _ = NotEqual
800 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
801 eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2
802 eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
803 eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
804 eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
805 eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
806 eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
807 eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
808 eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
809 eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
811 eq_ifaceExpr env (IfaceCase s1 b1 as1) (IfaceCase s2 b2 as2)
812 = eq_ifaceExpr env s1 s2 &&&
813 eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
815 eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
816 = bool (eq_ifaceConAlt c1 c2) &&&
817 eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
819 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
820 = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
822 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
823 = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
825 (bs1,rs1) = unzip as1
826 (bs2,rs2) = unzip as2
829 eq_ifaceExpr env _ _ = NotEqual
832 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
833 eq_ifaceConAlt IfaceDefault IfaceDefault = True
834 eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2
835 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2
836 eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2
837 eq_ifaceConAlt _ _ = False
840 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
841 eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
842 eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2) = eq_ifType env t1 t2
843 eq_ifaceNote env IfaceInlineCall IfaceInlineCall = Equal
844 eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
845 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
846 eq_ifaceNote env _ _ = NotEqual
850 ---------------------
851 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
854 eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2
855 eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
856 eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2
857 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
858 eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
859 eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
860 eq_ifType env _ _ = NotEqual
863 eq_ifTypes env = eqListBy (eq_ifType env)
866 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
869 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2
870 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2
871 eq_ifPredType env _ _ = NotEqual
874 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
875 eqIfTc IfaceIntTc IfaceIntTc = Equal
876 eqIfTc IfaceCharTc IfaceCharTc = Equal
877 eqIfTc IfaceBoolTc IfaceBoolTc = Equal
878 eqIfTc IfaceListTc IfaceListTc = Equal
879 eqIfTc IfacePArrTc IfacePArrTc = Equal
880 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
881 eqIfTc _ _ = NotEqual
884 -----------------------------------------------------------
885 Support code for equality checking
886 -----------------------------------------------------------
889 ------------------------------------
890 type EqEnv = OccEnv OccName -- Tracks the mapping from L-variables to R-variables
892 eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq
893 eqIfOcc env n1 n2 = case lookupOccEnv env n1 of
894 Just n1 -> bool (n1 == n2)
895 Nothing -> bool (n1 == n2)
897 extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv
898 extendEqEnv env n1 n2 | n1 == n2 = env
899 | otherwise = extendOccEnv env n1 n2
902 emptyEqEnv = emptyOccEnv
904 ------------------------------------
905 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
907 eq_ifNakedBndr :: ExtEnv OccName
908 eq_ifBndr :: ExtEnv IfaceBndr
909 eq_ifTvBndr :: ExtEnv IfaceTvBndr
910 eq_ifIdBndr :: ExtEnv IfaceIdBndr
912 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
914 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
915 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
916 eq_ifBndr _ _ _ _ = NotEqual
918 eq_ifTvBndr env (v1, k1) (v2, k2) k = bool (k1 == k2) &&& k (extendEqEnv env v1 v2)
919 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
921 eq_ifBndrs :: ExtEnv [IfaceBndr]
922 eq_ifIdBndrs :: ExtEnv [IfaceIdBndr]
923 eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
924 eq_ifNakedBndrs :: ExtEnv [OccName]
925 eq_ifBndrs = eq_bndrs_with eq_ifBndr
926 eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr
927 eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
928 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
930 eq_bndrs_with eq env [] [] k = k env
931 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
932 eq_bndrs_with eq env _ _ _ = NotEqual
936 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
937 eqListBy eq [] [] = Equal
938 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
939 eqListBy eq xs ys = NotEqual
941 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
942 eqMaybeBy eq Nothing Nothing = Equal
943 eqMaybeBy eq (Just x) (Just y) = eq x y
944 eqMaybeBy eq x y = NotEqual