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 ( Handle, hPutStr, openFile,
12 hClose, hPutStrLn, IOMode(..) )
15 import HsCore ( HsIdInfo(..), toUfExpr )
16 import RdrHsSyn ( RdrNameRuleDecl )
17 import HsPragmas ( DataPragmas(..), ClassPragmas(..) )
18 import HsTypes ( toHsTyVars )
19 import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..),
20 Version, bumpVersion, initialVersion, isLoopBreaker
23 import RnEnv ( availName )
25 import TcInstUtil ( InstInfo(..) )
28 import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
33 import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
34 import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), InlinePragInfo(..),
35 CprInfo(..), CafInfo(..),
36 inlinePragInfo, arityInfo, arityLowerBound,
37 strictnessInfo, isBottomingStrictness,
38 cafInfo, specInfo, cprInfo,
39 occInfo, isNeverInlinePrag,
40 workerExists, workerInfo, WorkerInfo(..)
42 import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
43 import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
44 import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
45 import Module ( moduleString, pprModule, pprModuleName )
46 import RdrName ( RdrName )
47 import Name ( isLocallyDefined, isWiredInName, toRdrName, nameModule,
50 import OccName ( OccName, pprOccName )
51 import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
52 tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
54 import Class ( Class, classExtraBigSig )
55 import FieldLabel ( fieldLabelName, fieldLabelType )
56 import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
57 deNoteType, classesToPreds,
58 Type, ThetaType, PredType(..), ClassContext
62 import FunDeps ( pprFundeps )
63 import Rules ( pprProtoCoreRule, ProtoCoreRule(..) )
65 import Bag ( bagToList, isEmptyBag )
66 import Maybes ( catMaybes, maybeToBool )
67 import FiniteMap ( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap )
68 import UniqFM ( lookupUFM, listToUFM )
69 import UniqSet ( uniqSetToList )
70 import Util ( sortLt, mapAccumL )
71 import SrcLoc ( noSrcLoc )
77 %************************************************************************
79 \subsection{Write a new interface file}
81 %************************************************************************
84 writeIface this_mod old_iface new_iface
85 local_tycons local_classes inst_info
86 final_ids tidy_binds tidy_orphan_rules
87 = case opt_ProduceHi of {
88 Nothing -> return () ; -- not producing any .hi file
92 case checkIface old_iface full_new_iface of {
93 Nothing -> do { putStrLn "Interface file unchanged" ;
94 return () } ; -- No need to update .hi file
98 do let mod_vers_unchanged = case old_iface of
99 Just iface -> pi_vers iface == pi_vers final_iface
101 if mod_vers_unchanged
102 then putStrLn "Module version unchanged, but usages differ; hence need new hi file"
105 if_hdl <- openFile filename WriteMode
106 printForIface if_hdl (pprIface final_iface)
110 full_new_iface = completeIface new_iface local_tycons local_classes
111 inst_info final_ids tidy_binds
116 %************************************************************************
118 \subsection{Checking if the new interface is up to date
120 %************************************************************************
123 checkIface :: Maybe ParsedIface -- The old interface, read from M.hi
124 -> ParsedIface -- The new interface; but with all version numbers = 1
125 -> Maybe ParsedIface -- Nothing => no change; no need to write new Iface
126 -- Just pi => Here is the new interface to write
127 -- with correct version numbers
129 -- NB: the fixities, declarations, rules are all assumed
130 -- to be sorted by increasing order of hsDeclName, so that
131 -- we can compare for equality
133 checkIface Nothing new_iface
134 -- No old interface, so definitely write a new one!
137 checkIface (Just iface) new_iface
138 | no_output_change && no_usage_change
141 | otherwise -- Add updated version numbers
143 {- pprTrace "checkIface" (
144 vcat [ppr no_decl_changed <+> ppr no_export_change <+> ppr no_usage_change,
146 vcat (map ppr (pi_decls iface)),
148 vcat (map ppr (pi_decls new_iface))
151 Just (new_iface { pi_vers = new_mod_vers,
152 pi_fixity = (new_fixity_vers, new_fixities),
153 pi_rules = (new_rules_vers, new_rules),
154 pi_decls = final_decls
158 no_usage_change = pi_usages iface == pi_usages new_iface
160 no_output_change = no_decl_changed &&
161 new_fixity_vers == fixity_vers &&
162 new_rules_vers == rules_vers &&
165 no_export_change = pi_exports iface == pi_exports new_iface
167 new_mod_vers | no_output_change = mod_vers
168 | otherwise = bumpVersion mod_vers
170 mod_vers = pi_vers iface
172 (fixity_vers, fixities) = pi_fixity iface
173 (_, new_fixities) = pi_fixity new_iface
174 new_fixity_vers | fixities == new_fixities = fixity_vers
175 | otherwise = bumpVersion fixity_vers
177 (rules_vers, rules) = pi_rules iface
178 (_, new_rules) = pi_rules new_iface
179 new_rules_vers | rules == new_rules = rules_vers
180 | otherwise = bumpVersion rules_vers
182 (no_decl_changed, final_decls) = merge_decls True [] (pi_decls iface) (pi_decls new_iface)
184 -- Fill in the version number on the new declarations
185 -- by looking at the old declarations.
186 -- Set the flag if anything changes.
187 -- Assumes that the decls are sorted by hsDeclName
188 merge_decls ok_so_far acc [] [] = (ok_so_far, reverse acc)
189 merge_decls ok_so_far acc old [] = (False, reverse acc)
190 merge_decls ok_so_far acc [] (nvd:nvds) = merge_decls False (nvd:acc) [] nvds
191 merge_decls ok_so_far acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
192 = case d_name `compare` nd_name of
193 LT -> merge_decls False acc vds (nvd:nvds)
194 GT -> merge_decls False (nvd:acc) (vd:vds) nvds
195 EQ | d == nd -> merge_decls ok_so_far (vd:acc) vds nvds
196 | otherwise -> merge_decls False ((bumpVersion v, nd):acc) vds nvds
198 d_name = hsDeclName d
199 nd_name = hsDeclName nd
204 %************************************************************************
206 \subsection{Printing the interface}
208 %************************************************************************
211 pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
212 pi_usages = usages, pi_exports = exports,
213 pi_fixity = (fix_vers, fixities),
214 pi_insts = insts, pi_decls = decls,
215 pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
216 = vcat [ ptext SLIT("__interface")
217 <+> doubleQuotes (ptext opt_InPackage)
218 <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
219 <+> (if orphan then char '!' else empty)
220 <+> int opt_HiVersion
221 <+> ptext SLIT("where")
222 , vcat (map pprExport exports)
223 , vcat (map pprUsage usages)
224 , pprFixities fixities
225 , vcat [ppr i <+> semi | i <- insts]
226 , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
231 ppr_vers v | v == initialVersion = empty
234 | fix_vers == initialVersion && rule_vers == initialVersion = empty
235 | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
238 When printing export lists, we print like this:
240 AvailTC C [C, x, y] C(x,y)
241 AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
244 pprExport :: ExportItem -> SDoc
245 pprExport (mod, items)
246 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
248 upp_avail :: RdrAvailInfo -> SDoc
249 upp_avail (Avail name) = pprOccName name
250 upp_avail (AvailTC name []) = empty
251 upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
253 bang | name `elem` ns = empty
254 | otherwise = char '|'
255 ns' = filter (/= name) ns
257 upp_export [] = empty
258 upp_export names = braces (hsep (map pprOccName names))
263 pprUsage :: ImportVersion OccName -> SDoc
264 pprUsage (m, has_orphans, is_boot, whats_imported)
265 = hsep [ptext SLIT("import"), pprModuleName m,
267 upp_import_versions whats_imported
270 pp_orphan | has_orphans = char '!'
272 pp_boot | is_boot = char '@'
275 -- Importing the whole module is indicated by an empty list
276 upp_import_versions NothingAtAll = empty
277 upp_import_versions (Everything v) = dcolon <+> int v
278 upp_import_versions (Specifically vm vf vr nvs)
279 = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
284 pprFixities [] = empty
285 pprFixities fixes = hsep (map ppr fixes) <> semi
288 pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
290 pprDeprecs [] = empty
291 pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
293 guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
294 | Deprecation ie txt _ <- deps ]
298 %************************************************************************
300 \subsection{Completing the new interface}
302 %************************************************************************
305 completeIface new_iface local_tycons local_classes
306 inst_info final_ids tidy_binds
308 = new_iface { pi_decls = [(initialVersion,d) | d <- sortLt lt_decl all_decls],
309 pi_insts = sortLt lt_inst_decl inst_dcls,
310 pi_rules = (initialVersion, rule_dcls)
313 all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls
314 (inst_dcls, inst_ids) = ifaceInstances inst_info
315 cls_dcls = map ifaceClass local_classes
316 ty_dcls = map ifaceTyCon (filter (not . isWiredInName . getName) local_tycons)
318 (val_dcls, emitted_ids) = ifaceBinds (inst_ids `unionVarSet` orphan_rule_ids)
321 rule_dcls | opt_OmitInterfacePragmas = []
322 | otherwise = ifaceRules tidy_orphan_rules emitted_ids
324 orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
325 | ProtoCoreRule _ _ rule <- tidy_orphan_rules]
327 lt_inst_decl (InstDecl _ _ _ dfun_id1 _) (InstDecl _ _ _ dfun_id2 _)
328 = dfun_id1 < dfun_id2
329 -- The dfuns are assigned names df1, df2, etc,
330 -- in order of original textual
331 -- occurrence, and this makes as good a sort order as any
333 lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
337 %************************************************************************
339 \subsection{Completion stuff}
341 %************************************************************************
344 ifaceRules :: [ProtoCoreRule] -> IdSet -> [RdrNameRuleDecl]
345 ifaceRules rules emitted
346 = orphan_rules ++ local_rules
348 orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
349 local_rules = [ toHsRule fn rule
350 | fn <- varSetElems emitted,
351 rule <- rulesRules (idSpecialisation fn),
352 not (isBuiltinRule rule),
353 -- We can't print builtin rules in interface files
354 -- Since they are built in, an importing module
355 -- will have access to them anyway
356 all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
357 -- Spit out a rule only if all its lhs free vars are emitted
358 -- This is a good reason not to do it when we emit the Id itself
363 ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet)
364 -- The IdSet is the needed dfuns
366 ifaceInstances inst_infos
367 = (decls, needed_ids)
369 decls = map to_decl togo_insts
370 togo_insts = filter is_togo_inst (bagToList inst_infos)
371 needed_ids = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
372 is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
375 to_decl (InstInfo clas tvs tys theta 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.
386 forall_ty = mkSigmaTy tvs (classesToPreds theta)
387 (deNoteType (mkDictTy clas tys))
388 tidy_ty = tidyTopType forall_ty
390 InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (toRdrName dfun_id) noSrcLoc
394 ifaceTyCon :: TyCon -> RdrNameHsDecl
397 = TyClD (TySynonym (toRdrName tycon)
398 (toHsTyVars tyvars) (toHsType ty)
401 (tyvars, ty) = getSynTyConDefn tycon
405 = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon))
408 (map ifaceConDecl (tyConDataCons tycon))
409 (tyConFamilySize tycon)
410 Nothing NoDataPragmas noSrcLoc)
412 tyvars = tyConTyVars tycon
413 new_or_data | isNewTyCon tycon = NewType
414 | otherwise = DataType
416 ifaceConDecl data_con
417 = ConDecl (toRdrName data_con) (error "ifaceConDecl")
418 (toHsTyVars ex_tyvars)
419 (toHsContext ex_theta)
422 (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
423 field_labels = dataConFieldLabels data_con
424 strict_marks = dataConStrictMarks data_con
427 = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
428 VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
431 = RecCon (zipWith mk_field strict_marks field_labels)
433 mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
434 mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
435 mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
437 mk_field strict_mark field_label
438 = ([toRdrName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
441 = pprPanic "pprIfaceTyDecl" (ppr tycon)
444 = TyClD (ClassDecl (toHsContext sc_theta)
446 (toHsTyVars clas_tyvars)
448 (map toClassOpSig op_stuff)
449 EmptyMonoBinds NoClassPragmas
450 bogus bogus bogus [] noSrcLoc
453 bogus = error "ifaceClass"
454 (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
456 toClassOpSig (sel_id, dm_id, explicit_dm)
457 = ASSERT( sel_tyvars == clas_tyvars)
458 ClassOpSig (toRdrName sel_id) bogus explicit_dm (toHsType op_ty) noSrcLoc
460 (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
464 %************************************************************************
466 \subsection{Value bindings}
468 %************************************************************************
471 ifaceBinds :: IdSet -- These Ids are needed already
472 -> [Id] -- Ids used at code-gen time; they have better pragma info!
473 -> [CoreBind] -- In dependency order, later depend on earlier
474 -> (Bag RdrNameHsDecl, IdSet) -- Set of Ids actually spat out
476 ifaceBinds needed_ids final_ids binds
477 = go needed_ids (reverse binds) emptyBag emptyVarSet
478 -- Reverse so that later things will
479 -- provoke earlier ones to be emitted
481 final_id_map = listToUFM [(id,id) | id <- final_ids]
482 get_idinfo id = case lookupUFM final_id_map id of
483 Just id' -> idInfo id'
484 Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
487 go needed [] decls emitted
488 | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
489 (sep (map ppr (varSetElems needed)))
491 | otherwise = (decls, emitted)
493 go needed (NonRec id rhs : binds) decls emitted
494 = case ifaceId get_idinfo needed False id rhs of
495 Nothing -> go needed binds decls emitted
496 Just (decl, extras) -> let
497 needed' = (needed `unionVarSet` extras) `delVarSet` id
498 -- 'extras' can include the Id itself via a rule
499 emitted' = emitted `extendVarSet` id
501 go needed' binds (decl `consBag` decls) emitted'
503 -- Recursive groups are a bit more of a pain. We may only need one to
504 -- start with, but it may call out the next one, and so on. So we
505 -- have to look for a fixed point.
506 go needed (Rec pairs : binds) decls emitted
507 = go needed' binds decls' emitted'
509 (new_decls, new_emitted, extras) = go_rec needed pairs
510 decls' = new_decls `unionBags` decls
511 needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
512 emitted' = emitted `unionVarSet` new_emitted
514 go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet)
516 | null decls = (emptyBag, emptyVarSet, emptyVarSet)
517 | otherwise = (more_decls `unionBags` listToBag decls,
518 more_emitted `unionVarSet` mkVarSet emitted,
519 more_extras `unionVarSet` extras)
521 maybes = map do_one pairs
522 emitted = [id | ((id,_), Just _) <- pairs `zip` maybes]
523 reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes]
524 (decls, extras_s) = unzip (catMaybes maybes)
525 extras = unionVarSets extras_s
526 (more_decls, more_emitted, more_extras) = go_rec extras reduced_pairs
528 do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
533 ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
534 -- by the STG passes. Sigh
536 -> IdSet -- Set of Ids that are needed by earlier interface
537 -- file emissions. If the Id isn't in this set, and isn't
538 -- exported, there's no need to emit anything
539 -> Bool -- True <=> recursive, so don't print unfolding
541 -> CoreExpr -- The Id's right hand side
542 -> Maybe (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
544 ifaceId get_idinfo needed_ids is_rec id rhs
545 | not (id `elemVarSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId]
546 (isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
547 = Nothing -- Well, that was easy!
549 ifaceId get_idinfo needed_ids is_rec id rhs
550 = ASSERT2( arity_matches_strictness, ppr id )
551 Just (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc),
555 core_idinfo = idInfo id
556 stg_idinfo = get_idinfo id
558 hs_idinfo | opt_OmitInterfacePragmas = []
559 | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
560 strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
562 ------------ Arity --------------
563 arity_info = arityInfo stg_idinfo
564 arity_hsinfo = case arityInfo stg_idinfo of
565 a@(ArityExactly n) -> [HsArity a]
568 ------------ Caf Info --------------
569 caf_hsinfo = case cafInfo stg_idinfo of
570 NoCafRefs -> [HsNoCafRefs]
573 ------------ CPR Info --------------
574 cpr_hsinfo = case cprInfo core_idinfo of
575 ReturnsCPR -> [HsCprInfo]
578 ------------ Strictness --------------
579 strict_info = strictnessInfo core_idinfo
580 bottoming_fn = isBottomingStrictness strict_info
581 strict_hsinfo = case strict_info of
582 NoStrictnessInfo -> []
583 info -> [HsStrictness info]
586 ------------ Worker --------------
587 work_info = workerInfo core_idinfo
588 has_worker = workerExists work_info
589 wrkr_hsinfo = case work_info of
590 HasWorker work_id _ -> [HsWorker (toRdrName work_id)]
593 ------------ Unfolding --------------
594 inline_pragma = inlinePragInfo core_idinfo
595 dont_inline = isNeverInlinePrag inline_pragma
597 unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
600 show_unfold = not has_worker && -- Not unnecessary
601 not bottoming_fn && -- Not necessary
604 rhs_is_small && -- Small enough
605 okToUnfoldInHiFile rhs -- No casms etc
607 rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
609 ------------ Specialisations --------------
610 spec_info = specInfo core_idinfo
612 ------------ Occ info --------------
613 loop_breaker = isLoopBreaker (occInfo core_idinfo)
615 ------------ Extra free Ids --------------
616 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
617 | otherwise = worker_ids `unionVarSet`
618 unfold_ids `unionVarSet`
621 worker_ids = case work_info of
622 HasWorker work_id _ | interestingId work_id -> unitVarSet work_id
623 -- Conceivably, the worker might come from
627 spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
629 unfold_ids | show_unfold = find_fvs rhs
630 | otherwise = emptyVarSet
632 find_fvs expr = exprSomeFreeVars interestingId expr
634 ------------ Sanity checking --------------
635 -- The arity of a wrapper function should match its strictness,
636 -- or else an importing module will get very confused indeed.
637 arity_matches_strictness
639 HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info
642 interestingId id = isId id && isLocallyDefined id &&
643 not (omitIfaceSigForId id)