2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[MkIface]{Print an interface for a module}
8 mkModDetails, mkModDetailsFromIface, completeIface,
12 #include "HsVersions.h"
15 import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
16 import HsTypes ( toHsTyVars )
17 import BasicTypes ( Fixity(..), NewOrData(..),
18 Version, initialVersion, bumpVersion, isLoopBreaker
21 import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
22 import TcHsSyn ( TypecheckedRuleDecl )
23 import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
24 IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
25 TyThing(..), DFunId, TypeEnv, Avails,
26 WhatsImported(..), GenAvailInfo(..),
27 ImportVersion, AvailInfo, Deprecations(..),
32 import Id ( Id, idType, idInfo, omitIfaceSigForId, isDictFunId,
33 idSpecialisation, setIdInfo, isLocalId, idName, hasNoBinding
37 import DataCon ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
39 import CoreSyn ( CoreBind, CoreRule(..), IdCoreRule,
40 isBuiltinRule, rulesRules,
41 bindersOf, bindersOfBinds
43 import CoreFVs ( ruleSomeLhsFreeVars )
44 import CoreUnfold ( neverUnfold, unfoldingTemplate )
45 import Name ( getName, nameModule, Name, NamedThing(..) )
47 import OccName ( pprOccName )
48 import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
49 tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
51 import Class ( classExtraBigSig, classTyCon, DefMeth(..) )
52 import FieldLabel ( fieldLabelType )
53 import Type ( splitSigmaTy, tidyTopType, deNoteType )
54 import SrcLoc ( noSrcLoc )
56 import Module ( ModuleName )
58 import IO ( IOMode(..), openFile, hClose )
62 %************************************************************************
64 \subsection{Write a new interface file}
66 %************************************************************************
69 mkModDetails :: TypeEnv -- From typechecker
70 -> [CoreBind] -- Final bindings
71 -> [Id] -- Top-level Ids from the code generator;
72 -- they have authoritative arity info
73 -> [IdCoreRule] -- Tidy orphan rules
75 mkModDetails type_env tidy_binds stg_ids orphan_rules
76 = ModDetails { md_types = new_type_env,
78 md_insts = filter isDictFunId final_ids }
80 -- The competed type environment is gotten from
81 -- a) keeping the types and classes
82 -- b) removing all Ids,
83 -- c) adding Ids with correct IdInfo, including unfoldings,
84 -- gotten from the bindings
85 -- From (c) we keep only those Ids with Global names;
86 -- the CoreTidy pass makes sure these are all and only
87 -- the externally-accessible ones
88 -- This truncates the type environment to include only the
89 -- exported Ids and things needed from them, which saves space
91 -- However, we do keep things like constructors, which should not appear
92 -- in interface files, because they are needed by importing modules when
93 -- using the compilation manager
94 new_type_env = extendTypeEnvList (filterNameEnv keep_it type_env)
97 -- We keep constructor workers, because they won't appear
98 -- in the bindings from which final_ids are derived!
99 keep_it (AnId id) = hasNoBinding id
102 stg_id_set = mkVarSet stg_ids
103 final_ids = [addStgInfo stg_id_set id | bind <- tidy_binds
104 , id <- bindersOf bind
105 , isGlobalName (idName id)]
107 -- The complete rules are gotten by combining
108 -- a) the orphan rules
109 -- b) rules embedded in the top-level Ids
110 rule_dcls | opt_OmitInterfacePragmas = []
111 | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids)
113 -- This version is used when we are re-linking a module
114 -- so we've only run the type checker on its previous interface
115 mkModDetailsFromIface :: TypeEnv
116 -> [TypecheckedRuleDecl]
118 mkModDetailsFromIface type_env rules
119 = ModDetails { md_types = type_env,
120 md_rules = rule_dcls,
121 md_insts = dfun_ids }
123 dfun_ids = [dfun_id | AnId dfun_id <- nameEnvElts type_env, isDictFunId dfun_id]
124 rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
125 -- All the rules from an interface are of the IfaceRuleOut form
129 We have to add on the arity and CAF info computed by the code generator
130 This is also the moment at which we may forget that this function has
131 a worker: see the comments below
134 addStgInfo :: IdSet -- Ids used at code-gen time; they have better pragma info!
136 addStgInfo stg_ids id
137 = id `setIdInfo` final_idinfo
140 idinfo' = idinfo `setArityInfo` stg_arity
141 `setCafInfo` cafInfo stg_idinfo
142 final_idinfo | worker_ok = idinfo'
143 | otherwise = idinfo' `setWorkerInfo` NoWorker
145 stg_idinfo = case lookupVarSet stg_ids id of
146 Just id' -> idInfo id'
147 Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
150 stg_arity = arityInfo stg_idinfo
152 ------------ Worker --------------
153 -- We only treat a function as having a worker if
154 -- the exported arity (which is now the number of visible lambdas)
155 -- is the same as the arity at the moment of the w/w split
156 -- If so, we can safely omit the unfolding inside the wrapper, and
157 -- instead re-generate it from the type/arity/strictness info
158 -- But if the arity has changed, we just take the simple path and
159 -- put the unfolding into the interface file, forgetting the fact
160 -- that it's a wrapper.
162 -- How can this happen? Sometimes we get
163 -- f = coerce t (\x y -> $wf x y)
164 -- at the moment of w/w split; but the eta reducer turns it into
166 -- which is perfectly fine except that the exposed arity so far as
167 -- the code generator is concerned (zero) differs from the arity
168 -- when we did the split (2).
170 -- All this arises because we use 'arity' to mean "exactly how many
171 -- top level lambdas are there" in interface files; but during the
172 -- compilation of this module it means "how many things can I apply
174 worker_ok = case workerInfo idinfo of
176 HasWorker work_id wrap_arity -> wrap_arity == arityLowerBound stg_arity
181 getRules :: [IdCoreRule] -- Orphan rules
182 -> [CoreBind] -- Bindings, with rules in the top-level Ids
183 -> IdSet -- Ids that are exported, so we need their rules
185 getRules orphan_rules binds emitted
186 = orphan_rules ++ local_rules
188 local_rules = [ (fn, rule)
189 | fn <- bindersOfBinds binds,
190 fn `elemVarSet` emitted,
191 rule <- rulesRules (idSpecialisation fn),
192 not (isBuiltinRule rule),
193 -- We can't print builtin rules in interface files
194 -- Since they are built in, an importing module
195 -- will have access to them anyway
197 -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
198 -- from coming out, and to make it work properly we need to add ????
199 -- (put it back in for now)
200 all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
201 -- Spit out a rule only if all its lhs free vars are emitted
202 -- This is a good reason not to do it when we emit the Id itself
205 interestingId id = isId id && isLocalId id
209 %************************************************************************
211 \subsection{Completing an interface}
213 %************************************************************************
216 completeIface :: Maybe ModIface -- The old interface, if we have it
217 -> ModIface -- The new one, minus the decls and versions
218 -> ModDetails -- The ModDetails for this module
219 -> (ModIface, Maybe SDoc) -- The new one, complete with decls and versions
220 -- The SDoc is a debug document giving differences
221 -- Nothing => no change
223 -- NB: 'Nothing' means that even the usages havn't changed, so there's no
224 -- need to write a new interface file. But even if the usages have
225 -- changed, the module version may not have.
226 completeIface maybe_old_iface new_iface mod_details
227 = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
229 new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
230 inst_dcls = map ifaceInstance (md_insts mod_details)
231 ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details)
232 rule_dcls = map ifaceRule (md_rules mod_details)
237 ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
238 ifaceTyCls (AClass clas) so_far
241 cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta,
242 tcdName = getName clas,
243 tcdTyVars = toHsTyVars clas_tyvars,
244 tcdFDs = toHsFDs clas_fds,
245 tcdSigs = map toClassOpSig op_stuff,
247 tcdSysNames = sys_names,
250 (clas_tyvars, clas_fds, sc_theta, sc_sels, op_stuff) = classExtraBigSig clas
251 tycon = classTyCon clas
252 data_con = head (tyConDataCons tycon)
253 sys_names = mkClassDeclSysNames (getName tycon, getName data_con,
254 getName (dataConId data_con), map getName sc_sels)
256 toClassOpSig (sel_id, def_meth)
257 = ASSERT(sel_tyvars == clas_tyvars)
258 ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
260 (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
261 def_meth' = case def_meth of
262 NoDefMeth -> NoDefMeth
263 GenDefMeth -> GenDefMeth
264 DefMeth id -> DefMeth (getName id)
266 ifaceTyCls (ATyCon tycon) so_far
267 | isClassTyCon tycon = so_far
268 | otherwise = ty_decl : so_far
270 ty_decl | isSynTyCon tycon
271 = TySynonym { tcdName = getName tycon,
272 tcdTyVars = toHsTyVars tyvars,
273 tcdSynRhs = toHsType syn_ty,
277 = TyData { tcdND = new_or_data,
278 tcdCtxt = toHsContext (tyConTheta tycon),
279 tcdName = getName tycon,
280 tcdTyVars = toHsTyVars tyvars,
281 tcdCons = map ifaceConDecl (tyConDataCons tycon),
282 tcdNCons = tyConFamilySize tycon,
284 tcdSysNames = map getName (tyConGenIds tycon),
287 | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
289 tyvars = tyConTyVars tycon
290 (_, syn_ty) = getSynTyConDefn tycon
291 new_or_data | isNewTyCon tycon = NewType
292 | otherwise = DataType
294 ifaceConDecl data_con
295 = ConDecl (getName data_con) (getName (dataConId data_con))
296 (toHsTyVars ex_tyvars)
297 (toHsContext ex_theta)
300 (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
301 field_labels = dataConFieldLabels data_con
302 strict_marks = dataConStrictMarks data_con
303 details | null field_labels
304 = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
305 VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
308 = RecCon (zipWith mk_field strict_marks field_labels)
310 mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
311 mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
312 mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
314 mk_field strict_mark field_label
315 = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
317 ifaceTyCls (AnId id) so_far
318 | omitIfaceSigForId id = so_far
319 | otherwise = iface_sig : so_far
321 iface_sig = IfaceSig { tcdName = getName id,
322 tcdType = toHsType id_type,
323 tcdIdInfo = hs_idinfo,
329 hs_idinfo | opt_OmitInterfacePragmas = []
330 | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
331 strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
333 ------------ Arity --------------
334 arity_hsinfo = case arityInfo id_info of
335 a@(ArityExactly n) -> [HsArity a]
338 ------------ Caf Info --------------
339 caf_hsinfo = case cafInfo id_info of
340 NoCafRefs -> [HsNoCafRefs]
343 ------------ CPR Info --------------
344 cpr_hsinfo = case cprInfo id_info of
345 ReturnsCPR -> [HsCprInfo]
348 ------------ Strictness --------------
349 strict_hsinfo = case strictnessInfo id_info of
350 NoStrictnessInfo -> []
351 info -> [HsStrictness info]
354 ------------ Worker --------------
355 work_info = workerInfo id_info
356 has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
357 wrkr_hsinfo = case work_info of
358 HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
361 ------------ Unfolding --------------
362 -- The unfolding is redundant if there is a worker
363 unfold_info = unfoldingInfo id_info
364 inline_prag = inlinePragInfo id_info
365 rhs = unfoldingTemplate unfold_info
366 unfold_hsinfo | neverUnfold unfold_info
368 | otherwise = [HsUnfold inline_prag (toUfExpr rhs)]
372 ifaceInstance :: DFunId -> RenamedInstDecl
373 ifaceInstance dfun_id
374 = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc
376 tidy_ty = tidyTopType (deNoteType (idType dfun_id))
377 -- The deNoteType is very important. It removes all type
378 -- synonyms from the instance type in interface files.
379 -- That in turn makes sure that when reading in instance decls
380 -- from interface files that the 'gating' mechanism works properly.
381 -- Otherwise you could have
382 -- type Tibble = T Int
383 -- instance Foo Tibble where ...
384 -- and this instance decl wouldn't get imported into a module
385 -- that mentioned T but not Tibble.
387 ifaceRule (id, BuiltinRule _)
388 = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
390 ifaceRule (id, Rule name bndrs args rhs)
391 = IfaceRule name (map toUfBndr bndrs) (getName id)
392 (map toUfExpr args) (toUfExpr rhs) noSrcLoc
395 = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
399 %************************************************************************
401 \subsection{Checking if the new interface is up to date
403 %************************************************************************
406 addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi
407 -> ModIface -- The new interface decls
408 -> (ModIface, Maybe SDoc) -- Nothing => no change; no need to write new Iface
409 -- Just mi => Here is the new interface to write
410 -- with correct version numbers
412 -- NB: the fixities, declarations, rules are all assumed
413 -- to be sorted by increasing order of hsDeclName, so that
414 -- we can compare for equality
416 addVersionInfo Nothing new_iface
417 -- No old interface, so definitely write a new one!
418 = (new_iface, Just (text "No old interface available"))
420 addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
421 mi_decls = old_decls,
422 mi_fixities = old_fixities }))
423 new_iface@(ModIface { mi_decls = new_decls,
424 mi_fixities = new_fixities })
426 | no_output_change && no_usage_change
427 = (new_iface, Nothing)
428 -- don't return the old iface because it may not have an
429 -- mi_globals field set to anything reasonable.
431 | otherwise -- Add updated version numbers
432 = --pprTrace "completeIface" (ppr (dcl_tycl old_decls))
433 (final_iface, Just pp_diffs)
436 final_iface = new_iface { mi_version = new_version }
437 new_version = VersionInfo { vers_module = bumpVersion no_output_change (vers_module old_version),
438 vers_exports = bumpVersion no_export_change (vers_exports old_version),
439 vers_rules = bumpVersion no_rule_change (vers_rules old_version),
440 vers_decls = tc_vers }
442 no_output_change = no_tc_change && no_rule_change && no_export_change
443 no_usage_change = mi_usages old_iface == mi_usages new_iface
445 no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted
446 no_rule_change = dcl_rules old_decls == dcl_rules new_decls -- Ditto
448 -- Fill in the version number on the new declarations by looking at the old declarations.
449 -- Set the flag if anything changes.
450 -- Assumes that the decls are sorted by hsDeclName.
451 old_vers_decls = vers_decls old_version
452 (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
453 (dcl_tycl old_decls) (dcl_tycl new_decls)
454 pp_diffs = vcat [pp_tc_diffs,
455 pp_change no_export_change "Export list",
456 pp_change no_rule_change "Rules",
457 pp_change no_usage_change "Usages"]
458 pp_change True what = empty
459 pp_change False what = text what <+> ptext SLIT("changed")
461 diffDecls :: NameEnv Version -- Old version map
462 -> NameEnv Fixity -> NameEnv Fixity -- Old and new fixities
463 -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls
464 -> (Bool, -- True <=> no change
465 SDoc, -- Record of differences
466 NameEnv Version) -- New version
468 diffDecls old_vers old_fixities new_fixities old new
469 = diff True empty emptyNameEnv old new
471 -- When seeing if two decls are the same,
472 -- remember to check whether any relevant fixity has changed
473 eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
474 same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
476 diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers)
477 diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods []
478 diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
479 diff ok_so_far pp new_vers (od:ods) (nd:nds)
480 = case od_name `compare` nd_name of
481 LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds)
482 GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
483 EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds
484 | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds
486 od_name = tyClDeclName od
487 nd_name = tyClDeclName nd
488 new_vers' = extendNameEnv new_vers nd_name
489 (bumpVersion False (lookupNameEnv_NF old_vers od_name))
491 only_old d = ptext SLIT("Only in old iface:") <+> ppr d
492 only_new d = ptext SLIT("Only in new iface:") <+> ppr d
493 changed od nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr od) $$
494 (ptext SLIT("New:") <+> ppr nd))
499 %************************************************************************
501 \subsection{Writing an interface file}
503 %************************************************************************
506 writeIface :: FilePath -> ModIface -> IO ()
507 writeIface hi_path mod_iface
508 = do { if_hdl <- openFile hi_path WriteMode
509 ; printForIface if_hdl from_this_mod (pprIface mod_iface)
513 -- Print names unqualified if they are from this module
514 from_this_mod n = nameModule n == this_mod
515 this_mod = mi_module mod_iface
517 pprIface :: ModIface -> SDoc
519 = vcat [ ptext SLIT("__interface")
520 <+> doubleQuotes (ptext opt_InPackage)
521 <+> ppr (mi_module iface) <+> ppr (vers_module version_info)
523 <+> (if mi_orphan iface then char '!' else empty)
524 <+> int opt_HiVersion
525 <+> ptext SLIT("where")
527 , vcat (map pprExport (mi_exports iface))
528 , vcat (map pprUsage (mi_usages iface))
530 , pprFixities (mi_fixities iface) (dcl_tycl decls)
531 , pprIfaceDecls (vers_decls version_info) decls
532 , pprDeprecs (mi_deprecs iface)
535 version_info = mi_version iface
536 decls = mi_decls iface
537 exp_vers = vers_exports version_info
538 rule_vers = vers_rules version_info
540 pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
541 | otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
544 When printing export lists, we print like this:
546 AvailTC C [C, x, y] C(x,y)
547 AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
550 pprExport :: (ModuleName, Avails) -> SDoc
551 pprExport (mod, items)
552 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
554 pp_avail :: AvailInfo -> SDoc
555 pp_avail (Avail name) = pprOcc name
556 pp_avail (AvailTC n []) = empty
557 pp_avail (AvailTC n (n':ns)) | n==n' = pprOcc n <> pp_export ns
558 | otherwise = pprOcc n <> char '|' <> pp_export (n':ns)
561 pp_export names = braces (hsep (map pprOcc names))
563 pprOcc :: Name -> SDoc -- Print the occurrence name only
564 pprOcc n = pprOccName (nameOccName n)
569 pprUsage :: ImportVersion Name -> SDoc
570 pprUsage (m, has_orphans, is_boot, whats_imported)
571 = hsep [ptext SLIT("import"), ppr m,
573 pp_versions whats_imported
576 pp_orphan | has_orphans = char '!'
578 pp_boot | is_boot = char '@'
581 -- Importing the whole module is indicated by an empty list
582 pp_versions NothingAtAll = empty
583 pp_versions (Everything v) = dcolon <+> int v
584 pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr
585 <+> hsep [ pprOcc n <+> int v | (n,v) <- nvs ]
587 pp_export_version Nothing = empty
588 pp_export_version (Just v) = int v
592 pprIfaceDecls version_map decls
593 = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
594 , vcat (map ppr_decl (dcl_tycl decls))
595 , pprRules (dcl_rules decls)
598 ppr_decl d = ppr_vers d <+> ppr d <> semi
600 -- Print the version for the decl
601 ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of
607 pprFixities fixity_map decls
608 = hsep [ ppr fix <+> ppr n
610 (n,_) <- tyClDeclNames d,
611 Just fix <- [lookupNameEnv fixity_map n]] <> semi
614 pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]
616 pprDeprecs NoDeprecs = empty
617 pprDeprecs deprecs = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
619 guts = case deprecs of
620 DeprecAll txt -> doubleQuotes (ptext txt)
621 DeprecSome env -> pp_deprecs env
623 pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
625 pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ptext txt)