From 0075a4cd7eb75a28b4978255e696a9a583172355 Mon Sep 17 00:00:00 2001 From: sewardj Date: Mon, 30 Oct 2000 13:46:24 +0000 Subject: [PATCH] [project @ 2000-10-30 13:46:24 by sewardj] Only pass a ModuleLocation into hscMain, not a ModSummary, so as to facilitate Main.main not necessarily being in Main.hs. --- ghc/compiler/ghci/CmSummarise.lhs | 2 +- ghc/compiler/hsSyn/HsImpExp.lhs | 2 ++ ghc/compiler/hsSyn/HsSyn.lhs | 6 +++- ghc/compiler/main/DriverPipeline.hs | 25 +++++++-------- ghc/compiler/main/Finder.lhs | 12 +++---- ghc/compiler/main/HscMain.lhs | 60 +++++++++++++++-------------------- ghc/compiler/main/HscTypes.lhs | 6 ++-- ghc/compiler/rename/Rename.lhs | 33 +++++++++---------- ghc/compiler/rename/RnHiFiles.lhs | 33 +++++++++---------- ghc/compiler/rename/RnIfaces.lhs | 8 ++--- 10 files changed, 91 insertions(+), 96 deletions(-) diff --git a/ghc/compiler/ghci/CmSummarise.lhs b/ghc/compiler/ghci/CmSummarise.lhs index 4d03acd..7ad604d 100644 --- a/ghc/compiler/ghci/CmSummarise.lhs +++ b/ghc/compiler/ghci/CmSummarise.lhs @@ -81,7 +81,7 @@ summarise :: Module -> ModuleLocation -> IO ModSummary summarise mod location = if isModuleInThisPackage mod then do - let source_fn = hs_file location + let source_fn = hs_preprocd_file location -- ToDo: -- ppsource_fn <- preprocess source_fn modsrc <- readFile source_fn diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index 8f51b6d..b47abf4 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -48,6 +48,8 @@ instance (Outputable name) => Outputable (ImportDecl name) where = parens (interpp'SP spec) pp_spec (Just (True, spec)) = ptext SLIT("hiding") <+> parens (interpp'SP spec) + +ideclName (ImportDecl mod_nm _ _ _ _ _) = mod_nm \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index a23a7ac..4a3c1f6 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -24,7 +24,8 @@ module HsSyn ( module HsTypes, Fixity, NewOrData, - collectTopBinders, collectMonoBinders, collectLocatedMonoBinders + collectTopBinders, collectMonoBinders, collectLocatedMonoBinders, + hsModuleName, hsModuleImports ) where #include "HsVersions.h" @@ -91,6 +92,9 @@ instance (Outputable name, Outputable pat) pp_nonnull [] = empty pp_nonnull xs = vcat (map ppr xs) + +hsModuleName (HsModule mod_name _ _ _ _ _ _) = mod_name +hsModuleImports (HsModule mod_name vers exports imports decls deprec src_loc) = imports \end{code} diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 8f1cb2b..cbf1fce 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.11 2000/10/30 11:18:14 sewardj Exp $ +-- $Id: DriverPipeline.hs,v 1.12 2000/10/30 13:46:24 sewardj Exp $ -- -- GHC Driver -- @@ -37,7 +37,6 @@ import Module import CmdLineOpts import Config import Util -import MkIface ( pprIface ) import Directory import System @@ -433,14 +432,12 @@ run_phase Hsc basename suff input_fn output_fn then return "-fsource-unchanged" else return "" - -- build a bogus ModSummary to pass to hscMain. - let summary = ModSummary { - ms_mod = (mkModuleInThisPackage . mkModuleName) - {-ToDo: modname!!-}basename, - ms_location = error "no loc", - ms_ppsource = Just (input_fn, error "no fingerprint"), - ms_imports = error "no imports" - } + -- build a bogus ModuleLocation to pass to hscMain. + let location = ModuleLocation { + hs_preprocd_file = input_fn, + hi_file = hifile, + obj_file = o_file + } -- get the DynFlags dyn_flags <- readIORef v_DynFlags @@ -449,7 +446,7 @@ run_phase Hsc basename suff input_fn output_fn pcs <- initPersistentCompilerState result <- hscMain dyn_flags{ hscOutName = output_fn } (source_unchanged == "-fsource-unchanged") - summary + location Nothing -- no iface emptyModuleEnv -- HomeSymbolTable emptyModuleEnv -- HomeIfaceTable @@ -733,7 +730,7 @@ compile summary old_iface hst hit pcs = do let input_fn = case ms_ppsource summary of Just (ppsource, fingerprint) -> ppsource - Nothing -> hs_file (ms_location summary) + Nothing -> hs_preprocd_file (ms_location summary) when verb (hPutStrLn stderr ("compile: input file " ++ input_fn)) @@ -751,7 +748,7 @@ compile summary old_iface hst hit pcs = do -- run the compiler hsc_result <- hscMain dyn_flags{ hscOutName = output_fn } (panic "compile:source_unchanged") - summary old_iface hst hit pcs + (ms_location summary) old_iface hst hit pcs case hsc_result of { HscFail pcs -> return (CompErrs pcs); @@ -764,7 +761,7 @@ compile summary old_iface hst hit pcs = do Nothing -> return (CompOK details Nothing pcs); Just iface -> do - let (basename, _) = splitFilename (hs_file (ms_location summary)) + let (basename, _) = splitFilename (hs_preprocd_file (ms_location summary)) maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c let stub_unlinked = case maybe_stub_o of Nothing -> [] diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 673bdb9..d256c86 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -123,9 +123,9 @@ mkHomeModuleLocn mod_name basename source_fn = do return (Just (mkHomeModule mod_name, ModuleLocation{ - hs_file = source_fn, - hi_file = hifile, - obj_file = o_file + hs_preprocd_file = source_fn, + hi_file = hifile, + obj_file = o_file } )) @@ -165,9 +165,9 @@ maybePackageModule mod_name = do Just (pkg_name,path) -> return (Just (mkModule mod_name pkg_name, ModuleLocation{ - hs_file = "error:_package_module;_no_source", - hi_file = path ++ '/':hi, - obj_file = "error:_package_module;_no_object" + hs_preprocd_file = "error:_package_module;_no_source", + hi_file = path ++ '/':hi, + obj_file = "error:_package_module;_no_object" } )) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 45eaed4..49e5297 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -19,7 +19,6 @@ import Lex ( PState(..), ParseResult(..) ) import SrcLoc ( mkSrcLoc ) import Rename ( renameModule, checkOldIface, closeIfaceDecls ) - import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThings ) import PrelNames ( knownKeyNames ) @@ -39,7 +38,7 @@ import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CodeOutput ( codeOutput ) -import Module ( ModuleName, moduleName, emptyModuleEnv ) +import Module ( ModuleName, moduleName, emptyModuleEnv, mkModuleInThisPackage ) import CmdLineOpts import ErrUtils ( dumpIfSet_dyn ) import UniqSupply ( mkSplitUniqSupply ) @@ -49,12 +48,11 @@ import Outputable import StgInterp ( stgToInterpSyn ) import HscStats ( ppSourceStats ) import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), - PersistentRenamerState(..), + PersistentRenamerState(..), ModuleLocation(..), HomeSymbolTable, PackageSymbolTable, OrigNameEnv(..), PackageRuleBase, HomeIfaceTable, extendTypeEnv, groupTyThings, typeEnvClasses, typeEnvTyCons, emptyIfaceTable ) -import CmSummarise ( ModSummary(..), ms_get_imports, mimp_name ) import InterpSyn ( UnlinkedIBind ) import StgInterp ( ItblEnv ) import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) @@ -86,22 +84,19 @@ data HscResult hscMain :: DynFlags - -> Bool -- source unchanged? - -> ModSummary -- summary, including source filename - -> Maybe ModIface -- old interface, if available + -> Bool -- source unchanged? + -> ModuleLocation -- location info + -> Maybe ModIface -- old interface, if available -> HomeSymbolTable -- for home module ModDetails -> HomeIfaceTable -> PersistentCompilerState -- IN: persistent compiler state -> IO HscResult -hscMain dflags source_unchanged summary maybe_old_iface hst hit pcs +hscMain dflags source_unchanged location maybe_old_iface hst hit pcs = do { - -- ????? source_unchanged :: Bool -- extracted from summary? - --let source_unchanged = trace "WARNING: source_unchanged?!" False - --; putStrLn "checking old iface ..."; (pcs_ch, check_errs, (recomp_reqd, maybe_checked_iface)) - <- checkOldIface dflags hit hst pcs (ms_mod summary) + <- checkOldIface dflags hit hst pcs (hi_file location) source_unchanged maybe_old_iface; if check_errs then return (HscFail pcs_ch) @@ -112,17 +107,18 @@ hscMain dflags source_unchanged summary maybe_old_iface hst hit pcs | otherwise = hscNoRecomp ; putStrLn "doing what_next ..."; - what_next dflags summary maybe_checked_iface + what_next dflags location maybe_checked_iface hst hit pcs_ch }} -hscNoRecomp dflags summary maybe_checked_iface hst hit pcs_ch +hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch = do { -- we definitely expect to have the old interface available let old_iface = case maybe_checked_iface of Just old_if -> old_if Nothing -> panic "hscNoRecomp:old_iface" + this_mod = mi_module old_iface ; -- CLOSURE (pcs_cl, closure_errs, cl_hs_decls) @@ -133,15 +129,15 @@ hscNoRecomp dflags summary maybe_checked_iface hst hit pcs_ch -- TYPECHECK maybe_tc_result - <- typecheckModule dflags (ms_mod summary) pcs_cl hst hit cl_hs_decls; + <- typecheckModule dflags this_mod pcs_cl hst hit cl_hs_decls; case maybe_tc_result of { Nothing -> return (HscFail pcs_cl); Just tc_result -> do { - let pcs_tc = tc_pcs tc_result - env_tc = tc_env tc_result - local_insts = tc_insts tc_result - local_rules = tc_rules tc_result + let pcs_tc = tc_pcs tc_result + env_tc = tc_env tc_result + local_insts = tc_insts tc_result + local_rules = tc_rules tc_result ; -- create a new details from the closed, typechecked, old iface let new_details = mkModDetailsFromIface env_tc local_insts local_rules @@ -154,19 +150,21 @@ hscNoRecomp dflags summary maybe_checked_iface hst hit pcs_ch }}}} -hscRecomp dflags summary maybe_checked_iface hst hit pcs_ch +hscRecomp dflags location maybe_checked_iface hst hit pcs_ch = do { -- what target are we shooting for? let toInterp = dopt_HscLang dflags == HscInterpreted - this_mod = ms_mod summary ; +-- putStrLn ("toInterp = " ++ show toInterp); -- PARSE - maybe_parsed <- myParseModule dflags summary; + maybe_parsed <- myParseModule dflags (hs_preprocd_file location); case maybe_parsed of { Nothing -> return (HscFail pcs_ch); Just rdr_module -> do { -- RENAME + let this_mod = mkModuleInThisPackage (hsModuleName rdr_module) + ; show_pass dflags "Renamer"; (pcs_rn, maybe_rn_result) <- renameModule dflags hit hst pcs_ch this_mod rdr_module; @@ -212,7 +210,8 @@ hscRecomp dflags summary maybe_checked_iface hst hit pcs_ch ; -- do the rest of code generation/emission (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds) - <- restOfCodeGeneration dflags toInterp summary + <- restOfCodeGeneration dflags toInterp this_mod + (map ideclName (hsModuleImports rdr_module)) cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds hit (pcs_PIT pcs_tc) ; @@ -223,18 +222,11 @@ hscRecomp dflags summary maybe_checked_iface hst hit pcs_ch }}}}}}} -myParseModule dflags summary +myParseModule dflags src_filename = do -------------------------- Parser ---------------- show_pass dflags "Parser" -- _scc_ "Parser" - let src_filename -- name of the preprocessed source file - = case ms_ppsource summary of - Just (filename, fingerprint) -> filename - Nothing -> pprPanic - "myParseModule:summary is not of a source module" - (ppr summary) - buf <- hGetStringBuffer True{-expand tabs-} src_filename let glaexts | dopt Opt_GlasgowExts dflags = 1# @@ -257,7 +249,7 @@ myParseModule dflags summary }} -restOfCodeGeneration dflags toInterp summary cost_centre_info +restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds hit pit -- these last two for mapping ModNames to Modules | toInterp @@ -285,9 +277,7 @@ restOfCodeGeneration dflags toInterp summary cost_centre_info where local_tycons = typeEnvTyCons env_tc local_classes = typeEnvClasses env_tc - this_mod = ms_mod summary - imported_modules = map (mod_name_to_Module.mimp_name) - (ms_get_imports summary) + imported_modules = map mod_name_to_Module imported_module_names (fe_binders,h_code,c_code) = foreign_stuff mod_name_to_Module :: ModuleName -> Module diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index e7f639d..1d6e371 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -87,9 +87,9 @@ import UniqSupply ( UniqSupply ) \begin{code} data ModuleLocation = ModuleLocation { - hs_file :: FilePath, - hi_file :: FilePath, - obj_file :: FilePath + hs_preprocd_file :: FilePath, -- location after preprocessing + hi_file :: FilePath, + obj_file :: FilePath } deriving Show diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 539c256..a19c541 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -25,7 +25,8 @@ import RnIfaces ( slurpImpDecls, mkImportInfo, getInterfaceExports, closeDecls, RecompileRequired, recompileRequired ) -import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs ) +import RnHiFiles ( readIface, removeContext, + loadExports, loadFixDecls, loadDeprecs ) import RnEnv ( availName, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, @@ -367,41 +368,45 @@ rnDeprecs gbl_env Nothing decls checkOldIface :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState - -> Module + -> FilePath -> Bool -- Source unchanged -> Maybe ModIface -- Old interface from compilation manager, if any -> IO (PersistentCompilerState, Bool, (RecompileRequired, Maybe ModIface)) -- True <=> errors happened -checkOldIface dflags hit hst pcs mod source_unchanged maybe_iface - = initRn dflags hit hst pcs mod $ +checkOldIface dflags hit hst pcs iface_path source_unchanged maybe_iface + = initRn dflags hit hst pcs (panic "checkOldIface: bogus mod") $ -- Load the old interface file, if we havn't already got it - loadOldIface mod maybe_iface `thenRn` \ maybe_iface -> + loadOldIface iface_path maybe_iface `thenRn` \ maybe_iface2 -> -- Check versions - recompileRequired mod source_unchanged maybe_iface `thenRn` \ recompile -> + recompileRequired iface_path source_unchanged maybe_iface2 `thenRn` \ recompile -> - returnRn (recompile, maybe_iface) + returnRn (recompile, maybe_iface2) \end{code} \begin{code} -loadOldIface :: Module -> Maybe ModIface -> RnMG (Maybe ModIface) -loadOldIface mod (Just iface) +loadOldIface :: FilePath -> Maybe ModIface -> RnMG (Maybe ModIface) +loadOldIface iface_path (Just iface) = returnRn (Just iface) -loadOldIface mod Nothing +loadOldIface iface_path Nothing = -- LOAD THE OLD INTERFACE FILE - findAndReadIface doc_str (moduleName mod) False {- Not hi-boot -} `thenRn` \ read_result -> + -- call readIface ... + readIface iface_path `thenRn` \ read_result -> case read_result of { Left err -> -- Old interface file not found, or garbled, so we'd better bail out traceRn (vcat [ptext SLIT("No old interface file:"), err]) `thenRn_` returnRn Nothing ; - Right (_, iface) -> + Right iface -> -- RENAME IT + let mod = pi_mod iface + doc_str = ptext SLIT("need usage info from") <+> ppr mod + in initIfaceRnMS mod ( loadHomeDecls (pi_decls iface) `thenRn` \ decls -> loadHomeRules (pi_rules iface) `thenRn` \ rules -> @@ -433,10 +438,6 @@ loadOldIface mod Nothing in returnRn (Just mod_iface) } - - - where - doc_str = ptext SLIT("need usage info from") <+> ppr mod \end{code} \begin{code} diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 77f753a..a81141a 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -5,7 +5,7 @@ \begin{code} module RnHiFiles ( - findAndReadIface, loadInterface, loadHomeInterface, + readIface, findAndReadIface, loadInterface, loadHomeInterface, tryLoadInterface, loadOrphanModules, loadExports, loadFixDecls, loadDeprecs, @@ -485,10 +485,17 @@ findAndReadIface doc_str mod_name hi_boot_file ioToRnM (findModule mod_name) `thenRn` \ maybe_found -> case maybe_found of - Right (Just (mod,locn)) - | hi_boot_file -> readIface mod (hi_file locn ++ "-boot") - | otherwise -> readIface mod (hi_file locn) - + Right (Just (wanted_mod,locn)) + -> readIface (hi_file locn ++ if hi_boot_file then "-boot" else "") + `thenRn` \ read_result -> + case read_result of + Left bad -> returnRn (Left bad) + Right iface + -> let read_mod = pi_mod iface + in warnCheckRn (wanted_mod == read_mod) + (hiModuleNameMismatchWarn wanted_mod read_mod) + `thenRn_` + returnRn (Right (wanted_mod, iface)) -- Can't find it other -> traceRn (ptext SLIT("...not found")) `thenRn_` returnRn (Left (noIfaceErr mod_name hi_boot_file)) @@ -504,12 +511,12 @@ findAndReadIface doc_str mod_name hi_boot_file @readIface@ tries just the one file. \begin{code} -readIface :: Module -> String -> RnM d (Either Message (Module, ParsedIface)) +readIface :: String -> RnM d (Either Message ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -readIface wanted_mod file_path - = traceRn (ptext SLIT("...reading from") <+> text file_path) `thenRn_` - ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result -> +readIface file_path + = traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_` + ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result -> case read_result of Right contents -> case parseIface contents @@ -517,13 +524,7 @@ readIface wanted_mod file_path context = [], glasgow_exts = 1#, loc = mkSrcLoc (mkFastString file_path) 1 } of - POk _ (PIface iface) -> - warnCheckRn (wanted_mod == read_mod) - (hiModuleNameMismatchWarn wanted_mod read_mod) `thenRn_` - returnRn (Right (wanted_mod, iface)) - where - read_mod = pi_mod iface - + POk _ (PIface iface) -> returnRn (Right iface) PFailed err -> bale_out err parse_result -> bale_out empty -- This last case can happen if the interface file is (say) empty diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 9d0ffaf..cdb542c 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -18,7 +18,7 @@ where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas ) +import CmdLineOpts ( opt_IgnoreIfacePragmas ) import HscTypes import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..), InstDecl(..), HsType(..), hsTyVarNames, getBangType @@ -785,12 +785,12 @@ type RecompileRequired = Bool upToDate = False -- Recompile not required outOfDate = True -- Recompile required -recompileRequired :: Module +recompileRequired :: FilePath -- Only needed for debug msgs -> Bool -- Source unchanged -> Maybe ModIface -- Old interface, if any -> RnMG RecompileRequired -recompileRequired mod source_unchanged maybe_iface - = traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_` +recompileRequired iface_path source_unchanged maybe_iface + = traceRn (text "Considering whether compilation is required for" <+> text iface_path <> colon) `thenRn_` -- CHECK WHETHER THE SOURCE HAS CHANGED if not source_unchanged then -- 1.7.10.4