Commit e06951a7 authored by Thomas Schilling's avatar Thomas Schilling
Browse files

Major clean-up of HscMain.

This patch entails a major restructuring of HscMain and a small bugfix
to MkIface (which required the restructuring in HscMain).

In MkIface:

  - mkIface* no longer outputs orphan warnings directly and also no
    longer quits GHC when -Werror is set.  Instead, errors are
    reported using the common IO (Messages, Maybe result) scheme.

In HscMain:

  - Get rid of the 'Comp' monad.  This monad was mostly GhcMonad + two
    reader arguments, a ModSummary for the currently compiled module
    and a possible old interface.  The latter actually lead to a small
    space-leak since only its hash was needed (to check whether the
    newly-generated interface file was the same as the original one).

    Functions originally of type 'Comp' now only take the arguments
    that they actually need.  This leads to slighly longer argument
    lists in some places, however, it is now much easier to see what
    is actually going on.

  - Get rid of 'myParseModule'.  Rename 'parseFile' to 'hscParse'.

  - Join 'deSugarModule' and 'hscDesugar' (keeping the latter).

  - Rename 'typecheck{Rename}Module{'}' to 'hscTypecheck{Rename}'.
    One variant keeps the renamed syntax, the other doesn't.

  - Parameterise 'HscStatus', so that 'InteractiveStatus' is just a
    different parameterisation of 'HscStatus'.

  - 'hscCompile{OneShot,Batch,Nothing,Interactive}' are now
    implemented using a (local) typeclass called 'HsCompiler'.  The
    idea is to make the common structure more obvious.  Using this
    typeclass we now have two functions 'genericHscCompile' (original
    'hscCompiler') and 'genericHscRecompile' (original 'genComp')
    describing the default pipeline.  The methods of the typeclass
    describe a sort of "hook" interface (in OO-terms this would be
    called the "template method" pattern).

    One problem with this approach is that we parameterise over the
    /result/ type which, in fact, is not actually different for
    "nothing" and "batch" mode.  To avoid functional dependencies or
    associated types, we use type tags to make them artificially
    different and parameterise the type class over the result type.
    A perhaps better approach might be to use records instead.
    
  - Drop some redundant 'HscEnv' arguments.  These were likely
    different from what 'getSession' would return because during
    compilation we temporarily set the module's DynFlags as well as a
    few other fields.  We now use the 'withTempSession' combinator to
    temporarily change the 'HscEnv' and automatically restore the
    original session after the enclosed action has returned (even in
    case of exceptions).

  - Rename 'hscCompile' to 'hscGenHardCode' (since that is what it
    does).

Calls in 'GHC' and 'DriverPipeline' accordingly needed small
adaptions.
parent 52420758
...@@ -100,7 +100,6 @@ import Control.Monad ...@@ -100,7 +100,6 @@ import Control.Monad
import Data.List import Data.List
import Data.IORef import Data.IORef
import System.FilePath import System.FilePath
import System.Exit ( exitWith, ExitCode(..) )
\end{code} \end{code}
...@@ -116,8 +115,9 @@ mkIface :: HscEnv ...@@ -116,8 +115,9 @@ mkIface :: HscEnv
-> Maybe Fingerprint -- The old fingerprint, if we have it -> Maybe Fingerprint -- The old fingerprint, if we have it
-> ModDetails -- The trimmed, tidied interface -> ModDetails -- The trimmed, tidied interface
-> ModGuts -- Usages, deprecations, etc -> ModGuts -- Usages, deprecations, etc
-> IO (ModIface, -- The new one -> IO (Messages,
Bool) -- True <=> there was an old Iface, and the Maybe (ModIface, -- The new one
Bool)) -- True <=> there was an old Iface, and the
-- new one is identical, so no need -- new one is identical, so no need
-- to write it -- to write it
...@@ -134,7 +134,7 @@ mkIface hsc_env maybe_old_fingerprint mod_details ...@@ -134,7 +134,7 @@ mkIface hsc_env maybe_old_fingerprint mod_details
= mkIface_ hsc_env maybe_old_fingerprint = mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env this_mod is_boot used_names deps rdr_env
fix_env warns hpc_info dir_imp_mods mod_details fix_env warns hpc_info dir_imp_mods mod_details
-- | make an interface from the results of typechecking only. Useful -- | make an interface from the results of typechecking only. Useful
-- for non-optimising compilation, or where we aren't generating any -- for non-optimising compilation, or where we aren't generating any
-- object code at all ('HscNothing'). -- object code at all ('HscNothing').
...@@ -142,8 +142,7 @@ mkIfaceTc :: HscEnv ...@@ -142,8 +142,7 @@ mkIfaceTc :: HscEnv
-> Maybe Fingerprint -- The old fingerprint, if we have it -> Maybe Fingerprint -- The old fingerprint, if we have it
-> ModDetails -- gotten from mkBootModDetails, probably -> ModDetails -- gotten from mkBootModDetails, probably
-> TcGblEnv -- Usages, deprecations, etc -> TcGblEnv -- Usages, deprecations, etc
-> IO (ModIface, -> IO (Messages, Maybe (ModIface, Bool))
Bool)
mkIfaceTc hsc_env maybe_old_fingerprint mod_details mkIfaceTc hsc_env maybe_old_fingerprint mod_details
tc_result@TcGblEnv{ tcg_mod = this_mod, tc_result@TcGblEnv{ tcg_mod = this_mod,
tcg_src = hsc_src, tcg_src = hsc_src,
...@@ -214,7 +213,7 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface ...@@ -214,7 +213,7 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
-> NameEnv FixItem -> Warnings -> HpcInfo -> NameEnv FixItem -> Warnings -> HpcInfo
-> ImportedMods -> ImportedMods
-> ModDetails -> ModDetails
-> IO (ModIface, Bool) -> IO (Messages, Maybe (ModIface, Bool))
mkIface_ hsc_env maybe_old_fingerprint mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
dir_imp_mods dir_imp_mods
...@@ -305,10 +304,9 @@ mkIface_ hsc_env maybe_old_fingerprint ...@@ -305,10 +304,9 @@ mkIface_ hsc_env maybe_old_fingerprint
| r <- iface_rules | r <- iface_rules
, isNothing (ifRuleOrph r) ] , isNothing (ifRuleOrph r) ]
; when (not (isEmptyBag orph_warnings)) ; if errorsFound dflags errs_and_warns
(do { printErrorsAndWarnings dflags errs_and_warns -- XXX then return ( errs_and_warns, Nothing )
; when (errorsFound dflags errs_and_warns) else do {
(exitWith (ExitFailure 1)) })
-- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs) -- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
...@@ -322,7 +320,7 @@ mkIface_ hsc_env maybe_old_fingerprint ...@@ -322,7 +320,7 @@ mkIface_ hsc_env maybe_old_fingerprint
-- with the old GlobalRdrEnv (mi_globals). -- with the old GlobalRdrEnv (mi_globals).
; let final_iface = new_iface{ mi_globals = Just rdr_env } ; let final_iface = new_iface{ mi_globals = Just rdr_env }
; return (final_iface, no_change_at_all) } ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
where where
r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2 i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2
......
...@@ -153,7 +153,7 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable ...@@ -153,7 +153,7 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
= ASSERT (isJust maybe_old_linkable) = ASSERT (isJust maybe_old_linkable)
return maybe_old_linkable return maybe_old_linkable
handleBatch (HscRecomp hasStub) handleBatch (HscRecomp hasStub _)
| isHsBoot src_flavour | isHsBoot src_flavour
= do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too = do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too
liftIO $ SysTools.touch dflags' "Touching object file" liftIO $ SysTools.touch dflags' "Touching object file"
...@@ -179,10 +179,10 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable ...@@ -179,10 +179,10 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
(hs_unlinked ++ stub_unlinked) (hs_unlinked ++ stub_unlinked)
return (Just linkable) return (Just linkable)
handleInterpreted InteractiveNoRecomp handleInterpreted HscNoRecomp
= ASSERT (isJust maybe_old_linkable) = ASSERT (isJust maybe_old_linkable)
return maybe_old_linkable return maybe_old_linkable
handleInterpreted (InteractiveRecomp hasStub comp_bc modBreaks) handleInterpreted (HscRecomp hasStub (comp_bc, modBreaks))
= do stub_unlinked <- getStubLinkable hasStub = do stub_unlinked <- getStubLinkable hasStub
let hs_unlinked = [BCOs comp_bc modBreaks] let hs_unlinked = [BCOs comp_bc modBreaks]
unlinked_time = ms_hs_date summary unlinked_time = ms_hs_date summary
...@@ -830,7 +830,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma ...@@ -830,7 +830,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
-- than the source file (else we wouldn't be in HscNoRecomp) -- than the source file (else we wouldn't be in HscNoRecomp)
-- but we touch it anyway, to keep 'make' happy (we think). -- but we touch it anyway, to keep 'make' happy (we think).
return (StopLn, dflags', Just location4, o_file) return (StopLn, dflags', Just location4, o_file)
(HscRecomp hasStub) (HscRecomp hasStub _)
-> do when hasStub $ -> do when hasStub $
do stub_o <- compileStub hsc_env' mod location4 do stub_o <- compileStub hsc_env' mod location4
liftIO $ consIORef v_Ld_inputs stub_o liftIO $ consIORef v_Ld_inputs stub_o
......
...@@ -1040,9 +1040,9 @@ getModSummary mod = do ...@@ -1040,9 +1040,9 @@ getModSummary mod = do
-- Throws a 'SourceError' on parse error. -- Throws a 'SourceError' on parse error.
parseModule :: GhcMonad m => ModSummary -> m ParsedModule parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule ms = do parseModule ms = do
hsc_env0 <- getSession rdr_module <- withTempSession
let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } (\e -> e { hsc_dflags = ms_hspp_opts ms }) $
rdr_module <- parseFile hsc_env ms hscParse ms
return (ParsedModule ms rdr_module) return (ParsedModule ms rdr_module)
-- | Typecheck and rename a parsed module. -- | Typecheck and rename a parsed module.
...@@ -1050,12 +1050,11 @@ parseModule ms = do ...@@ -1050,12 +1050,11 @@ parseModule ms = do
-- Throws a 'SourceError' if either fails. -- Throws a 'SourceError' if either fails.
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule pmod = do typecheckModule pmod = do
let ms = modSummary pmod let ms = modSummary pmod
hsc_env0 <- getSession withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
(tc_gbl_env, rn_info) (tc_gbl_env, rn_info)
<- typecheckRenameModule hsc_env ms (parsedSource pmod) <- hscTypecheckRename ms (parsedSource pmod)
details <- liftIO $ makeSimpleDetails hsc_env tc_gbl_env details <- makeSimpleDetails tc_gbl_env
return $ return $
TypecheckedModule { TypecheckedModule {
tm_internals_ = (tc_gbl_env, details), tm_internals_ = (tc_gbl_env, details),
...@@ -1076,11 +1075,10 @@ typecheckModule pmod = do ...@@ -1076,11 +1075,10 @@ typecheckModule pmod = do
-- | Desugar a typechecked module. -- | Desugar a typechecked module.
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule tcm = do desugarModule tcm = do
let ms = modSummary tcm let ms = modSummary tcm
hsc_env0 <- getSession withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
let (tcg, _) = tm_internals tcm let (tcg, _) = tm_internals tcm
guts <- deSugarModule hsc_env ms tcg guts <- hscDesugar ms tcg
return $ return $
DesugaredModule { DesugaredModule {
dm_typechecked_module = tcm, dm_typechecked_module = tcm,
...@@ -1094,16 +1092,17 @@ loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod ...@@ -1094,16 +1092,17 @@ loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
loadModule tcm = do loadModule tcm = do
let ms = modSummary tcm let ms = modSummary tcm
let mod = ms_mod_name ms let mod = ms_mod_name ms
hsc_env0 <- getSession
let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
let (tcg, details) = tm_internals tcm let (tcg, details) = tm_internals tcm
(iface,_) <- liftIO $ makeSimpleIface hsc_env Nothing tcg details hpt_new <-
let mod_info = HomeModInfo { withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
hm_iface = iface, (iface, _) <- makeSimpleIface Nothing tcg details
hm_details = details, let mod_info = HomeModInfo {
hm_linkable = Nothing } hm_iface = iface,
let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info hm_details = details,
modifySession $ \_ -> hsc_env0{ hsc_HPT = hpt_new } hm_linkable = Nothing }
hsc_env <- getSession
return $ addToUFM (hsc_HPT hsc_env) mod mod_info
modifySession $ \e -> e{ hsc_HPT = hpt_new }
return tcm return tcm
-- | This is the way to get access to the Core bindings corresponding -- | This is the way to get access to the Core bindings corresponding
...@@ -1132,11 +1131,9 @@ compileToCore fn = do ...@@ -1132,11 +1131,9 @@ compileToCore fn = do
-- whether to run the simplifier. -- whether to run the simplifier.
-- The resulting .o, .hi, and executable files, if any, are stored in the -- The resulting .o, .hi, and executable files, if any, are stored in the
-- current directory, and named according to the module name. -- current directory, and named according to the module name.
-- Returns True iff compilation succeeded.
-- This has only so far been tested with a single self-contained module. -- This has only so far been tested with a single self-contained module.
compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m () compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
hscEnv <- getSession
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
currentTime <- liftIO $ getClockTime currentTime <- liftIO $ getClockTime
cwd <- liftIO $ getCurrentDirectory cwd <- liftIO $ getCurrentDirectory
...@@ -1161,15 +1158,13 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do ...@@ -1161,15 +1158,13 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
ms_hspp_buf = Nothing ms_hspp_buf = Nothing
} }
ioMsgMaybe $ flip evalComp (CompState{ compHscEnv=hscEnv, let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
compModSummary=modSummary, | otherwise = return mod_guts
compOldIface=Nothing}) $ guts <- maybe_simplify (mkModGuts cm)
let maybe_simplify mod_guts | simplify = hscSimplify mod_guts (iface, changed, _details, cgguts)
| otherwise = return mod_guts <- hscNormalIface guts Nothing
in maybe_simplify (mkModGuts cm) hscWriteIface iface changed modSummary
>>= hscNormalIface hscGenHardCode cgguts modSummary
>>= hscWriteIface
>>= hscOneShot
return () return ()
-- Makes a "vanilla" ModGuts. -- Makes a "vanilla" ModGuts.
...@@ -1211,6 +1206,7 @@ compileCore simplify fn = do ...@@ -1211,6 +1206,7 @@ compileCore simplify fn = do
-- Now we have the module name; -- Now we have the module name;
-- parse, typecheck and desugar the module -- parse, typecheck and desugar the module
mod_guts <- coreModule `fmap` mod_guts <- coreModule `fmap`
-- TODO: space leaky: call hsc* directly?
(desugarModule =<< typecheckModule =<< parseModule modSummary) (desugarModule =<< typecheckModule =<< parseModule modSummary)
liftM gutsToCoreModule $ liftM gutsToCoreModule $
if simplify if simplify
...@@ -1218,11 +1214,7 @@ compileCore simplify fn = do ...@@ -1218,11 +1214,7 @@ compileCore simplify fn = do
-- If simplify is true: simplify (hscSimplify), then tidy -- If simplify is true: simplify (hscSimplify), then tidy
-- (tidyProgram). -- (tidyProgram).
hsc_env <- getSession hsc_env <- getSession
simpl_guts <- ioMsg $ evalComp (hscSimplify mod_guts) simpl_guts <- hscSimplify mod_guts
(CompState{
compHscEnv = hsc_env,
compModSummary = modSummary,
compOldIface = Nothing})
tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
return $ Left tidy_guts return $ Left tidy_guts
else else
......
This diff is collapsed.
...@@ -18,7 +18,7 @@ module HscTypes ( ...@@ -18,7 +18,7 @@ module HscTypes (
handleFlagWarnings, handleFlagWarnings,
-- * Sessions and compilation state -- * Sessions and compilation state
Session(..), withSession, modifySession, Session(..), withSession, modifySession, withTempSession,
HscEnv(..), hscEPS, HscEnv(..), hscEPS,
FinderCache, FindResult(..), ModLocationCache, FinderCache, FindResult(..), ModLocationCache,
Target(..), TargetId(..), pprTarget, pprTargetId, Target(..), TargetId(..), pprTarget, pprTargetId,
...@@ -293,6 +293,16 @@ modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () ...@@ -293,6 +293,16 @@ modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession f = do h <- getSession modifySession f = do h <- getSession
setSession $! f h 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, -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
-- e.g., to maintain additional state consider wrapping this monad or using -- e.g., to maintain additional state consider wrapping this monad or using
-- 'GhcT'. -- 'GhcT'.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment