2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[MkIface]{Print an interface for a module}
7 module MkIface ( writeIface ) where
9 #include "HsVersions.h"
11 import IO ( openFile, hClose, IOMode(..) )
14 import HsCore ( HsIdInfo(..), toUfExpr )
15 import RdrHsSyn ( RdrNameRuleDecl, mkTyData )
16 import HsPragmas ( DataPragmas(..), ClassPragmas(..) )
17 import HsTypes ( toHsTyVars )
18 import BasicTypes ( Fixity(..), NewOrData(..),
19 Version, bumpVersion, initialVersion, isLoopBreaker
23 import TcInstUtil ( InstInfo(..) )
26 import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
29 import Var ( isId, varName )
31 import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
32 import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..),
33 CprInfo(..), CafInfo(..),
34 inlinePragInfo, arityInfo, arityLowerBound,
35 strictnessInfo, isBottomingStrictness,
36 cafInfo, specInfo, cprInfo,
37 occInfo, isNeverInlinePrag,
38 workerInfo, WorkerInfo(..)
40 import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
41 import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
42 import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
43 import Module ( pprModuleName, moduleUserString )
44 import Name ( isLocallyDefined, isWiredInName, toRdrName, nameModule,
47 import OccName ( OccName, pprOccName )
48 import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
49 tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
51 import Class ( classExtraBigSig, DefMeth(..) )
52 import FieldLabel ( fieldLabelType )
53 import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
54 deNoteType, classesToPreds
57 import Rules ( ProtoCoreRule(..) )
59 import Bag ( bagToList )
60 import UniqFM ( lookupUFM, listToUFM )
61 import Util ( sortLt )
62 import SrcLoc ( noSrcLoc )
65 import ErrUtils ( dumpIfSet )
67 import Maybe ( isNothing )
68 import List ( partition )
73 %************************************************************************
75 \subsection{Write a new interface file}
77 %************************************************************************
80 writeIface this_mod old_iface new_iface
81 local_tycons local_classes inst_info
82 final_ids tidy_binds tidy_orphan_rules
84 if isNothing opt_HiDir && isNothing opt_HiFile
85 then return () -- not producing any .hi file
89 hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
90 filename = case opt_HiFile of {
94 Just dir -> dir ++ '/':moduleUserString this_mod
96 Nothing -> panic "writeIface"
100 do maybe_final_iface <- checkIface old_iface full_new_iface
101 case maybe_final_iface of {
102 Nothing -> when opt_D_dump_rn_trace $
103 putStrLn "Interface file unchanged" ; -- No need to update .hi file
107 do let mod_vers_unchanged = case old_iface of
108 Just iface -> pi_vers iface == pi_vers final_iface
110 when (mod_vers_unchanged && opt_D_dump_rn_trace) $
111 putStrLn "Module version unchanged, but usages differ; hence need new hi file"
113 if_hdl <- openFile filename WriteMode
114 printForIface if_hdl (pprIface final_iface)
118 full_new_iface = completeIface new_iface local_tycons local_classes
119 inst_info final_ids tidy_binds
124 %************************************************************************
126 \subsection{Checking if the new interface is up to date
128 %************************************************************************
131 checkIface :: Maybe ParsedIface -- The old interface, read from M.hi
132 -> ParsedIface -- The new interface; but with all version numbers = 1
133 -> IO (Maybe ParsedIface) -- Nothing => no change; no need to write new Iface
134 -- Just pi => Here is the new interface to write
135 -- with correct version numbers
136 -- The I/O part is just so it can print differences
138 -- NB: the fixities, declarations, rules are all assumed
139 -- to be sorted by increasing order of hsDeclName, so that
140 -- we can compare for equality
142 checkIface Nothing new_iface
143 -- No old interface, so definitely write a new one!
144 = return (Just new_iface)
146 checkIface (Just iface) new_iface
147 | no_output_change && no_usage_change
150 | otherwise -- Add updated version numbers
151 = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ;
152 return (Just final_iface )}
155 final_iface = new_iface { pi_vers = new_mod_vers,
156 pi_fixity = (new_fixity_vers, new_fixities),
157 pi_rules = (new_rules_vers, new_rules),
158 pi_decls = final_decls }
160 no_usage_change = pi_usages iface == pi_usages new_iface
162 no_output_change = no_decl_changed &&
163 new_fixity_vers == fixity_vers &&
164 new_rules_vers == rules_vers &&
167 no_export_change = pi_exports iface == pi_exports new_iface
169 new_mod_vers | no_output_change = mod_vers
170 | otherwise = bumpVersion mod_vers
172 mod_vers = pi_vers iface
174 (fixity_vers, fixities) = pi_fixity iface
175 (_, new_fixities) = pi_fixity new_iface
176 new_fixity_vers | fixities == new_fixities = fixity_vers
177 | otherwise = bumpVersion fixity_vers
179 (rules_vers, rules) = pi_rules iface
180 (_, new_rules) = pi_rules new_iface
181 new_rules_vers | rules == new_rules = rules_vers
182 | otherwise = bumpVersion rules_vers
184 (no_decl_changed, pp_diffs, final_decls) = merge_decls True empty [] (pi_decls iface) (pi_decls new_iface)
186 -- Fill in the version number on the new declarations
187 -- by looking at the old declarations.
188 -- Set the flag if anything changes.
189 -- Assumes that the decls are sorted by hsDeclName
190 merge_decls ok_so_far pp acc [] [] = (ok_so_far, pp, reverse acc)
191 merge_decls ok_so_far pp acc old [] = (False, pp, reverse acc)
192 merge_decls ok_so_far pp acc [] (nvd:nvds) = merge_decls False (pp $$ only_new nvd) (nvd:acc) [] nvds
193 merge_decls ok_so_far pp acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
194 = case d_name `compare` nd_name of
195 LT -> merge_decls False (pp $$ only_old vd) acc vds (nvd:nvds)
196 GT -> merge_decls False (pp $$ only_new nvd) (nvd:acc) (vd:vds) nvds
197 EQ | d == nd -> merge_decls ok_so_far pp (vd:acc) vds nvds
198 | otherwise -> merge_decls False (pp $$ changed d nd) ((bumpVersion v, nd):acc) vds nvds
200 d_name = hsDeclName d
201 nd_name = hsDeclName nd
203 only_old (_,d) = ptext SLIT("Only in old iface:") <+> ppr d
204 only_new (_,d) = ptext SLIT("Only in new iface:") <+> ppr d
205 changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
206 (ptext SLIT("New:") <+> ppr nd))
211 %************************************************************************
213 \subsection{Printing the interface}
215 %************************************************************************
218 pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
219 pi_usages = usages, pi_exports = exports,
220 pi_fixity = (fix_vers, fixities),
221 pi_insts = insts, pi_decls = decls,
222 pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
223 = vcat [ ptext SLIT("__interface")
224 <+> doubleQuotes (ptext opt_InPackage)
225 <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
226 <+> (if orphan then char '!' else empty)
227 <+> int opt_HiVersion
228 <+> ptext SLIT("where")
229 , vcat (map pprExport exports)
230 , vcat (map pprUsage usages)
231 , pprFixities fixities
232 , vcat [ppr i <+> semi | i <- insts]
233 , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
238 ppr_vers v | v == initialVersion = empty
241 | fix_vers == initialVersion && rule_vers == initialVersion = empty
242 | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
245 When printing export lists, we print like this:
247 AvailTC C [C, x, y] C(x,y)
248 AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
251 pprExport :: ExportItem -> SDoc
252 pprExport (mod, items)
253 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
255 upp_avail :: RdrAvailInfo -> SDoc
256 upp_avail (Avail name) = pprOccName name
257 upp_avail (AvailTC name []) = empty
258 upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
260 bang | name `elem` ns = empty
261 | otherwise = char '|'
262 ns' = filter (/= name) ns
264 upp_export [] = empty
265 upp_export names = braces (hsep (map pprOccName names))
270 pprUsage :: ImportVersion OccName -> SDoc
271 pprUsage (m, has_orphans, is_boot, whats_imported)
272 = hsep [ptext SLIT("import"), pprModuleName m,
274 upp_import_versions whats_imported
277 pp_orphan | has_orphans = char '!'
279 pp_boot | is_boot = char '@'
282 -- Importing the whole module is indicated by an empty list
283 upp_import_versions NothingAtAll = empty
284 upp_import_versions (Everything v) = dcolon <+> int v
285 upp_import_versions (Specifically vm vf vr nvs)
286 = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
291 pprFixities [] = empty
292 pprFixities fixes = hsep (map ppr fixes) <> semi
295 pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
297 pprDeprecs [] = empty
298 pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
300 guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
301 | Deprecation ie txt _ <- deps ]
305 %************************************************************************
307 \subsection{Completing the new interface}
309 %************************************************************************
312 completeIface new_iface local_tycons local_classes
313 inst_info final_ids tidy_binds
315 = new_iface { pi_decls = [(initialVersion,d) | d <- sortLt lt_decl all_decls],
316 pi_insts = sortLt lt_inst_decl inst_dcls,
317 pi_rules = (initialVersion, rule_dcls)
320 all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls
321 (inst_dcls, inst_ids) = ifaceInstances inst_info
322 cls_dcls = map ifaceClass local_classes
324 ty_dcls = map ifaceTyCon (filter (not . isWiredInName . getName) local_tycons)
326 (val_dcls, emitted_ids) = ifaceBinds (inst_ids `unionVarSet` orphan_rule_ids)
329 rule_dcls | opt_OmitInterfacePragmas = []
330 | otherwise = ifaceRules tidy_orphan_rules emitted_ids
332 orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
333 | ProtoCoreRule _ _ rule <- tidy_orphan_rules]
335 lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
336 lt_inst_decl d1 d2 = instDeclName d1 < instDeclName d2
337 -- Even instance decls have names, namely the dfun name
341 %************************************************************************
343 \subsection{Completion stuff}
345 %************************************************************************
348 ifaceRules :: [ProtoCoreRule] -> IdSet -> [RdrNameRuleDecl]
349 ifaceRules rules emitted
350 = orphan_rules ++ local_rules
352 orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
353 local_rules = [ toHsRule fn rule
354 | fn <- varSetElems emitted,
355 rule <- rulesRules (idSpecialisation fn),
356 not (isBuiltinRule rule),
357 -- We can't print builtin rules in interface files
358 -- Since they are built in, an importing module
359 -- will have access to them anyway
361 -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
362 -- from coming out, and to make it work properly we need to add
363 all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
364 -- Spit out a rule only if all its lhs free vars are emitted
365 -- This is a good reason not to do it when we emit the Id itself
370 ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet)
371 -- The IdSet is the needed dfuns
373 ifaceInstances inst_infos
374 = (decls, needed_ids)
376 decls = map to_decl togo_insts
377 togo_insts = filter is_togo_inst (bagToList inst_infos)
378 needed_ids = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
379 is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
382 to_decl (InstInfo clas tvs tys theta dfun_id _ _ _)
384 -- The deNoteType is very important. It removes all type
385 -- synonyms from the instance type in interface files.
386 -- That in turn makes sure that when reading in instance decls
387 -- from interface files that the 'gating' mechanism works properly.
388 -- Otherwise you could have
389 -- type Tibble = T Int
390 -- instance Foo Tibble where ...
391 -- and this instance decl wouldn't get imported into a module
392 -- that mentioned T but not Tibble.
393 forall_ty = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys))
394 tidy_ty = tidyTopType forall_ty
396 InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc
400 ifaceTyCon :: TyCon -> RdrNameHsDecl
403 = TyClD (TySynonym (toRdrName tycon)
404 (toHsTyVars tyvars) (toHsType ty)
407 (tyvars, ty) = getSynTyConDefn tycon
411 = TyClD (mkTyData new_or_data (toHsContext (tyConTheta tycon))
414 (map ifaceConDecl (tyConDataCons tycon))
415 (tyConFamilySize tycon)
416 Nothing NoDataPragmas noSrcLoc)
418 tyvars = tyConTyVars tycon
419 new_or_data | isNewTyCon tycon = NewType
420 | otherwise = DataType
422 ifaceConDecl data_con
423 = ConDecl (toRdrName data_con) (error "ifaceConDecl")
424 (toHsTyVars ex_tyvars)
425 (toHsContext ex_theta)
428 (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
429 field_labels = dataConFieldLabels data_con
430 strict_marks = dataConStrictMarks data_con
433 = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
434 VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
437 = RecCon (zipWith mk_field strict_marks field_labels)
439 mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
440 mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
441 mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
443 mk_field strict_mark field_label
444 = ([toRdrName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
447 = pprPanic "pprIfaceTyDecl" (ppr tycon)
450 = TyClD (ClassDecl (toHsContext sc_theta)
452 (toHsTyVars clas_tyvars)
454 (map toClassOpSig op_stuff)
455 EmptyMonoBinds NoClassPragmas
459 bogus = error "ifaceClass"
460 (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
462 toClassOpSig (sel_id, def_meth) =
463 ASSERT(sel_tyvars == clas_tyvars)
464 ClassOpSig (toRdrName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
466 (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
467 def_meth' = case def_meth of
468 NoDefMeth -> NoDefMeth
469 GenDefMeth -> GenDefMeth
470 DefMeth id -> DefMeth (toRdrName id)
474 %************************************************************************
476 \subsection{Value bindings}
478 %************************************************************************
481 ifaceBinds :: IdSet -- These Ids are needed already
482 -> [Id] -- Ids used at code-gen time; they have better pragma info!
483 -> [CoreBind] -- In dependency order, later depend on earlier
484 -> (Bag RdrNameHsDecl, IdSet) -- Set of Ids actually spat out
486 ifaceBinds needed_ids final_ids binds
487 = go needed_ids (reverse binds) emptyBag emptyVarSet
488 -- Reverse so that later things will
489 -- provoke earlier ones to be emitted
491 final_id_map = listToUFM [(id,id) | id <- final_ids]
492 get_idinfo id = case lookupUFM final_id_map id of
493 Just id' -> idInfo id'
494 Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
497 -- The 'needed' set contains the Ids that are needed by earlier
498 -- interface file emissions. If the Id isn't in this set, and isn't
499 -- exported, there's no need to emit anything
500 need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id
502 go needed [] decls emitted
503 | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
504 (sep (map ppr (varSetElems needed)))
506 | otherwise = (decls, emitted)
508 go needed (NonRec id rhs : binds) decls emitted
510 = if omitIfaceSigForId id then
511 go (needed `delVarSet` id) binds decls (emitted `extendVarSet` id)
513 go ((needed `unionVarSet` extras) `delVarSet` id)
515 (decl `consBag` decls)
516 (emitted `extendVarSet` id)
518 = go needed binds decls emitted
520 (decl, extras) = ifaceId get_idinfo False id rhs
522 -- Recursive groups are a bit more of a pain. We may only need one to
523 -- start with, but it may call out the next one, and so on. So we
524 -- have to look for a fixed point. We don't want necessarily them all,
525 -- because without -O we may only need the first one (if we don't emit
527 go needed (Rec pairs : binds) decls emitted
528 = go needed' binds decls' emitted'
530 (new_decls, new_emitted, extras) = go_rec needed pairs
531 decls' = new_decls `unionBags` decls
532 needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
533 emitted' = emitted `unionVarSet` new_emitted
535 go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet)
537 | null decls = (emptyBag, emptyVarSet, emptyVarSet)
538 | otherwise = (more_decls `unionBags` listToBag decls,
539 more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
540 more_extras `unionVarSet` extras)
542 (needed_prs,leftover_prs) = partition is_needed pairs
543 (decls, extras_s) = unzip [ifaceId get_idinfo True id rhs
544 | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
545 extras = unionVarSets extras_s
546 (more_decls, more_emitted, more_extras) = go_rec extras leftover_prs
547 is_needed (id,_) = need_id needed id
552 ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
553 -- by the STG passes. Sigh
554 -> Bool -- True <=> recursive, so don't print unfolding
556 -> CoreExpr -- The Id's right hand side
557 -> (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
559 ifaceId get_idinfo is_rec id rhs
560 = (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc), new_needed_ids)
563 core_idinfo = idInfo id
564 stg_idinfo = get_idinfo id
566 hs_idinfo | opt_OmitInterfacePragmas = []
567 | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
568 strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
570 ------------ Arity --------------
571 arity_info = arityInfo stg_idinfo
572 stg_arity = arityLowerBound arity_info
573 arity_hsinfo = case arityInfo stg_idinfo of
574 a@(ArityExactly n) -> [HsArity a]
577 ------------ Caf Info --------------
578 caf_hsinfo = case cafInfo stg_idinfo of
579 NoCafRefs -> [HsNoCafRefs]
582 ------------ CPR Info --------------
583 cpr_hsinfo = case cprInfo core_idinfo of
584 ReturnsCPR -> [HsCprInfo]
587 ------------ Strictness --------------
588 strict_info = strictnessInfo core_idinfo
589 bottoming_fn = isBottomingStrictness strict_info
590 strict_hsinfo = case strict_info of
591 NoStrictnessInfo -> []
592 info -> [HsStrictness info]
595 ------------ Worker --------------
596 -- We only treat a function as having a worker if
597 -- the exported arity (which is now the number of visible lambdas)
598 -- is the same as the arity at the moment of the w/w split
599 -- If so, we can safely omit the unfolding inside the wrapper, and
600 -- instead re-generate it from the type/arity/strictness info
601 -- But if the arity has changed, we just take the simple path and
602 -- put the unfolding into the interface file, forgetting the fact
603 -- that it's a wrapper.
605 -- How can this happen? Sometimes we get
606 -- f = coerce t (\x y -> $wf x y)
607 -- at the moment of w/w split; but the eta reducer turns it into
609 -- which is perfectly fine except that the exposed arity so far as
610 -- the code generator is concerned (zero) differs from the arity
611 -- when we did the split (2).
613 -- All this arises because we use 'arity' to mean "exactly how many
614 -- top level lambdas are there" in interface files; but during the
615 -- compilation of this module it means "how many things can I apply
617 work_info = workerInfo core_idinfo
618 HasWorker work_id _ = work_info
620 has_worker = case work_info of
621 HasWorker work_id wrap_arity
622 | wrap_arity == stg_arity -> True
623 | otherwise -> pprTrace "ifaceId: arity change:" (ppr id)
628 wrkr_hsinfo | has_worker = [HsWorker (toRdrName work_id)]
631 ------------ Unfolding --------------
632 inline_pragma = inlinePragInfo core_idinfo
633 dont_inline = isNeverInlinePrag inline_pragma
635 unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
638 show_unfold = not has_worker && -- Not unnecessary
639 not bottoming_fn && -- Not necessary
642 rhs_is_small && -- Small enough
643 okToUnfoldInHiFile rhs -- No casms etc
645 rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
647 ------------ Specialisations --------------
648 spec_info = specInfo core_idinfo
650 ------------ Occ info --------------
651 loop_breaker = isLoopBreaker (occInfo core_idinfo)
653 ------------ Extra free Ids --------------
654 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
655 | otherwise = worker_ids `unionVarSet`
656 unfold_ids `unionVarSet`
659 worker_ids | has_worker && interestingId work_id = unitVarSet work_id
660 -- Conceivably, the worker might come from
662 | otherwise = emptyVarSet
664 spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
666 unfold_ids | show_unfold = find_fvs rhs
667 | otherwise = emptyVarSet
669 find_fvs expr = exprSomeFreeVars interestingId expr
671 interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)