From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 16:38:57 +0000 (+0000) Subject: Massive patch for the first months work adding System FC to GHC #20 X-Git-Tag: After_FC_branch_merge~96 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=1e37b7f52ea9ac1965fd11edffbfca61b6fa0965 Massive patch for the first months work adding System FC to GHC #20 Fri Aug 4 17:43:25 EDT 2006 Manuel M T Chakravarty * Massive patch for the first months work adding System FC to GHC #20 Broken up massive patch -=chak Original log message: This is (sadly) all done in one patch to avoid Darcs bugs. It's not complete work... more FC stuff to come. A compiler using just this patch will fail dismally. --- diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 3faf00c..f76fa78 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -1,4 +1,4 @@ -% + % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section{Dealing with interface files} @@ -9,7 +9,9 @@ module LoadIface ( loadSrcInterface, loadSysInterface, loadOrphanModules, findAndReadIface, readIface, -- Used when reading the module's old interface loadDecls, ifaceStats, discardDeclPrags, - initExternalPackageState + initExternalPackageState, + + pprModIface, showIface -- Print the iface in Foo.hi ) where #include "HsVersions.h" @@ -20,7 +22,9 @@ import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceIdInfo(..) ) import IfaceEnv ( newGlobalBinder ) -import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), +import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..), + Deprecs(..), Dependencies(..), + emptyModIface, EpsStats(..), GenAvailInfo(..), addEpsInStats, ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv, HscEnv(..), lookupIfaceByModule, emptyPackageIfaceTable, @@ -28,8 +32,8 @@ import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), implicitTyThings ) -import BasicTypes ( Version, Fixity(..), FixityDirection(..), - isMarkedStrict ) +import BasicTypes ( Version, initialVersion, + Fixity(..), FixityDirection(..), isMarkedStrict ) import TcRnMonad import PrelNames ( gHC_PRIM ) @@ -43,18 +47,22 @@ import NameEnv import MkId ( seqId ) import Module import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, - mkClassDataConOcc, mkSuperDictSelOcc, - mkDataConWrapperOcc, mkDataConWorkerOcc ) + mkClassDataConOcc, mkSuperDictSelOcc, + mkDataConWrapperOcc, mkDataConWorkerOcc, + mkNewTyCoOcc ) import SrcLoc ( importedSrcLoc ) import Maybes ( MaybeErr(..) ) import ErrUtils ( Message ) import Finder ( findImportedModule, findExactModule, FindResult(..), cannotFindInterface ) import UniqFM +import StaticFlags ( opt_HiVersion ) import Outputable -import BinIface ( readBinIface ) +import BinIface ( readBinIface, v_IgnoreHiWay ) +import Binary ( getBinFileWithDict ) import Panic ( ghcError, tryMost, showException, GhcException(..) ) import List ( nub ) +import DATA_IOREF ( writeIORef ) \end{code} @@ -296,7 +304,7 @@ loadDecl ignore_prags mod (_version, decl) ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] lookup n = case lookupOccEnv mini_env (getOccName n) of Just thing -> thing - Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n) + Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (stripped_decl) ) ; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) } -- We build a list from the *known* names, with (lookup n) thunks @@ -334,6 +342,8 @@ ifaceDeclSubBndrs :: IfaceDecl -> [OccName] -- *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon +-- +-- If you change this, make sure you change HscTypes.implicitTyThings in sync ifaceDeclSubBndrs IfaceClass { ifCtxt = sc_ctxt, ifName = cls_occ, @@ -356,18 +366,17 @@ ifaceDeclSubBndrs IfaceClass { ifCtxt = sc_ctxt, ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] -- Newtype -ifaceDeclSubBndrs IfaceData {ifCons = IfNewTyCon (IfVanillaCon { - ifConOcc = con_occ, - ifConFields = fields})} - = fields ++ [con_occ, mkDataConWrapperOcc con_occ] +ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, + ifCons = IfNewTyCon ( + IfCon { ifConOcc = con_occ, + ifConFields = fields})}) + = fields ++ [con_occ, mkDataConWrapperOcc con_occ, mkNewTyCoOcc tc_occ] -- Wrapper, no worker; see MkId.mkDataConIds ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) - = nub (concatMap fld_occs cons) -- Eliminate duplicate fields + = nub (concatMap ifConFields cons) -- Eliminate duplicate fields ++ concatMap dc_occs cons where - fld_occs (IfVanillaCon { ifConFields = fields }) = fields - fld_occs (IfGadtCon {}) = [] dc_occs con_decl | has_wrapper = [con_occ, work_occ, wrap_occ] | otherwise = [con_occ, work_occ] @@ -379,8 +388,7 @@ ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) -- ToDo: may miss strictness in existential dicts -ifaceDeclSubBndrs _other = [] - +ifaceDeclSubBndrs _other = [] \end{code} @@ -546,6 +554,123 @@ ifaceStats eps \end{code} +%************************************************************************ +%* * + Printing interfaces +%* * +%************************************************************************ + +\begin{code} +showIface :: FilePath -> IO () +-- Read binary interface, and print it out +showIface filename = do + -- skip the version check; we don't want to worry about profiled vs. + -- non-profiled interfaces, for example. + writeIORef v_IgnoreHiWay True + iface <- Binary.getBinFileWithDict filename + printDump (pprModIface iface) + where +\end{code} + + +\begin{code} +pprModIface :: ModIface -> SDoc +-- Show a ModIface +pprModIface iface + = vcat [ ptext SLIT("interface") + <+> ppr_package (mi_package iface) + <+> ppr (mi_module iface) <+> pp_boot + <+> ppr (mi_mod_vers iface) <+> pp_sub_vers + <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty) + <+> int opt_HiVersion + <+> ptext SLIT("where") + , vcat (map pprExport (mi_exports iface)) + , pprDeps (mi_deps iface) + , vcat (map pprUsage (mi_usages iface)) + , pprFixities (mi_fixities iface) + , vcat (map pprIfaceDecl (mi_decls iface)) + , vcat (map ppr (mi_insts iface)) + , vcat (map ppr (mi_rules iface)) + , pprDeprecs (mi_deprecs iface) + ] + where + pp_boot | mi_boot iface = ptext SLIT("[boot]") + | otherwise = empty + ppr_package HomePackage = empty + ppr_package (ExtPackage id) = doubleQuotes (ppr id) + + exp_vers = mi_exp_vers iface + rule_vers = mi_rule_vers iface + + pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty + | otherwise = brackets (ppr exp_vers <+> ppr rule_vers) +\end{code} + +When printing export lists, we print like this: + Avail f f + AvailTC C [C, x, y] C(x,y) + AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C + +\begin{code} +pprExport :: IfaceExport -> SDoc +pprExport (mod, items) + = hsep [ ptext SLIT("export"), ppr mod, hsep (map pp_avail items) ] + where + pp_avail :: GenAvailInfo OccName -> SDoc + pp_avail (Avail occ) = ppr occ + pp_avail (AvailTC _ []) = empty + pp_avail (AvailTC n (n':ns)) + | n==n' = ppr n <> pp_export ns + | otherwise = ppr n <> char '|' <> pp_export (n':ns) + + pp_export [] = empty + pp_export names = braces (hsep (map ppr names)) + +pprUsage :: Usage -> SDoc +pprUsage usage + = hsep [ptext SLIT("import"), ppr (usg_name usage), + int (usg_mod usage), + pp_export_version (usg_exports usage), + int (usg_rules usage), + pp_versions (usg_entities usage) ] + where + pp_versions nvs = hsep [ ppr n <+> int v | (n,v) <- nvs ] + pp_export_version Nothing = empty + pp_export_version (Just v) = int v + +pprDeps :: Dependencies -> SDoc +pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs}) + = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods), + ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), + ptext SLIT("orphans:") <+> fsep (map ppr orphs) + ] + where + ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot + ppr_boot True = text "[boot]" + ppr_boot False = empty + +pprIfaceDecl :: (Version, IfaceDecl) -> SDoc +pprIfaceDecl (ver, decl) + = ppr_vers ver <+> ppr decl + where + -- Print the version for the decl + ppr_vers v | v == initialVersion = empty + | otherwise = int v + +pprFixities :: [(OccName, Fixity)] -> SDoc +pprFixities [] = empty +pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes + where + pprFix (occ,fix) = ppr fix <+> ppr occ + +pprDeprecs NoDeprecs = empty +pprDeprecs (DeprecAll txt) = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt) +pprDeprecs (DeprecSome prs) = ptext SLIT("Deprecate") <+> vcat (map pprDeprec prs) + where + pprDeprec (name, txt) = ppr name <+> doubleQuotes (ftext txt) +\end{code} + + %********************************************************* %* * \subsection{Errors} @@ -579,3 +704,4 @@ wrongIfaceModErr iface mod_name file_path ] where iface_file = doubleQuotes (text file_path) \end{code} +