summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/SrcLoc.lhs4
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/ghci/Debugger.hs5
-rw-r--r--compiler/main/DriverMkDepend.hs1
-rw-r--r--compiler/main/DriverPipeline.hs221
-rw-r--r--compiler/main/ErrUtils.lhs52
-rw-r--r--compiler/main/GHC.hs389
-rw-r--r--compiler/main/GhcMonad.hs177
-rw-r--r--compiler/main/HeaderInfo.hs13
-rw-r--r--compiler/main/HscMain.lhs836
-rw-r--r--compiler/main/HscTypes.lhs326
-rw-r--r--compiler/main/InteractiveEval.hs41
-rw-r--r--compiler/rename/RnNames.lhs14
-rw-r--r--compiler/simplCore/CoreMonad.lhs1
-rw-r--r--compiler/typecheck/TcRnMonad.lhs5
-rw-r--r--compiler/typecheck/TcSplice.lhs2
-rw-r--r--compiler/utils/MonadUtils.hs24
-rw-r--r--compiler/utils/StringBuffer.lhs5
-rw-r--r--compiler/vectorise/Vectorise.hs2
-rw-r--r--compiler/vectorise/Vectorise/Monad.hs1
-rw-r--r--ghc/GhciMonad.hs16
-rw-r--r--ghc/InteractiveUI.hs23
-rw-r--r--ghc/Main.hs28
23 files changed, 1107 insertions, 1080 deletions
diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index d912beb4a6..06f8ec8c27 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 a7f5242981..0711a93ccb 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 9f38313901..141a513f45 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 48617ec50c..e430c6e269 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 1c29c7f688..9b57c4db2c 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 3ab89bd733..15b142b15d 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 638e1dba37..e1bc5de643 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 0000000000..c62ea4c093
--- /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 508f855f48..4e455a622c 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 42ed3e4598..d52337ed1f 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 "<interactive>") 1 1
+hscParseThing parser str
+ = {-# SCC "Parser" #-} do
+ dflags <- getDynFlags
+ liftIO $ showPass dflags "Parser"
+
+ let buf = stringToStringBuffer str
+ loc = mkSrcLoc (fsLit "<interactive>") 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 1124f995aa..33b4448c6a 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 4161d9811c..f1ecd87b09 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 bc01bf6e3a..a9a9c460b6 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 e3dbf3a304..d821d40736 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 097db0449b..65128baf4e 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 2a3bce62f6..7e46e52d4a 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 dc54620c20..75a88dfcbd 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 2b3b775791..869cb8ac84 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 223d88b07a..b4b383ea80 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 42c1435178..6ead3d07fc 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 5494b4ea4c..82f2aa7c73 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 7249ef4c46..ef81535a8c 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 <thing-you-want-info-about>'")
-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 fab773ba95..53a7af1e06 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
-- ---------------------------------------------------------------------------
View Lorry Controller Status