X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FLoadIface.lhs;h=d4cd503ffef282b2c1c9b117732702ca0abf98dd;hp=51b540cc80d713f45a87202a844ade621dc06880;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=a985eb214dc777cccba85883cb24181fe188fe9c diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 51b540c..d4cd503 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" @@ -18,9 +20,12 @@ import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst ) import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), - IfaceConDecls(..), IfaceIdInfo(..) ) -import IfaceEnv ( newGlobalBinder ) -import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), + IfaceConDecls(..), IfaceFamInst(..), + IfaceIdInfo(..) ) +import IfaceEnv ( newGlobalBinder, lookupIfaceTc ) +import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..), + Deprecs(..), Dependencies(..), + emptyModIface, EpsStats(..), GenAvailInfo(..), addEpsInStats, ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv, HscEnv(..), lookupIfaceByModule, emptyPackageIfaceTable, @@ -28,9 +33,10 @@ import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), implicitTyThings ) -import BasicTypes ( Version, Fixity(..), FixityDirection(..), - isMarkedStrict ) +import BasicTypes ( Version, initialVersion, + Fixity(..), FixityDirection(..), isMarkedStrict ) import TcRnMonad +import Type ( TyThing(..) ) import PrelNames ( gHC_PRIM ) import PrelInfo ( ghcPrimExports ) @@ -42,18 +48,24 @@ import Name ( Name {-instance NamedThing-}, getOccName, import NameEnv import MkId ( seqId ) import Module -import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc, - mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc ) +import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, + mkClassDataConOcc, mkSuperDictSelOcc, + mkDataConWrapperOcc, mkDataConWorkerOcc, + mkNewTyCoOcc, mkInstTyCoOcc ) import SrcLoc ( importedSrcLoc ) import Maybes ( MaybeErr(..) ) import ErrUtils ( Message ) import Finder ( findImportedModule, findExactModule, - FindResult(..), cantFindError ) + 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 Maybe ( isJust ) +import DATA_IOREF ( writeIORef ) \end{code} @@ -81,14 +93,11 @@ loadSrcInterface doc mod want_boot = do Found _ mod -> do mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) case mb_iface of - Failed err -> failWithTc (elaborate err) + Failed err -> failWithTc err Succeeded iface -> return iface err -> let dflags = hsc_dflags hsc_env in - failWithTc (elaborate (cantFindError dflags mod err)) - where - elaborate err = hang (ptext SLIT("Failed to load interface for") <+> - quotes (ppr mod) <> colon) 4 err + failWithTc (cannotFindInterface dflags mod err) -- | Load interfaces for a collection of orphan modules. loadOrphanModules :: [Module] -> TcM () @@ -186,7 +195,6 @@ loadInterface doc_str mod from -- READ THE MODULE IN ; read_result <- findAndReadIface doc_str mod hi_boot_file - ; dflags <- getDOpts ; case read_result of { Failed err -> do { let fake_iface = emptyModIface mod @@ -199,7 +207,7 @@ loadInterface doc_str mod from ; returnM (Failed err) } ; -- Found and parsed! - Succeeded (iface, file_path) -- Sanity check: + Succeeded (iface, file_path) -- Sanity check: | ImportBySystem <- from, -- system-importing... modulePackageId (mi_module iface) == thisPackage dflags, -- a home-package module... @@ -263,6 +271,10 @@ badDepMsg mod -- each binder with the right package info in it -- All subsequent lookups, including crucially lookups during typechecking -- the declaration itself, will find the fully-glorious Name +-- +-- We handle ATs specially. They are not main declarations, but also not +-- implict things (in particular, adding them to `implicitTyThings' would mess +-- things up in the renaming/type checking of source programs). ----------------------------------------------------- addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv @@ -277,16 +289,20 @@ loadDecls ignore_prags ver_decls ; return (concat thingss) } -loadDecl :: Bool -- Don't load pragmas into the decl pool +loadDecl :: Bool -- Don't load pragmas into the decl pool -> Module -> (Version, IfaceDecl) - -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the - -- TyThings are forkM'd thunks + -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the + -- TyThings are forkM'd thunks loadDecl ignore_prags mod (_version, decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl main_name <- mk_new_bndr mod Nothing (ifName decl) - ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl) + ; parent_name <- case ifFamily decl of -- make family the parent + Just famTyCon -> lookupIfaceTc famTyCon + _ -> return main_name + ; implicit_names <- mapM (mk_new_bndr mod (Just parent_name)) + (ifaceDeclSubBndrs decl) -- Typecheck the thing, lazily -- NB. firstly, the laziness is there in case we never need the @@ -298,9 +314,12 @@ 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]) } + ; returnM $ (main_name, thing) : [(n, lookup n) | n <- implicit_names] + } -- We build a list from the *known* names, with (lookup n) thunks -- as the TyThings. That way we can extend the PTE without poking the -- thunks @@ -318,6 +337,11 @@ loadDecl ignore_prags mod (_version, decl) (importedSrcLoc (showSDoc (ppr (moduleName mod)))) -- ToDo: qualify with the package name if necessary + ifFamily (IfaceData { + ifFamInst = Just (IfaceFamInst {ifFamInstTyCon = famTyCon})}) + = Just famTyCon + ifFamily _ = Nothing + doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) discardDeclPrags :: IfaceDecl -> IfaceDecl @@ -336,34 +360,46 @@ 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 - -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs }) - = [tc_occ, dc_occ, dcww_occ] ++ - [op | IfaceClassOp op _ _ <- sigs] ++ +-- +-- If you change this, make sure you change HscTypes.implicitTyThings in sync + +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) + = co_occs ++ + [tc_occ, dc_occ, dcww_occ] ++ + [op | IfaceClassOp op _ _ <- sigs] ++ + [ifName at | at <- ats ] ++ [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] where n_ctxt = length sc_ctxt n_sigs = length sigs tc_occ = mkClassTyConOcc cls_occ dc_occ = mkClassDataConOcc cls_occ - dcww_occ | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker + co_occs | is_newtype = [mkNewTyCoOcc tc_occ] + | otherwise = [] + dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper is_newtype = n_sigs + n_ctxt == 1 -- Sigh -ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon}) +ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] -- Newtype -ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con_occ, - ifConFields = fields})}) - = fields ++ [con_occ, mkDataConWrapperOcc con_occ] - -- Wrapper, no worker; see MkId.mkDataConIds - -ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) - = nub (concatMap fld_occs cons) -- Eliminate duplicate fields +ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, + ifCons = IfNewTyCon ( + IfCon { ifConOcc = con_occ, + ifConFields = fields + }), + ifFamInst = famInst}) + = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ] + ++ famInstCo famInst tc_occ + +ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, + ifCons = IfDataTyCon cons, + ifFamInst = famInst}) + = nub (concatMap ifConFields cons) -- Eliminate duplicate fields ++ concatMap dc_occs cons + ++ famInstCo famInst tc_occ 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] @@ -373,10 +409,15 @@ ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) wrap_occ = mkDataConWrapperOcc con_occ work_occ = mkDataConWorkerOcc con_occ has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) + || not (null . ifConEqSpec $ con_decl) + || isJust famInst -- ToDo: may miss strictness in existential dicts -ifaceDeclSubBndrs _other = [] +ifaceDeclSubBndrs _other = [] +-- coercion for data/newtype family instances +famInstCo Nothing baseOcc = [] +famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc] \end{code} @@ -420,7 +461,8 @@ findAndReadIface doc_str mod hi_boot_file Failed err -> do { traceIf (ptext SLIT("...not found")) ; dflags <- getDOpts - ; returnM (Failed (cantFindError dflags (moduleName mod) err)) } ; + ; returnM (Failed (cannotFindInterface dflags + (moduleName mod) err)) } ; Succeeded file_path -> do @@ -541,6 +583,120 @@ 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 (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 + + 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} @@ -574,3 +730,4 @@ wrongIfaceModErr iface mod_name file_path ] where iface_file = doubleQuotes (text file_path) \end{code} +