2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[MkIface]{Print an interface for a module}
7 #include "HsVersions.h"
16 IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..)))
19 import RdrHsSyn ( RdrName(..) )
20 import RnHsSyn ( SYN_IE(RenamedHsModule) )
22 import RnEnv ( availName )
24 import TcInstUtil ( InstInfo(..) )
27 import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
28 getIdInfo, idWantsToBeINLINEd, omitIfaceSigForId,
29 dataConStrictMarks, StrictnessMark(..),
30 SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet,
31 isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
32 GenId{-instance NamedThing/Outputable-}
34 import IdInfo ( StrictnessInfo, ArityInfo, Unfolding,
35 arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo,
36 getWorkerId_maybe, bottomIsGuaranteed
38 import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr, GenCoreBinding(..) )
39 import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..) )
40 import FreeVars ( addExprFVs )
41 import Name ( isLocallyDefined, isWiredInName, modAndOcc, getName, pprOccName,
42 OccName, occNameString, nameOccName, nameString, isExported, pprNonSym,
43 Name {-instance NamedThing-}, Provenance
45 import TyCon ( TyCon{-instance NamedThing-} )
46 import Class ( GenClass(..){-instance NamedThing-}, GenClassOp, classOpLocalType )
47 import FieldLabel ( FieldLabel{-instance NamedThing-} )
48 import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
49 import TyVar ( GenTyVar {- instance Eq -} )
50 import Unique ( Unique {- instance Eq -} )
52 import PprEnv -- not sure how much...
53 import PprStyle ( PprStyle(..) )
55 import PprCore ( pprIfaceUnfolding )
57 import Unpretty -- ditto
60 import Bag ( bagToList )
61 import Maybes ( catMaybes, maybeToBool )
62 import FiniteMap ( emptyFM, addToFM, addToFM_C, lookupFM, fmToList, eltsFM, FiniteMap )
63 import UniqFM ( UniqFM, lookupUFM, listToUFM )
64 import Util ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL,
65 assertPanic, panic{-ToDo:rm-}, pprTrace )
69 We have a function @startIface@ to open the output file and put
70 (something like) ``interface Foo'' in it. It gives back a handle
71 for subsequent additions to the interface file.
73 We then have one-function-per-block-of-interface-stuff, e.g.,
74 @ifaceExportList@ produces the @__exports__@ section; it appends
75 to the handle provided by @startIface@.
79 -> IO (Maybe Handle) -- Nothing <=> don't do an interface
81 ifaceMain :: Maybe Handle
86 ifaceDecls :: Maybe Handle
89 -> [Id] -- Ids used at code-gen time; they have better pragma info!
90 -> [CoreBinding] -- In dependency order, later depend on earlier
93 endIface :: Maybe Handle -> IO ()
98 = case opt_ProduceHi of
99 Nothing -> return Nothing -- not producing any .hi file
101 openFile fn WriteMode >>= \ if_hdl ->
102 hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\n_interface_ "++ _UNPK_ mod ++ "\n") >>
105 endIface Nothing = return ()
106 endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
111 ifaceMain Nothing iface_stuff = return ()
112 ifaceMain (Just if_hdl)
113 (import_usages, ExportEnv avails fixities, instance_modules)
115 ifaceInstanceModules if_hdl instance_modules >>
116 ifaceUsages if_hdl import_usages >>
117 ifaceExports if_hdl avails >>
118 ifaceFixities if_hdl fixities >>
121 ifaceDecls Nothing rn_mod inst_info final_ids simplified = return ()
122 ifaceDecls (Just hdl)
123 (HsModule _ _ _ _ _ decls _)
126 | null decls = return ()
127 -- You could have a module with just (re-)exports/instances in it
129 = ifaceInstances hdl inst_infos >>= \ needed_ids ->
130 hPutStr hdl "_declarations_\n" >>
131 ifaceTCDecls hdl decls >>
132 ifaceBinds hdl needed_ids final_ids binds >>
137 ifaceUsages if_hdl import_usages
138 = hPutStr if_hdl "_usages_\n" >>
139 hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
141 upp_uses (m, mv, versions)
142 = uppBesides [upp_module m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
143 upp_import_versions (sort_versions versions), uppSemi]
145 -- For imported versions we do print the version number
146 upp_import_versions nvs
147 = uppIntersperse uppSP [ uppCat [ppr_unqual_name n, uppInt v] | (n,v) <- nvs ]
150 ifaceInstanceModules if_hdl [] = return ()
151 ifaceInstanceModules if_hdl imods
152 = hPutStr if_hdl "_instance_modules_\n" >>
153 hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) >>
156 ifaceExports if_hdl [] = return ()
157 ifaceExports if_hdl avails
158 = hPutStr if_hdl "_exports_\n" >>
159 hPutCol if_hdl do_one_module (fmToList export_fm)
161 -- Sort them into groups by module
162 export_fm :: FiniteMap Module [AvailInfo]
163 export_fm = foldr insert emptyFM avails
165 insert NotAvailable efm = efm
166 insert avail efm = addToFM_C (++) efm mod [avail]
168 (mod,_) = modAndOcc (availName avail)
170 -- Print one module's worth of stuff
171 do_one_module (mod_name, avails)
172 = uppBesides [upp_module mod_name, uppSP,
173 uppCat (map upp_avail (sortLt lt_avail avails)),
176 ifaceFixities if_hdl [] = return ()
177 ifaceFixities if_hdl fixities
178 = hPutStr if_hdl "_fixities_\n" >>
179 hPutCol if_hdl upp_fixity fixities
181 ifaceTCDecls if_hdl decls
182 = hPutCol if_hdl ppr_decl tc_decls_for_iface
184 tc_decls_for_iface = sortLt lt_decl (filter for_iface decls)
185 for_iface decl@(ClD _) = for_iface_name (hsDeclName decl)
186 for_iface decl@(TyD _) = for_iface_name (hsDeclName decl)
187 for_iface other_decl = False
189 for_iface_name name = isLocallyDefined name &&
190 not (isWiredInName name)
192 lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
195 %************************************************************************
197 \subsection{Instance declarations}
199 %************************************************************************
203 ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet -- The IdSet is the needed dfuns
204 ifaceInstances if_hdl inst_infos
205 | null togo_insts = return emptyIdSet
206 | otherwise = hPutStr if_hdl "_instances_\n" >>
207 hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
210 togo_insts = filter is_togo_inst (bagToList inst_infos)
211 needed_ids = mkIdSet [dfun_id | InstInfo _ _ _ _ _ dfun_id _ _ _ <- togo_insts]
212 is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
215 lt_inst (InstInfo _ _ _ _ _ dfun_id1 _ _ _)
216 (InstInfo _ _ _ _ _ dfun_id2 _ _ _)
217 = getOccName dfun_id1 < getOccName dfun_id2
218 -- The dfuns are assigned names df1, df2, etc, in order of original textual
219 -- occurrence, and this makes as good a sort order as any
222 pp_inst (InstInfo clas tvs ty theta _ dfun_id _ _ _)
224 forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty)
225 renumbered_ty = renumber_ty forall_ty
227 uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty,
228 uppPStr SLIT(" = "), ppr_unqual_name dfun_id, uppSemi]
232 %************************************************************************
234 \subsection{Printing values}
236 %************************************************************************
239 ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
240 -- by the STG passes. Sigh
242 -> IdSet -- Set of Ids that are needed by earlier interface
243 -- file emissions. If the Id isn't in this set, and isn't
244 -- exported, there's no need to emit anything
245 -> Bool -- True <=> recursive, so don't print unfolding
247 -> CoreExpr -- The Id's right hand side
248 -> Maybe (Pretty, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids
250 ifaceId get_idinfo needed_ids is_rec id rhs
251 | not (id `elementOfIdSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId]
252 (isExported id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
253 = Nothing -- Well, that was easy!
255 ifaceId get_idinfo needed_ids is_rec id rhs
256 = Just (ppCat [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids)
258 pp_double_semi = ppPStr SLIT(";;")
259 idinfo = get_idinfo id
260 inline_pragma = idWantsToBeINLINEd id
262 ty_pretty = pprType PprInterface (initNmbr (nmbrType (idType id)))
263 sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" _:_ "), ty_pretty]
266 | opt_OmitInterfacePragmas = ppNil
267 | otherwise = ppCat [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi]
269 ------------ Arity --------------
270 arity_pretty = ppArityInfo PprInterface (arityInfo idinfo)
272 ------------ Strictness --------------
273 strict_info = strictnessInfo idinfo
274 maybe_worker = getWorkerId_maybe strict_info
275 strict_pretty = ppStrictnessInfo PprInterface strict_info
277 ------------ Unfolding --------------
278 unfold_pretty | show_unfold = ppCat [ppPStr SLIT("_U_"), pprIfaceUnfolding rhs]
281 show_unfold = not implicit_unfolding && -- Unnecessary
282 (inline_pragma || not dodgy_unfolding) -- Dangerous
284 implicit_unfolding = maybeToBool maybe_worker ||
285 bottomIsGuaranteed strict_info
287 dodgy_unfolding = is_rec || -- No recursive unfoldings please!
288 case guidance of -- Too big to show
292 guidance = calcUnfoldingGuidance inline_pragma
293 opt_InterfaceUnfoldThreshold
297 ------------ Extra free Ids --------------
298 new_needed_ids = (needed_ids `minusIdSet` unitIdSet id) `unionIdSets`
301 extra_ids | opt_OmitInterfacePragmas = emptyIdSet
302 | otherwise = worker_ids `unionIdSets`
305 worker_ids = case maybe_worker of
306 Just wkr -> unitIdSet wkr
307 Nothing -> emptyIdSet
309 unfold_ids | show_unfold = free_vars
310 | otherwise = emptyIdSet
312 (_,free_vars) = addExprFVs interesting emptyIdSet rhs
313 interesting bound id = isLocallyDefined id &&
314 not (id `elementOfIdSet` bound) &&
315 not (omitIfaceSigForId id)
320 -> IdSet -- These Ids are needed already
321 -> [Id] -- Ids used at code-gen time; they have better pragma info!
322 -> [CoreBinding] -- In dependency order, later depend on earlier
325 ifaceBinds hdl needed_ids final_ids binds
326 = hPutStr hdl (uppShow 0 (prettyToUn (ppAboves pretties))) >>
329 final_id_map = listToUFM [(id,id) | id <- final_ids]
330 get_idinfo id = case lookupUFM final_id_map id of
331 Just id' -> getIdInfo id'
332 Nothing -> pprTrace "ifaceBinds not found:" (ppr PprDebug id) $
335 pretties = go needed_ids (reverse binds) -- Reverse so that later things will
336 -- provoke earlier ones to be emitted
337 go needed [] = if not (isEmptyIdSet needed) then
338 pprTrace "ifaceBinds: free vars:"
339 (ppSep (map (ppr PprDebug) (idSetToList needed))) $
344 go needed (NonRec id rhs : binds)
345 = case ifaceId get_idinfo needed False id rhs of
346 Nothing -> go needed binds
347 Just (pretty, needed') -> pretty : go needed' binds
349 -- Recursive groups are a bit more of a pain. We may only need one to
350 -- start with, but it may call out the next one, and so on. So we
351 -- have to look for a fixed point.
352 go needed (Rec pairs : binds)
353 = pretties ++ go needed'' binds
355 (needed', pretties) = go_rec needed pairs
356 needed'' = needed' `minusIdSet` mkIdSet (map fst pairs)
357 -- Later ones may spuriously cause earlier ones to be "needed" again
359 go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Pretty])
361 | null pretties = (needed, [])
362 | otherwise = (final_needed, more_pretties ++ pretties)
364 reduced_pairs = [pair | (pair,Nothing) <- pairs `zip` maybes]
365 pretties = catMaybes maybes
366 (needed', maybes) = mapAccumL do_one needed pairs
367 (final_needed, more_pretties) = go_rec needed' reduced_pairs
369 do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
370 Nothing -> (needed, Nothing)
371 Just (pretty, needed') -> (needed', Just pretty)
375 %************************************************************************
377 \subsection{Random small things}
379 %************************************************************************
381 When printing export lists, we print like this:
383 AvailTC C [C, x, y] C(x,y)
384 AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
387 upp_avail NotAvailable = uppNil
388 upp_avail (Avail name) = upp_occname (getOccName name)
389 upp_avail (AvailTC name []) = uppNil
390 upp_avail (AvailTC name ns) = uppBesides [upp_occname (getOccName name), bang, upp_export ns']
392 bang | name `elem` ns = uppNil
393 | otherwise = uppChar '!'
394 ns' = filter (/= name) ns
396 upp_export [] = uppNil
397 upp_export names = uppBesides [uppChar '(',
398 uppIntersperse uppSP (map (upp_occname . getOccName) names),
401 upp_fixity (occ, (Fixity prec dir, prov)) = uppBesides [upp_dir dir, uppSP,
403 upp_occname occ, uppSemi]
404 upp_dir InfixR = uppPStr SLIT("infixr")
405 upp_dir InfixL = uppPStr SLIT("infixl")
406 upp_dir InfixN = uppPStr SLIT("infix")
408 ppr_unqual_name :: NamedThing a => a -> Unpretty -- Just its occurrence name
409 ppr_unqual_name name = upp_occname (getOccName name)
411 ppr_name :: NamedThing a => a -> Unpretty -- Its full name
412 ppr_name n = uppPStr (nameString (getName n))
414 upp_occname :: OccName -> Unpretty
415 upp_occname occ = uppPStr (occNameString occ)
417 upp_module :: Module -> Unpretty
418 upp_module mod = uppPStr mod
420 uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
422 ppr_ty ty = prettyToUn (pprType PprInterface ty)
423 ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
424 ppr_tyvar_bndr tv = prettyToUn (pprTyVarBndr PprInterface tv)
426 ppr_decl decl = prettyToUn (ppr PprInterface decl) `uppBeside` uppSemi
428 renumber_ty ty = initNmbr (nmbrType ty)
432 %************************************************************************
434 \subsection{Comparisons
436 %************************************************************************
439 The various sorts above simply prevent unnecessary "wobbling" when
440 things change that don't have to. We therefore compare lexically, not
444 lt_avail :: AvailInfo -> AvailInfo -> Bool
446 a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
448 lt_name :: Name -> Name -> Bool
449 n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
451 lt_lexical :: NamedThing a => a -> a -> Bool
452 lt_lexical a1 a2 = getName a1 `lt_name` getName a2
454 lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
455 lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2
457 sort_versions vs = sortLt lt_vers vs
459 lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
460 lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
469 hPutCol hdl fmt xs = hPutStr hdl (uppShow 0 (uppAboves (map fmt xs))) >>