X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fmain%2FMkIface.lhs;h=e823e478e6b7f29ac55c50b79d4bab0853823ba9;hb=18ec950adfd951e4e86ef5d52fc1a95b5f27e5d4;hp=a3b148e0b96bba1ad5813c991fba89e80c2019e9;hpb=7876920bbb403c2626878224d64f678b89748b07;p=ghc-hetmet.git diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index a3b148e..e823e47 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -1,13 +1,11 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % \section[MkIface]{Print an interface for a module} \begin{code} module MkIface ( - startIface, endIface, - ifaceMain, - ifaceDecls + startIface, endIface, ifaceDecls ) where #include "HsVersions.h" @@ -16,58 +14,54 @@ import IO ( Handle, hPutStr, openFile, hClose, hPutStrLn, IOMode(..) ) import HsSyn -import RdrHsSyn ( RdrName(..) ) -import RnHsSyn ( RenamedHsModule ) -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..), - pprModule - ) +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) ) import RnMonad -import RnEnv ( availName, ifaceFlavour ) +import RnEnv ( availName ) import TcInstUtil ( InstInfo(..) ) -import WorkWrap ( getWorkerIdAndCons ) import CmdLineOpts -import Id ( idType, dataConRawArgTys, dataConFieldLabels, - idInfo, omitIfaceSigForId, - dataConStrictMarks, StrictnessMark(..), - IdSet, idSetToList, unionIdSets, unitIdSet, minusIdSet, - isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet, - pprId, getIdSpecialisation, - Id +import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, + getIdSpecialisation ) +import Var ( isId ) +import VarSet +import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks ) import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo, - arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo, - bottomIsGuaranteed, workerExists, - ) -import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) ) -import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding, - okToUnfoldInHiFile + arityInfo, ppArityInfo, + strictnessInfo, ppStrictnessInfo, isBottomingStrictness, + cafInfo, ppCafInfo, specInfo, + cprInfo, ppCprInfo, + workerExists, workerInfo, ppWorkerInfo ) -import FreeVars ( exprFreeVars ) -import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName, - OccName, occNameString, nameOccName, nameString, isExported, - Name {-instance NamedThing-}, Provenance, NamedThing(..) +import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars ) +import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) +import CoreUnfold ( calcUnfoldingGuidance, okToUnfoldInHiFile, couldBeSmallEnoughToInline ) +import Module ( moduleString, pprModule, pprModuleName ) +import Name ( isLocallyDefined, isWiredInName, nameRdrName, nameModule, + Name, NamedThing(..) ) +import OccName ( OccName, pprOccName ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConTheta, tyConTyVars, tyConDataCons ) import Class ( Class, classBigSig ) -import SpecEnv ( specEnvToList ) import FieldLabel ( fieldLabelName, fieldLabelType ) -import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, - mkTyVarTys, Type, ThetaType +import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType, + Type, ThetaType ) -import PprEnv -- not sure how much... import PprType -import PprCore ( pprIfaceUnfolding ) +import PprCore ( pprIfaceUnfolding, pprCoreRule ) +import Rules ( pprProtoCoreRule, ProtoCoreRule(..) ) import Bag ( bagToList, isEmptyBag ) import Maybes ( catMaybes, maybeToBool ) -import FiniteMap ( emptyFM, addToFM, addToFM_C, lookupFM, fmToList, eltsFM, FiniteMap ) -import UniqFM ( UniqFM, lookupUFM, listToUFM ) -import Util ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL ) +import FiniteMap ( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap ) +import UniqFM ( lookupUFM, listToUFM ) +import UniqSet ( uniqSetToList ) +import Util ( sortLt, mapAccumL ) +import Bag import Outputable \end{code} @@ -80,32 +74,37 @@ We then have one-function-per-block-of-interface-stuff, e.g., to the handle provided by @startIface@. \begin{code} -startIface :: Module +startIface :: Module -> InterfaceDetails -> IO (Maybe Handle) -- Nothing <=> don't do an interface -ifaceMain :: Maybe Handle - -> InterfaceDetails - -> IO () - - ifaceDecls :: Maybe Handle -> [TyCon] -> [Class] -> Bag InstInfo -> [Id] -- Ids used at code-gen time; they have better pragma info! - -> [CoreBinding] -- In dependency order, later depend on earlier + -> [CoreBind] -- In dependency order, later depend on earlier + -> [ProtoCoreRule] -- Rules -> IO () endIface :: Maybe Handle -> IO () \end{code} \begin{code} -startIface mod +startIface mod (has_orphans, import_usages, ExportEnv avails fixities) = case opt_ProduceHi of - Nothing -> return Nothing -- not producing any .hi file - Just fn -> do + Nothing -> return Nothing ; -- not producing any .hi file + + Just fn -> do if_hdl <- openFile fn WriteMode - hPutStrLn if_hdl ("_interface_ "++ _UNPK_ mod ++ ' ':show (opt_HiVersion :: Int)) + hPutStr if_hdl ("__interface " ++ moduleString mod) + hPutStr if_hdl (' ' : show (opt_HiVersion :: Int) ++ orphan_indicator) + hPutStrLn if_hdl " where" + ifaceExports if_hdl avails + ifaceImports if_hdl import_usages + ifaceFixities if_hdl fixities return (Just if_hdl) + where + orphan_indicator | has_orphans = " !" + | otherwise = "" endIface Nothing = return () endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl @@ -113,70 +112,72 @@ endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl \begin{code} -ifaceMain Nothing iface_stuff = return () -ifaceMain (Just if_hdl) - (import_usages, ExportEnv avails fixities, instance_modules) - = - ifaceInstanceModules if_hdl instance_modules >> - ifaceUsages if_hdl import_usages >> - ifaceExports if_hdl avails >> - ifaceFixities if_hdl fixities >> - return () - -ifaceDecls Nothing tycons classes inst_info final_ids simplified = return () +ifaceDecls Nothing tycons classes inst_info final_ids simplified rules = return () ifaceDecls (Just hdl) tycons classes inst_infos final_ids binds + orphan_rules -- Rules defined locally for an Id that is *not* defined locally | null_decls = return () -- You could have a module with just (re-)exports/instances in it | otherwise - = ifaceInstances hdl inst_infos >>= \ needed_ids -> - hPutStr hdl "_declarations_\n" >> - ifaceClasses hdl classes >> + = ifaceClasses hdl classes >> + ifaceInstances hdl inst_infos >>= \ inst_ids -> ifaceTyCons hdl tycons >> - ifaceBinds hdl needed_ids final_ids binds >> + ifaceBinds hdl (inst_ids `unionVarSet` orphan_rule_ids) + final_ids binds >>= \ emitted_ids -> + ifaceRules hdl orphan_rules emitted_ids >> return () where + orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule + | ProtoCoreRule _ _ rule <- orphan_rules] + null_decls = null binds && null tycons && null classes && - isEmptyBag inst_infos + isEmptyBag inst_infos && + null orphan_rules \end{code} \begin{code} -ifaceUsages if_hdl import_usages - = hPutStr if_hdl "_usages_\n" >> - hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) +ifaceImports if_hdl import_usages + = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) where - upp_uses (m, hif, mv, whats_imported) - = hsep [pprModule m, pp_hif hif, int mv, ptext SLIT("::"), + upp_uses (m, mv, has_orphans, whats_imported) + = hsep [ptext SLIT("import"), pprModuleName m, + int mv, pp_orphan, upp_import_versions whats_imported ] <> semi + where + pp_orphan | has_orphans = ptext SLIT("!") + | otherwise = empty -- Importing the whole module is indicated by an empty list upp_import_versions Everything = empty -- For imported versions we do print the version number upp_import_versions (Specifically nvs) - = hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ] - -ifaceInstanceModules if_hdl [] = return () -ifaceInstanceModules if_hdl imods - = hPutStr if_hdl "_instance_modules_\n" >> - printForIface if_hdl (hsep (map ptext (sortLt (<) imods))) >> + = dcolon <+> hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ] + +ifaceModuleDeps if_hdl [] = return () +ifaceModuleDeps if_hdl mod_deps + = let + lines = map ppr_mod_dep mod_deps + ppr_mod_dep (mod, contains_orphans) + | contains_orphans = pprModuleName mod <+> ptext SLIT("!") + | otherwise = pprModuleName mod + in + printForIface if_hdl (ptext SLIT("__depends") <+> vcat lines <> ptext SLIT(" ;")) >> hPutStr if_hdl "\n" ifaceExports if_hdl [] = return () ifaceExports if_hdl avails - = hPutStr if_hdl "_exports_\n" >> - hPutCol if_hdl do_one_module (fmToList export_fm) + = hPutCol if_hdl do_one_module (fmToList export_fm) where -- Sort them into groups by module export_fm :: FiniteMap Module [AvailInfo] export_fm = foldr insert emptyFM avails - insert NotAvailable efm = efm insert avail efm = addToFM_C (++) efm mod [avail] where mod = nameModule (availName avail) @@ -184,20 +185,41 @@ ifaceExports if_hdl avails -- Print one module's worth of stuff do_one_module :: (Module, [AvailInfo]) -> SDoc do_one_module (mod_name, avails@(avail1:_)) - = hsep [pp_hif (ifaceFlavour (availName avail1)), - pprModule mod_name, + = ptext SLIT("__export ") <> + hsep [pprModule mod_name, hsep (map upp_avail (sortLt lt_avail avails)) ] <> semi --- The "!" indicates that the exported things came from a hi-boot interface -pp_hif HiFile = empty -pp_hif HiBootFile = char '!' - ifaceFixities if_hdl [] = return () ifaceFixities if_hdl fixities - = hPutStr if_hdl "_fixities_\n" >> - hPutCol if_hdl upp_fixity fixities -\end{code} + = hPutCol if_hdl upp_fixity fixities + +ifaceRules if_hdl rules emitted + | null orphan_rule_pretties && null local_id_pretties + = return () + | otherwise + = do printForIface if_hdl (vcat [ + ptext SLIT("{-## __R"), + + vcat orphan_rule_pretties, + + vcat local_id_pretties, + + ptext SLIT("##-}") + ]) + + return () + where + orphan_rule_pretties = [ pprCoreRule (Just fn) rule <+> semi + | ProtoCoreRule _ fn rule <- rules + ] + local_id_pretties = [ pprCoreRule (Just fn) rule <+> semi + | fn <- varSetElems emitted, + rule <- rulesRules (getIdSpecialisation fn), + all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) + -- Spit out a rule only if all its lhs free vars are eemitted + ] +\end{code} %************************************************************************ %* * @@ -209,27 +231,35 @@ ifaceFixities if_hdl fixities \begin{code} ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet -- The IdSet is the needed dfuns ifaceInstances if_hdl inst_infos - | null togo_insts = return emptyIdSet - | otherwise = hPutStr if_hdl "_instances_\n" >> - hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >> + | null togo_insts = return emptyVarSet + | otherwise = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >> return needed_ids where togo_insts = filter is_togo_inst (bagToList inst_infos) - needed_ids = mkIdSet [dfun_id | InstInfo _ _ _ _ _ dfun_id _ _ _ <- togo_insts] - is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id + needed_ids = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts] + is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id ------- - lt_inst (InstInfo _ _ _ _ _ dfun_id1 _ _ _) - (InstInfo _ _ _ _ _ dfun_id2 _ _ _) + lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _) + (InstInfo _ _ _ _ dfun_id2 _ _ _) = getOccName dfun_id1 < getOccName dfun_id2 -- The dfuns are assigned names df1, df2, etc, in order of original textual -- occurrence, and this makes as good a sort order as any ------- - pp_inst (InstInfo clas tvs tys theta _ dfun_id _ _ _) + pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _) = let - forall_ty = mkSigmaTy tvs theta (mkDictTy clas tys) - renumbered_ty = nmbrGlobalType forall_ty + -- The deNoteType is very important. It removes all type + -- synonyms from the instance type in interface files. + -- That in turn makes sure that when reading in instance decls + -- from interface files that the 'gating' mechanism works properly. + -- Otherwise you could have + -- type Tibble = T Int + -- instance Foo Tibble where ... + -- and this instance decl wouldn't get imported into a module + -- that mentioned T but not Tibble. + forall_ty = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys)) + renumbered_ty = tidyTopType forall_ty in hcat [ptext SLIT("instance "), pprType renumbered_ty, ptext SLIT(" = "), ppr_unqual_name dfun_id, semi] @@ -252,120 +282,108 @@ ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added -> Bool -- True <=> recursive, so don't print unfolding -> Id -> CoreExpr -- The Id's right hand side - -> Maybe (SDoc, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids + -> Maybe (SDoc, IdSet) -- The emitted stuff, plus any *extra* needed Ids ifaceId get_idinfo needed_ids is_rec id rhs - | not (id `elementOfIdSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId] - (isExported id && not (omitIfaceSigForId id))) -- or exported and not to be omitted + | not (id `elemVarSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId] + (isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted = Nothing -- Well, that was easy! ifaceId get_idinfo needed_ids is_rec id rhs - = Just (hsep [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids) + = Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids) where - pp_double_semi = ptext SLIT(";;") - idinfo = get_idinfo id - inline_pragma = inlinePragInfo idinfo + core_idinfo = idInfo id + stg_idinfo = get_idinfo id - ty_pretty = pprType (nmbrGlobalType (idType id)) - sig_pretty = hcat [ppr (getOccName id), ptext SLIT(" _:_ "), ty_pretty] + ty_pretty = pprType (idType id) + sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty] prag_pretty | opt_OmitInterfacePragmas = empty - | otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty, - spec_pretty, pp_double_semi] + | otherwise = hsep [ptext SLIT("{-##"), + arity_pretty, + caf_pretty, + cpr_pretty, + strict_pretty, + wrkr_pretty, + unfold_pretty, + ptext SLIT("##-}")] ------------ Arity -------------- - arity_pretty = ppArityInfo (arityInfo idinfo) + arity_pretty = ppArityInfo (arityInfo stg_idinfo) - ------------ Strictness -------------- - strict_info = strictnessInfo idinfo - has_worker = workerExists strict_info - strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty + ------------ Caf Info -------------- + caf_pretty = ppCafInfo (cafInfo stg_idinfo) - wrkr_pretty | not has_worker = empty - | null con_list = pprId work_id - | otherwise = pprId work_id <+> - braces (hsep (map (pprId) con_list)) + ------------ CPR Info -------------- + cpr_pretty = ppCprInfo (cprInfo core_idinfo) - (work_id, wrapper_cons) = getWorkerIdAndCons id rhs - con_list = idSetToList wrapper_cons + ------------ Strictness -------------- + strict_info = strictnessInfo core_idinfo + bottoming_fn = isBottomingStrictness strict_info + strict_pretty = ppStrictnessInfo strict_info - ------------ Unfolding -------------- - unfold_pretty | show_unfold = hsep [ptext unfold_herald, pprIfaceUnfolding rhs] - | otherwise = empty + ------------ Worker -------------- + work_info = workerInfo core_idinfo + has_worker = workerExists work_info + wrkr_pretty = ppWorkerInfo work_info + Just work_id = work_info - unfold_herald = case inline_pragma of - IMustBeINLINEd -> SLIT("_U_") - IWantToBeINLINEd -> SLIT("_U_") - other -> SLIT("_u_") - show_unfold = not implicit_unfolding && -- Not unnecessary - unfolding_is_ok -- Not dangerous + ------------ Unfolding -------------- + inline_pragma = inlinePragInfo core_idinfo + dont_inline = case inline_pragma of + IMustNotBeINLINEd -> True + IAmALoopBreaker -> True + other -> False - implicit_unfolding = has_worker || - bottomIsGuaranteed strict_info + unfold_pretty | show_unfold = ptext SLIT("__U") <+> pprIfaceUnfolding rhs + | otherwise = empty - unfolding_is_ok - = case inline_pragma of - IMustBeINLINEd -> definitely_ok_to_unfold - IWantToBeINLINEd -> definitely_ok_to_unfold - IDontWantToBeINLINEd -> False - IMustNotBeINLINEd -> False - NoPragmaInfo -> case guidance of - UnfoldNever -> False -- Too big - other -> definitely_ok_to_unfold + show_unfold = not has_worker && -- Not unnecessary + not bottoming_fn && -- Not necessary + not dont_inline && + rhs_is_small && -- Small enough + okToUnfoldInHiFile rhs -- No casms etc - definitely_ok_to_unfold = okToUnfoldInHiFile rhs - guidance = calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs + rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs) ------------ Specialisations -------------- - spec_list = specEnvToList (getIdSpecialisation id) - spec_pretty = hsep (map pp_spec spec_list) - pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"), - if null tyvars then ptext SLIT("[ ]") - else brackets (interppSP tyvars), - -- The lexer interprets "[]" as a CONID. Sigh. - hsep (map pprParendType tys), - ptext SLIT("="), - pprIfaceUnfolding rhs - ] + spec_info = specInfo core_idinfo ------------ Extra free Ids -------------- - new_needed_ids = (needed_ids `minusIdSet` unitIdSet id) `unionIdSets` - extra_ids + new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet + | otherwise = worker_ids `unionVarSet` + unfold_ids `unionVarSet` + spec_ids - extra_ids | opt_OmitInterfacePragmas = emptyIdSet - | otherwise = worker_ids `unionIdSets` - unfold_ids `unionIdSets` - spec_ids + worker_ids | has_worker && interestingId work_id = unitVarSet work_id + -- Conceivably, the worker might come from + -- another module + | otherwise = emptyVarSet - worker_ids | has_worker = unitIdSet work_id - | otherwise = emptyIdSet - - spec_ids = foldr add emptyIdSet spec_list - where - add (_, _, rhs) = unionIdSets (find_fvs rhs) + spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info) unfold_ids | show_unfold = find_fvs rhs - | otherwise = emptyIdSet + | otherwise = emptyVarSet + + find_fvs expr = exprSomeFreeVars interestingId expr - find_fvs expr = free_vars - where - free_vars = exprFreeVars interesting expr - interesting id = isLocallyDefined id && - not (omitIfaceSigForId id) +interestingId id = isId id && isLocallyDefined id && + not (omitIfaceSigForId id) \end{code} \begin{code} ifaceBinds :: Handle -> IdSet -- These Ids are needed already -> [Id] -- Ids used at code-gen time; they have better pragma info! - -> [CoreBinding] -- In dependency order, later depend on earlier - -> IO () + -> [CoreBind] -- In dependency order, later depend on earlier + -> IO IdSet -- Set of Ids actually spat out ifaceBinds hdl needed_ids final_ids binds - = mapIO (printForIface hdl) pretties >> - hPutStr hdl "\n" + = mapIO (printForIface hdl) (bagToList pretties) >> + hPutStr hdl "\n" >> + return emitted where final_id_map = listToUFM [(id,id) | id <- final_ids] get_idinfo id = case lookupUFM final_id_map id of @@ -373,43 +391,51 @@ ifaceBinds hdl needed_ids final_ids binds Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $ idInfo id - pretties = go needed_ids (reverse binds) -- Reverse so that later things will - -- provoke earlier ones to be emitted - go needed [] = if not (isEmptyIdSet needed) then - pprTrace "ifaceBinds: free vars:" - (sep (map ppr (idSetToList needed))) $ - [] - else - [] + (pretties, emitted) = go needed_ids (reverse binds) emptyBag emptyVarSet + -- Reverse so that later things will + -- provoke earlier ones to be emitted + go needed [] pretties emitted + | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" + (sep (map ppr (varSetElems needed))) + (pretties, emitted) + | otherwise = (pretties, emitted) - go needed (NonRec id rhs : binds) + go needed (NonRec id rhs : binds) pretties emitted = case ifaceId get_idinfo needed False id rhs of - Nothing -> go needed binds - Just (pretty, needed') -> pretty : go needed' binds + Nothing -> go needed binds pretties emitted + Just (pretty, extras) -> let + needed' = (needed `unionVarSet` extras) `delVarSet` id + -- 'extras' can include the Id itself via a rule + emitted' = emitted `extendVarSet` id + in + go needed' binds (pretty `consBag` pretties) emitted' -- Recursive groups are a bit more of a pain. We may only need one to -- start with, but it may call out the next one, and so on. So we -- have to look for a fixed point. - go needed (Rec pairs : binds) - = pretties ++ go needed'' binds + go needed (Rec pairs : binds) pretties emitted + = go needed' binds pretties' emitted' where - (needed', pretties) = go_rec needed pairs - needed'' = needed' `minusIdSet` mkIdSet (map fst pairs) - -- Later ones may spuriously cause earlier ones to be "needed" again + (new_pretties, new_emitted, extras) = go_rec needed pairs + pretties' = new_pretties `unionBags` pretties + needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) + emitted' = emitted `unionVarSet` new_emitted - go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc]) + go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet) go_rec needed pairs - | null pretties = (needed, []) - | otherwise = (final_needed, more_pretties ++ pretties) + | null pretties = (emptyBag, emptyVarSet, emptyVarSet) + | otherwise = (more_pretties `unionBags` listToBag pretties, + more_emitted `unionVarSet` mkVarSet emitted, + more_extras `unionVarSet` extras) where - reduced_pairs = [pair | (pair,Nothing) <- pairs `zip` maybes] - pretties = catMaybes maybes - (needed', maybes) = mapAccumL do_one needed pairs - (final_needed, more_pretties) = go_rec needed' reduced_pairs - - do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of - Nothing -> (needed, Nothing) - Just (pretty, needed') -> (needed', Just pretty) + maybes = map do_one pairs + emitted = [id | ((id,_), Just _) <- pairs `zip` maybes] + reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes] + (pretties, extras_s) = unzip (catMaybes maybes) + extras = unionVarSets extras_s + (more_pretties, more_emitted, more_extras) = go_rec extras reduced_pairs + + do_one (id,rhs) = ifaceId get_idinfo needed True id rhs \end{code} @@ -459,33 +485,40 @@ ifaceTyCon tycon keyword | isNewTyCon tycon = SLIT("newtype") | otherwise = SLIT("data") + tyvars = tyConTyVars tycon + ppr_con data_con | null field_labels - = hsep [ ppr name, + = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) + hsep [ ppr_ex ex_tyvars ex_theta, + ppr name, hsep (map ppr_arg_ty (strict_marks `zip` arg_tys)) ] | otherwise - = hsep [ ppr name, + = hsep [ ppr_ex ex_tyvars ex_theta, + ppr name, braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels)) ] where + (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con field_labels = dataConFieldLabels data_con - arg_tys = dataConRawArgTys data_con strict_marks = dataConStrictMarks data_con name = getName data_con + ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty + ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs) + <+> pprIfaceTheta ex_theta <+> ptext SLIT("=>") + ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty - ppr_strict_mark NotMarkedStrict = empty - ppr_strict_mark MarkedStrict = ptext SLIT("! ") - -- The extra space helps the lexical analyser that lexes - -- interface files; it doesn't make the rigid operator/identifier - -- distinction, so "!a" is a valid identifier so far as it is concerned + ppr_strict_mark NotMarkedStrict = empty + ppr_strict_mark (MarkedUnboxed _ _) = ptext SLIT("! ! ") + ppr_strict_mark MarkedStrict = ptext SLIT("! ") ppr_field (strict_mark, field_label) = hsep [ ppr (fieldLabelName field_label), - ptext SLIT("::"), + dcolon, ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label) ] @@ -512,20 +545,19 @@ ifaceClass clas = ASSERT( sel_tyvars == clas_tyvars) hsep [ppr (getOccName sel_id), if maybeToBool maybe_defm then equals else empty, - ptext SLIT("::"), + dcolon, ppr op_ty ] where (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) ppr_decl_context :: ThetaType -> SDoc -ppr_decl_context [] = empty -ppr_decl_context theta - = braces (hsep (punctuate comma (map (ppr_dict) theta))) - <> - ptext SLIT(" =>") - where - ppr_dict (clas,tys) = ppr clas <+> hsep (map pprParendType tys) +ppr_decl_context [] = empty +ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>") + +pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files +pprIfaceTheta [] = empty +pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta])) \end{code} %************************************************************************ @@ -540,31 +572,31 @@ When printing export lists, we print like this: AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C \begin{code} -upp_avail NotAvailable = empty -upp_avail (Avail name) = upp_occname (getOccName name) +upp_avail :: AvailInfo -> SDoc +upp_avail (Avail name) = pprOccName (getOccName name) upp_avail (AvailTC name []) = empty -upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns'] +upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns'] where bang | name `elem` ns = empty | otherwise = char '|' ns' = filter (/= name) ns +upp_export :: [Name] -> SDoc upp_export [] = empty -upp_export names = parens (hsep (map (upp_occname . getOccName) names)) +upp_export names = braces (hsep (map (pprOccName . getOccName) names)) -upp_fixity (occ, fixity) = hcat [ppr fixity, space, upp_occname occ, semi] +upp_fixity :: (Name, Fixity) -> SDoc +upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi] + -- Dummy version number! ppr_unqual_name :: NamedThing a => a -> SDoc -- Just its occurrence name -ppr_unqual_name name = upp_occname (getOccName name) - -upp_occname :: OccName -> SDoc -upp_occname occ = ptext (occNameString occ) +ppr_unqual_name name = pprOccName (getOccName name) \end{code} %************************************************************************ %* * -\subsection{Comparisons +\subsection{Comparisons} %* * %************************************************************************ @@ -579,7 +611,7 @@ lt_avail :: AvailInfo -> AvailInfo -> Bool a1 `lt_avail` a2 = availName a1 `lt_name` availName a2 lt_name :: Name -> Name -> Bool -n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2 +n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2 lt_lexical :: NamedThing a => a -> a -> Bool lt_lexical a1 a2 = getName a1 `lt_name` getName a2