From 156d91339295539a2b3461efc1ac8c83f29d83f0 Mon Sep 17 00:00:00 2001 From: sewardj Date: Mon, 30 Oct 2000 18:13:16 +0000 Subject: [PATCH] [project @ 2000-10-30 18:13:15 by sewardj] Move readIface from RnM to IO, and commensurate changes. Also, add a field to ModuleLocation to hold preprocessed source locations. --- ghc/compiler/ghci/CmSummarise.lhs | 5 +-- ghc/compiler/main/DriverPipeline.hs | 24 ++++++------ ghc/compiler/main/Finder.lhs | 14 ++++--- ghc/compiler/main/HscMain.lhs | 9 +++-- ghc/compiler/main/HscTypes.lhs | 7 ++-- ghc/compiler/main/MkIface.lhs | 18 +++------ ghc/compiler/rename/Rename.lhs | 71 +++++++++++++++++++---------------- ghc/compiler/rename/RnHiFiles.lhs | 37 ++++++++++-------- ghc/compiler/rename/RnIfaces.lhs | 12 ++---- ghc/compiler/rename/RnMonad.lhs | 6 +++ ghc/compiler/utils/Util.lhs | 16 +++++++- 11 files changed, 122 insertions(+), 97 deletions(-) diff --git a/ghc/compiler/ghci/CmSummarise.lhs b/ghc/compiler/ghci/CmSummarise.lhs index 7ad604d..eff75bc 100644 --- a/ghc/compiler/ghci/CmSummarise.lhs +++ b/ghc/compiler/ghci/CmSummarise.lhs @@ -14,6 +14,7 @@ where import List ( nub ) import Char ( ord, isAlphaNum ) +import Util ( unJust ) import HscTypes ( ModuleLocation(..) ) import FastTypes @@ -81,9 +82,7 @@ summarise :: Module -> ModuleLocation -> IO ModSummary summarise mod location = if isModuleInThisPackage mod then do - let source_fn = hs_preprocd_file location - -- ToDo: - -- ppsource_fn <- preprocess source_fn + let source_fn = unJust (ml_hspp_file location) "summarise" modsrc <- readFile source_fn let imps = getImports modsrc fp = fingerprint modsrc diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index cbf1fce..1a3fc0d 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.12 2000/10/30 13:46:24 sewardj Exp $ +-- $Id: DriverPipeline.hs,v 1.13 2000/10/30 18:13:15 sewardj Exp $ -- -- GHC Driver -- @@ -404,8 +404,8 @@ run_phase Hsc basename suff input_fn output_fn ohi <- readIORef v_Output_hi hisuf <- readIORef v_Hi_suf let hifile = case ohi of - Nothing -> current_dir ++ {-ToDo: modname!!-}basename - ++ hisuf + Nothing -> current_dir ++ "/" ++ basename + ++ "." ++ hisuf Just fn -> fn -- figure out if the source has changed, for recompilation avoidance. @@ -434,9 +434,10 @@ run_phase Hsc basename suff input_fn output_fn -- build a bogus ModuleLocation to pass to hscMain. let location = ModuleLocation { - hs_preprocd_file = input_fn, - hi_file = hifile, - obj_file = o_file + ml_hs_file = Nothing, + ml_hspp_file = Just input_fn, + ml_hi_file = Just hifile, + ml_obj_file = Just o_file } -- get the DynFlags @@ -727,10 +728,9 @@ compile summary old_iface hst hit pcs = do init_dyn_flags <- readIORef v_InitDynFlags writeIORef v_DynFlags init_dyn_flags - - let input_fn = case ms_ppsource summary of - Just (ppsource, fingerprint) -> ppsource - Nothing -> hs_preprocd_file (ms_location summary) + + let location = ms_location summary + let input_fn = unJust (ml_hs_file location) "compile:hs" when verb (hPutStrLn stderr ("compile: input file " ++ input_fn)) @@ -748,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") - (ms_location summary) old_iface hst hit pcs + location old_iface hst hit pcs case hsc_result of { HscFail pcs -> return (CompErrs pcs); @@ -761,7 +761,7 @@ compile summary old_iface hst hit pcs = do Nothing -> return (CompOK details Nothing pcs); Just iface -> do - let (basename, _) = splitFilename (hs_preprocd_file (ms_location summary)) + let (basename, _) = splitFilename input_fn 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 d256c86..e985ac0 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -123,9 +123,10 @@ mkHomeModuleLocn mod_name basename source_fn = do return (Just (mkHomeModule mod_name, ModuleLocation{ - hs_preprocd_file = source_fn, - hi_file = hifile, - obj_file = o_file + ml_hspp_file = Nothing, + ml_hs_file = Just source_fn, + ml_hi_file = Just hifile, + ml_obj_file = Just o_file } )) @@ -165,9 +166,10 @@ maybePackageModule mod_name = do Just (pkg_name,path) -> return (Just (mkModule mod_name pkg_name, ModuleLocation{ - hs_preprocd_file = "error:_package_module;_no_source", - hi_file = path ++ '/':hi, - obj_file = "error:_package_module;_no_object" + ml_hspp_file = Nothing, + ml_hs_file = Nothing, + ml_hi_file = Just (path ++ '/':hi), + ml_obj_file = Nothing } )) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index db3f9d7..7612f78 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -41,6 +41,7 @@ import CodeOutput ( codeOutput ) import Module ( ModuleName, moduleName, mkModuleInThisPackage ) import CmdLineOpts import ErrUtils ( dumpIfSet_dyn ) +import Util ( unJust ) import UniqSupply ( mkSplitUniqSupply ) import Bag ( emptyBag ) @@ -93,9 +94,10 @@ hscMain hscMain dflags source_unchanged location maybe_old_iface hst hit pcs = do { + putStrLn ( "hscMain: location =\n" ++ show location); putStrLn "checking old iface ..."; (pcs_ch, check_errs, (recomp_reqd, maybe_checked_iface)) - <- checkOldIface dflags hit hst pcs (hi_file location) + <- checkOldIface dflags hit hst pcs (unJust (ml_hi_file location) "hscMain") source_unchanged maybe_old_iface; if check_errs then return (HscFail pcs_ch) @@ -156,7 +158,8 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch ; -- putStrLn ("toInterp = " ++ show toInterp); -- PARSE - maybe_parsed <- myParseModule dflags (hs_preprocd_file location); + maybe_parsed + <- myParseModule dflags (unJust (ml_hspp_file location) "hscRecomp:hspp"); case maybe_parsed of { Nothing -> return (HscFail pcs_ch); Just rdr_module -> do { @@ -205,7 +208,7 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch Just (fif, sdoc) -> Just fif; Nothing -> Nothing ; -- Write the interface file - writeIface maybe_final_iface + writeIface (unJust (ml_hi_file location) "hscRecomp:hi") maybe_final_iface ; -- do the rest of code generation/emission (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 1f97736..ab77b47 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -88,9 +88,10 @@ import UniqSupply ( UniqSupply ) \begin{code} data ModuleLocation = ModuleLocation { - hs_preprocd_file :: FilePath, -- location after preprocessing - hi_file :: FilePath, - obj_file :: FilePath + ml_hs_file :: Maybe FilePath, + ml_hspp_file :: Maybe FilePath, -- path of preprocessed source + ml_hi_file :: Maybe FilePath, + ml_obj_file :: Maybe FilePath } deriving Show diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 01e7bb2..c837f4c 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -605,23 +605,15 @@ diffDecls old_vers old_fixities new_fixities old new %************************************************************************ \begin{code} -writeIface :: Maybe ModIface -> IO () -writeIface Nothing +writeIface :: FilePath -> Maybe ModIface -> IO () +writeIface hi_path Nothing = return () -writeIface (Just mod_iface) - = do { maybe_found <- findModule mod_name ; - ; case maybe_found of { - Nothing -> printErrs (text "Can't write interface file for" <+> ppr mod_name) ; - Just (_, locn) -> - - do { let filename = hi_file locn - ; if_hdl <- openFile filename WriteMode +writeIface hi_path (Just mod_iface) + = do { if_hdl <- openFile hi_path WriteMode ; printForIface if_hdl (pprIface mod_iface) ; hClose if_hdl - }}} - where - mod_name = moduleName (mi_module mod_iface) + } pprIface :: ModIface -> SDoc pprIface iface diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 9b9258e..88beb68 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -17,13 +17,13 @@ import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDe instDeclFVs, tyClDeclFVs, ruleDeclFVs ) -import CmdLineOpts ( DynFlags, DynFlag(..) ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) import RnIfaces ( slurpImpDecls, mkImportInfo, getInterfaceExports, closeDecls, - RecompileRequired, recompileRequired + RecompileRequired, outOfDate, recompileRequired ) import RnHiFiles ( readIface, removeContext, loadExports, loadFixDecls, loadDeprecs ) @@ -33,7 +33,8 @@ import RnEnv ( availName, lookupOrigNames, lookupGlobalRn, newGlobalName ) import Module ( Module, ModuleName, WhereFrom(..), - moduleNameUserString, moduleName, moduleEnvElts + moduleNameUserString, moduleName, + mkModuleInThisPackage, mkModuleName, moduleEnvElts ) import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, nameOccName, nameModule, @@ -376,35 +377,41 @@ checkOldIface :: DynFlags -- True <=> errors happened 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 iface_path maybe_iface `thenRn` \ maybe_iface2 -> - - -- Check versions - recompileRequired iface_path source_unchanged maybe_iface2 `thenRn` \ recompile -> - - returnRn (recompile, maybe_iface2) + = case maybe_iface of + Just old_iface -> -- Use the one we already have + startRn (mi_module old_iface) $ + check_versions old_iface + Nothing -- try and read it from a file + -> do read_result <- readIface do_traceRn iface_path + case read_result of + Left err -> -- Old interface file not found, or garbled; give up + return (pcs, False, (outOfDate, Nothing)) + Right parsed_iface + -> startRn (pi_mod parsed_iface) $ + loadOldIface parsed_iface `thenRn` \ m_iface -> + check_versions m_iface + where + check_versions :: ModIface -> RnMG (RecompileRequired, Maybe ModIface) + check_versions iface + = -- Check versions + recompileRequired iface_path source_unchanged iface + `thenRn` \ recompile -> + returnRn (recompile, Just iface) + + do_traceRn = dopt Opt_D_dump_rn_trace dflags + ioTraceRn sdoc = if do_traceRn then printErrs sdoc else return () + startRn mod = initRn dflags hit hst pcs mod \end{code} +I think the following function should now have a more representative name, +but what? \begin{code} -loadOldIface :: FilePath -> Maybe ModIface -> RnMG (Maybe ModIface) -loadOldIface iface_path (Just iface) - = returnRn (Just iface) - -loadOldIface iface_path Nothing - = -- LOAD THE OLD INTERFACE FILE - -- 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 -> - - -- RENAME IT +loadOldIface :: ParsedIface -> RnMG ModIface + +loadOldIface parsed_iface + = let iface = parsed_iface + in -- RENAME IT let mod = pi_mod iface doc_str = ptext SLIT("need usage info from") <+> ppr mod in @@ -413,10 +420,11 @@ loadOldIface iface_path Nothing loadHomeRules (pi_rules iface) `thenRn` \ rules -> loadHomeInsts (pi_insts iface) `thenRn` \ insts -> returnRn (decls, rules, insts) - ) `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) -> + ) + `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) -> mapRn loadHomeUsage (pi_usages iface) `thenRn` \ usages -> - loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> + loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> let @@ -437,8 +445,7 @@ loadOldIface iface_path Nothing mi_globals = panic "No mi_globals in old interface" } in - returnRn (Just mod_iface) - } + returnRn mod_iface \end{code} \begin{code} diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 55e8549..2fa3bdd 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -17,7 +17,7 @@ module RnHiFiles ( #include "HsVersions.h" -import CmdLineOpts ( opt_IgnoreIfacePragmas ) +import CmdLineOpts ( DynFlag(..), opt_IgnoreIfacePragmas ) import HscTypes ( ModuleLocation(..), ModIface(..), emptyModIface, VersionInfo(..), @@ -57,10 +57,13 @@ import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message ) import Finder ( findModule ) +import Util ( unJust ) import Lex import FiniteMap import Outputable import Bag + +import Monad ( when ) \end{code} @@ -468,8 +471,6 @@ getSysTyClDeclBinders mod other_decl = returnRn [] \end{code} - - %********************************************************* %* * \subsection{Reading an interface file} @@ -487,10 +488,14 @@ findAndReadIface :: SDoc -> ModuleName findAndReadIface doc_str mod_name hi_boot_file = traceRn trace_msg `thenRn_` ioToRnM (findModule mod_name) `thenRn` \ maybe_found -> - + doptRn Opt_D_dump_rn_trace `thenRn` \ rn_trace -> case maybe_found of Right (Just (wanted_mod,locn)) - -> readIface (hi_file locn ++ if hi_boot_file then "-boot" else "") + -> ioToRnM_no_fail ( + readIface rn_trace + (unJust (ml_hi_file locn) "findAndReadIface" + ++ if hi_boot_file then "-boot" else "") + ) `thenRn` \ read_result -> case read_result of Left bad -> returnRn (Left bad) @@ -515,30 +520,30 @@ findAndReadIface doc_str mod_name hi_boot_file @readIface@ tries just the one file. \begin{code} -readIface :: String -> RnM d (Either Message ParsedIface) +readIface :: Bool -> String -> IO (Either Message ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -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 +readIface tr file_path + = when tr (printErrs (ptext SLIT("readIFace") <+> text file_path)) + >> + ((hGetStringBuffer False file_path >>= \ contents -> + case parseIface contents PState{ bol = 0#, atbol = 1#, context = [], glasgow_exts = 1#, loc = mkSrcLoc (mkFastString file_path) 1 } of - POk _ (PIface iface) -> returnRn (Right iface) + POk _ (PIface iface) -> return (Right iface) PFailed err -> bale_out err parse_result -> bale_out empty -- This last case can happen if the interface file is (say) empty -- in which case the parser thinks it looks like an IdInfo or -- something like that. Just an artefact of the fact that the -- parser is used for several purposes at once. - - Left io_err -> bale_out (text (show io_err)) + ) + `catch` + (\ io_err -> bale_out (text (show io_err)))) where - bale_out err = returnRn (Left (badIfaceFile file_path err)) + bale_out err = return (Left (badIfaceFile file_path err)) \end{code} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index e351248..81c9ab9 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -787,9 +787,9 @@ outOfDate = True -- Recompile required recompileRequired :: FilePath -- Only needed for debug msgs -> Bool -- Source unchanged - -> Maybe ModIface -- Old interface, if any + -> ModIface -- Old interface -> RnMG RecompileRequired -recompileRequired iface_path source_unchanged maybe_iface +recompileRequired iface_path source_unchanged iface = traceRn (text "Considering whether compilation is required for" <+> text iface_path <> colon) `thenRn_` -- CHECK WHETHER THE SOURCE HAS CHANGED @@ -799,12 +799,8 @@ recompileRequired iface_path source_unchanged maybe_iface else -- CHECK WHETHER WE HAVE AN OLD IFACE - case maybe_iface of - Nothing -> traceRn (nest 4 (ptext SLIT("No old interface file"))) `thenRn_` - returnRn outOfDate ; - - Just iface -> -- Source code unchanged and no errors yet... carry on - checkList [checkModUsage u | u <- mi_usages iface] + -- Source code unchanged and no errors yet... carry on + checkList [checkModUsage u | u <- mi_usages iface] checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired checkList [] = returnRn upToDate diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index d2dfc42..74101b7 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -86,6 +86,12 @@ ioToRnM :: IO r -> RnM d (Either IOError r) ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) `catch` (\ err -> return (Left err)) + +ioToRnM_no_fail :: IO r -> RnM d r +ioToRnM_no_fail io rn_down g_down + = (io >>= \ ok -> return ok) + `catch` + (\ err -> panic "ioToRnM_no_fail: the I/O operation failed!") traceRn :: SDoc -> RnM d () traceRn msg diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 3a0da47..52966b8 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -24,6 +24,9 @@ module Util ( -- for-loop nTimes, + -- maybe-ish + unJust, + -- sorting IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA) sortLt, @@ -65,8 +68,8 @@ module Util ( #include "HsVersions.h" -import IO ( hPutStrLn, stderr ) import List ( zipWith4 ) +import Maybe ( Maybe(..) ) import Panic ( panic ) import IOExts ( IORef, newIORef, unsafePerformIO ) import FastTypes @@ -128,6 +131,17 @@ nTimes 1 f = f nTimes n f = f . nTimes (n-1) f \end{code} +%************************************************************************ +%* * +\subsection{Maybe-ery} +%* * +%************************************************************************ + +\begin{code} +unJust :: Maybe a -> String -> a +unJust (Just x) who = x +unJust Nothing who = panic ("unJust of Nothing, called by " ++ who) +\end{code} %************************************************************************ %* * -- 1.7.10.4