From 94bf0d3604ff0d2ecab246924af712bdd1c29a40 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Wed, 27 Oct 2010 12:11:32 +0000 Subject: [PATCH] Refactoring and tidyup of HscMain and related things (also fix #1666) While trying to fix #1666 (-Werror aborts too early) I decided to some tidyup in GHC/DriverPipeline/HscMain. - The GhcMonad overloading is gone from DriverPipeline and HscMain now. GhcMonad is now defined in a module of its own, and only used in the top-level GHC layer. DriverPipeline and HscMain use the plain IO monad and take HscEnv as an argument. - WarnLogMonad is gone. printExceptionAndWarnings is now called printException (the old name is deprecated). Session no longer contains warnings. - HscMain has its own little monad that collects warnings, and also plumbs HscEnv around. The idea here is that warnings are collected while we're in HscMain, but on exit from HscMain (any function) we check for warnings and either print them (via log_action, so IDEs can still override the printing), or turn them into an error if -Werror is on. - GhcApiCallbacks is gone, along with GHC.loadWithLogger. Thomas Schilling told me he wasn't using these, and I don't see a good reason to have them. - there's a new pure API to the parser (suggestion from Neil Mitchell): parser :: String -> DynFlags -> FilePath -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) --- compiler/basicTypes/SrcLoc.lhs | 4 +- compiler/ghc.cabal.in | 1 + compiler/ghci/Debugger.hs | 5 +- compiler/main/DriverMkDepend.hs | 1 + compiler/main/DriverPipeline.hs | 221 +++++---- compiler/main/ErrUtils.lhs | 52 +- compiler/main/GHC.hs | 389 +++++++-------- compiler/main/GhcMonad.hs | 177 +++++++ compiler/main/HeaderInfo.hs | 13 +- compiler/main/HscMain.lhs | 836 +++++++++++++++++++++------------ compiler/main/HscTypes.lhs | 326 ++----------- compiler/main/InteractiveEval.hs | 41 +- compiler/rename/RnNames.lhs | 14 +- compiler/simplCore/CoreMonad.lhs | 1 + compiler/typecheck/TcRnMonad.lhs | 5 +- compiler/typecheck/TcSplice.lhs | 2 +- compiler/utils/MonadUtils.hs | 24 +- compiler/utils/StringBuffer.lhs | 5 +- compiler/vectorise/Vectorise.hs | 2 + compiler/vectorise/Vectorise/Monad.hs | 1 + ghc/GhciMonad.hs | 16 +- ghc/InteractiveUI.hs | 23 +- ghc/Main.hs | 28 +- 23 files changed, 1107 insertions(+), 1080 deletions(-) create mode 100644 compiler/main/GhcMonad.hs diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index d912beb..06f8ec8 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -165,11 +165,11 @@ instance Ord SrcLoc where cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 -cmpSrcLoc (UnhelpfulLoc _) _other = LT +cmpSrcLoc (UnhelpfulLoc _) (SrcLoc _ _ _) = GT +cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulLoc _) = LT cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2) -cmpSrcLoc (SrcLoc _ _ _) _other = GT instance Outputable SrcLoc where ppr (SrcLoc src_path src_line src_col) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a7f5242..0711a93 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -152,6 +152,7 @@ Library DataCon Demand Exception + GhcMonad Id IdInfo Literal diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 9f38313..141a513 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -15,23 +15,20 @@ module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where import Linker import RtClosureInspect +import GhcMonad import HscTypes import Id import Name import Var hiding ( varName ) import VarSet --- import Name import UniqSupply import TcType import GHC --- import DynFlags import InteractiveEval import Outputable --- import SrcLoc import PprTyThing import MonadUtils --- import Exception import Control.Monad import Data.List import Data.Maybe diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 48617ec..e430c6e 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -17,6 +17,7 @@ module DriverMkDepend ( import qualified GHC -- import GHC ( ModSummary(..), GhcMonad ) +import GhcMonad import HsSyn ( ImportDecl(..) ) import DynFlags import Util diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 1c29c7f..9b57c4d 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -49,7 +49,7 @@ import ParserCoreUtils ( getCoreModuleName ) import SrcLoc import FastString import LlvmCodeGen ( llvmFixupAsm ) --- import MonadUtils +import MonadUtils -- import Data.Either import Exception @@ -73,10 +73,9 @@ import System.Environment -- We return the augmented DynFlags, because they contain the result -- of slurping in the OPTIONS pragmas -preprocess :: GhcMonad m => - HscEnv +preprocess :: HscEnv -> (FilePath, Maybe Phase) -- ^ filename and starting phase - -> m (DynFlags, FilePath) + -> IO (DynFlags, FilePath) preprocess hsc_env (filename, mb_phase) = ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) runPipeline anyHsc hsc_env (filename, mb_phase) @@ -90,37 +89,33 @@ preprocess hsc_env (filename, mb_phase) = -- -- This is the interface between the compilation manager and the -- compiler proper (hsc), where we deal with tedious details like --- reading the OPTIONS pragma from the source file, and passing the --- output of hsc through the C compiler. +-- reading the OPTIONS pragma from the source file, converting the +-- C or assembly that GHC produces into an object file, and compiling +-- FFI stub files. -- -- NB. No old interface can also mean that the source has changed. -compile :: GhcMonad m => - HscEnv +compile :: HscEnv -> ModSummary -- ^ summary for module being compiled -> Int -- ^ module N ... -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one -> Maybe Linkable -- ^ old linkable, if we have one - -> m HomeModInfo -- ^ the complete HomeModInfo, if successful + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch) -type Compiler m a = HscEnv -> ModSummary -> Bool - -> Maybe ModIface -> Maybe (Int, Int) - -> m a - -compile' :: GhcMonad m => - (Compiler m (HscStatus, ModIface, ModDetails), - Compiler m (InteractiveStatus, ModIface, ModDetails), - Compiler m (HscStatus, ModIface, ModDetails)) +compile' :: + (Compiler (HscStatus, ModIface, ModDetails), + Compiler (InteractiveStatus, ModIface, ModDetails), + Compiler (HscStatus, ModIface, ModDetails)) -> HscEnv -> ModSummary -- ^ summary for module being compiled -> Int -- ^ module N ... -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one -> Maybe Linkable -- ^ old linkable, if we have one - -> m HomeModInfo -- ^ the complete HomeModInfo, if successful + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compile' (nothingCompiler, interactiveCompiler, batchCompiler) hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable @@ -132,7 +127,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) input_fn = expectJust "compile:hs" (ml_hs_file location) input_fnpp = ms_hspp_file summary - liftIO $ debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) + debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) let basename = dropExtension input_fn @@ -151,7 +146,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- ... and what the next phase should be let next_phase = hscNextPhase dflags src_flavour hsc_lang -- ... and what file to generate the output into - output_fn <- liftIO $ getOutputFilename next_phase + output_fn <- getOutputFilename next_phase Temporary basename dflags next_phase (Just location) let dflags' = dflags { hscTarget = hsc_lang, @@ -193,7 +188,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) Persistent (Just location) -- The object filename comes from the ModLocation - o_time <- liftIO $ getModificationTime object_filename + o_time <- getModificationTime object_filename return ([DotO object_filename], o_time) let linkable = LM unlinked_time this_mod (hs_unlinked ++ stub_unlinked) @@ -231,13 +226,9 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) hm_linkable = linkable }) -- run the compiler case hsc_lang of - HscInterpreted -> - runCompiler interactiveCompiler handleInterpreted - HscNothing -> - runCompiler nothingCompiler handleBatch - _other -> - runCompiler batchCompiler handleBatch - + HscInterpreted -> runCompiler interactiveCompiler handleInterpreted + HscNothing -> runCompiler nothingCompiler handleBatch + _other -> runCompiler batchCompiler handleBatch ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) @@ -258,8 +249,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want -- obj/A_stub.o. -compileStub :: GhcMonad m => HscEnv -> Module -> ModLocation - -> m FilePath +compileStub :: HscEnv -> Module -> ModLocation -> IO FilePath compileStub hsc_env mod location = do -- compile the _stub.c file w/ gcc let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env) @@ -415,16 +405,14 @@ findHSLib dirs lib = do -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. -oneShot :: GhcMonad m => - HscEnv -> Phase -> [(String, Maybe Phase)] -> m () +oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () oneShot hsc_env stop_phase srcs = do o_files <- mapM (compileFile hsc_env stop_phase) srcs - liftIO $ doLink (hsc_dflags hsc_env) stop_phase o_files + doLink (hsc_dflags hsc_env) stop_phase o_files -compileFile :: GhcMonad m => - HscEnv -> Phase -> (FilePath, Maybe Phase) -> m FilePath +compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath compileFile hsc_env stop_phase (src, mb_phase) = do - exists <- liftIO $ doesFileExist src + exists <- doesFileExist src when (not exists) $ ghcError (CmdLineError ("does not exist: " ++ src)) @@ -489,14 +477,13 @@ data PipelineOutput -- OPTIONS_GHC pragmas), and the changes affect later phases in the -- pipeline. runPipeline - :: GhcMonad m => - Phase -- ^ When to stop + :: Phase -- ^ When to stop -> HscEnv -- ^ Compilation environment -> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix) -> Maybe FilePath -- ^ original basename (if different from ^^^) -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module - -> m (DynFlags, FilePath) -- ^ (final flags, output filename) + -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc = do @@ -542,7 +529,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo case output of Temporary -> return (dflags', output_fn) - _other -> liftIO $ + _other -> do final_fn <- get_output_fn dflags' stop_phase maybe_loc when (final_fn /= output_fn) $ do let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'") @@ -552,12 +539,11 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo -pipeLoop :: GhcMonad m => - HscEnv -> Phase -> Phase +pipeLoop :: HscEnv -> Phase -> Phase -> FilePath -> String -> Suffix -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) -> Maybe ModLocation - -> m (DynFlags, FilePath, Maybe ModLocation) + -> IO (DynFlags, FilePath, Maybe ModLocation) pipeLoop hsc_env phase stop_phase input_fn orig_basename orig_suff @@ -575,8 +561,8 @@ pipeLoop hsc_env phase stop_phase " but I wanted to stop at phase " ++ show stop_phase) | otherwise - = do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4 - (ptext (sLit "Running phase") <+> ppr phase) + = do debugTraceMsg (hsc_dflags hsc_env) 4 + (ptext (sLit "Running phase") <+> ppr phase) (next_phase, dflags', maybe_loc, output_fn) <- runPhase phase stop_phase hsc_env orig_basename orig_suff input_fn orig_get_output_fn maybe_loc @@ -645,8 +631,7 @@ getOutputFilename stop_phase output basename -- of a source file can change the latter stages of the pipeline from -- taking the via-C route to using the native code generator. -- -runPhase :: GhcMonad m => - Phase -- ^ Do this phase first +runPhase :: Phase -- ^ Do this phase first -> Phase -- ^ Stop just before this phase -> HscEnv -> String -- ^ basename of original input source @@ -655,10 +640,10 @@ runPhase :: GhcMonad m => -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) -- ^ how to calculate the output filename -> Maybe ModLocation -- ^ the ModLocation, if we have one - -> m (Phase, -- next phase - DynFlags, -- new dynamic flags - Maybe ModLocation, -- the ModLocation, if we have one - FilePath) -- output filename + -> IO (Phase, -- next phase + DynFlags, -- new dynamic flags + Maybe ModLocation, -- the ModLocation, if we have one + FilePath) -- output filename -- Invariant: the output filename always contains the output -- Interesting case: Hsc when there is no recompilation to do @@ -670,7 +655,7 @@ runPhase :: GhcMonad m => runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc = do let dflags = hsc_dflags hsc_env - output_fn <- liftIO $ get_output_fn dflags (Cpp sf) maybe_loc + output_fn <- get_output_fn dflags (Cpp sf) maybe_loc let unlit_flags = getOpts dflags opt_L flags = map SysTools.Option unlit_flags ++ @@ -684,7 +669,7 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l , SysTools.FileOption "" output_fn ] - liftIO $ SysTools.runUnlit dflags flags + SysTools.runUnlit dflags flags return (Cpp sf, dflags, maybe_loc, output_fn) @@ -694,9 +679,9 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc = do let dflags0 = hsc_dflags hsc_env - src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn + src_opts <- getOptionsFromFile dflags0 input_fn (dflags1, unhandled_flags, warns) - <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts + <- parseDynamicNoPackageFlags dflags0 src_opts checkProcessArgsResult unhandled_flags if not (xopt Opt_Cpp dflags1) then do @@ -707,13 +692,13 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- to the next phase of the pipeline. return (HsPp sf, dflags1, maybe_loc, input_fn) else do - output_fn <- liftIO $ get_output_fn dflags1 (HsPp sf) maybe_loc - liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn + output_fn <- get_output_fn dflags1 (HsPp sf) maybe_loc + doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file -- See #2464,#3457 - src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn + src_opts <- getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) - <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts + <- parseDynamicNoPackageFlags dflags0 src_opts unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings checkProcessArgsResult unhandled_flags @@ -732,8 +717,8 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc else do let hspp_opts = getOpts dflags opt_F let orig_fn = basename <.> suff - output_fn <- liftIO $ get_output_fn dflags (Hsc sf) maybe_loc - liftIO $ SysTools.runPp dflags + output_fn <- get_output_fn dflags (Hsc sf) maybe_loc + SysTools.runPp dflags ( [ SysTools.Option orig_fn , SysTools.Option input_fn , SysTools.FileOption "" output_fn @@ -742,9 +727,9 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc ) -- re-read pragmas now that we've parsed the file (see #3674) - src_opts <- liftIO $ getOptionsFromFile dflags output_fn + src_opts <- getOptionsFromFile dflags output_fn (dflags1, unhandled_flags, warns) - <- liftIO $ parseDynamicNoPackageFlags dflags src_opts + <- parseDynamicNoPackageFlags dflags src_opts handleFlagWarnings dflags1 warns checkProcessArgsResult unhandled_flags @@ -773,11 +758,11 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma (hspp_buf,mod_name,imps,src_imps) <- case src_flavour of ExtCoreFile -> do -- no explicit imports in ExtCore input. - m <- liftIO $ getCoreModuleName input_fn + m <- getCoreModuleName input_fn return (Nothing, mkModuleName m, [], []) _ -> do - buf <- liftIO $ hGetStringBuffer input_fn + buf <- hGetStringBuffer input_fn (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) return (Just buf, mod_name, imps, src_imps) @@ -787,7 +772,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- the .hi and .o filenames, and this is as good a way -- as any to generate them, and better than most. (e.g. takes -- into accout the -osuf flags) - location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff + location1 <- mkHomeModLocation2 dflags mod_name basename suff -- Boot-ify it if necessary let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 @@ -822,7 +807,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- changed (which the compiler itself figures out). -- Setting source_unchanged to False tells the compiler that M.o is out of -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - src_timestamp <- liftIO $ getModificationTime (basename <.> suff) + src_timestamp <- getModificationTime (basename <.> suff) let force_recomp = dopt Opt_ForceRecomp dflags hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags) @@ -833,17 +818,17 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- (b) we aren't going all the way to .o file (e.g. ghc -S) then return False -- Otherwise look at file modification dates - else do o_file_exists <- liftIO $ doesFileExist o_file + else do o_file_exists <- doesFileExist o_file if not o_file_exists then return False -- Need to recompile - else do t2 <- liftIO $ getModificationTime o_file + else do t2 <- getModificationTime o_file if t2 > src_timestamp then return True else return False -- get the DynFlags let next_phase = hscNextPhase dflags src_flavour hsc_lang - output_fn <- liftIO $ get_output_fn dflags next_phase (Just location4) + output_fn <- get_output_fn dflags next_phase (Just location4) let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, @@ -852,7 +837,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma let hsc_env' = hsc_env {hsc_dflags = dflags'} -- Tell the finder cache about this module - mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4 + mod <- addHomeModuleToFinder hsc_env' mod_name location4 -- Make the ModSummary to hand to hscMain let @@ -875,7 +860,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma case result of HscNoRecomp - -> do liftIO $ SysTools.touch dflags' "Touching object file" o_file + -> do SysTools.touch dflags' "Touching object file" o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't be in HscNoRecomp) -- but we touch it anyway, to keep 'make' happy (we think). @@ -887,7 +872,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make when (isHsBoot src_flavour) $ - liftIO $ SysTools.touch dflags' "Touching object file" o_file + SysTools.touch dflags' "Touching object file" o_file return (next_phase, dflags', Just location4, output_fn) ----------------------------------------------------------------------------- @@ -896,8 +881,8 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc = do let dflags = hsc_dflags hsc_env - output_fn <- liftIO $ get_output_fn dflags Cmm maybe_loc - liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn + output_fn <- get_output_fn dflags Cmm maybe_loc + doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn return (Cmm, dflags, maybe_loc, output_fn) runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc @@ -905,14 +890,14 @@ runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc let dflags = hsc_dflags hsc_env let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) let next_phase = hscNextPhase dflags HsSrcFile hsc_lang - output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc + output_fn <- get_output_fn dflags next_phase maybe_loc let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, extCoreName = basename ++ ".hcr" } let hsc_env' = hsc_env {hsc_dflags = dflags'} - hscCmmFile hsc_env' input_fn + hscCompileCmmFile hsc_env' input_fn -- XXX: catch errors above and convert them into ghcError? Original -- code was: @@ -936,17 +921,17 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc let cmdline_include_paths = includePaths dflags -- HC files have the dependent packages stamped into them - pkgs <- if hcc then liftIO (getHCFilePackages input_fn) else return [] + pkgs <- if hcc then getHCFilePackages input_fn else return [] -- add package include paths even if we're just compiling .c -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :) - pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs + pkg_include_dirs <- getPackageIncludePath dflags pkgs let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags - gcc_extra_viac_flags <- liftIO $ getExtraViaCOpts dflags + gcc_extra_viac_flags <- getExtraViaCOpts dflags let pic_c_flags = picCCOpts dflags let verb = getVerbFlag dflags @@ -957,10 +942,10 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc pkg_extra_cc_opts <- if cc_phase `eqPhase` HCc then return [] - else liftIO $ getPackageExtraCcOpts dflags pkgs + else getPackageExtraCcOpts dflags pkgs #ifdef darwin_TARGET_OS - pkg_framework_paths <- liftIO $ getPackageFrameworkPath dflags pkgs + pkg_framework_paths <- getPackageFrameworkPath dflags pkgs let cmdline_framework_paths = frameworkPaths dflags let framework_paths = map ("-F"++) (cmdline_framework_paths ++ pkg_framework_paths) @@ -979,7 +964,7 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc next_phase | hcc && mangle = Mangle | otherwise = As - output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc + output_fn <- get_output_fn dflags next_phase maybe_loc let more_hcc_opts = @@ -999,7 +984,7 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - liftIO $ SysTools.runCc dflags ( + SysTools.runCc dflags ( -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. -- Also useful for plain .c files, just in case GHC saw a @@ -1080,9 +1065,9 @@ runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc next_phase | split = SplitMangle | otherwise = As - output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc + output_fn <- get_output_fn dflags next_phase maybe_loc - liftIO $ SysTools.runMangle dflags (map SysTools.Option mangler_opts + SysTools.runMangle dflags (map SysTools.Option mangler_opts ++ [ SysTools.FileOption "" input_fn , SysTools.FileOption "" output_fn ] @@ -1094,8 +1079,7 @@ runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- Splitting phase runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc - = liftIO $ - do -- tmp_pfx is the prefix used for the split .s files + = do -- tmp_pfx is the prefix used for the split .s files -- We also use it as the file to contain the no. of split .s files (sigh) let dflags = hsc_dflags hsc_env split_s_prefix <- SysTools.newTempName dflags "split" @@ -1123,8 +1107,7 @@ runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe -- As phase runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = liftIO $ - do let dflags = hsc_dflags hsc_env + = do let dflags = hsc_dflags hsc_env let as_opts = getOpts dflags opt_a let cmdline_include_paths = includePaths dflags @@ -1159,7 +1142,7 @@ runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc - = liftIO $ do + = do let dflags = hsc_dflags hsc_env output_fn <- get_output_fn dflags StopLn maybe_loc @@ -1207,36 +1190,16 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc mapM_ assemble_file [1..n] - -- and join the split objects into a single object file: - let ld_r args = SysTools.runLink dflags ([ - SysTools.Option "-nostdlib", - SysTools.Option "-nodefaultlibs", - SysTools.Option "-Wl,-r", - SysTools.Option ld_x_flag, - SysTools.Option "-o", - SysTools.FileOption "" output_fn ] - ++ map SysTools.Option md_c_flags - ++ args) - ld_x_flag | null cLD_X = "" - | otherwise = "-Wl,-x" - - if cLdIsGNULd == "YES" - then do - let script = split_odir "ld.script" - writeFile script $ - "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")" - ld_r [SysTools.FileOption "" script] - else do - ld_r (map (SysTools.FileOption "" . split_obj) [1..n]) + -- join them into a single .o file + joinObjectFiles dflags (map split_obj [1..n]) output_fn return (StopLn, dflags, maybe_loc, output_fn) - ----------------------------------------------------------------------------- -- LlvmOpt phase runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = liftIO $ do + = do let dflags = hsc_dflags hsc_env let lo_opts = getOpts dflags opt_lo let opt_lvl = max 0 (min 2 $ optLevel dflags) @@ -1268,7 +1231,7 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- LlvmLlc phase runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = liftIO $ do + = do let dflags = hsc_dflags hsc_env let lc_opts = getOpts dflags opt_lc let opt_lvl = max 0 (min 2 $ optLevel dflags) @@ -1303,7 +1266,7 @@ runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- LlvmMangle phase runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = liftIO $ do + = do let dflags = hsc_dflags hsc_env output_fn <- get_output_fn dflags As maybe_loc llvmFixupAsm input_fn output_fn @@ -1865,6 +1828,32 @@ hsSourceCppOpts :: [String] hsSourceCppOpts = [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] +-- --------------------------------------------------------------------------- +-- join object files into a single relocatable object file, using ld -r + +joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () +joinObjectFiles dflags o_files output_fn = do + let ld_r args = SysTools.runLink dflags ([ + SysTools.Option "-nostdlib", + SysTools.Option "-nodefaultlibs", + SysTools.Option "-Wl,-r", + SysTools.Option ld_x_flag, + SysTools.Option "-o", + SysTools.FileOption "" output_fn ] + ++ map SysTools.Option md_c_flags + ++ args) + ld_x_flag | null cLD_X = "" + | otherwise = "-Wl,-x" + + (md_c_flags, _) = machdepCCOpts dflags + + if cLdIsGNULd == "YES" + then do + script <- newTempName dflags "ldscript" + writeFile script $ "INPUT(" ++ unwords o_files ++ ")" + ld_r [SysTools.FileOption "" script] + else do + ld_r (map (SysTools.FileOption "") o_files) -- ----------------------------------------------------------------------------- -- Misc. diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 3ab89bd..15b142b 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -13,7 +13,7 @@ module ErrUtils ( errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, - printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, + printBagOfErrors, printBagOfWarnings, warnIsErrorMsg, mkLongWarnMsg, ghcExit, @@ -39,7 +39,6 @@ import SrcLoc import DynFlags ( DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_ErrorSpans ) -import Control.Monad import System.Exit ( ExitCode(..), exitWith ) import Data.List import System.IO @@ -126,56 +125,29 @@ emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) warnIsErrorMsg :: ErrMsg -warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n") +warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.") errorsFound :: DynFlags -> Messages -> Bool --- The dyn-flags are used to see if the user has specified --- -Werror, which says that warnings should be fatal -errorsFound dflags (warns, errs) - | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns) - | otherwise = not (isEmptyBag errs) - -printErrorsAndWarnings :: DynFlags -> Messages -> IO () -printErrorsAndWarnings dflags (warns, errs) - | no_errs && no_warns = return () - | no_errs = do printBagOfWarnings dflags warns - when (dopt Opt_WarnIsError dflags) $ - errorMsg dflags $ - text "\nFailing due to -Werror.\n" - -- Don't print any warnings if there are errors - | otherwise = printBagOfErrors dflags errs - where - no_warns = isEmptyBag warns - no_errs = isEmptyBag errs +errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () -printBagOfErrors dflags bag_of_errors - = sequence_ [ let style = mkErrStyle unqual - in log_action dflags SevError s style (d $$ e) - | ErrMsg { errMsgSpans = s:_, - errMsgShortDoc = d, - errMsgExtraInfo = e, - errMsgContext = unqual } <- sorted_errs ] - where - bag_ls = bagToList bag_of_errors - sorted_errs = sortLe occ'ed_before bag_ls +printBagOfErrors dflags bag_of_errors = + printMsgBag dflags bag_of_errors SevError - occ'ed_before err1 err2 = - case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of - LT -> True - EQ -> True - GT -> False +printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO () +printBagOfWarnings dflags bag_of_warns = + printMsgBag dflags bag_of_warns SevWarning -printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO () -printBagOfWarnings dflags bag_of_warns +printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO () +printMsgBag dflags bag sev = sequence_ [ let style = mkErrStyle unqual - in log_action dflags SevWarning s style (d $$ e) + in log_action dflags sev s style (d $$ e) | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgExtraInfo = e, errMsgContext = unqual } <- sorted_errs ] where - bag_ls = bagToList bag_of_warns + bag_ls = bagToList bag sorted_errs = sortLe occ'ed_before bag_ls occ'ed_before err1 err2 = diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 638e1db..e1bc5de 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -15,9 +15,9 @@ module GHC ( Ghc, GhcT, GhcMonad(..), runGhc, runGhcT, initGhcMonad, gcatch, gbracket, gfinally, - clearWarnings, getWarnings, hasWarnings, - printExceptionAndWarnings, printWarnings, - handleSourceError, defaultCallbacks, GhcApiCallbacks(..), + printException, + printExceptionAndWarnings, + handleSourceError, needsTemplateHaskell, -- * Flags and settings @@ -38,7 +38,7 @@ module GHC ( -- * Loading\/compiling the program depanal, - load, loadWithLogger, LoadHowMuch(..), + load, LoadHowMuch(..), SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, @@ -217,6 +217,9 @@ module GHC ( getTokenStream, getRichTokenStream, showRichTokenStream, addSourceToTokens, + -- * Pure interface to the parser + parser, + -- * Miscellaneous --sessionHscEnv, cyclicModuleErr, @@ -239,7 +242,7 @@ import BreakArray import InteractiveEval #endif -import TcRnDriver +import GhcMonad import TcIface import TcRnTypes import TcRnMonad ( initIfaceCheck ) @@ -260,11 +263,9 @@ import Class import DataCon import Name hiding ( varName ) -- import OccName ( parenSymOcc ) -import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, - emptyInstEnv ) -import FamInstEnv ( emptyFamInstEnv ) +import InstEnv import SrcLoc ---import CoreSyn +import CoreSyn ( CoreBind ) import TidyPgm import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) @@ -282,15 +283,16 @@ import Module import UniqFM import Panic import Digraph -import Bag ( unitBag, listToBag, emptyBag, isEmptyBag ) +import Bag ( unitBag, listToBag ) import ErrUtils import MonadUtils import Util -import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar ) +import StringBuffer import Outputable import BasicTypes import Maybes ( expectJust, mapCatMaybes ) import FastString +import qualified Parser import Lexer import System.Directory ( getModificationTime, doesFileExist, @@ -373,28 +375,14 @@ defaultCleanupHandler dflags inner = -- | Print the error message and all warnings. Useful inside exception -- handlers. Clears warnings after printing. +printException :: GhcMonad m => SourceError -> m () +printException err = do + dflags <- getSessionDynFlags + liftIO $ printBagOfErrors dflags (srcErrorMessages err) + +{-# DEPRECATED printExceptionAndWarnings "use printException instead" #-} printExceptionAndWarnings :: GhcMonad m => SourceError -> m () -printExceptionAndWarnings err = do - let errs = srcErrorMessages err - warns <- getWarnings - dflags <- getSessionDynFlags - if isEmptyBag errs - -- Empty errors means we failed due to -Werror. (Since this function - -- takes a source error as argument, we know for sure _some_ error - -- did indeed happen.) - then liftIO $ do - printBagOfWarnings dflags warns - printBagOfErrors dflags (unitBag warnIsErrorMsg) - else liftIO $ printBagOfErrors dflags errs - clearWarnings - --- | Print all accumulated warnings using 'log_action'. -printWarnings :: GhcMonad m => m () -printWarnings = do - dflags <- getSessionDynFlags - warns <- getWarnings - liftIO $ printBagOfWarnings dflags warns - clearWarnings +printExceptionAndWarnings = printException -- | Run function for the 'Ghc' monad. -- @@ -409,9 +397,8 @@ runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. -> Ghc a -- ^ The action to perform. -> IO a runGhc mb_top_dir ghc = do - wref <- newIORef emptyBag ref <- newIORef undefined - let session = Session ref wref + let session = Session ref flip unGhc session $ do initGhcMonad mb_top_dir ghc @@ -428,9 +415,8 @@ runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) => -> GhcT m a -- ^ The action to perform. -> m a runGhcT mb_top_dir ghct = do - wref <- liftIO $ newIORef emptyBag ref <- liftIO $ newIORef undefined - let session = Session ref wref + let session = Session ref flip unGhcT session $ do initGhcMonad mb_top_dir ghct @@ -456,24 +442,12 @@ initGhcMonad mb_top_dir = do dflags0 <- liftIO $ initDynFlags defaultDynFlags dflags <- liftIO $ initSysTools mb_top_dir dflags0 - env <- liftIO $ newHscEnv defaultCallbacks dflags + env <- liftIO $ newHscEnv dflags setSession env - clearWarnings - -defaultCallbacks :: GhcApiCallbacks -defaultCallbacks = - GhcApiCallbacks { - reportModuleCompilationResult = - \_ mb_err -> defaultWarnErrLogger mb_err - } -- ----------------------------------------------------------------------------- -- Flags & settings --- | Grabs the DynFlags from the Session -getSessionDynFlags :: GhcMonad m => m DynFlags -getSessionDynFlags = withSession (return . hsc_dflags) - -- | Updates the DynFlags in a Session. This also reads -- the package database (unless it has already been read), -- and prepares the compilers knowledge about packages. It @@ -620,7 +594,7 @@ depanal excluded_mods allow_dup_roots = do text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))]) - mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots + mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } return mod_graph @@ -657,29 +631,8 @@ load how_much = do type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () defaultWarnErrLogger :: WarnErrLogger -defaultWarnErrLogger Nothing = printWarnings -defaultWarnErrLogger (Just e) = printExceptionAndWarnings e - --- | Try to load the program. If a Module is supplied, then just --- attempt to load up to this target. If no Module is supplied, --- then try to load all targets. --- --- The first argument is a function that is called after compiling each --- module to print wanrings and errors. --- --- While compiling a module, all 'SourceError's are caught and passed to the --- logger, however, this function may still throw a 'SourceError' if --- dependency analysis failed (e.g., due to a parse error). --- -loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag -loadWithLogger logger how_much = do - -- Dependency analysis first. Note that this fixes the module graph: - -- even if we don't get a fully successful upsweep, the full module - -- graph is still retained in the Session. We can tell which modules - -- were successfully loaded by inspecting the Session's HPT. - withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult = - \_ -> logger }) $ - load how_much +defaultWarnErrLogger Nothing = return () +defaultWarnErrLogger (Just e) = printException e load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> m SuccessFlag @@ -809,9 +762,10 @@ load2 how_much mod_graph = do liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) - (upsweep_ok, hsc_env1, modsUpswept) - <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) - pruned_hpt stable_mods cleanup mg + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) + <- upsweep pruned_hpt stable_mods cleanup mg -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. @@ -853,9 +807,10 @@ load2 how_much mod_graph = do moduleNameString (moduleName main_mod) ++ " module.") -- link everything together + hsc_env1 <- getSession linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - loadFinish Succeeded linkresult hsc_env1 + loadFinish Succeeded linkresult else -- Tricky. We need to back out the effects of compiling any @@ -872,6 +827,7 @@ load2 how_much mod_graph = do = filter ((`notElem` mods_to_zap_names).ms_mod) modsDone + hsc_env1 <- getSession let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) (hsc_HPT hsc_env1) @@ -885,24 +841,25 @@ load2 how_much mod_graph = do -- Link everything together linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 - let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } - loadFinish Failed linkresult hsc_env4 + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } + loadFinish Failed linkresult -- Finish up after a load. -- If the link failed, unload everything and return. loadFinish :: GhcMonad m => - SuccessFlag -> SuccessFlag -> HscEnv + SuccessFlag -> SuccessFlag -> m SuccessFlag -loadFinish _all_ok Failed hsc_env - = do liftIO $ unload hsc_env [] - modifySession $ \_ -> discardProg hsc_env +loadFinish _all_ok Failed + = do hsc_env <- getSession + liftIO $ unload hsc_env [] + modifySession discardProg return Failed -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. -loadFinish all_ok Succeeded hsc_env - = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext } +loadFinish all_ok Succeeded + = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } return all_ok @@ -1026,9 +983,9 @@ getModSummary mod = do -- Throws a 'SourceError' on parse error. parseModule :: GhcMonad m => ModSummary -> m ParsedModule parseModule ms = do - rdr_module <- withTempSession - (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ - hscParse ms + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + rdr_module <- liftIO $ hscParse hsc_env_tmp ms return (ParsedModule ms rdr_module) -- | Typecheck and rename a parsed module. @@ -1037,11 +994,12 @@ parseModule ms = do typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule typecheckModule pmod = do let ms = modSummary pmod - withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do - (tc_gbl_env, rn_info) - <- hscTypecheckRename ms (parsedSource pmod) - details <- makeSimpleDetails tc_gbl_env - return $ + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + (tc_gbl_env, rn_info) + <- liftIO $ hscTypecheckRename hsc_env_tmp ms (parsedSource pmod) + details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env + return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), tm_parsed_module = pmod, @@ -1062,10 +1020,11 @@ typecheckModule pmod = do desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule desugarModule tcm = do let ms = modSummary tcm - withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do - let (tcg, _) = tm_internals tcm - guts <- hscDesugar ms tcg - return $ + let (tcg, _) = tm_internals tcm + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg + return $ DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts @@ -1086,32 +1045,44 @@ loadModule tcm = do let mod = ms_mod_name ms let loc = ms_location ms let (tcg, _details) = tm_internals tcm - hpt_new <- - withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do - let compilerBackend comp env ms' _ _mb_old_iface _ = - withTempSession (\_ -> env) $ - hscBackend comp tcg ms' Nothing - - hsc_env <- getSession - mod_info <- do - mb_linkable <- - case ms_obj_date ms of + mb_linkable <- case ms_obj_date ms of Just t | t > ms_hs_date ms -> do l <- liftIO $ findObjectLinkable (ms_mod ms) (ml_obj_file loc) t return (Just l) _otherwise -> return Nothing - compile' (compilerBackend hscNothingCompiler - ,compilerBackend hscInteractiveCompiler - ,hscCheckRecompBackend hscBatchCompiler tcg) - hsc_env ms 1 1 Nothing mb_linkable - -- compile' shouldn't change the environment - return $ addToUFM (hsc_HPT hsc_env) mod mod_info - modifySession $ \e -> e{ hsc_HPT = hpt_new } + -- compile doesn't change the session + hsc_env <- getSession + mod_info <- liftIO $ compile' (hscNothingBackendOnly tcg, + hscInteractiveBackendOnly tcg, + hscBatchBackendOnly tcg) + hsc_env ms 1 1 Nothing mb_linkable + + modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info } return tcm +-- ----------------------------------------------------------------------------- +-- Operations dealing with Core + +-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for +-- the 'GHC.compileToCoreModule' interface. +data CoreModule + = CoreModule { + -- | Module name + cm_module :: !Module, + -- | Type environment for types declared in this module + cm_types :: !TypeEnv, + -- | Declarations + cm_binds :: [CoreBind], + -- | Imports + cm_imports :: ![Module] + } + +instance Outputable CoreModule where + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = + text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' parses, typechecks, and @@ -1166,40 +1137,9 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do ms_hspp_buf = Nothing } - let maybe_simplify mod_guts | simplify = hscSimplify mod_guts - | otherwise = return mod_guts - guts <- maybe_simplify (mkModGuts cm) - (iface, changed, _details, cgguts) - <- hscNormalIface guts Nothing - hscWriteIface iface changed modSummary - _ <- hscGenHardCode cgguts modSummary - return () - --- Makes a "vanilla" ModGuts. -mkModGuts :: CoreModule -> ModGuts -mkModGuts coreModule = ModGuts { - mg_module = cm_module coreModule, - mg_boot = False, - mg_exports = [], - mg_deps = noDependencies, - mg_dir_imps = emptyModuleEnv, - mg_used_names = emptyNameSet, - mg_rdr_env = emptyGlobalRdrEnv, - mg_fix_env = emptyFixityEnv, - mg_types = emptyTypeEnv, - mg_insts = [], - mg_fam_insts = [], - mg_rules = [], - mg_binds = cm_binds coreModule, - mg_foreign = NoStubs, - mg_warns = NoWarnings, - mg_anns = [], - mg_hpc_info = emptyHpcInfo False, - mg_modBreaks = emptyModBreaks, - mg_vect_info = noVectInfo, - mg_inst_env = emptyInstEnv, - mg_fam_inst_env = emptyFamInstEnv -} + hsc_env <- getSession + liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm) + compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule compileCore simplify fn = do @@ -1222,7 +1162,7 @@ compileCore simplify fn = do -- If simplify is true: simplify (hscSimplify), then tidy -- (tidyProgram). hsc_env <- getSession - simpl_guts <- hscSimplify mod_guts + simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts return $ Left tidy_guts else @@ -1435,54 +1375,54 @@ findPartiallyCompletedCycles modsDone theGraph -- There better had not be any cyclic groups here -- we check for them. upsweep - :: GhcMonad m => - HscEnv -- ^ Includes initially-empty HPT - -> HomePackageTable -- ^ HPT from last time round (pruned) + :: GhcMonad m + => HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) -> IO () -- ^ How to clean up unwanted tmp files -> [SCC ModSummary] -- ^ Mods to do (the worklist) -> m (SuccessFlag, - HscEnv, - [ModSummary]) + [ModSummary]) -- ^ Returns: -- -- 1. A flag whether the complete upsweep was successful. - -- 2. The 'HscEnv' with an updated HPT + -- 2. The 'HscEnv' in the monad has an updated HPT -- 3. A list of modules which succeeded loading. -upsweep hsc_env old_hpt stable_mods cleanup sccs = do - (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs) - return (res, hsc_env, reverse done) +upsweep old_hpt stable_mods cleanup sccs = do + (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) + return (res, reverse done) where - upsweep' hsc_env _old_hpt done + upsweep' _old_hpt done [] _ _ - = return (Succeeded, hsc_env, done) + = return (Succeeded, done) - upsweep' hsc_env _old_hpt done + upsweep' _old_hpt done (CyclicSCC ms:_) _ _ - = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms) - return (Failed, hsc_env, done) + = do dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + return (Failed, done) - upsweep' hsc_env old_hpt done + upsweep' old_hpt done (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) - let logger = reportModuleCompilationResult (hsc_callbacks hsc_env) + let logger _mod = defaultWarnErrLogger + hsc_env <- getSession mb_mod_info <- handleSourceError (\err -> do logger mod (Just err); return Nothing) $ do - mod_info <- upsweep_mod hsc_env old_hpt stable_mods - mod mod_index nmods + mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods + mod mod_index nmods logger mod Nothing -- log warnings return (Just mod_info) liftIO cleanup -- Remove unwanted tmp files between compilations case mb_mod_info of - Nothing -> return (Failed, hsc_env, done) + Nothing -> return (Failed, done) Just mod_info -> do let this_mod = ms_mod_name mod @@ -1505,19 +1445,19 @@ upsweep hsc_env old_hpt stable_mods cleanup sccs = do -- fixup our HomePackageTable after we've finished compiling -- a mutually-recursive loop. See reTypecheckLoop, below. hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' + setSession hsc_env2 - upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods + upsweep' old_hpt1 done' mods (mod_index+1) nmods -- | Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: GhcMonad m => - HscEnv +upsweep_mod :: HscEnv -> HomePackageTable -> ([ModuleName],[ModuleName]) -> ModSummary -> Int -- index of module -> Int -- total number of modules - -> m HomeModInfo + -> IO HomeModInfo upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods = let @@ -1569,13 +1509,15 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods where iface = hm_iface hm_info - compile_it :: GhcMonad m => Maybe Linkable -> m HomeModInfo - compile_it = compile hsc_env summary' mod_index nmods mb_old_iface + compile_it :: Maybe Linkable -> IO HomeModInfo + compile_it mb_linkable = + compile hsc_env summary' mod_index nmods + mb_old_iface mb_linkable - compile_it_discard_iface :: GhcMonad m => - Maybe Linkable -> m HomeModInfo - compile_it_discard_iface - = compile hsc_env summary' mod_index nmods Nothing + compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo + compile_it_discard_iface mb_linkable = + compile hsc_env summary' mod_index nmods + Nothing mb_linkable -- With the HscNothing target we create empty linkables to avoid -- recompilation. We have to detect these to recompile anyway if @@ -1857,7 +1799,7 @@ nodeMapElts = Map.elems -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE -- were necessary, then the edge would be part of a cycle. warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () -warnUnnecessarySourceImports sccs = +warnUnnecessarySourceImports sccs = do logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) where check ms = let mods_in_this_cycle = map ms_mod_name ms in @@ -1885,22 +1827,19 @@ warnUnnecessarySourceImports sccs = -- module, plus one for any hs-boot files. The imports of these nodes -- are all there, including the imports of non-home-package modules. -downsweep :: GhcMonad m => - HscEnv +downsweep :: HscEnv -> [ModSummary] -- Old summaries -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have -- the same module name; this is -- very useful for ghc -M - -> m [ModSummary] + -> IO [ModSummary] -- The elts of [ModSummary] all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true -- in which case there can be repeats downsweep hsc_env old_summaries excl_mods allow_dup_roots - = do -- catch error messages and return them - --handleErrMsg -- should be covered by GhcMonad now - -- (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do + = do rootSummaries <- mapM getRootSummary roots let root_map = mkRootMap rootSummaries checkDuplicates root_map @@ -1912,7 +1851,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots old_summary_map :: NodeMap ModSummary old_summary_map = mkNodeMap old_summaries - getRootSummary :: GhcMonad m => Target -> m ModSummary + getRootSummary :: Target -> IO ModSummary getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) = do exists <- liftIO $ doesFileExist file if exists @@ -1934,7 +1873,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- name, so we have to check that there aren't multiple root files -- defining the same module (otherwise the duplicates will be silently -- ignored, leading to confusing behaviour). - checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m () + checkDuplicates :: NodeMap [ModSummary] -> IO () checkDuplicates root_map | allow_dup_roots = return () | null dup_roots = return () @@ -1943,14 +1882,13 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots dup_roots :: [[ModSummary]] -- Each at least of length 2 dup_roots = filterOut isSingleton (nodeMapElts root_map) - loop :: GhcMonad m => - [(Located ModuleName,IsBootInterface)] + loop :: [(Located ModuleName,IsBootInterface)] -- Work list: process these modules -> NodeMap [ModSummary] -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True - -> m [ModSummary] + -> IO [ModSummary] -- The result includes the worklist, except -- for those mentioned in the visited set loop [] done = return (concat (nodeMapElts done)) @@ -1959,7 +1897,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = if isSingleton summs then loop ss done else - do { liftIO $ multiRootsErr summs; return [] } + do { multiRootsErr summs; return [] } | otherwise = do mb_s <- summariseModule hsc_env old_summary_map is_boot wanted_mod True @@ -2018,14 +1956,13 @@ ms_home_imps = home_imps . ms_imps -- resides. summariseFile - :: GhcMonad m => - HscEnv + :: HscEnv -> [ModSummary] -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase -> Bool -- object code allowed? -> Maybe (StringBuffer,ClockTime) - -> m ModSummary + -> IO ModSummary summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf -- we can use a cached summary if one is available and the @@ -2104,15 +2041,14 @@ findSummaryBySourceFile summaries file -- Summarise a module, and pick up source and timestamp. summariseModule - :: GhcMonad m => - HscEnv + :: HscEnv -> NodeMap ModSummary -- Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised -> Bool -- object code allowed? -> Maybe (StringBuffer, ClockTime) -> [ModuleName] -- Modules to exclude - -> m (Maybe ModSummary) -- Its new summary + -> IO (Maybe ModSummary) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) obj_allowed maybe_buf excl_mods @@ -2131,11 +2067,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) case maybe_buf of Just (_,t) -> check_timestamp old_summary location src_fn t Nothing -> do - m <- liftIO $ System.IO.Error.try (getModificationTime src_fn) + m <- System.IO.Error.try (getModificationTime src_fn) case m of Right t -> check_timestamp old_summary location src_fn t Left e | isDoesNotExistError e -> find_it - | otherwise -> liftIO $ ioError e + | otherwise -> ioError e | otherwise = find_it where @@ -2146,7 +2082,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) check_timestamp old_summary location src_fn src_timestamp | ms_hs_date old_summary == src_timestamp = do -- update the object-file timestamp - obj_timestamp <- liftIO $ + obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then getObjTimestamp location is_boot @@ -2161,8 +2097,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- previously a package module, it may have now appeared on the -- search path, so we want to consider it to be a home module. If -- the module was previously a home module, it may have moved. - liftIO $ uncacheModule hsc_env wanted_mod - found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing + uncacheModule hsc_env wanted_mod + found <- findImportedModule hsc_env wanted_mod Nothing case found of Found location mod | isJust (ml_hs_file location) -> @@ -2173,7 +2109,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) ASSERT(modulePackageId mod /= thisPackage dflags) return Nothing - err -> liftIO $ noModError dflags loc wanted_mod err + err -> noModError dflags loc wanted_mod err -- Not found just_found location mod = do @@ -2185,7 +2121,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- Check that it exists -- It might have been deleted since the Finder last found it - maybe_t <- liftIO $ modificationTimeIfExists src_fn + maybe_t <- modificationTimeIfExists src_fn case maybe_t of Nothing -> noHsFileErr loc src_fn Just t -> new_summary location' mod src_fn t @@ -2205,7 +2141,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) $$ text "Expected:" <+> quotes (ppr wanted_mod) -- Find the object timestamp, and return the summary - obj_timestamp <- liftIO $ + obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then getObjTimestamp location is_boot @@ -2229,16 +2165,15 @@ getObjTimestamp location is_boot else modificationTimeIfExists (ml_obj_file location) -preprocessFile :: GhcMonad m => - HscEnv +preprocessFile :: HscEnv -> FilePath -> Maybe Phase -- ^ Starting phase -> Maybe (StringBuffer,ClockTime) - -> m (DynFlags, FilePath, StringBuffer) + -> IO (DynFlags, FilePath, StringBuffer) preprocessFile hsc_env src_fn mb_phase Nothing = do (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- liftIO $ hGetStringBuffer hspp_fn + buf <- hGetStringBuffer hspp_fn return (dflags', hspp_fn, buf) preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) @@ -2277,11 +2212,11 @@ noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab noModError dflags loc wanted_mod err = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err -noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a +noHsFileErr :: SrcSpan -> String -> IO a noHsFileErr loc path = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path -packageModErr :: GhcMonad m => ModuleName -> m a +packageModErr :: ModuleName -> IO a packageModErr mod = throwOneError $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is a package module" @@ -2395,7 +2330,7 @@ getModuleInfo mdl = withSession $ \hsc_env -> do getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) #ifdef GHCI getPackageModuleInfo hsc_env mdl = do - (_msgs, mb_avails) <- getModuleExports hsc_env mdl + mb_avails <- hscGetModuleExports hsc_env mdl case mb_avails of Nothing -> return Nothing Just avails -> do @@ -2701,8 +2636,30 @@ obtainTermFromId bound force id = -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any -- entity known to GHC, including 'Name's defined using 'runStmt'. lookupName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupName name = withSession $ \hsc_env -> do - mb_tything <- ioMsg $ tcRnLookupName hsc_env name - return mb_tything - -- XXX: calls panic in some circumstances; is that ok? +lookupName name = + withSession $ \hsc_env -> + liftIO $ hscTcRcLookupName hsc_env name + +-- ----------------------------------------------------------------------------- +-- Pure API + +-- | A pure interface to the module parser. +-- +parser :: String -- ^ Haskell module source text (full Unicode is supported) + -> DynFlags -- ^ the flags + -> FilePath -- ^ the filename (for source locations) + -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) + +parser str dflags filename = + let + loc = mkSrcLoc (mkFastString filename) 1 1 + buf = stringToStringBuffer str + in + case unP Parser.parseModule (mkPState dflags buf loc) of + + PFailed span err -> + Left (unitBag (mkPlainErrMsg span err)) + POk pst rdr_module -> + let (warns,_) = getMessages pst in + Right (warns, rdr_module) diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs new file mode 100644 index 0000000..c62ea4c --- /dev/null +++ b/compiler/main/GhcMonad.hs @@ -0,0 +1,177 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2010 +-- +-- The Session type and related functionality +-- +-- ----------------------------------------------------------------------------- + +module GhcMonad ( + -- * 'Ghc' monad stuff + GhcMonad(..), + Ghc(..), + GhcT(..), liftGhcT, + reflectGhc, reifyGhc, + getSessionDynFlags, + liftIO, + Session(..), withSession, modifySession, withTempSession, + + -- ** Warnings + logWarnings + ) where + +import MonadUtils +import HscTypes +import DynFlags +import Exception +import ErrUtils + +import Data.IORef + +-- ----------------------------------------------------------------------------- +-- | A monad that has all the features needed by GHC API calls. +-- +-- In short, a GHC monad +-- +-- - allows embedding of IO actions, +-- +-- - can log warnings, +-- +-- - allows handling of (extensible) exceptions, and +-- +-- - maintains a current session. +-- +-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' +-- before any call to the GHC API functions can occur. +-- +class (Functor m, MonadIO m, ExceptionMonad m) => GhcMonad m where + getSession :: m HscEnv + setSession :: HscEnv -> m () + + +-- | Call the argument with the current session. +withSession :: GhcMonad m => (HscEnv -> m a) -> m a +withSession f = getSession >>= f + +-- | Grabs the DynFlags from the Session +getSessionDynFlags :: GhcMonad m => m DynFlags +getSessionDynFlags = withSession (return . hsc_dflags) + +-- | Set the current session to the result of applying the current session to +-- the argument. +modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () +modifySession f = do h <- getSession + setSession $! f h + +withSavedSession :: GhcMonad m => m a -> m a +withSavedSession m = do + saved_session <- getSession + m `gfinally` setSession saved_session + +-- | Call an action with a temporarily modified Session. +withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a +withTempSession f m = + withSavedSession $ modifySession f >> m + +-- ----------------------------------------------------------------------------- +-- | A monad that allows logging of warnings. + +logWarnings :: GhcMonad m => WarningMessages -> m () +logWarnings warns = do + dflags <- getSessionDynFlags + liftIO $ printOrThrowWarnings dflags warns + +-- ----------------------------------------------------------------------------- +-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, +-- e.g., to maintain additional state consider wrapping this monad or using +-- 'GhcT'. +newtype Ghc a = Ghc { unGhc :: Session -> IO a } + +-- | The Session is a handle to the complete state of a compilation +-- session. A compilation session consists of a set of modules +-- constituting the current program or library, the context for +-- interactive evaluation, and various caches. +data Session = Session !(IORef HscEnv) + +instance Functor Ghc where + fmap f m = Ghc $ \s -> f `fmap` unGhc m s + +instance Monad Ghc where + return a = Ghc $ \_ -> return a + m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s + +instance MonadIO Ghc where + liftIO ioA = Ghc $ \_ -> ioA + +instance ExceptionMonad Ghc where + gcatch act handle = + Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s + gblock (Ghc m) = Ghc $ \s -> gblock (m s) + gunblock (Ghc m) = Ghc $ \s -> gunblock (m s) + gmask f = + Ghc $ \s -> gmask $ \io_restore -> + let + g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) + in + unGhc (f g_restore) s + +instance GhcMonad Ghc where + getSession = Ghc $ \(Session r) -> readIORef r + setSession s' = Ghc $ \(Session r) -> writeIORef r s' + +-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. +-- +-- You can use this to call functions returning an action in the 'Ghc' monad +-- inside an 'IO' action. This is needed for some (too restrictive) callback +-- arguments of some library functions: +-- +-- > libFunc :: String -> (Int -> IO a) -> IO a +-- > ghcFunc :: Int -> Ghc a +-- > +-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a +-- > ghcFuncUsingLibFunc str = +-- > reifyGhc $ \s -> +-- > libFunc $ \i -> do +-- > reflectGhc (ghcFunc i) s +-- +reflectGhc :: Ghc a -> Session -> IO a +reflectGhc m = unGhc m + +-- > Dual to 'reflectGhc'. See its documentation. +reifyGhc :: (Session -> IO a) -> Ghc a +reifyGhc act = Ghc $ act + +-- ----------------------------------------------------------------------------- +-- | A monad transformer to add GHC specific features to another monad. +-- +-- Note that the wrapped monad must support IO and handling of exceptions. +newtype GhcT m a = GhcT { unGhcT :: Session -> m a } +liftGhcT :: Monad m => m a -> GhcT m a +liftGhcT m = GhcT $ \_ -> m + +instance Functor m => Functor (GhcT m) where + fmap f m = GhcT $ \s -> f `fmap` unGhcT m s + +instance Monad m => Monad (GhcT m) where + return x = GhcT $ \_ -> return x + m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s + +instance MonadIO m => MonadIO (GhcT m) where + liftIO ioA = GhcT $ \_ -> liftIO ioA + +instance ExceptionMonad m => ExceptionMonad (GhcT m) where + gcatch act handle = + GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s + gblock (GhcT m) = GhcT $ \s -> gblock (m s) + gunblock (GhcT m) = GhcT $ \s -> gunblock (m s) + gmask f = + GhcT $ \s -> gmask $ \io_restore -> + let + g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) + in + unGhcT (f g_restore) s + +instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where + getSession = GhcT $ \(Session r) -> liftIO $ readIORef r + setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 508f855..4e455a6 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -33,9 +33,9 @@ import Outputable import Pretty () import Maybes import Bag ( emptyBag, listToBag, unitBag ) - -import MonadUtils ( MonadIO ) +import MonadUtils import Exception + import Control.Monad import System.IO import System.IO.Unsafe @@ -46,14 +46,13 @@ import Data.List -- | Parse the imports of a source file. -- -- Throws a 'SourceError' if parsing fails. -getImports :: GhcMonad m => - DynFlags +getImports :: DynFlags -> StringBuffer -- ^ Parse this. -> FilePath -- ^ Filename the buffer came from. Used for -- reporting parse error locations. -> FilePath -- ^ The original source filename (used for locations -- in the function result) - -> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName) + -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName) -- ^ The source imports, normal imports, and the module name. getImports dflags buf filename source_filename = do let loc = mkSrcLoc (mkFastString filename) 1 1 @@ -66,7 +65,7 @@ getImports dflags buf filename source_filename = do ms = (emptyBag, errs) -- logWarnings warns if errorsFound dflags ms - then liftIO $ throwIO $ mkSrcErr errs + then throwIO $ mkSrcErr errs else case rdr_module of L _ (HsModule mb_mod _ imps _ _ _) -> @@ -114,7 +113,7 @@ mkPrelImports this_mod implicit_prelude import_decls loc = mkGeneralSrcSpan (fsLit "Implicit import declaration") -parseError :: GhcMonad m => SrcSpan -> Message -> m a +parseError :: SrcSpan -> Message -> IO a parseError span err = throwOneError $ mkPlainErrMsg span err -------------------------------------------------------------- diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 42ed3e4..d52337e 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -2,57 +2,83 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 % \begin{code} --- | Main driver for the compiling plain Haskell source code. +-- | Main API for compiling plain Haskell source code. -- --- This module implements compilation of a Haskell-only source file. It is --- /not/ concerned with preprocessing of source files; this is handled in --- "DriverPipeline". +-- This module implements compilation of a Haskell source. It is +-- /not/ concerned with preprocessing of source files; this is handled +-- in "DriverPipeline". +-- +-- There are various entry points depending on what mode we're in: +-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and +-- "interactive" mode (GHCi). There are also entry points for +-- individual passes: parsing, typechecking/renaming, desugaring, and +-- simplification. +-- +-- All the functions here take an 'HscEnv' as a parameter, but none of +-- them return a new one: 'HscEnv' is treated as an immutable value +-- from here on in (although it has mutable components, for the +-- caches). +-- +-- Warning messages are dealt with consistently throughout this API: +-- during compilation warnings are collected, and before any function +-- in @HscMain@ returns, the warnings are either printed, or turned +-- into a real compialtion error if the @-Werror@ flag is enabled. -- module HscMain - ( newHscEnv, hscCmmFile - , hscParseIdentifier - , hscSimplify - , hscNormalIface, hscWriteIface, hscGenHardCode -#ifdef GHCI - , hscStmt, hscTcExpr, hscImport, hscKcType - , compileExpr -#endif - , HsCompiler(..) - , hscOneShotCompiler, hscNothingCompiler - , hscInteractiveCompiler, hscBatchCompiler - , hscCompileOneShot -- :: Compiler HscStatus - , hscCompileBatch -- :: Compiler (HscStatus, ModIface, ModDetails) - , hscCompileNothing -- :: Compiler (HscStatus, ModIface, ModDetails) - , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails) - , hscCheckRecompBackend + ( + -- * Making an HscEnv + newHscEnv + + -- * Compiling complete source files + , Compiler , HscStatus' (..) , InteractiveStatus, HscStatus - - -- The new interface + , hscCompileOneShot + , hscCompileBatch + , hscCompileNothing + , hscCompileInteractive + , hscCompileCmmFile + , hscCompileCore + + -- * Running passes separately , hscParse - , hscTypecheck , hscTypecheckRename , hscDesugar , makeSimpleIface , makeSimpleDetails + , hscSimplify -- ToDo, shouldn't really export this + + -- ** Backends + , hscOneShotBackendOnly + , hscBatchBackendOnly + , hscNothingBackendOnly + , hscInteractiveBackendOnly + + -- * Support for interactive evaluation + , hscParseIdentifier + , hscTcRcLookupName + , hscTcRnGetInfo + , hscRnImportDecls +#ifdef GHCI + , hscGetModuleExports + , hscTcRnLookupRdrName + , hscStmt, hscTcExpr, hscImport, hscKcType + , hscCompileCoreExpr +#endif + ) where #ifdef GHCI -import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) import CoreTidy ( tidyExpr ) -import CorePrep ( corePrepExpr ) -import Desugar ( deSugarExpr ) -import SimplCore ( simplifyExpr ) -import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) -import Type ( Type, tyVarsOfTypes ) +import Type ( Type ) +import TcType ( tyVarsOfTypes ) import PrelNames ( iNTERACTIVE ) import {- Kind parts of -} Type ( Kind ) import Id ( idType ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) -import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc ) import VarSet import VarEnv ( emptyTidyEnv ) import Panic @@ -63,22 +89,22 @@ import Module ( emptyModuleEnv, ModLocation(..), Module ) import RdrName import HsSyn import CoreSyn -import SrcLoc ( Located(..) ) import StringBuffer import Parser -import Lexer -import SrcLoc ( mkSrcLoc ) -import TcRnDriver ( tcRnModule ) +import Lexer hiding (getDynFlags) +import SrcLoc +import TcRnDriver import TcIface ( typecheckIface ) -import TcRnMonad ( initIfaceCheck, TcGblEnv(..) ) +import TcRnMonad +import RnNames ( rnImports ) import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) import MkIface -import Desugar ( deSugar ) -import SimplCore ( core2core ) +import Desugar +import SimplCore import TidyPgm -import CorePrep ( corePrepPgm ) +import CorePrep import CoreToStg ( coreToStg ) import qualified StgCmm ( codeGen ) import StgSyn @@ -98,14 +124,18 @@ import OptimizationFuel ( initOptFuelState ) import CmmCvt import CmmTx import CmmContFlowOpt -import CodeOutput ( codeOutput ) +import CodeOutput import NameEnv ( emptyNameEnv ) +import NameSet ( emptyNameSet ) +import InstEnv +import FamInstEnv ( emptyFamInstEnv ) import Fingerprint ( Fingerprint ) import DynFlags import ErrUtils import UniqSupply ( mkSplitUniqSupply ) +import MonadUtils import Outputable import HscStats ( ppSourceStats ) import HscTypes @@ -113,7 +143,7 @@ import MkExternalCore ( emitExternalCore ) import FastString import UniqFM ( emptyUFM ) import UniqSupply ( initUs_ ) -import Bag ( unitBag ) +import Bag import Exception -- import MonadUtils @@ -131,8 +161,8 @@ import Data.IORef %************************************************************************ \begin{code} -newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv -newHscEnv callbacks dflags +newHscEnv :: DynFlags -> IO HscEnv +newHscEnv dflags = do { eps_var <- newIORef initExternalPackageState ; us <- mkSplitUniqSupply 'r' ; nc_var <- newIORef (initNameCache us knownKeyNames) @@ -140,7 +170,6 @@ newHscEnv callbacks dflags ; mlc_var <- newIORef emptyModuleEnv ; optFuel <- initOptFuelState ; return (HscEnv { hsc_dflags = dflags, - hsc_callbacks = callbacks, hsc_targets = [], hsc_mod_graph = [], hsc_IC = emptyInteractiveContext, @@ -160,19 +189,145 @@ knownKeyNames = map getName wiredInThings #ifdef GHCI ++ templateHaskellNames #endif -\end{code} +-- ----------------------------------------------------------------------------- +-- The Hsc monad: collecting warnings -\begin{code} +newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) + +instance Monad Hsc where + return a = Hsc $ \_ w -> return (a, w) + Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w + case k a of + Hsc k' -> k' e w1 + +instance MonadIO Hsc where + liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) + +runHsc :: HscEnv -> Hsc a -> IO a +runHsc hsc_env (Hsc hsc) = do + (a, w) <- hsc hsc_env emptyBag + printOrThrowWarnings (hsc_dflags hsc_env) w + return a + +getWarnings :: Hsc WarningMessages +getWarnings = Hsc $ \_ w -> return (w, w) + +clearWarnings :: Hsc () +clearWarnings = Hsc $ \_ _w -> return ((), emptyBag) + +logWarnings :: WarningMessages -> Hsc () +logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) + +getHscEnv :: Hsc HscEnv +getHscEnv = Hsc $ \e w -> return (e, w) + +getDynFlags :: Hsc DynFlags +getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) + +handleWarnings :: Hsc () +handleWarnings = do + dflags <- getDynFlags + w <- getWarnings + liftIO $ printOrThrowWarnings dflags w + clearWarnings + +-- | log warning in the monad, and if there are errors then +-- throw a SourceError exception. +logWarningsReportErrors :: Messages -> Hsc () +logWarningsReportErrors (warns,errs) = do + logWarnings warns + when (not (isEmptyBag errs)) $ do + liftIO $ throwIO $ mkSrcErr errs + +-- | Deal with errors and warnings returned by a compilation step +-- +-- In order to reduce dependencies to other parts of the compiler, functions +-- outside the "main" parts of GHC return warnings and errors as a parameter +-- and signal success via by wrapping the result in a 'Maybe' type. This +-- function logs the returned warnings and propagates errors as exceptions +-- (of type 'SourceError'). +-- +-- This function assumes the following invariants: +-- +-- 1. If the second result indicates success (is of the form 'Just x'), +-- there must be no error messages in the first result. +-- +-- 2. If there are no error messages, but the second result indicates failure +-- there should be warnings in the first result. That is, if the action +-- failed, it must have been due to the warnings (i.e., @-Werror@). +ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a +ioMsgMaybe ioA = do + ((warns,errs), mb_r) <- liftIO $ ioA + logWarnings warns + case mb_r of + Nothing -> liftIO $ throwIO (mkSrcErr errs) + Just r -> ASSERT( isEmptyBag errs ) return r + +-- | like ioMsgMaybe, except that we ignore error messages and return +-- 'Nothing' instead. +ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' ioA = do + ((warns,_errs), mb_r) <- liftIO $ ioA + logWarnings warns + return mb_r + +-- ----------------------------------------------------------------------------- +-- | Lookup things in the compiler's environment + +#ifdef GHCI +hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name] +hscTcRnLookupRdrName hsc_env rdr_name = + runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name +#endif + +hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +hscTcRcLookupName hsc_env name = + runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name + -- ignore errors: the only error we're likely to get is + -- "name not found", and the Maybe in the return type + -- is used to indicate that. + +hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [Instance])) +hscTcRnGetInfo hsc_env name = + runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name + +#ifdef GHCI +hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo]) +hscGetModuleExports hsc_env mdl = + runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl +#endif + +-- ----------------------------------------------------------------------------- +-- | Rename some import declarations + +hscRnImportDecls + :: HscEnv + -> Module + -> [LImportDecl RdrName] + -> IO GlobalRdrEnv + +hscRnImportDecls hsc_env this_mod import_decls = runHsc hsc_env $ do + (_, r, _, _) <- + ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $ + rnImports import_decls + return r + +-- ----------------------------------------------------------------------------- -- | parse a file, returning the abstract syntax -hscParse :: GhcMonad m => - ModSummary - -> m (Located (HsModule RdrName)) -hscParse mod_summary = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env + +hscParse :: HscEnv -> ModSummary -> IO (Located (HsModule RdrName)) +hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary + +-- internal version, that doesn't fail due to -Werror +hscParse' :: ModSummary -> Hsc (Located (HsModule RdrName)) +hscParse' mod_summary + = do + dflags <- getDynFlags + let src_filename = ms_hspp_file mod_summary maybe_src_buf = ms_hspp_buf mod_summary + -------------------------- Parser ---------------- liftIO $ showPass dflags "Parser" {-# SCC "Parser" #-} do @@ -188,30 +343,17 @@ hscParse mod_summary = do case unP parseModule (mkPState dflags buf loc) of PFailed span err -> - throwOneError (mkPlainErrMsg span err) + liftIO $ throwOneError (mkPlainErrMsg span err) POk pst rdr_module -> do - let ms@(warns,errs) = getMessages pst - logWarnings warns - if errorsFound dflags ms then - liftIO $ throwIO $ mkSrcErr errs - else liftIO $ do - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; - dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" - (ppSourceStats False rdr_module) ; - return rdr_module + logWarningsReportErrors (getMessages pst) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $ + ppr rdr_module + liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $ + ppSourceStats False rdr_module + return rdr_module -- ToDo: free the string buffer later. --- | Rename and typecheck a module -hscTypecheck :: GhcMonad m => - ModSummary -> Located (HsModule RdrName) - -> m TcGblEnv -hscTypecheck mod_summary rdr_module = do - hsc_env <- getSession - r <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module - return r - -- XXX: should this really be a Maybe X? Check under which circumstances this -- can become a Nothing and decide whether this should instead throw an -- exception/signal an error. @@ -220,48 +362,59 @@ type RenamedStuff = Maybe LHsDocString)) -- | Rename and typecheck a module, additionally returning the renamed syntax -hscTypecheckRename :: - GhcMonad m => - ModSummary -> Located (HsModule RdrName) - -> m (TcGblEnv, RenamedStuff) -hscTypecheckRename mod_summary rdr_module = do - hsc_env <- getSession - tc_result +hscTypecheckRename :: HscEnv -> ModSummary -> Located (HsModule RdrName) + -> IO (TcGblEnv, RenamedStuff) +hscTypecheckRename hsc_env mod_summary rdr_module + = runHsc hsc_env $ do + tc_result <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module + ioMsgMaybe $ + tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module - let -- This 'do' is in the Maybe monad! - rn_info = do { decl <- tcg_rn_decls tc_result - ; let imports = tcg_rn_imports tc_result + let -- This 'do' is in the Maybe monad! + rn_info = do decl <- tcg_rn_decls tc_result + let imports = tcg_rn_imports tc_result exports = tcg_rn_exports tc_result doc_hdr = tcg_doc_hdr tc_result - ; return (decl,imports,exports,doc_hdr) } + return (decl,imports,exports,doc_hdr) - return (tc_result, rn_info) + return (tc_result, rn_info) -- | Convert a typechecked module to Core -hscDesugar :: GhcMonad m => ModSummary -> TcGblEnv -> m ModGuts -hscDesugar mod_summary tc_result = - withSession $ \hsc_env -> - ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result +hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts +hscDesugar hsc_env mod_summary tc_result + = runHsc hsc_env $ hscDesugar' mod_summary tc_result + +hscDesugar' :: ModSummary -> TcGblEnv -> Hsc ModGuts +hscDesugar' mod_summary tc_result + = do + hsc_env <- getHscEnv + r <- ioMsgMaybe $ + deSugar hsc_env (ms_location mod_summary) tc_result + + handleWarnings + -- always check -Werror after desugaring, this is + -- the last opportunity for warnings to arise before + -- the backend. + return r -- | Make a 'ModIface' from the results of typechecking. Used when -- not optimising, and the interface doesn't need to contain any -- unfoldings or other cross-module optimisation info. -- ToDo: the old interface is only needed to get the version numbers, -- we should use fingerprint versions instead. -makeSimpleIface :: GhcMonad m => +makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails - -> m (ModIface,Bool) -makeSimpleIface maybe_old_iface tc_result details = - withSession $ \hsc_env -> - ioMsgMaybe $ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result + -> IO (ModIface,Bool) +makeSimpleIface hsc_env maybe_old_iface tc_result details + = runHsc hsc_env $ + ioMsgMaybe $ + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result -- | Make a 'ModDetails' from the results of typechecking. Used when -- typechecking only, as opposed to full compilation. -makeSimpleDetails :: GhcMonad m => TcGblEnv -> m ModDetails -makeSimpleDetails tc_result = - withSession $ \hsc_env -> liftIO $ mkBootModDetailsTc hsc_env tc_result +makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails +makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result \end{code} %************************************************************************ @@ -327,82 +480,82 @@ type InteractiveResult = (InteractiveStatus, ModIface, ModDetails) -- FIXME: The old interface and module index are only using in 'batch' and -- 'interactive' mode. They should be removed from 'oneshot' mode. -type Compiler result = GhcMonad m => - HscEnv +type Compiler result = HscEnv -> ModSummary -> Bool -- True <=> source unchanged -> Maybe ModIface -- Old interface, if available -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs) - -> m result + -> IO result data HsCompiler a = HsCompiler { -- | Called when no recompilation is necessary. - hscNoRecomp :: GhcMonad m => - ModIface -> m a, + hscNoRecomp :: ModIface + -> Hsc a, -- | Called to recompile the module. - hscRecompile :: GhcMonad m => - ModSummary -> Maybe Fingerprint -> m a, + hscRecompile :: ModSummary -> Maybe Fingerprint + -> Hsc a, - hscBackend :: GhcMonad m => - TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a, + hscBackend :: TcGblEnv -> ModSummary -> Maybe Fingerprint + -> Hsc a, -- | Code generation for Boot modules. - hscGenBootOutput :: GhcMonad m => - TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a, + hscGenBootOutput :: TcGblEnv -> ModSummary -> Maybe Fingerprint + -> Hsc a, -- | Code generation for normal modules. - hscGenOutput :: GhcMonad m => - ModGuts -> ModSummary -> Maybe Fingerprint -> m a + hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint + -> Hsc a } -genericHscCompile :: GhcMonad m => - HsCompiler a - -> (Maybe (Int,Int) -> Bool -> ModSummary -> m ()) +genericHscCompile :: HsCompiler a + -> (HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ()) -> HscEnv -> ModSummary -> Bool -> Maybe ModIface -> Maybe (Int, Int) - -> m a -genericHscCompile compiler hscMessage - hsc_env mod_summary source_unchanged - mb_old_iface0 mb_mod_index = - withTempSession (\_ -> hsc_env) $ do + -> IO a +genericHscCompile compiler hscMessage hsc_env + mod_summary source_unchanged + mb_old_iface0 mb_mod_index + = do (recomp_reqd, mb_checked_iface) <- {-# SCC "checkOldIface" #-} - liftIO $ checkOldIface hsc_env mod_summary - source_unchanged mb_old_iface0 + checkOldIface hsc_env mod_summary + source_unchanged mb_old_iface0 -- save the interface that comes back from checkOldIface. -- In one-shot mode we don't have the old iface until this -- point, when checkOldIface reads it from the disk. let mb_old_hash = fmap mi_iface_hash mb_checked_iface case mb_checked_iface of Just iface | not recomp_reqd - -> do hscMessage mb_mod_index False mod_summary - hscNoRecomp compiler iface + -> do hscMessage hsc_env mb_mod_index False mod_summary + runHsc hsc_env $ hscNoRecomp compiler iface _otherwise - -> do hscMessage mb_mod_index True mod_summary - hscRecompile compiler mod_summary mb_old_hash + -> do hscMessage hsc_env mb_mod_index True mod_summary + runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a hscCheckRecompBackend compiler tc_result - hsc_env mod_summary source_unchanged mb_old_iface _m_of_n = - withTempSession (\_ -> hsc_env) $ do + hsc_env mod_summary source_unchanged mb_old_iface _m_of_n + = do (recomp_reqd, mb_checked_iface) <- {-# SCC "checkOldIface" #-} - liftIO $ checkOldIface hsc_env mod_summary - source_unchanged mb_old_iface + checkOldIface hsc_env mod_summary + source_unchanged mb_old_iface let mb_old_hash = fmap mi_iface_hash mb_checked_iface case mb_checked_iface of Just iface | not recomp_reqd - -> hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) } + -> runHsc hsc_env $ + hscNoRecomp compiler + iface{ mi_globals = Just (tcg_rdr_env tc_result) } _otherwise - -> hscBackend compiler tc_result mod_summary mb_old_hash + -> runHsc hsc_env $ + hscBackend compiler tc_result mod_summary mb_old_hash -genericHscRecompile :: GhcMonad m => - HsCompiler a +genericHscRecompile :: HsCompiler a -> ModSummary -> Maybe Fingerprint - -> m a + -> Hsc a genericHscRecompile compiler mod_summary mb_old_hash | ExtCoreFile <- ms_hsc_src mod_summary = panic "GHC does not currently support reading External Core files" @@ -410,17 +563,21 @@ genericHscRecompile compiler mod_summary mb_old_hash tc_result <- hscFileFrontEnd mod_summary hscBackend compiler tc_result mod_summary mb_old_hash -genericHscBackend :: GhcMonad m => - HsCompiler a +genericHscBackend :: HsCompiler a -> TcGblEnv -> ModSummary -> Maybe Fingerprint - -> m a + -> Hsc a genericHscBackend compiler tc_result mod_summary mb_old_hash | HsBootFile <- ms_hsc_src mod_summary = hscGenBootOutput compiler tc_result mod_summary mb_old_hash | otherwise = do - guts <- hscDesugar mod_summary tc_result + guts <- hscDesugar' mod_summary tc_result hscGenOutput compiler guts mod_summary mb_old_hash +compilerBackend :: HsCompiler a -> TcGblEnv -> Compiler a +compilerBackend comp tcg hsc_env ms' _ _mb_old_iface _ = + runHsc hsc_env $ + hscBackend comp tcg ms' Nothing + -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- @@ -430,16 +587,17 @@ hscOneShotCompiler = HsCompiler { hscNoRecomp = \_old_iface -> do - withSession (liftIO . dumpIfaceStats) + hsc_env <- getHscEnv + liftIO $ dumpIfaceStats hsc_env return HscNoRecomp , hscRecompile = genericHscRecompile hscOneShotCompiler , hscBackend = \ tc_result mod_summary mb_old_hash -> do - hsc_env <- getSession - case hscTarget (hsc_dflags hsc_env) of + dflags <- getDynFlags + case hscTarget dflags of HscNothing -> return (HscRecomp False ()) - _otherw -> genericHscBackend hscOneShotCompiler + _otherw -> genericHscBackend hscOneShotCompiler tc_result mod_summary mb_old_hash , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do @@ -448,9 +606,8 @@ hscOneShotCompiler = return (HscRecomp False ()) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do - guts <- hscSimplify guts0 - (iface, changed, _details, cgguts) - <- hscNormalIface guts mb_old_iface + guts <- hscSimplify' guts0 + (iface, changed, _details, cgguts) <- hscNormalIface guts mb_old_iface hscWriteIface iface changed mod_summary hasStub <- hscGenHardCode cgguts mod_summary return (HscRecomp hasStub ()) @@ -458,10 +615,11 @@ hscOneShotCompiler = -- Compile Haskell, boot and extCore in OneShot mode. hscCompileOneShot :: Compiler OneShotResult -hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do +hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n + = do -- One-shot mode needs a knot-tying mutable variable for interface -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. - type_env_var <- liftIO $ newIORef emptyNameEnv + type_env_var <- newIORef emptyNameEnv let mod = ms_mod mod_summary hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } @@ -471,6 +629,9 @@ hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do mb_old_iface mb_i_of_n +hscOneShotBackendOnly :: TcGblEnv -> Compiler OneShotResult +hscOneShotBackendOnly = compilerBackend hscOneShotCompiler + -------------------------------------------------------------- hscBatchCompiler :: HsCompiler BatchResult @@ -486,15 +647,13 @@ hscBatchCompiler = , hscBackend = genericHscBackend hscBatchCompiler , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do - (iface, changed, details) - <- hscSimpleIface tc_result mb_old_iface + (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary return (HscRecomp False (), iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do - guts <- hscSimplify guts0 - (iface, changed, details, cgguts) - <- hscNormalIface guts mb_old_iface + guts <- hscSimplify' guts0 + (iface, changed, details, cgguts) <- hscNormalIface guts mb_old_iface hscWriteIface iface changed mod_summary hasStub <- hscGenHardCode cgguts mod_summary return (HscRecomp hasStub (), iface, details) @@ -504,6 +663,9 @@ hscBatchCompiler = hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg +hscBatchBackendOnly :: TcGblEnv -> Compiler BatchResult +hscBatchBackendOnly = hscCheckRecompBackend hscBatchCompiler + -------------------------------------------------------------- hscInteractiveCompiler :: HsCompiler InteractiveResult @@ -522,9 +684,8 @@ hscInteractiveCompiler = return (HscRecomp False Nothing, iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do - guts <- hscSimplify guts0 - (iface, _changed, details, cgguts) - <- hscNormalIface guts mb_old_iface + guts <- hscSimplify' guts0 + (iface, _changed, details, cgguts) <- hscNormalIface guts mb_old_iface hscInteractive (iface, details, cgguts) mod_summary } @@ -532,6 +693,9 @@ hscInteractiveCompiler = hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg +hscInteractiveBackendOnly :: TcGblEnv -> Compiler InteractiveResult +hscInteractiveBackendOnly = compilerBackend hscInteractiveCompiler + -------------------------------------------------------------- hscNothingCompiler :: HsCompiler NothingResult @@ -544,6 +708,7 @@ hscNothingCompiler = , hscRecompile = genericHscRecompile hscNothingCompiler , hscBackend = \tc_result _mod_summary mb_old_iface -> do + handleWarnings (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface return (HscRecomp False (), iface, details) @@ -558,39 +723,40 @@ hscNothingCompiler = hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg +hscNothingBackendOnly :: TcGblEnv -> Compiler NothingResult +hscNothingBackendOnly = compilerBackend hscNothingCompiler + -------------------------------------------------------------- -- NoRecomp handlers -------------------------------------------------------------- -genModDetails :: GhcMonad m => ModIface -> m ModDetails -genModDetails old_iface = - withSession $ \hsc_env -> liftIO $ do +genModDetails :: ModIface -> Hsc ModDetails +genModDetails old_iface + = do + hsc_env <- getHscEnv new_details <- {-# SCC "tcRnIface" #-} - initIfaceCheck hsc_env $ - typecheckIface old_iface - dumpIfaceStats hsc_env + liftIO $ initIfaceCheck hsc_env $ + typecheckIface old_iface + liftIO $ dumpIfaceStats hsc_env return new_details -------------------------------------------------------------- -- Progress displayers. -------------------------------------------------------------- -oneShotMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m () -oneShotMsg _mb_mod_index recomp _mod_summary - = do hsc_env <- getSession - liftIO $ do +oneShotMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO () +oneShotMsg hsc_env _mb_mod_index recomp _mod_summary = if recomp then return () else compilationProgressMsg (hsc_dflags hsc_env) $ "compilation IS NOT required" -batchMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m () -batchMsg mb_mod_index recomp mod_summary - = do hsc_env <- getSession +batchMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO () +batchMsg hsc_env mb_mod_index recomp mod_summary + = do let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $ (showModuleIndex mb_mod_index ++ msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary) - liftIO $ do if recomp then showMsg "Compiling " else if verbosity (hsc_dflags hsc_env) >= 2 @@ -600,47 +766,53 @@ batchMsg mb_mod_index recomp mod_summary -------------------------------------------------------------- -- FrontEnds -------------------------------------------------------------- -hscFileFrontEnd :: GhcMonad m => ModSummary -> m TcGblEnv + +hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv hscFileFrontEnd mod_summary = - do rdr_module <- hscParse mod_summary - hscTypecheck mod_summary rdr_module + do rdr_module <- hscParse' mod_summary + hsc_env <- getHscEnv + {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module -------------------------------------------------------------- -- Simplifiers -------------------------------------------------------------- -hscSimplify :: GhcMonad m => ModGuts -> m ModGuts -hscSimplify ds_result - = do hsc_env <- getSession - simpl_result <- {-# SCC "Core2Core" #-} - liftIO $ core2core hsc_env ds_result - return simpl_result +hscSimplify :: HscEnv -> ModGuts -> IO ModGuts +hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts + +hscSimplify' :: ModGuts -> Hsc ModGuts +hscSimplify' ds_result + = do hsc_env <- getHscEnv + {-# SCC "Core2Core" #-} + liftIO $ core2core hsc_env ds_result -------------------------------------------------------------- -- Interface generators -------------------------------------------------------------- -hscSimpleIface :: GhcMonad m => - TcGblEnv +hscSimpleIface :: TcGblEnv -> Maybe Fingerprint - -> m (ModIface, Bool, ModDetails) + -> Hsc (ModIface, Bool, ModDetails) hscSimpleIface tc_result mb_old_iface - = do hsc_env <- getSession + = do + hsc_env <- getHscEnv details <- liftIO $ mkBootModDetailsTc hsc_env tc_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - ioMsgMaybe $ mkIfaceTc hsc_env mb_old_iface details tc_result + ioMsgMaybe $ + mkIfaceTc hsc_env mb_old_iface details tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env return (new_iface, no_change, details) -hscNormalIface :: GhcMonad m => - ModGuts +hscNormalIface :: ModGuts -> Maybe Fingerprint - -> m (ModIface, Bool, ModDetails, CgGuts) + -> Hsc (ModIface, Bool, ModDetails, CgGuts) hscNormalIface simpl_result mb_old_iface - = do hsc_env <- getSession - + = do + hsc_env <- getHscEnv (cg_guts, details) <- {-# SCC "CoreTidy" #-} liftIO $ tidyProgram hsc_env simpl_result @@ -651,9 +823,10 @@ hscNormalIface simpl_result mb_old_iface -- until after code output (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - ioMsgMaybe $ mkIface hsc_env mb_old_iface - details simpl_result - -- Emit external core + ioMsgMaybe $ + mkIface hsc_env mb_old_iface details simpl_result + + -- Emit external core -- This should definitely be here and not after CorePrep, -- because CorePrep produces unqualified constructor wrapper declarations, -- so its output isn't valid External Core (without some preprocessing). @@ -667,23 +840,23 @@ hscNormalIface simpl_result mb_old_iface -- BackEnd combinators -------------------------------------------------------------- -hscWriteIface :: GhcMonad m => - ModIface -> Bool +hscWriteIface :: ModIface + -> Bool -> ModSummary - -> m () + -> Hsc () + hscWriteIface iface no_change mod_summary - = do hsc_env <- getSession - let dflags = hsc_dflags hsc_env - liftIO $ do + = do dflags <- getDynFlags unless no_change - $ writeIfaceFile dflags (ms_location mod_summary) iface + $ liftIO $ writeIfaceFile dflags (ms_location mod_summary) iface -- | Compile to hard-code. -hscGenHardCode :: GhcMonad m => - CgGuts -> ModSummary - -> m Bool -- ^ @True@ <=> stub.c exists +hscGenHardCode :: CgGuts -> ModSummary + -> Hsc Bool -- ^ @True@ <=> stub.c exists hscGenHardCode cgguts mod_summary - = withSession $ \hsc_env -> liftIO $ do + = do + hsc_env <- getHscEnv + liftIO $ do let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -710,7 +883,8 @@ hscGenHardCode cgguts mod_summary myCoreToStg dflags this_mod prepd_binds ------------------ Code generation ------------------ - cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env) + + cmms <- if dopt Opt_TryNewCodeGen dflags then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons dir_imps cost_centre_info stg_binds hpc_info @@ -731,14 +905,13 @@ hscGenHardCode cgguts mod_summary dependencies rawcmms return stub_c_exists -hscInteractive :: GhcMonad m => - (ModIface, ModDetails, CgGuts) +hscInteractive :: (ModIface, ModDetails, CgGuts) -> ModSummary - -> m (InteractiveStatus, ModIface, ModDetails) + -> Hsc (InteractiveStatus, ModIface, ModDetails) #ifdef GHCI hscInteractive (iface, details, cgguts) mod_summary - = do hsc_env <- getSession - liftIO $ do + = do + dflags <- getDynFlags let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -746,7 +919,7 @@ hscInteractive (iface, details, cgguts) mod_summary cg_tycons = tycons, cg_foreign = foreign_stubs, cg_modBreaks = mod_breaks } = cgguts - dflags = hsc_dflags hsc_env + location = ms_location mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, @@ -756,12 +929,13 @@ hscInteractive (iface, details, cgguts) mod_summary -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm dflags core_binds data_tycons ; + liftIO $ corePrepPgm dflags core_binds data_tycons ; ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks + comp_bc <- liftIO $ byteCodeGen dflags prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff --- (_istub_h_exists, istub_c_exists) - <- outputForeignStubs dflags this_mod location foreign_stubs + <- liftIO $ outputForeignStubs dflags this_mod + location foreign_stubs return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks)) , iface, details) #else @@ -770,15 +944,16 @@ hscInteractive _ _ = panic "GHC not compiled with interpreter" ------------------------------ -hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m () -hscCmmFile hsc_env filename = do - dflags <- return $ hsc_dflags hsc_env - cmm <- ioMsgMaybe $ - parseCmmFile dflags filename - cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm] - rawCmms <- liftIO $ cmmToRawCmm cmms - _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms - return () +hscCompileCmmFile :: HscEnv -> FilePath -> IO () +hscCompileCmmFile hsc_env filename + = runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env + cmm <- ioMsgMaybe $ parseCmmFile dflags filename + liftIO $ do + cmms <- optionallyConvertAndOrCPS hsc_env [cmm] + rawCmms <- cmmToRawCmm cmms + _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms + return () where no_mod = panic "hscCmmFile: no_mod" no_loc = ModLocation{ ml_hs_file = Just filename, @@ -905,116 +1080,155 @@ A naked expression returns a singleton Name [it]. \begin{code} #ifdef GHCI hscStmt -- Compile a stmt all the way to an HValue, but don't run it - :: GhcMonad m => - HscEnv + :: HscEnv -> String -- The statement - -> m (Maybe ([Id], HValue)) + -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error -hscStmt hsc_env stmt = do - maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt +hscStmt hsc_env stmt = runHsc hsc_env $ do + maybe_stmt <- hscParseStmt stmt case maybe_stmt of Nothing -> return Nothing Just parsed_stmt -> do -- The real stuff -- Rename and typecheck it let icontext = hsc_IC hsc_env - (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt + (ids, tc_expr) <- ioMsgMaybe $ + tcRnStmt hsc_env icontext parsed_stmt -- Desugar it let rdr_env = ic_rn_gbl_env icontext type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext)) ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr + handleWarnings -- Then desugar, code gen, and link it let src_span = srcLocSpan interactiveSrcLoc - hval <- liftIO $ compileExpr hsc_env src_span ds_expr + hsc_env <- getHscEnv + hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr return $ Just (ids, hval) -hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName) -hscImport hsc_env str = do - (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str +hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) +hscImport hsc_env str = runHsc hsc_env $ do + (L _ (HsModule{hsmodImports=is})) <- + hscParseThing parseModule str case is of [i] -> return (unLoc i) - _ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration"))) + _ -> liftIO $ throwOneError $ + mkPlainErrMsg noSrcSpan $ + ptext (sLit "parse error in import declaration") hscTcExpr -- Typecheck an expression (but don't run it) - :: GhcMonad m => - HscEnv + :: HscEnv -> String -- The expression - -> m Type + -> IO Type -hscTcExpr hsc_env expr = do - maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr - let icontext = hsc_IC hsc_env +hscTcExpr hsc_env expr = runHsc hsc_env $ do + maybe_stmt <- hscParseStmt expr case maybe_stmt of - Just (L _ (ExprStmt expr _ _)) -> do - ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr - return ty - _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg - noSrcSpan - (text "not an expression:" <+> quotes (text expr)) + Just (L _ (ExprStmt expr _ _)) -> + ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr + _ -> + liftIO $ throwIO $ mkSrcErr $ unitBag $ + mkPlainErrMsg noSrcSpan + (text "not an expression:" <+> quotes (text expr)) -- | Find the kind of a type hscKcType - :: GhcMonad m => - HscEnv + :: HscEnv -> String -- ^ The type - -> m Kind + -> IO Kind -hscKcType hsc_env str = do - ty <- hscParseType (hsc_dflags hsc_env) str - let icontext = hsc_IC hsc_env - ioMsgMaybe $ tcRnType hsc_env icontext ty +hscKcType hsc_env str = runHsc hsc_env $ do + ty <- hscParseType str + ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) ty #endif \end{code} \begin{code} #ifdef GHCI -hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName)) +hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName)) hscParseStmt = hscParseThing parseStmt -hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName) +hscParseType :: String -> Hsc (LHsType RdrName) hscParseType = hscParseThing parseType #endif -hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName) -hscParseIdentifier = hscParseThing parseIdentifier +hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) +hscParseIdentifier hsc_env str = runHsc hsc_env $ + hscParseThing parseIdentifier str -hscParseThing :: (Outputable thing, GhcMonad m) - => Lexer.P thing - -> DynFlags -> String - -> m thing - -- Nothing => Parse error (message already printed) - -- Just x => success -hscParseThing parser dflags str - = (liftIO $ showPass dflags "Parser") >> - {-# SCC "Parser" #-} do - buf <- liftIO $ stringToStringBuffer str +hscParseThing :: (Outputable thing) + => Lexer.P thing + -> String + -> Hsc thing - let loc = mkSrcLoc (fsLit "") 1 1 +hscParseThing parser str + = {-# SCC "Parser" #-} do + dflags <- getDynFlags + liftIO $ showPass dflags "Parser" + + let buf = stringToStringBuffer str + loc = mkSrcLoc (fsLit "") 1 1 case unP parser (mkPState dflags buf loc) of - PFailed span err -> do + PFailed span err -> do let msg = mkPlainErrMsg span err - throw (mkSrcErr (unitBag msg)) + liftIO $ throwIO (mkSrcErr (unitBag msg)) - POk pst thing -> do - - let ms@(warns, errs) = getMessages pst - logWarnings warns - when (errorsFound dflags ms) $ -- handle -Werror - throw (mkSrcErr errs) - - --ToDo: can't free the string buffer until we've finished this - -- compilation sweep and all the identifiers have gone away. + POk pst thing -> do + logWarningsReportErrors (getMessages pst) liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) return thing \end{code} +\begin{code} +hscCompileCore :: HscEnv + -> Bool + -> ModSummary + -> [CoreBind] + -> IO () + +hscCompileCore hsc_env simplify mod_summary binds + = runHsc hsc_env $ do + let maybe_simplify mod_guts | simplify = hscSimplify' mod_guts + | otherwise = return mod_guts + guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds) + (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing + hscWriteIface iface changed mod_summary + _ <- hscGenHardCode cgguts mod_summary + return () + +-- Makes a "vanilla" ModGuts. +mkModGuts :: Module -> [CoreBind] -> ModGuts +mkModGuts mod binds = ModGuts { + mg_module = mod, + mg_boot = False, + mg_exports = [], + mg_deps = noDependencies, + mg_dir_imps = emptyModuleEnv, + mg_used_names = emptyNameSet, + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_types = emptyTypeEnv, + mg_insts = [], + mg_fam_insts = [], + mg_rules = [], + mg_binds = binds, + mg_foreign = NoStubs, + mg_warns = NoWarnings, + mg_anns = [], + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo, + mg_inst_env = emptyInstEnv, + mg_fam_inst_env = emptyFamInstEnv +} +\end{code} + %************************************************************************ %* * Desugar, simplify, convert to bytecode, and link an expression @@ -1023,46 +1237,44 @@ hscParseThing parser dflags str \begin{code} #ifdef GHCI -compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue - -compileExpr hsc_env srcspan ds_expr +hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue +hscCompileCoreExpr hsc_env srcspan ds_expr | rtsIsProfiled - = throwIO (InstallationError "You can't call compileExpr in a profiled compiler") + = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler") -- Otherwise you get a seg-fault when you run it - | otherwise - = do { let { dflags = hsc_dflags hsc_env ; - lint_on = dopt Opt_DoCoreLinting dflags } - - -- Simplify it - ; simpl_expr <- simplifyExpr dflags ds_expr - - -- Tidy it (temporary, until coreSat does cloning) - ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr - - -- Prepare for codegen - ; prepd_expr <- corePrepExpr dflags tidy_expr - - -- Lint if necessary - -- ToDo: improve SrcLoc - ; if lint_on then - let ictxt = hsc_IC hsc_env - tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt))) - in - case lintUnfolding noSrcLoc tyvars prepd_expr of - Just err -> pprPanic "compileExpr" err - Nothing -> return () - else - return () - - -- Convert to BCOs - ; bcos <- coreExprToBCOs dflags prepd_expr - - -- link it - ; hval <- linkExpr hsc_env srcspan bcos - - ; return hval - } + | otherwise = do + let dflags = hsc_dflags hsc_env + let lint_on = dopt Opt_DoCoreLinting dflags + + -- Simplify it + simpl_expr <- simplifyExpr dflags ds_expr + + -- Tidy it (temporary, until coreSat does cloning) + let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + + -- Prepare for codegen + prepd_expr <- corePrepExpr dflags tidy_expr + + -- Lint if necessary + -- ToDo: improve SrcLoc + if lint_on then + let ictxt = hsc_IC hsc_env + tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt))) + in + case lintUnfolding noSrcLoc tyvars prepd_expr of + Just err -> pprPanic "hscCompileCoreExpr" err + Nothing -> return () + else + return () + + -- Convert to BCOs + bcos <- coreExprToBCOs dflags prepd_expr + + -- link it + hval <- linkExpr hsc_env srcspan bcos + + return hval #endif \end{code} diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 1124f99..33b4448 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -6,29 +6,15 @@ \begin{code} -- | Types for the per-module compiler module HscTypes ( - -- * 'Ghc' monad stuff - Ghc(..), GhcT(..), liftGhcT, - GhcMonad(..), WarnLogMonad(..), - liftIO, - ioMsgMaybe, ioMsg, - logWarnings, clearWarnings, hasWarnings, - SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, - throwOneError, handleSourceError, - reflectGhc, reifyGhc, - handleFlagWarnings, - - -- * Sessions and compilation state - Session(..), withSession, modifySession, withTempSession, + -- * compilation state HscEnv(..), hscEPS, FinderCache, FindResult(..), ModLocationCache, Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, - -- ** Callbacks - GhcApiCallbacks(..), withLocalCallbacks, -- * Information about modules ModDetails(..), emptyModDetails, - ModGuts(..), CoreModule(..), CgGuts(..), ForeignStubs(..), + ModGuts(..), CgGuts(..), ForeignStubs(..), ImportedMods, ModSummary(..), ms_mod_name, showModMsg, isBootSummary, @@ -102,7 +88,12 @@ module HscTypes ( -- * Vectorisation information VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, - noIfaceVectInfo + noIfaceVectInfo, + + -- * Compilation errors and warnings + SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, + throwOneError, handleSourceError, + handleFlagWarnings, printOrThrowWarnings, ) where #include "HsVersions.h" @@ -163,22 +154,12 @@ import Data.List import Data.Map (Map) import Control.Monad ( mplus, guard, liftM, when ) import Exception -\end{code} +-- ----------------------------------------------------------------------------- +-- Source Errors -%************************************************************************ -%* * -\subsection{Compilation environment} -%* * -%************************************************************************ - - -\begin{code} --- | The Session is a handle to the complete state of a compilation --- session. A compilation session consists of a set of modules --- constituting the current program or library, the context for --- interactive evaluation, and various caches. -data Session = Session !(IORef HscEnv) !(IORef WarningMessages) +-- When the compiler (HscMain) discovers errors, it throws an +-- exception in the IO monad. mkSrcErr :: ErrorMessages -> SourceError srcErrorMessages :: SourceError -> ErrorMessages @@ -246,255 +227,25 @@ instance Exception GhcApiError mkApiErr = GhcApiError --- | A monad that allows logging of warnings. -class Monad m => WarnLogMonad m where - setWarnings :: WarningMessages -> m () - getWarnings :: m WarningMessages - -logWarnings :: WarnLogMonad m => WarningMessages -> m () -logWarnings warns = do - warns0 <- getWarnings - setWarnings (unionBags warns warns0) - --- | Clear the log of 'Warnings'. -clearWarnings :: WarnLogMonad m => m () -clearWarnings = setWarnings emptyBag - --- | Returns true if there were any warnings. -hasWarnings :: WarnLogMonad m => m Bool -hasWarnings = getWarnings >>= return . not . isEmptyBag - --- | A monad that has all the features needed by GHC API calls. --- --- In short, a GHC monad --- --- - allows embedding of IO actions, --- --- - can log warnings, --- --- - allows handling of (extensible) exceptions, and --- --- - maintains a current session. --- --- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' --- before any call to the GHC API functions can occur. --- -class (Functor m, MonadIO m, WarnLogMonad m, ExceptionMonad m) - => GhcMonad m where - getSession :: m HscEnv - setSession :: HscEnv -> m () - --- | Call the argument with the current session. -withSession :: GhcMonad m => (HscEnv -> m a) -> m a -withSession f = getSession >>= f - --- | Set the current session to the result of applying the current session to --- the argument. -modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () -modifySession f = do h <- getSession - setSession $! f h - -withSavedSession :: GhcMonad m => m a -> m a -withSavedSession m = do - saved_session <- getSession - m `gfinally` setSession saved_session - --- | Call an action with a temporarily modified Session. -withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a -withTempSession f m = - withSavedSession $ modifySession f >> m - --- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, --- e.g., to maintain additional state consider wrapping this monad or using --- 'GhcT'. -newtype Ghc a = Ghc { unGhc :: Session -> IO a } - -instance Functor Ghc where - fmap f m = Ghc $ \s -> f `fmap` unGhc m s - -instance Monad Ghc where - return a = Ghc $ \_ -> return a - m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s - -instance MonadIO Ghc where - liftIO ioA = Ghc $ \_ -> ioA - -instance ExceptionMonad Ghc where - gcatch act handle = - Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s - gblock (Ghc m) = Ghc $ \s -> gblock (m s) - gunblock (Ghc m) = Ghc $ \s -> gunblock (m s) - gmask f = - Ghc $ \s -> gmask $ \io_restore -> - let - g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) - in - unGhc (f g_restore) s - -instance WarnLogMonad Ghc where - setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns - -- | Return 'Warnings' accumulated so far. - getWarnings = Ghc $ \(Session _ wref) -> readIORef wref - -instance GhcMonad Ghc where - getSession = Ghc $ \(Session r _) -> readIORef r - setSession s' = Ghc $ \(Session r _) -> writeIORef r s' - --- | A monad transformer to add GHC specific features to another monad. --- --- Note that the wrapped monad must support IO and handling of exceptions. -newtype GhcT m a = GhcT { unGhcT :: Session -> m a } -liftGhcT :: Monad m => m a -> GhcT m a -liftGhcT m = GhcT $ \_ -> m - -instance Functor m => Functor (GhcT m) where - fmap f m = GhcT $ \s -> f `fmap` unGhcT m s - -instance Monad m => Monad (GhcT m) where - return x = GhcT $ \_ -> return x - m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s - -instance MonadIO m => MonadIO (GhcT m) where - liftIO ioA = GhcT $ \_ -> liftIO ioA - -instance ExceptionMonad m => ExceptionMonad (GhcT m) where - gcatch act handle = - GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s - gblock (GhcT m) = GhcT $ \s -> gblock (m s) - gunblock (GhcT m) = GhcT $ \s -> gunblock (m s) - gmask f = - GhcT $ \s -> gmask $ \io_restore -> - let - g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) - in - unGhcT (f g_restore) s - -instance MonadIO m => WarnLogMonad (GhcT m) where - setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns - -- | Return 'Warnings' accumulated so far. - getWarnings = GhcT $ \(Session _ wref) -> liftIO $ readIORef wref - -instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where - getSession = GhcT $ \(Session r _) -> liftIO $ readIORef r - setSession s' = GhcT $ \(Session r _) -> liftIO $ writeIORef r s' - --- | Lift an IO action returning errors messages into a 'GhcMonad'. --- --- In order to reduce dependencies to other parts of the compiler, functions --- outside the "main" parts of GHC return warnings and errors as a parameter --- and signal success via by wrapping the result in a 'Maybe' type. This --- function logs the returned warnings and propagates errors as exceptions --- (of type 'SourceError'). --- --- This function assumes the following invariants: --- --- 1. If the second result indicates success (is of the form 'Just x'), --- there must be no error messages in the first result. --- --- 2. If there are no error messages, but the second result indicates failure --- there should be warnings in the first result. That is, if the action --- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: GhcMonad m => - IO (Messages, Maybe a) -> m a -ioMsgMaybe ioA = do - ((warns,errs), mb_r) <- liftIO ioA - logWarnings warns - case mb_r of - Nothing -> liftIO $ throwIO (mkSrcErr errs) - Just r -> ASSERT( isEmptyBag errs ) return r - --- | Lift a non-failing IO action into a 'GhcMonad'. --- --- Like 'ioMsgMaybe', but assumes that the action will never return any error --- messages. -ioMsg :: GhcMonad m => IO (Messages, a) -> m a -ioMsg ioA = do - ((warns,errs), r) <- liftIO ioA - logWarnings warns - ASSERT( isEmptyBag errs ) return r - --- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. --- --- You can use this to call functions returning an action in the 'Ghc' monad --- inside an 'IO' action. This is needed for some (too restrictive) callback --- arguments of some library functions: --- --- > libFunc :: String -> (Int -> IO a) -> IO a --- > ghcFunc :: Int -> Ghc a --- > --- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a --- > ghcFuncUsingLibFunc str = --- > reifyGhc $ \s -> --- > libFunc $ \i -> do --- > reflectGhc (ghcFunc i) s --- -reflectGhc :: Ghc a -> Session -> IO a -reflectGhc m = unGhc m - --- > Dual to 'reflectGhc'. See its documentation. -reifyGhc :: (Session -> IO a) -> Ghc a -reifyGhc act = Ghc $ act +-- | Given a bag of warnings, turn them into an exception if +-- -Werror is enabled, or print them out otherwise. +printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings dflags warns + | dopt Opt_WarnIsError dflags + = when (not (isEmptyBag warns)) $ do + throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg + | otherwise + = printBagOfWarnings dflags warns -handleFlagWarnings :: GhcMonad m => DynFlags -> [Located String] -> m () +handleFlagWarnings :: DynFlags -> [Located String] -> IO () handleFlagWarnings dflags warns - = when (dopt Opt_WarnDeprecatedFlags dflags) - (handleFlagWarnings' dflags warns) - -handleFlagWarnings' :: GhcMonad m => DynFlags -> [Located String] -> m () -handleFlagWarnings' _ [] = return () -handleFlagWarnings' dflags warns - = do -- It would be nicer if warns :: [Located Message], but that has circular - -- import problems. - logWarnings $ listToBag (map mkFlagWarning warns) - when (dopt Opt_WarnIsError dflags) $ - liftIO $ throwIO $ mkSrcErr emptyBag - -mkFlagWarning :: Located String -> WarnMsg -mkFlagWarning (L loc warn) - = mkPlainWarnMsg loc (text warn) -\end{code} - -\begin{code} --- | These functions are called in various places of the GHC API. --- --- API clients can override any of these callbacks to change GHC's default --- behaviour. -data GhcApiCallbacks - = GhcApiCallbacks { - - -- | Called by 'load' after the compilating of each module. - -- - -- The default implementation simply prints all warnings and errors to - -- @stderr@. Don't forget to call 'clearWarnings' when implementing your - -- own call. - -- - -- The first argument is the module that was compiled. - -- - -- The second argument is @Nothing@ if no errors occured, but there may - -- have been warnings. If it is @Just err@ at least one error has - -- occured. If 'srcErrorMessages' is empty, compilation failed due to - -- @-Werror@. - reportModuleCompilationResult :: GhcMonad m => - ModSummary -> Maybe SourceError - -> m () - } - --- | Temporarily modify the callbacks. After the action is executed all --- callbacks are reset (not, however, any other modifications to the session --- state.) -withLocalCallbacks :: GhcMonad m => - (GhcApiCallbacks -> GhcApiCallbacks) - -> m a -> m a -withLocalCallbacks f m = do - hsc_env <- getSession - let cb0 = hsc_callbacks hsc_env - let cb' = f cb0 - setSession (hsc_env { hsc_callbacks = cb' `seq` cb' }) - r <- m - hsc_env' <- getSession - setSession (hsc_env' { hsc_callbacks = cb0 }) - return r + = when (dopt Opt_WarnDeprecatedFlags dflags) $ do + -- It would be nicer if warns :: [Located Message], but that + -- has circular import problems. + let bag = listToBag [ mkPlainWarnMsg loc (text warn) + | L loc warn <- warns ] + printOrThrowWarnings dflags bag \end{code} \begin{code} @@ -513,9 +264,6 @@ data HscEnv hsc_dflags :: DynFlags, -- ^ The dynamic flag settings - hsc_callbacks :: GhcApiCallbacks, - -- ^ Callbacks for the GHC API. - hsc_targets :: [Target], -- ^ The targets (or roots) of the current session @@ -1006,24 +754,6 @@ data ModGuts -- mg_rules Orphan rules only (local ones now attached to binds) -- mg_binds With rules attached --- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for --- the 'GHC.compileToCoreModule' interface. -data CoreModule - = CoreModule { - -- | Module name - cm_module :: !Module, - -- | Type environment for types declared in this module - cm_types :: !TypeEnv, - -- | Declarations - cm_binds :: [CoreBind], - -- | Imports - cm_imports :: ![Module] - } - -instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = - text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) - -- The ModGuts takes on several slightly different forms: -- -- After simplification, the following fields change slightly: diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 4161d98..f1ecd87 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -37,12 +37,12 @@ module InteractiveEval ( #include "HsVersions.h" -import HscMain hiding (compileExpr) +import GhcMonad +import HscMain import HsSyn (ImportDecl) import HscTypes import TcRnDriver -import TcRnMonad (initTc) -import RnNames (gresFromAvails, rnImports) +import RnNames (gresFromAvails) import InstEnv import Type import TcType hiding( typeKind ) @@ -201,20 +201,12 @@ runStmt expr step = let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds hsc_env' = hsc_env{ hsc_dflags = dflags' } - r <- hscStmt hsc_env' expr + r <- liftIO $ hscStmt hsc_env' expr case r of Nothing -> return RunFailed -- empty statement / comment Just (ids, hval) -> do - -- XXX: This is the only place we can print warnings before the - -- result. Is this really the right thing to do? It's fine for - -- GHCi, but what's correct for other GHC API clients? We could - -- introduce a callback argument. - warns <- getWarnings - liftIO $ printBagOfWarnings dflags' warns - clearWarnings - status <- withVirtualCWD $ withBreakAction (isStep step) dflags' breakMVar statusMVar $ do @@ -254,7 +246,7 @@ withVirtualCWD m = do gbracket set_cwd reset_cwd $ \_ -> m parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) -parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr +parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr emptyHistory :: BoundedList History emptyHistory = nilBL 50 -- keep a log of length 50 @@ -790,11 +782,9 @@ setContext toplev_mods other_mods = do export_env <- liftIO $ mkExportEnv hsc_env export_mods import_env <- if null imprt_decls then return emptyGlobalRdrEnv else do - let imports = rnImports imprt_decls - this_mod = if null toplev_mods then pRELUDE else head toplev_mods - (_, env, _,_) <- - ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports - return env + let this_mod | null toplev_mods = pRELUDE + | otherwise = head toplev_mods + liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs modifySession $ \_ -> @@ -859,7 +849,7 @@ moduleIsInterpreted modl = withSession $ \h -> getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) getInfo name = withSession $ \hsc_env -> - do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name + do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name case mb_stuff of Nothing -> return Nothing Just (thing, fixity, ispecs) -> do @@ -911,8 +901,8 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov } -- the identifier can refer to in the current interactive context. parseName :: GhcMonad m => String -> m [Name] parseName str = withSession $ \hsc_env -> do - (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str - ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name + (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str + liftIO $ hscTcRnLookupRdrName hsc_env rdr_name -- ----------------------------------------------------------------------------- -- Getting the type of an expression @@ -920,7 +910,7 @@ parseName str = withSession $ \hsc_env -> do -- | Get the type of an expression exprType :: GhcMonad m => String -> m Type exprType expr = withSession $ \hsc_env -> do - ty <- hscTcExpr hsc_env expr + ty <- liftIO $ hscTcExpr hsc_env expr return $ tidyType emptyTidyEnv ty -- ----------------------------------------------------------------------------- @@ -929,14 +919,14 @@ exprType expr = withSession $ \hsc_env -> do -- | Get the kind of a type typeKind :: GhcMonad m => String -> m Kind typeKind str = withSession $ \hsc_env -> do - hscKcType hsc_env str + liftIO $ hscKcType hsc_env str ----------------------------------------------------------------------------- -- cmCompileExpr: compile an expression and deliver an HValue compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = withSession $ \hsc_env -> do - Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr) + Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) -- Run it! hvals <- liftIO (unsafeCoerce# hval :: IO [HValue]) @@ -955,7 +945,8 @@ dynCompileExpr expr = do (stringToPackageId "base") (mkModuleName "Data.Dynamic") ,Nothing):exports let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" - Just (ids, hvals) <- withSession (flip hscStmt stmt) + Just (ids, hvals) <- withSession $ \hsc_env -> + liftIO $ hscStmt hsc_env stmt setContext full exports vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) case (ids,vals) of diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index bc01bf6..a9a9c46 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -1499,11 +1499,23 @@ exportClashErr global_env name1 name2 ie1 ie2 = case lookupGRE_Name global_env name of (gre:_) -> gre [] -> pprPanic "exportClashErr" (ppr name) - get_loc name = nameSrcLoc $ gre_name $ get_gre name + get_loc name = greSrcSpan (get_gre name) (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2 then (name1, ie1, name2, ie2) else (name2, ie2, name1, ie1) +-- the SrcSpan that pprNameProvenance prints out depends on whether +-- the Name is defined locally or not: for a local definition the +-- definition site is used, otherwise the location of the import +-- declaration. We want to sort the export locations in +-- exportClashErr by this SrcSpan, we need to extract it: +greSrcSpan :: GlobalRdrElt -> SrcSpan +greSrcSpan gre + | Imported (is:_) <- gre_prov gre = is_dloc (is_decl is) + | otherwise = name_span + where + name_span = nameSrcSpan (gre_name gre) + addDupDeclErr :: [Name] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index e3dbf3a..d821d40 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -79,6 +79,7 @@ import Bag import Maybes import UniqSupply import UniqFM ( UniqFM, mapUFM, filterUFM ) +import MonadUtils import Util ( split ) import Data.List ( intersperse ) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 097db04..65128ba 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -168,9 +168,8 @@ initTcPrintErrors -- Used from the interactive loop only -> Module -> TcM r -> IO (Messages, Maybe r) -initTcPrintErrors env mod todo = do - (msgs, res) <- initTc env HsSrcFile False mod todo - return (msgs, res) + +initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 2a3bce6..7e46e52 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -787,7 +787,7 @@ runMeta show_code run_and_convert expr ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM ; either_hval <- tryM $ liftIO $ - HscMain.compileExpr hsc_env src_span ds_expr + HscMain.hscCompileCoreExpr hsc_env src_span ds_expr ; case either_hval of { Left exn -> failWithTc (mk_msg "compile and link" exn) ; Right hval -> do diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index dc54620..75a88df 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -27,16 +27,16 @@ module MonadUtils import Outputable ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- Detection of available libraries ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- we don't depend on MTL for now #define HAVE_MTL 0 ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- Imports ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- import Maybes @@ -47,9 +47,9 @@ import Control.Monad.Trans import Control.Monad import Control.Monad.Fix ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- The ID monad ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- newtype ID a = ID a instance Monad ID where @@ -61,9 +61,9 @@ instance Monad ID where runID :: ID a -> a runID (ID x) = x ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- MTL ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- #if !HAVE_MTL @@ -73,10 +73,10 @@ class Monad m => MonadIO m where instance MonadIO IO where liftIO = id #endif ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- Lift combinators -- These are used throughout the compiler ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- | Lift an 'IO' operation with 1 argument into another monad liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b @@ -94,10 +94,10 @@ liftIO3 = ((.).((.).(.))) liftIO liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e liftIO4 = (((.).(.)).((.).(.))) liftIO ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- Common functions -- These are used throughout the compiler ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] zipWith3M _ [] _ _ = return [] diff --git a/compiler/utils/StringBuffer.lhs b/compiler/utils/StringBuffer.lhs index 2b3b775..869cb8a 100644 --- a/compiler/utils/StringBuffer.lhs +++ b/compiler/utils/StringBuffer.lhs @@ -138,8 +138,9 @@ appendStringBuffers sb1 sb2 calcLen sb = len sb - cur sb size = sb1_len + sb2_len -stringToStringBuffer :: String -> IO StringBuffer -stringToStringBuffer str = do +stringToStringBuffer :: String -> StringBuffer +stringToStringBuffer str = + unsafePerformIO $ do let size = utf8EncodedLength str buf <- mallocForeignPtrArray (size+3) withForeignPtr buf $ \ptr -> do diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 223d88b..b4b383e 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -25,6 +25,8 @@ import OccName import BasicTypes ( isLoopBreaker ) import Outputable import Util ( zipLazy ) +import MonadUtils + import Control.Monad debug = False diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 42c1435..6ead3d0 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -31,6 +31,7 @@ import Vectorise.Builtins import Vectorise.Env import HscTypes hiding ( MonadThings(..) ) +import MonadUtils (liftIO) import Module import TyCon import Var diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 5494b4e..82f2aa7 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -14,12 +14,13 @@ module GhciMonad where #include "HsVersions.h" import qualified GHC +import GhcMonad hiding (liftIO) import Outputable hiding (printForUser, printForUserPartWay) import qualified Outputable import Panic hiding (showException) import Util import DynFlags -import HscTypes hiding (liftIO) +import HscTypes import SrcLoc import Module import ObjLink @@ -28,13 +29,10 @@ import StaticFlags import qualified MonadUtils import Exception --- import Data.Maybe import Numeric import Data.Array --- import Data.Char import Data.Int ( Int64 ) import Data.IORef --- import Data.List import System.CPUTime import System.Environment import System.IO @@ -181,10 +179,6 @@ instance GhcMonad (InputT GHCi) where instance MonadUtils.MonadIO (InputT GHCi) where liftIO = Trans.liftIO -instance WarnLogMonad (InputT GHCi) where - setWarnings = lift . setWarnings - getWarnings = lift getWarnings - instance ExceptionMonad GHCi where gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) gblock (GHCi m) = GHCi $ \r -> gblock (m r) @@ -196,10 +190,6 @@ instance ExceptionMonad GHCi where in unGHCi (f g_restore) s -instance WarnLogMonad GHCi where - setWarnings warns = liftGhc $ setWarnings warns - getWarnings = liftGhc $ getWarnings - instance MonadIO GHCi where liftIO = io @@ -263,7 +253,7 @@ runStmt expr step = do withProgName (progname st) $ withArgs (args st) $ reflectGHCi x $ do - GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e + GHC.handleSourceError (\e -> do GHC.printException e return GHC.RunFailed) $ do GHC.runStmt expr step diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 7249ef4..ef81535 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -599,7 +599,7 @@ runOneCommand eh getCmd = do (doCommand c) where printErrorAndKeepGoing err = do - GHC.printExceptionAndWarnings err + GHC.printException err return False noSpace q = q >>= maybe (return Nothing) @@ -815,7 +815,7 @@ help _ = io (putStr helpText) info :: String -> InputT GHCi () info "" = ghcError (CmdLineError "syntax: ':i '") -info s = handleSourceError GHC.printExceptionAndWarnings $ +info s = handleSourceError GHC.printException $ withFlattenedDynflags $ do { let names = words s ; dflags <- getDynFlags @@ -894,8 +894,7 @@ changeDirectory "" = do changeDirectory dir = do graph <- GHC.getModuleGraph when (not (null graph)) $ - do liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded," - liftIO $ putStrLn "because the search path has changed." + liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed." prev_context <- GHC.getContext GHC.setTargets [] _ <- GHC.load LoadAllTargets @@ -906,7 +905,7 @@ changeDirectory dir = do trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag trySuccess act = - handleSourceError (\e -> do GHC.printExceptionAndWarnings e + handleSourceError (\e -> do GHC.printException e return Failed) $ do act @@ -977,7 +976,7 @@ defineMacro overwrite s = do let new_expr = '(' : definition ++ ") :: String -> IO String" -- compile the expression - handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ + handleSourceError (\e -> GHC.printException e) $ withFlattenedDynflags $ do hv <- GHC.compileExpr new_expr io (writeIORef macros_ref -- @@ -1005,7 +1004,7 @@ undefineMacro str = mapM_ undef (words str) cmdCmd :: String -> GHCi () cmdCmd str = do let expr = '(' : str ++ ") :: IO String" - handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ + handleSourceError (\e -> GHC.printException e) $ withFlattenedDynflags $ do hv <- GHC.compileExpr expr cmds <- io $ (unsafeCoerce# hv :: IO String) @@ -1048,7 +1047,7 @@ checkModule :: String -> InputT GHCi () checkModule m = do let modl = GHC.mkModuleName m prev_context <- GHC.getContext - ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do + ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl liftIO $ putStrLn $ showSDoc $ case GHC.moduleInfo r of @@ -1169,7 +1168,7 @@ modulesLoadedMsg ok mods = do typeOfExpr :: String -> InputT GHCi () typeOfExpr str - = handleSourceError (\e -> GHC.printExceptionAndWarnings e) + = handleSourceError GHC.printException $ withFlattenedDynflags $ do ty <- GHC.exprType str @@ -1179,7 +1178,7 @@ typeOfExpr str kindOfType :: String -> InputT GHCi () kindOfType str - = handleSourceError (\e -> GHC.printExceptionAndWarnings e) + = handleSourceError GHC.printException $ withFlattenedDynflags $ do ty <- GHC.typeKind str @@ -1506,7 +1505,7 @@ newDynFlags minus_opts = do dflags <- getDynFlags let pkg_flags = packageFlags dflags (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts - handleFlagWarnings dflags' warns + liftIO $ handleFlagWarnings dflags' warns if (not (null leftovers)) then ghcError $ errorsToGhcException leftovers @@ -1855,7 +1854,7 @@ wantNameFromInterpretedModule :: GHC.GhcMonad m -> (Name -> m ()) -> m () wantNameFromInterpretedModule noCanDo str and_then = - handleSourceError (GHC.printExceptionAndWarnings) $ do + handleSourceError GHC.printException $ do names <- GHC.parseName str case names of [] -> return () diff --git a/ghc/Main.hs b/ghc/Main.hs index fab773b..53a7af1 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -14,8 +14,8 @@ module Main (main) where import qualified GHC import GHC ( -- DynFlags(..), HscTarget(..), -- GhcMode(..), GhcLink(..), - LoadHowMuch(..), -- dopt, DynFlag(..), - defaultCallbacks ) + Ghc, GhcMonad(..), + LoadHowMuch(..) ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) @@ -44,7 +44,7 @@ import Outputable import SrcLoc import Util import Panic --- import MonadUtils ( liftIO ) +import MonadUtils ( liftIO ) -- Imports for --abi-hash import LoadIface ( loadUserInterface ) @@ -167,9 +167,9 @@ main' postLoadMode dflags0 args flagWarnings = do let flagWarnings' = flagWarnings ++ dynamicFlagWarnings handleSourceError (\e -> do - GHC.printExceptionAndWarnings e - liftIO $ exitWith (ExitFailure 1)) $ - handleFlagWarnings dflags2 flagWarnings' + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + liftIO $ handleFlagWarnings dflags2 flagWarnings' -- make sure we clean up after ourselves GHC.defaultCleanupHandler dflags2 $ do @@ -204,14 +204,13 @@ main' postLoadMode dflags0 args flagWarnings = do ---------------- Do the business ----------- handleSourceError (\e -> do - GHC.printExceptionAndWarnings e + GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags3 f DoMake -> doMake srcs - DoMkDependHS -> do doMkDependHS (map fst srcs) - GHC.printWarnings - StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings + DoMkDependHS -> doMkDependHS (map fst srcs) + StopBefore p -> liftIO (oneShot hsc_env p srcs) DoInteractive -> interactiveUI srcs Nothing DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs DoAbiHash -> abiHash srcs @@ -601,13 +600,10 @@ doMake srcs = do -- This means that "ghc Foo.o Bar.o -o baz" links the program as -- we expect. if (null hs_srcs) - then oneShot hsc_env StopLn srcs >> GHC.printWarnings + then liftIO (oneShot hsc_env StopLn srcs) else do - o_files <- mapM (\x -> do - f <- compileFile hsc_env StopLn x - GHC.printWarnings - return f) + o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) non_hs_srcs liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files) @@ -624,7 +620,7 @@ doMake srcs = do doShowIface :: DynFlags -> FilePath -> IO () doShowIface dflags file = do - hsc_env <- newHscEnv defaultCallbacks dflags + hsc_env <- newHscEnv dflags showIface hsc_env file -- --------------------------------------------------------------------------- -- 1.7.10.4