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,
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, 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
263 instance Outputable IfaceClassOp where
264 ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
266 pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
267 pp_decl_head context thing tyvars
268 = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars]
270 pp_condecls Unknown = ptext SLIT("{- abstract -}")
271 pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
273 instance Outputable IfaceConDecl where
274 ppr (IfaceConDecl name ex_tvs ex_ctxt arg_tys strs fields)
275 = pprIfaceForAllPart ex_tvs ex_ctxt $
276 sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
277 if null strs then empty
278 else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
279 if null fields then empty
280 else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
282 instance Outputable IfaceRule where
283 ppr (IfaceRule name act bndrs fn args rhs)
284 = sep [hsep [doubleQuotes (ftext name), ppr act,
285 ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
286 nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
287 ptext SLIT("=") <+> ppr rhs])
289 ppr (IfaceBuiltinRule name rule)
290 = ptext SLIT("Built-in rule for") <+> ppr name
292 instance Outputable IfaceInst where
293 ppr (IfaceInst {ifDFun = dfun_id, ifInstHead = ty})
294 = hang (ptext SLIT("instance") <+> ppr ty)
295 2 (equals <+> ppr dfun_id)
299 ----------------------------- Printing IfaceExpr ------------------------------------
302 instance Outputable IfaceExpr where
303 ppr e = pprIfaceExpr noParens e
305 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
306 -- The function adds parens in context that need
307 -- an atomic value (e.g. function args)
309 pprIfaceExpr add_par (IfaceLcl v) = ppr v
310 pprIfaceExpr add_par (IfaceExt v) = ppr v
311 pprIfaceExpr add_par (IfaceLit l) = ppr l
312 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
313 pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
315 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
316 pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as)
318 pprIfaceExpr add_par e@(IfaceLam _ _)
319 = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
320 pprIfaceExpr noParens body])
322 (bndrs,body) = collect [] e
323 collect bs (IfaceLam b e) = collect (b:bs) e
324 collect bs e = (reverse bs, e)
326 pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
327 = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
328 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
329 pprIfaceExpr noParens rhs <+> char '}'])
331 pprIfaceExpr add_par (IfaceCase scrut bndr alts)
332 = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
333 <+> ppr bndr <+> char '{',
334 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
336 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
337 = add_par (sep [ptext SLIT("let {"),
338 nest 2 (ppr_bind (b, rhs)),
340 pprIfaceExpr noParens body])
342 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
343 = add_par (sep [ptext SLIT("letrec {"),
344 nest 2 (sep (map ppr_bind pairs)),
346 pprIfaceExpr noParens body])
348 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
350 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
351 arrow <+> pprIfaceExpr noParens rhs]
353 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
354 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
356 ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
357 equals <+> pprIfaceExpr noParens rhs]
360 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
361 pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
364 instance Outputable IfaceNote where
365 ppr (IfaceSCC cc) = pprCostCentreCore cc
366 ppr (IfaceCoerce ty) = ptext SLIT("__coerce") <+> pprParendIfaceType ty
367 ppr IfaceInlineCall = ptext SLIT("__inline_call")
368 ppr IfaceInlineMe = ptext SLIT("__inline_me")
369 ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
371 instance Outputable IfaceConAlt where
372 ppr IfaceDefault = text "DEFAULT"
373 ppr (IfaceLitAlt l) = ppr l
374 ppr (IfaceDataAlt d) = ppr d
375 -- IfaceTupleAlt is handled by the case-alternative printer
378 instance Outputable IfaceIdInfo where
380 ppr DiscardedInfo = ptext SLIT("<discarded>")
381 ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
383 ppr_hs_info (HsUnfold prag unf) = sep [ptext SLIT("Unfolding: ") <> ppr prag,
384 parens (pprIfaceExpr noParens unf)]
385 ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity
386 ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
387 ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs")
388 ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
392 %************************************************************************
394 Converting things to their Iface equivalents
396 %************************************************************************
400 tyThingToIfaceDecl :: Bool -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl
401 tyThingToIfaceDecl discard_prags ext (AnId id)
402 = IfaceId { ifName = getOccName id,
403 ifType = toIfaceType ext (idType id),
406 info | discard_prags = NoInfo
407 | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id))
409 tyThingToIfaceDecl _ ext (AClass clas)
410 = IfaceClass { ifCtxt = toIfaceContext ext sc_theta,
411 ifName = getOccName clas,
412 ifTyVars = toIfaceTvBndrs clas_tyvars,
413 ifFDs = map toIfaceFD clas_fds,
414 ifSigs = map toIfaceClassOp op_stuff,
415 ifRec = boolToRecFlag (isRecursiveTyCon tycon),
416 ifVrcs = tyConArgVrcs tycon }
418 (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
419 tycon = classTyCon clas
421 toIfaceClassOp (sel_id, def_meth)
422 = ASSERT(sel_tyvars == clas_tyvars)
423 IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty)
425 -- Be careful when splitting the type, because of things
426 -- like class Foo a where
427 -- op :: (?x :: String) => a -> a
428 -- and class Baz a where
429 -- op :: (Ord a) => a -> a
430 (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
431 op_ty = funResultTy rho_ty
433 toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
435 tyThingToIfaceDecl _ ext (ATyCon tycon)
437 = IfaceSyn { ifName = getOccName tycon,
438 ifTyVars = toIfaceTvBndrs tyvars,
439 ifVrcs = tyConArgVrcs tycon,
440 ifSynRhs = toIfaceType ext syn_ty }
443 = IfaceData { ifND = new_or_data,
444 ifCtxt = toIfaceContext ext (tyConTheta tycon),
445 ifName = getOccName tycon,
446 ifTyVars = toIfaceTvBndrs tyvars,
447 ifCons = ifaceConDecls (tyConDataConDetails tycon),
448 ifRec = boolToRecFlag (isRecursiveTyCon tycon),
449 ifVrcs = tyConArgVrcs tycon,
450 ifGeneric = tyConHasGenerics tycon }
452 | isForeignTyCon tycon
453 = IfaceForeign { ifName = getOccName tycon,
454 ifExtName = tyConExtName tycon }
456 | isPrimTyCon tycon || isFunTyCon tycon
457 -- Needed in GHCi for ':info Int#', for example
458 = IfaceData { ifND = DataType,
460 ifName = getOccName tycon,
461 ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
464 ifRec = NonRecursive,
465 ifVrcs = tyConArgVrcs tycon }
467 | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
469 tyvars = tyConTyVars tycon
470 (_, syn_ty) = getSynTyConDefn tycon
471 new_or_data | isNewTyCon tycon = NewType
472 | otherwise = DataType
474 ifaceConDecls Unknown = Unknown
475 ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
477 ifaceConDecl data_con
478 = IfaceConDecl (getOccName (dataConName data_con))
479 (toIfaceTvBndrs ex_tyvars)
480 (toIfaceContext ext ex_theta)
481 (map (toIfaceType ext) arg_tys)
483 (map getOccName field_labels)
485 (_, _, ex_tyvars, ex_theta, arg_tys, _) = dataConSig data_con
486 field_labels = dataConFieldLabels data_con
487 strict_marks = dataConStrictMarks data_con
489 -- This case only happens in the call to ifaceThing in InteractiveUI
490 -- Otherwise DataCons are filtered out in ifaceThing_acc
491 tyThingToIfaceDecl _ ext (ADataCon dc)
492 = IfaceId { ifName = getOccName dc,
493 ifType = toIfaceType ext full_ty,
496 (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc
498 -- The "stupid context" isn't part of the wrapper-Id type
499 -- (for better or worse -- see note in DataCon.lhs), so we
500 -- have to make it up here
501 full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta)
502 (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs)))
504 --------------------------
505 dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst
506 dfunToIfaceInst mod dfun_id
507 = IfaceInst { ifDFun = getOccName dfun_id,
508 ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty }
510 (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
511 head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys))
512 -- No need to record the instance context;
513 -- it's in the dfun anyway
515 tidy_ty = tidyTopType (deNoteType head_ty)
516 -- The deNoteType is very important. It removes all type
517 -- synonyms from the instance type in interface files.
518 -- That in turn makes sure that when reading in instance decls
519 -- from interface files that the 'gating' mechanism works properly.
520 -- Otherwise you could have
521 -- type Tibble = T Int
522 -- instance Foo Tibble where ...
523 -- and this instance decl wouldn't get imported into a module
524 -- that mentioned T but not Tibble.
527 --------------------------
528 toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem]
529 toIfaceIdInfo ext id_info
530 = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
531 wrkr_hsinfo, unfold_hsinfo]
533 ------------ Arity --------------
534 arity_info = arityInfo id_info
535 arity_hsinfo | arity_info == 0 = Nothing
536 | otherwise = Just (HsArity arity_info)
538 ------------ Caf Info --------------
539 caf_info = cafInfo id_info
540 caf_hsinfo = case caf_info of
541 NoCafRefs -> Just HsNoCafRefs
544 ------------ Strictness --------------
545 -- No point in explicitly exporting TopSig
546 strict_hsinfo = case newStrictnessInfo id_info of
547 Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
550 ------------ Worker --------------
551 work_info = workerInfo id_info
552 has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
553 wrkr_hsinfo = case work_info of
554 HasWorker work_id wrap_arity ->
555 Just (HsWorker (getOccName work_id) wrap_arity)
558 ------------ Unfolding --------------
559 -- The unfolding is redundant if there is a worker
560 unfold_info = unfoldingInfo id_info
561 inline_prag = inlinePragInfo id_info
562 rhs = unfoldingTemplate unfold_info
563 unfold_hsinfo | neverUnfold unfold_info
564 || has_worker = Nothing
565 | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs))
567 --------------------------
568 coreRuleToIfaceRule :: ModuleName -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule
569 coreRuleToIfaceRule mod ext (id, BuiltinRule _ _)
570 = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id)))
572 coreRuleToIfaceRule mod ext (id, Rule name act bndrs args rhs)
573 = IfaceRule { ifRuleName = name, ifActivation = act,
574 ifRuleBndrs = map (toIfaceBndr ext) bndrs,
575 ifRuleHead = ext (getName id),
576 ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args,
577 -- Use LHS name-fn for the args
578 ifRuleRhs = toIfaceExpr ext rhs }
580 bogusIfaceRule :: IfaceExtName -> IfaceRule
581 bogusIfaceRule id_name
582 = IfaceRule FSLIT("bogus") NeverActive [] id_name [] (IfaceExt id_name)
584 ---------------------
585 toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr
586 toIfaceExpr ext (Var v) = toIfaceVar ext v
587 toIfaceExpr ext (Lit l) = IfaceLit l
588 toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty)
589 toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
590 toIfaceExpr ext (App f a) = toIfaceApp ext f [a]
591 toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as)
592 toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
593 toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
595 ---------------------
596 toIfaceNote ext (SCC cc) = IfaceSCC cc
597 toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1)
598 toIfaceNote ext InlineCall = IfaceInlineCall
599 toIfaceNote ext InlineMe = IfaceInlineMe
600 toIfaceNote ext (CoreNote s) = IfaceCoreNote s
602 ---------------------
603 toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r)
604 toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
606 ---------------------
607 toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r)
609 ---------------------
610 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
611 | otherwise = IfaceDataAlt (getOccName dc)
615 toIfaceCon (LitAlt l) = IfaceLitAlt l
616 toIfaceCon DEFAULT = IfaceDefault
618 ---------------------
619 toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as)
620 toIfaceApp ext (Var v) as
621 = case isDataConWorkId_maybe v of
622 -- We convert the *worker* for tuples into IfaceTuples
623 Just dc | isTupleTyCon tc && saturated
624 -> IfaceTuple (tupleTyConBoxity tc) tup_args
626 val_args = dropWhile isTypeArg as
627 saturated = val_args `lengthIs` idArity v
628 tup_args = map (toIfaceExpr ext) val_args
631 other -> mkIfaceApps ext (toIfaceVar ext v) as
633 toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as
635 mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as
637 ---------------------
638 toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr
640 | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
641 -- Foreign calls have special syntax
642 | isExternalName name = IfaceExt (ext name)
643 | otherwise = IfaceLcl (nameOccName name)
647 ---------------------
648 -- mkLhsNameFn ignores versioning info altogether
649 -- Used for the LHS of instance decls and rules, where we
650 -- there's no point in recording version info
651 mkLhsNameFn :: ModuleName -> Name -> IfaceExtName
652 mkLhsNameFn this_mod name
653 | mod == this_mod = LocalTop occ
654 | otherwise = ExtPkg mod occ
656 mod = nameModuleName name
657 occ = nameOccName name
661 %************************************************************************
663 Equality, for interface file version generaion only
665 %************************************************************************
667 Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is
668 EqBut, which gives the set of *locally-defined* things whose version must be equal
669 for the whole thing to be equal. So the key function is eqIfExt, which compares
672 Of course, equality is also done modulo alpha conversion.
676 = Equal -- Definitely exactly the same
677 | NotEqual -- Definitely different
678 | EqBut OccSet -- The same provided these local things have not changed
680 bool :: Bool -> IfaceEq
682 bool False = NotEqual
684 zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
685 zapEq (EqBut _) = Equal
688 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
690 NotEqual &&& x = NotEqual
691 EqBut occs &&& Equal = EqBut occs
692 EqBut occs &&& NotEqual = NotEqual
693 EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
695 ---------------------
696 eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
697 -- This function is the core of the EqBut stuff
698 eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2)
699 eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
700 eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1)
701 eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1)
702 eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
703 eqIfExt n1 n2 = NotEqual
708 ---------------------
709 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
710 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
711 = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
713 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
714 = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
716 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
717 = bool (ifName d1 == ifName d2 &&
718 ifND d1 == ifND d2 &&
719 ifRec d1 == ifRec d2 &&
720 ifVrcs d1 == ifVrcs d2 &&
721 ifGeneric d1 == ifGeneric d2) &&&
722 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
723 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
724 eq_hsCD env (ifCons d1) (ifCons d2)
727 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
728 = bool (ifName d1 == ifName d2) &&&
729 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
730 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
733 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
734 = bool (ifName d1 == ifName d2 &&
735 ifRec d1 == ifRec d2 &&
736 ifVrcs d1 == ifVrcs d2) &&&
737 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
738 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
739 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
740 eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
743 eqIfDecl _ _ = NotEqual -- default case
746 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
747 eqWith = eq_ifTvBndrs emptyEqEnv
749 -----------------------
750 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) &&&
751 zapEq (ifInstHead d1 `eqIfType` ifInstHead d2)
752 -- zapEq: for instances, ignore the EqBut part
754 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1)
755 (IfaceRule n2 a2 bs2 f2 es2 rhs2)
756 = bool (n1==n2 && a1==a2) &&&
758 eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
759 zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
760 -- zapEq: for the LHSs, ignore the EqBut part
761 eq_ifaceExpr env rhs1 rhs2)
762 eqIfRule _ _ = NotEqual
764 eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2
765 eq_hsCD env Unknown Unknown = Equal
766 eq_hsCD env d1 d2 = NotEqual
768 eq_ConDecl env (IfaceConDecl n1 tvs1 cxt1 args1 ss1 lbls1)
769 (IfaceConDecl n2 tvs2 cxt2 args2 ss2 lbls2)
770 = bool (n1 == n2 && ss1 == ss2 && lbls1 == lbls2) &&&
771 eq_ifTvBndrs env tvs1 tvs2 (\ env ->
772 eq_ifContext env cxt1 cxt2 &&&
773 eq_ifTypes env args1 args2)
775 eq_hsFD env (ns1,ms1) (ns2,ms2)
776 = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
778 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
779 = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
785 eqIfIdInfo NoInfo NoInfo = Equal
786 eqIfIdInfo DiscardedInfo DiscardedInfo = Equal -- Should not happen?
787 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
788 eqIfIdInfo i1 i2 = NotEqual
790 eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
791 eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
792 eq_item (HsUnfold a1 u1) (HsUnfold a2 u2) = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2
793 eq_item HsNoCafRefs HsNoCafRefs = Equal
794 eq_item (HsWorker occ1 a1) (HsWorker occ2 a2) = bool (a1==a2 && occ1==occ2)
795 eq_item _ _ = NotEqual
798 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
799 eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2
800 eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
801 eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
802 eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
803 eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
804 eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
805 eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
806 eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
807 eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
809 eq_ifaceExpr env (IfaceCase s1 b1 as1) (IfaceCase s2 b2 as2)
810 = eq_ifaceExpr env s1 s2 &&&
811 eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
813 eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
814 = bool (eq_ifaceConAlt c1 c2) &&&
815 eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
817 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
818 = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
820 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
821 = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
823 (bs1,rs1) = unzip as1
824 (bs2,rs2) = unzip as2
827 eq_ifaceExpr env _ _ = NotEqual
830 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
831 eq_ifaceConAlt IfaceDefault IfaceDefault = True
832 eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2
833 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2
834 eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2
835 eq_ifaceConAlt _ _ = False
838 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
839 eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
840 eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2) = eq_ifType env t1 t2
841 eq_ifaceNote env IfaceInlineCall IfaceInlineCall = Equal
842 eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
843 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
844 eq_ifaceNote env _ _ = NotEqual
848 ---------------------
849 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
852 eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2
853 eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
854 eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2
855 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
856 eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
857 eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
858 eq_ifType env _ _ = NotEqual
861 eq_ifTypes env = eqListBy (eq_ifType env)
864 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
867 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2
868 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2
869 eq_ifPredType env _ _ = NotEqual
872 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
873 eqIfTc IfaceIntTc IfaceIntTc = Equal
874 eqIfTc IfaceCharTc IfaceCharTc = Equal
875 eqIfTc IfaceBoolTc IfaceBoolTc = Equal
876 eqIfTc IfaceListTc IfaceListTc = Equal
877 eqIfTc IfacePArrTc IfacePArrTc = Equal
878 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
879 eqIfTc _ _ = NotEqual
882 -----------------------------------------------------------
883 Support code for equality checking
884 -----------------------------------------------------------
887 ------------------------------------
888 type EqEnv = OccEnv OccName -- Tracks the mapping from L-variables to R-variables
890 eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq
891 eqIfOcc env n1 n2 = case lookupOccEnv env n1 of
892 Just n1 -> bool (n1 == n2)
893 Nothing -> bool (n1 == n2)
895 extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv
896 extendEqEnv env n1 n2 | n1 == n2 = env
897 | otherwise = extendOccEnv env n1 n2
900 emptyEqEnv = emptyOccEnv
902 ------------------------------------
903 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
905 eq_ifNakedBndr :: ExtEnv OccName
906 eq_ifBndr :: ExtEnv IfaceBndr
907 eq_ifTvBndr :: ExtEnv IfaceTvBndr
908 eq_ifIdBndr :: ExtEnv IfaceIdBndr
910 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
912 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
913 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
914 eq_ifBndr _ _ _ _ = NotEqual
916 eq_ifTvBndr env (v1, k1) (v2, k2) k = bool (k1 == k2) &&& k (extendEqEnv env v1 v2)
917 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
919 eq_ifBndrs :: ExtEnv [IfaceBndr]
920 eq_ifIdBndrs :: ExtEnv [IfaceIdBndr]
921 eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
922 eq_ifNakedBndrs :: ExtEnv [OccName]
923 eq_ifBndrs = eq_bndrs_with eq_ifBndr
924 eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr
925 eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
926 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
928 eq_bndrs_with eq env [] [] k = k env
929 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
930 eq_bndrs_with eq env _ _ _ = NotEqual
934 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
935 eqListBy eq [] [] = Equal
936 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
937 eqListBy eq xs ys = NotEqual
939 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
940 eqMaybeBy eq Nothing Nothing = Equal
941 eqMaybeBy eq (Just x) (Just y) = eq x y
942 eqMaybeBy eq x y = NotEqual