X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMkIface.lhs;h=9ba3a2fca0f7ba664bd9291cf634476d74b704f4;hb=31285afea6a7b553380fd0a01e0a8ce0d7e50878;hp=87436d3079d462c00ae3d3863ef414878f100913;hpb=4435024f2be6d7c9f0ff796db6c5c9033e6403a4;p=ghc-hetmet.git diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 87436d3..9ba3a2f 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -1,12 +1,14 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % + \section[MkIface]{Print an interface for a module} \begin{code} module MkIface ( - mkModDetails, mkModDetailsFromIface, completeIface, - writeIface, pprIface, pprUsage + mkFinalIface, + pprModDetails, pprIface, pprUsage, + ifaceTyCls, ) where #include "HsVersions.h" @@ -14,176 +16,145 @@ module MkIface ( import HsSyn import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr ) import HsTypes ( toHsTyVars ) +import TysPrim ( alphaTyVars ) import BasicTypes ( Fixity(..), NewOrData(..), Version, initialVersion, bumpVersion, ) import RnMonad import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) -import TcHsSyn ( TypecheckedRuleDecl ) import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..), + ModuleLocation(..), GhciMode(..), IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - TyThing(..), DFunId, TypeEnv, Avails, + TyThing(..), DFunId, Avails, WhatsImported(..), GenAvailInfo(..), ImportVersion, AvailInfo, Deprecations(..), - extendTypeEnvList, lookupVersion, + lookupVersion, ) import CmdLineOpts -import Id ( idType, idInfo, isImplicitId, isDictFunId, - idSpecialisation, isLocalId, idName, hasNoBinding +import Id ( idType, idInfo, isImplicitId, idCgInfo, + isLocalId, idName, ) -import Var ( isId ) -import VarSet -import DataCon ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks ) +import DataCon ( dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks ) import IdInfo -- Lots -import CoreSyn ( CoreBind, CoreRule(..), IdCoreRule, - isBuiltinRule, rulesRules, - bindersOf, bindersOfBinds - ) -import CoreFVs ( ruleSomeLhsFreeVars ) +import CoreSyn ( CoreRule(..) ) +import CoreFVs ( ruleLhsFreeNames ) import CoreUnfold ( neverUnfold, unfoldingTemplate ) -import Name ( getName, nameModule, Name, NamedThing(..) ) -import Name -- Env +import PprCore ( pprIdCoreRule ) +import Name ( getName, nameModule, toRdrName, isGlobalName, + nameIsLocalOrFrom, Name, NamedThing(..) ) +import NameEnv +import NameSet import OccName ( pprOccName ) -import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds, - tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon +import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, + isAlgTyCon, tyConGenIds, tyConTheta, tyConTyVars, + tyConDataCons, tyConFamilySize, isPrimTyCon, + isClassTyCon, isForeignTyCon, tyConArity ) import Class ( classExtraBigSig, classTyCon, DefMeth(..) ) import FieldLabel ( fieldLabelType ) -import Type ( splitSigmaTy, tidyTopType, deNoteType ) +import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead ) import SrcLoc ( noSrcLoc ) import Outputable import Module ( ModuleName ) -import Maybes ( orElse ) +import Util ( sortLt ) +import ErrUtils ( dumpIfSet_dyn ) +import Monad ( when ) import IO ( IOMode(..), openFile, hClose ) \end{code} %************************************************************************ %* * -\subsection{Write a new interface file} +\subsection{Completing an interface} %* * %************************************************************************ \begin{code} -mkModDetails :: TypeEnv -- From typechecker - -> [CoreBind] -- Final bindings - -- they have authoritative arity info - -> [IdCoreRule] -- Tidy orphan rules - -> ModDetails -mkModDetails type_env tidy_binds orphan_rules - = ModDetails { md_types = new_type_env, - md_rules = rule_dcls, - md_insts = filter isDictFunId final_ids } - where - -- The competed type environment is gotten from - -- a) keeping the types and classes - -- b) removing all Ids, - -- c) adding Ids with correct IdInfo, including unfoldings, - -- gotten from the bindings - -- From (c) we keep only those Ids with Global names; - -- the CoreTidy pass makes sure these are all and only - -- the externally-accessible ones - -- This truncates the type environment to include only the - -- exported Ids and things needed from them, which saves space - -- - -- However, we do keep things like constructors, which should not appear - -- in interface files, because they are needed by importing modules when - -- using the compilation manager - new_type_env = extendTypeEnvList (filterNameEnv keep_it type_env) - (map AnId final_ids) - - -- We keep constructor workers, because they won't appear - -- in the bindings from which final_ids are derived! - keep_it (AnId id) = hasNoBinding id - keep_it other = True - - final_ids = [id | bind <- tidy_binds - , id <- bindersOf bind - , isGlobalName (idName id)] - - -- The complete rules are gotten by combining - -- a) the orphan rules - -- b) rules embedded in the top-level Ids - rule_dcls | opt_OmitInterfacePragmas = [] - | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids) - --- This version is used when we are re-linking a module --- so we've only run the type checker on its previous interface -mkModDetailsFromIface :: TypeEnv - -> [TypecheckedRuleDecl] - -> ModDetails -mkModDetailsFromIface type_env rules - = ModDetails { md_types = type_env, - md_rules = rule_dcls, - md_insts = dfun_ids } + + + +mkFinalIface :: GhciMode + -> DynFlags + -> ModuleLocation + -> Maybe ModIface -- The old interface, if we have it + -> ModIface -- The new one, minus the decls and versions + -> ModDetails -- The ModDetails for this module + -> IO ModIface -- The new one, complete with decls and versions +-- mkFinalIface +-- a) completes the interface +-- b) writes it out to a file if necessary + +mkFinalIface ghci_mode dflags location + maybe_old_iface new_iface new_details + = do { + -- Add the new declarations, and the is-orphan flag + let iface_w_decls = new_iface { mi_decls = new_decls, + mi_orphan = orphan_mod } + + -- Add version information + ; let (final_iface, maybe_diffs) = addVersionInfo maybe_old_iface iface_w_decls + + -- Write the interface file, if necessary + ; when (must_write_hi_file maybe_diffs) + (writeIface hi_file_path final_iface) + + -- Debug printing + ; write_diffs dflags final_iface maybe_diffs + + ; return final_iface } + where - dfun_ids = [dfun_id | AnId dfun_id <- nameEnvElts type_env, isDictFunId dfun_id] - rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules] - -- All the rules from an interface are of the IfaceRuleOut form + must_write_hi_file Nothing = False + must_write_hi_file (Just diffs) = ghci_mode /= Interactive + -- We must write a new .hi file if there are some changes + -- and we're not in interactive mode + -- maybe_diffs = 'Nothing' means that even the usages havn't changed, + -- so there's no need to write a new interface file. But even if + -- the usages have changed, the module version may not have. + + hi_file_path = ml_hi_file location + new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls + inst_dcls = map ifaceInstance (md_insts new_details) + ty_cls_dcls = foldNameEnv ifaceTyCls_acc [] (md_types new_details) + rule_dcls = map ifaceRule (md_rules new_details) + orphan_mod = isOrphanModule (mi_module new_iface) new_details + +write_diffs dflags new_iface Nothing + = do when (dopt Opt_D_dump_hi_diffs dflags) (printDump (text "INTERFACE UNCHANGED")) + dumpIfSet_dyn dflags Opt_D_dump_hi "UNCHANGED FINAL INTERFACE" (pprIface new_iface) + +write_diffs dflags new_iface (Just sdoc_diffs) + = do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED" sdoc_diffs + dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE" (pprIface new_iface) \end{code} \begin{code} -getRules :: [IdCoreRule] -- Orphan rules - -> [CoreBind] -- Bindings, with rules in the top-level Ids - -> IdSet -- Ids that are exported, so we need their rules - -> [IdCoreRule] -getRules orphan_rules binds emitted - = orphan_rules ++ local_rules +isOrphanModule this_mod (ModDetails {md_insts = insts, md_rules = rules}) + = any orphan_inst insts || any orphan_rule rules where - local_rules = [ (fn, rule) - | fn <- bindersOfBinds binds, - fn `elemVarSet` emitted, - rule <- rulesRules (idSpecialisation fn), - not (isBuiltinRule rule), - -- We can't print builtin rules in interface files - -- Since they are built in, an importing module - -- will have access to them anyway - - -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules - -- from coming out, and to make it work properly we need to add ???? - -- (put it back in for now) - all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) - -- Spit out a rule only if all its lhs free vars are emitted - -- This is a good reason not to do it when we emit the Id itself - ] - -interestingId id = isId id && isLocalId id + orphan_inst dfun_id = no_locals (namesOfDFunHead (idType dfun_id)) + orphan_rule rule = no_locals (ruleLhsFreeNames rule) + no_locals names = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names) \end{code} - -%************************************************************************ -%* * -\subsection{Completing an interface} -%* * -%************************************************************************ +Implicit Ids and class tycons aren't included in interface files, so +we miss them out of the accumulating parameter here. \begin{code} -completeIface :: Maybe ModIface -- The old interface, if we have it - -> ModIface -- The new one, minus the decls and versions - -> ModDetails -- The ModDetails for this module - -> (ModIface, Maybe SDoc) -- The new one, complete with decls and versions - -- The SDoc is a debug document giving differences - -- Nothing => no change - - -- NB: 'Nothing' means that even the usages havn't changed, so there's no - -- need to write a new interface file. But even if the usages have - -- changed, the module version may not have. -completeIface maybe_old_iface new_iface mod_details - = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls }) - where - new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls - inst_dcls = map ifaceInstance (md_insts mod_details) - ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details) - rule_dcls = map ifaceRule (md_rules mod_details) +ifaceTyCls_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] +ifaceTyCls_acc (AnId id) so_far | isImplicitId id = so_far +ifaceTyCls_acc (ATyCon id) so_far | isClassTyCon id = so_far +ifaceTyCls_acc other so_far = ifaceTyCls other : so_far \end{code} +Convert *any* TyThing into a RenamedTyClDecl. Used both for +generating interface files and for the ':info' command in GHCi. \begin{code} -ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] -ifaceTyCls (AClass clas) so_far - = cls_decl : so_far +ifaceTyCls :: TyThing -> RenamedTyClDecl +ifaceTyCls (AClass clas) = cls_decl where cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta, tcdName = getName clas, @@ -204,15 +175,13 @@ ifaceTyCls (AClass clas) so_far = ASSERT(sel_tyvars == clas_tyvars) ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc where - (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) + (sel_tyvars, _, op_ty) = tcSplitSigmaTy (idType sel_id) def_meth' = case def_meth of NoDefMeth -> NoDefMeth GenDefMeth -> GenDefMeth DefMeth id -> DefMeth (getName id) -ifaceTyCls (ATyCon tycon) so_far - | isClassTyCon tycon = so_far - | otherwise = ty_decl : so_far +ifaceTyCls (ATyCon tycon) = ty_decl where ty_decl | isSynTyCon tycon = TySynonym { tcdName = getName tycon, @@ -231,6 +200,23 @@ ifaceTyCls (ATyCon tycon) so_far tcdSysNames = map getName (tyConGenIds tycon), tcdLoc = noSrcLoc } + | isForeignTyCon tycon + = ForeignType { tcdName = getName tycon, + tcdFoType = DNType, -- The only case at present + tcdLoc = noSrcLoc } + + | isPrimTyCon tycon + -- needed in GHCi for ':info Int#', for example + = TyData { tcdND = DataType, + tcdCtxt = [], + tcdName = getName tycon, + tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars), + tcdCons = [], + tcdNCons = 0, + tcdDerivs = Nothing, + tcdSysNames = [], + tcdLoc = noSrcLoc } + | otherwise = pprPanic "ifaceTyCls" (ppr tycon) tyvars = tyConTyVars tycon @@ -246,24 +232,20 @@ ifaceTyCls (ATyCon tycon) so_far where (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con field_labels = dataConFieldLabels data_con - strict_marks = dataConStrictMarks data_con + strict_marks = drop (length ex_theta) (dataConStrictMarks data_con) + -- The 'drop' is because dataConStrictMarks + -- includes the existential dictionaries details | null field_labels = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) - VanillaCon (zipWith mk_bang_ty strict_marks arg_tys) + VanillaCon (zipWith BangType strict_marks (map toHsType arg_tys)) | otherwise = RecCon (zipWith mk_field strict_marks field_labels) - mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty) - mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty) - mk_bang_ty MarkedStrict ty = Banged (toHsType ty) - mk_field strict_mark field_label - = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label)) + = ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label))) -ifaceTyCls (AnId id) so_far - | isImplicitId id = so_far - | otherwise = iface_sig : so_far +ifaceTyCls (AnId id) = iface_sig where iface_sig = IfaceSig { tcdName = getName id, tcdType = toHsType id_type, @@ -272,37 +254,35 @@ ifaceTyCls (AnId id) so_far id_type = idType id id_info = idInfo id + cg_info = idCgInfo id + arity_info = cgArity cg_info + caf_info = cgCafInfo cg_info hs_idinfo | opt_OmitInterfacePragmas = [] - | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++ + | otherwise = arity_hsinfo ++ caf_hsinfo ++ strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo ------------ Arity -------------- - arity_hsinfo = case arityInfo id_info of - a@(ArityExactly n) -> [HsArity a] - other -> [] + arity_hsinfo | arity_info == 0 = [] + | otherwise = [HsArity arity_info] ------------ Caf Info -------------- - caf_hsinfo = case cafInfo id_info of + caf_hsinfo = case caf_info of NoCafRefs -> [HsNoCafRefs] otherwise -> [] - ------------ CPR Info -------------- - cpr_hsinfo = case cprInfo id_info of - ReturnsCPR -> [HsCprInfo] - NoCPRInfo -> [] - ------------ Strictness -------------- - strict_hsinfo = case strictnessInfo id_info of - NoStrictnessInfo -> [] - info -> [HsStrictness info] + strict_hsinfo = case newStrictnessInfo id_info of + Nothing -> [] + Just sig -> [HsStrictness sig] ------------ Worker -------------- work_info = workerInfo id_info has_worker = case work_info of { HasWorker _ _ -> True; other -> False } wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> [HsWorker (getName work_id)] - NoWorker -> [] + HasWorker work_id wrap_arity -> + [HsWorker (getName work_id) wrap_arity] + NoWorker -> [] ------------ Unfolding -------------- -- The unfolding is redundant if there is a worker @@ -330,7 +310,7 @@ ifaceInstance dfun_id -- and this instance decl wouldn't get imported into a module -- that mentioned T but not Tibble. -ifaceRule (id, BuiltinRule _) +ifaceRule (id, BuiltinRule _ _) = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) ifaceRule (id, Rule name bndrs args rhs) @@ -456,6 +436,53 @@ diffDecls (VersionInfo { vers_module = old_mod_vers, vers_decls = old_decls_vers %************************************************************************ %* * +\subsection{Writing ModDetails} +%* * +%************************************************************************ + +\begin{code} +pprModDetails :: ModDetails -> SDoc +pprModDetails (ModDetails { md_types = type_env, md_insts = dfun_ids, md_rules = rules }) + = vcat [ dump_types dfun_ids type_env + , dump_insts dfun_ids + , dump_rules rules] + +dump_types dfun_ids type_env + = text "TYPE SIGNATURES" $$ nest 4 (dump_sigs ids) + where + ids = [id | AnId id <- nameEnvElts type_env, want_sig id] + want_sig id | opt_PprStyle_Debug = True + | otherwise = isLocalId id && + isGlobalName (idName id) && + not (id `elem` dfun_ids) + -- isLocalId ignores data constructors, records selectors etc + -- The isGlobalName ignores local dictionary and method bindings + -- that the type checker has invented. User-defined things have + -- Global names. + +dump_insts [] = empty +dump_insts dfun_ids = text "INSTANCES" $$ nest 4 (dump_sigs dfun_ids) + +dump_sigs ids + -- Print type signatures + -- Convert to HsType so that we get source-language style printing + -- And sort by RdrName + = vcat $ map ppr_sig $ sortLt lt_sig $ + [ (toRdrName id, toHsType (idType id)) + | id <- ids ] + where + lt_sig (n1,_) (n2,_) = n1 < n2 + ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t + +dump_rules [] = empty +dump_rules rs = vcat [ptext SLIT("{-# RULES"), + nest 4 (vcat (map pprIdCoreRule rs)), + ptext SLIT("#-}")] +\end{code} + + +%************************************************************************ +%* * \subsection{Writing an interface file} %* * %************************************************************************ @@ -576,14 +603,14 @@ pprRulesAndDeprecs rules deprecs pp_rules [] = empty pp_rules rules = ptext SLIT("__R") <+> vcat (map ppr rules) - ppr_deprecs NoDeprecs = empty - ppr_deprecs deprecs = ptext SLIT("__D") <+> guts + pp_deprecs NoDeprecs = empty + pp_deprecs deprecs = ptext SLIT("__D") <+> guts where guts = case deprecs of DeprecAll txt -> doubleQuotes (ptext txt) - DeprecSome env -> pp_deprecs env + DeprecSome env -> ppr_deprec_env env -pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env))) - where - pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ptext txt) +ppr_deprec_env env = vcat (punctuate semi (map pp_deprec (nameEnvElts env))) + where + pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ptext txt) \end{code}