2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[MkIface]{Print an interface for a module}
7 module MkIface ( completeIface ) where
9 #include "HsVersions.h"
12 import HsCore ( HsIdInfo(..), toUfExpr, ifaceSigName )
13 import HsTypes ( toHsTyVars )
14 import BasicTypes ( Fixity(..), NewOrData(..),
15 Version, bumpVersion, isLoopBreaker
18 import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedIfaceSig )
19 import HscTypes ( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..),
23 import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
28 import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
29 import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..),
30 CprInfo(..), CafInfo(..),
31 inlinePragInfo, arityInfo, arityLowerBound,
32 strictnessInfo, isBottomingStrictness,
33 cafInfo, specInfo, cprInfo,
34 occInfo, isNeverInlinePrag,
35 workerInfo, WorkerInfo(..)
37 import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
38 import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
39 import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
40 import Name ( isLocallyDefined, getName, nameModule,
42 plusNameEnv, lookupNameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv_NF, nameEnvElts
44 import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
45 tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
47 import Class ( classExtraBigSig, DefMeth(..) )
48 import FieldLabel ( fieldLabelType )
49 import Type ( splitSigmaTy, tidyTopType, deNoteType )
51 import Rules ( ProtoCoreRule(..) )
53 import Bag ( bagToList )
54 import UniqFM ( lookupUFM, listToUFM )
55 import SrcLoc ( noSrcLoc )
59 import List ( partition )
63 %************************************************************************
65 \subsection{Write a new interface file}
67 %************************************************************************
70 completeModDetails :: ModDetails
71 -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
72 -- code generator; they have authoritative arity info
73 -> [ProtoCoreRule] -- Tidy orphan rules
76 completeIface :: Maybe ModIface -- The old interface, if we have it
77 -> ModIface -- The new one, minus the decls and versions
78 -> ModDetails -- The ModDetails for this module
79 -> Maybe (ModIface, SDoc) -- The new one, complete with decls and versions
80 -- The SDoc is a debug document giving differences
81 -- Nothing => no change
83 -- NB: 'Nothing' means that even the usages havn't changed, so there's no
84 -- need to write a new interface file. But even if the usages have
85 -- changed, the module version may not have.
87 -- The IO in the type is solely for debug output
88 -- In particular, dumping a record of what has changed
89 completeIface maybe_old_iface new_iface mod_details
90 tidy_binds final_ids tidy_orphan_rules
92 new_decls = declsFromDetails mod_details tidy_binds final_ids tidy_orphan_rules
94 addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
96 declsFromDetails :: ModDetails -> [CoreBind] -> [Id] -> [ProtoCoreRule] -> IfaceDecls
97 declsFromDetails details tidy_binds final_ids tidy_orphan_rules
98 = IfaceDecls { dcl_tycl = ty_cls_dcls ++ bagToList val_dcls,
99 dcl_insts = inst_dcls,
100 dcl_rules = rule_dcls }
102 dfun_ids = md_insts details
103 inst_dcls = map ifaceInstance dfun_ids
104 ty_cls_dcls = map ifaceTyCls (filter emitTyCls (nameEnvElts (md_types details)))
106 (val_dcls, emitted_ids) = ifaceBinds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
109 rule_dcls | opt_OmitInterfacePragmas = []
110 | otherwise = ifaceRules tidy_orphan_rules emitted_ids
112 orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
113 | ProtoCoreRule _ _ rule <- tidy_orphan_rules]
117 %************************************************************************
119 \subsection{Types and classes}
121 %************************************************************************
124 emitTyCls :: TyThing -> Bool
125 emitTyCls (ATyCon tc) = True -- Could filter out wired in ones, but it's not
126 -- strictly necessary, and it costs extra time
127 emitTyCls (AClass cl) = True
128 emitTyCls (AnId _) = False
131 ifaceTyCls :: TyThing -> RenamedTyClDecl
132 ifaceTyCls (AClass clas)
133 = ClassDecl (toHsContext sc_theta)
135 (toHsTyVars clas_tyvars)
137 (map toClassOpSig op_stuff)
141 (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
143 toClassOpSig (sel_id, def_meth)
144 = ASSERT(sel_tyvars == clas_tyvars)
145 ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
147 (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
148 def_meth' = case def_meth of
149 NoDefMeth -> NoDefMeth
150 GenDefMeth -> GenDefMeth
151 DefMeth id -> DefMeth (getName id)
153 ifaceTyCls (ATyCon tycon)
155 = TySynonym (getName tycon)(toHsTyVars tyvars) (toHsType ty) noSrcLoc
157 (tyvars, ty) = getSynTyConDefn tycon
159 ifaceTyCls (ATyCon tycon)
161 = TyData new_or_data (toHsContext (tyConTheta tycon))
164 (map ifaceConDecl (tyConDataCons tycon))
165 (tyConFamilySize tycon)
166 Nothing noSrcLoc (panic "gen1") (panic "gen2")
168 tyvars = tyConTyVars tycon
169 new_or_data | isNewTyCon tycon = NewType
170 | otherwise = DataType
172 ifaceConDecl data_con
173 = ConDecl (getName data_con) (error "ifaceConDecl")
174 (toHsTyVars ex_tyvars)
175 (toHsContext ex_theta)
178 (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
179 field_labels = dataConFieldLabels data_con
180 strict_marks = dataConStrictMarks data_con
181 details | null field_labels
182 = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
183 VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
186 = RecCon (zipWith mk_field strict_marks field_labels)
188 mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
189 mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
190 mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
192 mk_field strict_mark field_label
193 = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
195 ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
199 %************************************************************************
201 \subsection{Instances and rules}
203 %************************************************************************
206 ifaceInstance :: DFunId -> RenamedInstDecl
207 ifaceInstance dfun_id
208 = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc
210 tidy_ty = tidyTopType (deNoteType (idType dfun_id))
211 -- The deNoteType is very important. It removes all type
212 -- synonyms from the instance type in interface files.
213 -- That in turn makes sure that when reading in instance decls
214 -- from interface files that the 'gating' mechanism works properly.
215 -- Otherwise you could have
216 -- type Tibble = T Int
217 -- instance Foo Tibble where ...
218 -- and this instance decl wouldn't get imported into a module
219 -- that mentioned T but not Tibble.
223 ifaceRules :: [ProtoCoreRule] -> IdSet -> [RenamedRuleDecl]
224 ifaceRules rules emitted
225 = orphan_rules ++ local_rules
227 orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
228 local_rules = [ toHsRule fn rule
229 | fn <- varSetElems emitted,
230 rule <- rulesRules (idSpecialisation fn),
231 not (isBuiltinRule rule),
232 -- We can't print builtin rules in interface files
233 -- Since they are built in, an importing module
234 -- will have access to them anyway
236 -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
237 -- from coming out, and to make it work properly we need to add ????
238 -- (put it back in for now)
239 all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
240 -- Spit out a rule only if all its lhs free vars are emitted
241 -- This is a good reason not to do it when we emit the Id itself
246 %************************************************************************
248 \subsection{Value bindings}
250 %************************************************************************
253 ifaceBinds :: IdSet -- These Ids are needed already
254 -> [Id] -- Ids used at code-gen time; they have better pragma info!
255 -> [CoreBind] -- In dependency order, later depend on earlier
256 -> (Bag RenamedIfaceSig, IdSet) -- Set of Ids actually spat out
258 ifaceBinds needed_ids final_ids binds
259 = go needed_ids (reverse binds) emptyBag emptyVarSet
260 -- Reverse so that later things will
261 -- provoke earlier ones to be emitted
263 final_id_map = listToUFM [(id,id) | id <- final_ids]
264 get_idinfo id = case lookupUFM final_id_map id of
265 Just id' -> idInfo id'
266 Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
269 -- The 'needed' set contains the Ids that are needed by earlier
270 -- interface file emissions. If the Id isn't in this set, and isn't
271 -- exported, there's no need to emit anything
272 need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id
274 go needed [] decls emitted
275 | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
276 (sep (map ppr (varSetElems needed)))
278 | otherwise = (decls, emitted)
280 go needed (NonRec id rhs : binds) decls emitted
282 = if omitIfaceSigForId id then
283 go (needed `delVarSet` id) binds decls (emitted `extendVarSet` id)
285 go ((needed `unionVarSet` extras) `delVarSet` id)
287 (decl `consBag` decls)
288 (emitted `extendVarSet` id)
290 = go needed binds decls emitted
292 (decl, extras) = ifaceId get_idinfo False id rhs
294 -- Recursive groups are a bit more of a pain. We may only need one to
295 -- start with, but it may call out the next one, and so on. So we
296 -- have to look for a fixed point. We don't want necessarily them all,
297 -- because without -O we may only need the first one (if we don't emit
299 go needed (Rec pairs : binds) decls emitted
300 = go needed' binds decls' emitted'
302 (new_decls, new_emitted, extras) = go_rec needed pairs
303 decls' = new_decls `unionBags` decls
304 needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
305 emitted' = emitted `unionVarSet` new_emitted
307 go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RenamedIfaceSig, IdSet, IdSet)
309 | null decls = (emptyBag, emptyVarSet, emptyVarSet)
310 | otherwise = (more_decls `unionBags` listToBag decls,
311 more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
312 more_extras `unionVarSet` extras)
314 (needed_prs,leftover_prs) = partition is_needed pairs
315 (decls, extras_s) = unzip [ifaceId get_idinfo True id rhs
316 | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
317 extras = unionVarSets extras_s
318 (more_decls, more_emitted, more_extras) = go_rec extras leftover_prs
319 is_needed (id,_) = need_id needed id
324 ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
325 -- by the STG passes. Sigh
326 -> Bool -- True <=> recursive, so don't print unfolding
328 -> CoreExpr -- The Id's right hand side
329 -> (RenamedTyClDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
331 ifaceId get_idinfo is_rec id rhs
332 = (IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc, new_needed_ids)
335 core_idinfo = idInfo id
336 stg_idinfo = get_idinfo id
338 hs_idinfo | opt_OmitInterfacePragmas = []
339 | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
340 strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
342 ------------ Arity --------------
343 arity_info = arityInfo stg_idinfo
344 stg_arity = arityLowerBound arity_info
345 arity_hsinfo = case arityInfo stg_idinfo of
346 a@(ArityExactly n) -> [HsArity a]
349 ------------ Caf Info --------------
350 caf_hsinfo = case cafInfo stg_idinfo of
351 NoCafRefs -> [HsNoCafRefs]
354 ------------ CPR Info --------------
355 cpr_hsinfo = case cprInfo core_idinfo of
356 ReturnsCPR -> [HsCprInfo]
359 ------------ Strictness --------------
360 strict_info = strictnessInfo core_idinfo
361 bottoming_fn = isBottomingStrictness strict_info
362 strict_hsinfo = case strict_info of
363 NoStrictnessInfo -> []
364 info -> [HsStrictness info]
367 ------------ Worker --------------
368 -- We only treat a function as having a worker if
369 -- the exported arity (which is now the number of visible lambdas)
370 -- is the same as the arity at the moment of the w/w split
371 -- If so, we can safely omit the unfolding inside the wrapper, and
372 -- instead re-generate it from the type/arity/strictness info
373 -- But if the arity has changed, we just take the simple path and
374 -- put the unfolding into the interface file, forgetting the fact
375 -- that it's a wrapper.
377 -- How can this happen? Sometimes we get
378 -- f = coerce t (\x y -> $wf x y)
379 -- at the moment of w/w split; but the eta reducer turns it into
381 -- which is perfectly fine except that the exposed arity so far as
382 -- the code generator is concerned (zero) differs from the arity
383 -- when we did the split (2).
385 -- All this arises because we use 'arity' to mean "exactly how many
386 -- top level lambdas are there" in interface files; but during the
387 -- compilation of this module it means "how many things can I apply
389 work_info = workerInfo core_idinfo
390 HasWorker work_id _ = work_info
392 has_worker = case work_info of
393 HasWorker work_id wrap_arity
394 | wrap_arity == stg_arity -> True
395 | otherwise -> pprTrace "ifaceId: arity change:" (ppr id)
400 wrkr_hsinfo | has_worker = [HsWorker (getName work_id)]
403 ------------ Unfolding --------------
404 inline_pragma = inlinePragInfo core_idinfo
405 dont_inline = isNeverInlinePrag inline_pragma
407 unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
410 show_unfold = not has_worker && -- Not unnecessary
411 not bottoming_fn && -- Not necessary
414 rhs_is_small && -- Small enough
415 okToUnfoldInHiFile rhs -- No casms etc
417 rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
419 ------------ Specialisations --------------
420 spec_info = specInfo core_idinfo
422 ------------ Occ info --------------
423 loop_breaker = isLoopBreaker (occInfo core_idinfo)
425 ------------ Extra free Ids --------------
426 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
427 | otherwise = worker_ids `unionVarSet`
428 unfold_ids `unionVarSet`
431 worker_ids | has_worker && interestingId work_id = unitVarSet work_id
432 -- Conceivably, the worker might come from
434 | otherwise = emptyVarSet
436 spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
438 unfold_ids | show_unfold = find_fvs rhs
439 | otherwise = emptyVarSet
441 find_fvs expr = exprSomeFreeVars interestingId expr
443 interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
447 %************************************************************************
449 \subsection{Checking if the new interface is up to date
451 %************************************************************************
454 addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi
455 -> ModIface -- The new interface decls
456 -> Maybe (ModIface, SDoc) -- Nothing => no change; no need to write new Iface
457 -- Just mi => Here is the new interface to write
458 -- with correct version numbers
460 -- NB: the fixities, declarations, rules are all assumed
461 -- to be sorted by increasing order of hsDeclName, so that
462 -- we can compare for equality
464 addVersionInfo Nothing new_iface
465 -- No old interface, so definitely write a new one!
466 = Just (new_iface, text "No old interface available")
468 addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
469 mi_decls = old_decls,
470 mi_fixities = old_fixities }))
471 new_iface@(ModIface { mi_decls = new_decls,
472 mi_fixities = new_fixities })
474 | no_output_change && no_usage_change
477 | otherwise -- Add updated version numbers
478 = Just (final_iface, pp_tc_diffs $$ pp_sig_diffs)
481 final_iface = new_iface { mi_version = new_version }
482 new_version = VersionInfo { vers_module = bumpVersion no_output_change (vers_module old_version),
483 vers_exports = bumpVersion no_export_change (vers_exports old_version),
484 vers_rules = bumpVersion no_rule_change (vers_rules old_version),
485 vers_decls = sig_vers `plusNameEnv` tc_vers }
487 no_output_change = no_tc_change && no_rule_change && no_export_change
488 no_usage_change = mi_usages old_iface == mi_usages new_iface
490 no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted
491 no_rule_change = dcl_rules old_decls == dcl_rules new_decls -- Ditto
493 -- Fill in the version number on the new declarations by looking at the old declarations.
494 -- Set the flag if anything changes.
495 -- Assumes that the decls are sorted by hsDeclName.
496 old_vers_decls = vers_decls old_version
497 (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls (dcl_tycl old_decls) (dcl_tycl new_decls)
501 diffDecls :: NameEnv Version -- Old version map
502 -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls
503 -> (Bool, -- True <=> no change
504 SDoc, -- Record of differences
505 NameEnv Version) -- New version
507 diffDecls old_vers old new
508 = diff True empty emptyNameEnv old new
510 -- When seeing if two decls are the same,
511 -- remember to check whether any relevant fixity has changed
512 eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
513 same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
515 diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers)
516 diff ok_so_far pp new_vers old [] = (False, pp, new_vers)
517 diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
518 diff ok_so_far pp new_vers (od:ods) (nd:nds)
519 = case od_name `compare` nd_name of
520 LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds)
521 GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
522 EQ | od `eq` nd -> diff ok_so_far pp new_vers ods nds
523 | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds
525 od_name = get_name od
526 nd_name = get_name nd
527 new_vers' = extendNameEnv new_vers nd_name
528 (bumpVersion True (lookupNameEnv_NF old_vers od_name))
530 only_old d = ptext SLIT("Only in old iface:") <+> ppr d
531 only_new d = ptext SLIT("Only in new iface:") <+> ppr d
532 changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
533 (ptext SLIT("New:") <+> ppr nd))