2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[MkIface]{Print an interface for a module}
8 mkModDetails, mkModDetailsFromIface, completeIface
11 #include "HsVersions.h"
14 import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
15 import HsTypes ( toHsTyVars )
16 import BasicTypes ( Fixity(..), NewOrData(..),
17 Version, bumpVersion, isLoopBreaker
20 import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
21 import TcHsSyn ( TypecheckedRuleDecl )
22 import HscTypes ( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..),
23 TyThing(..), DFunId, TypeEnv, isTyClThing
27 import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
28 idSpecialisation, idName, setIdInfo
32 import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
34 import CoreSyn ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule,
35 isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules,
38 import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
39 import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
40 import Name ( isLocallyDefined, getName,
42 plusNameEnv, lookupNameEnv, emptyNameEnv, mkNameEnv,
43 extendNameEnv, lookupNameEnv_NF, nameEnvElts
45 import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
46 tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
48 import Class ( classExtraBigSig, DefMeth(..) )
49 import FieldLabel ( fieldLabelType )
50 import Type ( splitSigmaTy, tidyTopType, deNoteType )
51 import SrcLoc ( noSrcLoc )
54 import List ( partition )
58 %************************************************************************
60 \subsection{Write a new interface file}
62 %************************************************************************
65 mkModDetails :: TypeEnv -> [DFunId] -- From typechecker
66 -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
67 -- code generator; they have authoritative arity info
68 -> [IdCoreRule] -- Tidy orphan rules
70 mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
71 = ModDetails { md_types = new_type_env,
75 -- The competed type environment is gotten from
76 -- a) keeping the types and classes
77 -- b) removing all Ids, and Ids with correct IdInfo
78 -- gotten from the bindings
79 new_type_env = mkNameEnv [(getName tycl, tycl) | tycl <- orig_type_env, isTyClThing tycl]
81 mkNameEnv [(idName id, AnId id) | id <- final_ids]
83 orig_type_env = nameEnvElts type_env
85 final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
89 -- The complete rules are gotten by combining
90 -- a) the orphan rules
91 -- b) rules embedded in the top-level Ids
92 rule_dcls | opt_OmitInterfacePragmas = []
93 | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids)
95 orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
96 | (_, rule) <- orphan_rules]
99 -- This version is used when we are re-linking a module
100 -- so we've only run the type checker on its previous interface
101 mkModDetailsFromIface :: TypeEnv -> [DFunId] -- From typechecker
102 -> [TypecheckedRuleDecl]
104 mkModDetailsFromIface type_env dfun_ids rules
105 = ModDetails { md_types = type_env,
106 md_rules = rule_dcls,
107 md_insts = dfun_ids }
109 rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
110 -- All the rules from an interface are of the IfaceRuleOut form
112 completeIface :: Maybe ModIface -- The old interface, if we have it
113 -> ModIface -- The new one, minus the decls and versions
114 -> ModDetails -- The ModDetails for this module
115 -> Maybe (ModIface, SDoc) -- The new one, complete with decls and versions
116 -- The SDoc is a debug document giving differences
117 -- Nothing => no change
119 -- NB: 'Nothing' means that even the usages havn't changed, so there's no
120 -- need to write a new interface file. But even if the usages have
121 -- changed, the module version may not have.
123 -- The IO in the type is solely for debug output
124 -- In particular, dumping a record of what has changed
125 completeIface maybe_old_iface new_iface mod_details
126 = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
128 new_decls = IfaceDecls { dcl_tycl = ty_cls_dcls,
129 dcl_insts = inst_dcls,
130 dcl_rules = rule_dcls }
132 inst_dcls = map ifaceInstance (md_insts mod_details)
133 ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types mod_details))
134 rule_dcls = map ifaceRule (md_rules mod_details)
138 %************************************************************************
140 \subsection{Types and classes}
142 %************************************************************************
145 ifaceTyCls :: TyThing -> RenamedTyClDecl
146 ifaceTyCls (AClass clas)
147 = ClassDecl (toHsContext sc_theta)
149 (toHsTyVars clas_tyvars)
151 (map toClassOpSig op_stuff)
155 (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
157 toClassOpSig (sel_id, def_meth)
158 = ASSERT(sel_tyvars == clas_tyvars)
159 ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
161 (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
162 def_meth' = case def_meth of
163 NoDefMeth -> NoDefMeth
164 GenDefMeth -> GenDefMeth
165 DefMeth id -> DefMeth (getName id)
167 ifaceTyCls (ATyCon tycon)
169 = TySynonym (getName tycon)(toHsTyVars tyvars) (toHsType ty) noSrcLoc
171 (tyvars, ty) = getSynTyConDefn tycon
173 ifaceTyCls (ATyCon tycon)
175 = TyData new_or_data (toHsContext (tyConTheta tycon))
178 (map ifaceConDecl (tyConDataCons tycon))
179 (tyConFamilySize tycon)
180 Nothing noSrcLoc (panic "gen1") (panic "gen2")
182 tyvars = tyConTyVars tycon
183 new_or_data | isNewTyCon tycon = NewType
184 | otherwise = DataType
186 ifaceConDecl data_con
187 = ConDecl (getName data_con) (error "ifaceConDecl")
188 (toHsTyVars ex_tyvars)
189 (toHsContext ex_theta)
192 (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
193 field_labels = dataConFieldLabels data_con
194 strict_marks = dataConStrictMarks data_con
195 details | null field_labels
196 = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
197 VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
200 = RecCon (zipWith mk_field strict_marks field_labels)
202 mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
203 mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
204 mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
206 mk_field strict_mark field_label
207 = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
209 ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
212 = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
217 hs_idinfo | opt_OmitInterfacePragmas = []
218 | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
219 strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
221 ------------ Arity --------------
222 arity_hsinfo = case arityInfo id_info of
223 a@(ArityExactly n) -> [HsArity a]
226 ------------ Caf Info --------------
227 caf_hsinfo = case cafInfo id_info of
228 NoCafRefs -> [HsNoCafRefs]
231 ------------ CPR Info --------------
232 cpr_hsinfo = case cprInfo id_info of
233 ReturnsCPR -> [HsCprInfo]
236 ------------ Strictness --------------
237 strict_hsinfo = case strictnessInfo id_info of
238 NoStrictnessInfo -> []
239 info -> [HsStrictness info]
242 ------------ Worker --------------
243 wrkr_hsinfo = case workerInfo id_info of
244 HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
247 ------------ Unfolding --------------
248 unfold_info = unfoldingInfo id_info
249 inline_prag = inlinePragInfo id_info
250 rhs = unfoldingTemplate unfold_info
251 unfold_hsinfo | neverUnfold unfold_info = []
252 | otherwise = [HsUnfold inline_prag (toUfExpr rhs)]
256 %************************************************************************
258 \subsection{Instances and rules}
260 %************************************************************************
263 ifaceInstance :: DFunId -> RenamedInstDecl
264 ifaceInstance dfun_id
265 = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc
267 tidy_ty = tidyTopType (deNoteType (idType dfun_id))
268 -- The deNoteType is very important. It removes all type
269 -- synonyms from the instance type in interface files.
270 -- That in turn makes sure that when reading in instance decls
271 -- from interface files that the 'gating' mechanism works properly.
272 -- Otherwise you could have
273 -- type Tibble = T Int
274 -- instance Foo Tibble where ...
275 -- and this instance decl wouldn't get imported into a module
276 -- that mentioned T but not Tibble.
278 ifaceRule (id, BuiltinRule _)
279 = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
281 ifaceRule (id, Rule name bndrs args rhs)
282 = IfaceRule name (map toUfBndr bndrs) (getName id)
283 (map toUfExpr args) (toUfExpr rhs) noSrcLoc
286 = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
290 %************************************************************************
292 \subsection{Compute final Ids}
294 %************************************************************************
296 A "final Id" has exactly the IdInfo for going into an interface file, or
297 exporting to another module.
300 bindsToIds :: IdSet -- These Ids are needed already
301 -> IdSet -- Ids used at code-gen time; they have better pragma info!
302 -> [CoreBind] -- In dependency order, later depend on earlier
303 -> [Id] -- Set of Ids actually spat out, complete with exactly the IdInfo
304 -- they need for exporting to another module
306 bindsToIds needed_ids codegen_ids binds
307 = go needed_ids (reverse binds) []
308 -- Reverse so that later things will
309 -- provoke earlier ones to be emitted
311 -- The 'needed' set contains the Ids that are needed by earlier
312 -- interface file emissions. If the Id isn't in this set, and isn't
313 -- exported, there's no need to emit anything
314 need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id
317 | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
318 (sep (map ppr (varSetElems needed)))
320 | otherwise = emitted
322 go needed (NonRec id rhs : binds) emitted
324 = if omitIfaceSigForId id then
325 go (needed `delVarSet` id) binds (id:emitted)
327 go ((needed `unionVarSet` extras) `delVarSet` id)
331 = go needed binds emitted
333 (new_id, extras) = mkFinalId codegen_ids False id rhs
335 -- Recursive groups are a bit more of a pain. We may only need one to
336 -- start with, but it may call out the next one, and so on. So we
337 -- have to look for a fixed point. We don't want necessarily them all,
338 -- because without -O we may only need the first one (if we don't emit
340 go needed (Rec pairs : binds) emitted
341 = go needed' binds emitted'
343 (new_emitted, extras) = go_rec needed pairs
344 needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
345 emitted' = new_emitted ++ emitted
347 go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet)
349 | null needed_prs = ([], emptyVarSet)
350 | otherwise = (emitted ++ more_emitted,
351 extras `unionVarSet` more_extras)
353 (needed_prs,leftover_prs) = partition is_needed pairs
354 (emitted, extras_s) = unzip [ mkFinalId codegen_ids True id rhs
355 | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
356 extras = unionVarSets extras_s
357 (more_emitted, more_extras) = go_rec extras leftover_prs
359 is_needed (id,_) = need_id needed id
365 mkFinalId :: IdSet -- The Ids with arity info from the code generator
366 -> Bool -- True <=> recursive, so don't include unfolding
368 -> CoreExpr -- The Id's right hand side
369 -> (Id, IdSet) -- The emitted id, plus any *extra* needed Ids
371 mkFinalId codegen_ids is_rec id rhs
372 = (id `setIdInfo` new_idinfo, new_needed_ids)
374 core_idinfo = idInfo id
375 stg_idinfo = case lookupVarSet codegen_ids id of
376 Just id' -> idInfo id'
377 Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
380 new_idinfo | opt_OmitInterfacePragmas
383 = core_idinfo `setArityInfo` arity_info
384 `setCafInfo` cafInfo stg_idinfo
385 `setUnfoldingInfo` unfold_info
386 `setWorkerInfo` worker_info
387 `setSpecInfo` emptyCoreRules
388 -- We zap the specialisations because they are
389 -- passed on separately through the modules IdCoreRules
391 ------------ Arity --------------
392 arity_info = arityInfo stg_idinfo
393 stg_arity = arityLowerBound arity_info
395 ------------ Worker --------------
396 -- We only treat a function as having a worker if
397 -- the exported arity (which is now the number of visible lambdas)
398 -- is the same as the arity at the moment of the w/w split
399 -- If so, we can safely omit the unfolding inside the wrapper, and
400 -- instead re-generate it from the type/arity/strictness info
401 -- But if the arity has changed, we just take the simple path and
402 -- put the unfolding into the interface file, forgetting the fact
403 -- that it's a wrapper.
405 -- How can this happen? Sometimes we get
406 -- f = coerce t (\x y -> $wf x y)
407 -- at the moment of w/w split; but the eta reducer turns it into
409 -- which is perfectly fine except that the exposed arity so far as
410 -- the code generator is concerned (zero) differs from the arity
411 -- when we did the split (2).
413 -- All this arises because we use 'arity' to mean "exactly how many
414 -- top level lambdas are there" in interface files; but during the
415 -- compilation of this module it means "how many things can I apply
417 worker_info = case workerInfo core_idinfo of
418 info@(HasWorker work_id wrap_arity)
419 | wrap_arity == stg_arity -> info
420 | otherwise -> pprTrace "ifaceId: arity change:" (ppr id)
424 has_worker = case worker_info of
425 HasWorker _ _ -> True
428 HasWorker work_id _ = worker_info
430 ------------ Unfolding --------------
431 inline_pragma = inlinePragInfo core_idinfo
432 dont_inline = isNeverInlinePrag inline_pragma
433 loop_breaker = isLoopBreaker (occInfo core_idinfo)
434 bottoming_fn = isBottomingStrictness (strictnessInfo core_idinfo)
436 unfolding = mkTopUnfolding rhs
437 rhs_is_small = neverUnfold unfolding
439 unfold_info | show_unfold = unfolding
440 | otherwise = noUnfolding
442 show_unfold = not has_worker && -- Not unnecessary
443 not bottoming_fn && -- Not necessary
446 rhs_is_small && -- Small enough
447 okToUnfoldInHiFile rhs -- No casms etc
450 ------------ Extra free Ids --------------
451 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
452 | otherwise = worker_ids `unionVarSet`
453 unfold_ids `unionVarSet`
456 spec_ids = filterVarSet interestingId (rulesRhsFreeVars (specInfo core_idinfo))
458 worker_ids | has_worker && interestingId work_id = unitVarSet work_id
459 -- Conceivably, the worker might come from
461 | otherwise = emptyVarSet
463 unfold_ids | show_unfold = find_fvs rhs
464 | otherwise = emptyVarSet
466 find_fvs expr = exprSomeFreeVars interestingId expr
468 interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
473 getRules :: [IdCoreRule] -- Orphan rules
474 -> [CoreBind] -- Bindings, with rules in the top-level Ids
475 -> IdSet -- Ids that are exported, so we need their rules
477 getRules orphan_rules binds emitted
478 = orphan_rules ++ local_rules
480 local_rules = [ (fn, rule)
481 | fn <- bindersOfBinds binds,
482 fn `elemVarSet` emitted,
483 rule <- rulesRules (idSpecialisation fn),
484 not (isBuiltinRule rule),
485 -- We can't print builtin rules in interface files
486 -- Since they are built in, an importing module
487 -- will have access to them anyway
489 -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
490 -- from coming out, and to make it work properly we need to add ????
491 -- (put it back in for now)
492 all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
493 -- Spit out a rule only if all its lhs free vars are emitted
494 -- This is a good reason not to do it when we emit the Id itself
499 %************************************************************************
501 \subsection{Checking if the new interface is up to date
503 %************************************************************************
506 addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi
507 -> ModIface -- The new interface decls
508 -> Maybe (ModIface, SDoc) -- Nothing => no change; no need to write new Iface
509 -- Just mi => Here is the new interface to write
510 -- with correct version numbers
512 -- NB: the fixities, declarations, rules are all assumed
513 -- to be sorted by increasing order of hsDeclName, so that
514 -- we can compare for equality
516 addVersionInfo Nothing new_iface
517 -- No old interface, so definitely write a new one!
518 = Just (new_iface, text "No old interface available")
520 addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
521 mi_decls = old_decls,
522 mi_fixities = old_fixities }))
523 new_iface@(ModIface { mi_decls = new_decls,
524 mi_fixities = new_fixities })
526 | no_output_change && no_usage_change
529 | otherwise -- Add updated version numbers
530 = Just (final_iface, pp_tc_diffs)
533 final_iface = new_iface { mi_version = new_version }
534 new_version = VersionInfo { vers_module = bumpVersion no_output_change (vers_module old_version),
535 vers_exports = bumpVersion no_export_change (vers_exports old_version),
536 vers_rules = bumpVersion no_rule_change (vers_rules old_version),
537 vers_decls = tc_vers }
539 no_output_change = no_tc_change && no_rule_change && no_export_change
540 no_usage_change = mi_usages old_iface == mi_usages new_iface
542 no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted
543 no_rule_change = dcl_rules old_decls == dcl_rules new_decls -- Ditto
545 -- Fill in the version number on the new declarations by looking at the old declarations.
546 -- Set the flag if anything changes.
547 -- Assumes that the decls are sorted by hsDeclName.
548 old_vers_decls = vers_decls old_version
549 (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
550 (dcl_tycl old_decls) (dcl_tycl new_decls)
554 diffDecls :: NameEnv Version -- Old version map
555 -> NameEnv Fixity -> NameEnv Fixity -- Old and new fixities
556 -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls
557 -> (Bool, -- True <=> no change
558 SDoc, -- Record of differences
559 NameEnv Version) -- New version
561 diffDecls old_vers old_fixities new_fixities old new
562 = diff True empty emptyNameEnv old new
564 -- When seeing if two decls are the same,
565 -- remember to check whether any relevant fixity has changed
566 eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
567 same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
569 diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers)
570 diff ok_so_far pp new_vers old [] = (False, pp, new_vers)
571 diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
572 diff ok_so_far pp new_vers (od:ods) (nd:nds)
573 = case od_name `compare` nd_name of
574 LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds)
575 GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
576 EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds
577 | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds
579 od_name = tyClDeclName od
580 nd_name = tyClDeclName nd
581 new_vers' = extendNameEnv new_vers nd_name
582 (bumpVersion True (lookupNameEnv_NF old_vers od_name))
584 only_old d = ptext SLIT("Only in old iface:") <+> ppr d
585 only_new d = ptext SLIT("Only in new iface:") <+> ppr d
586 changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
587 (ptext SLIT("New:") <+> ppr nd))