Commit e06951a7 authored by Thomas Schilling's avatar Thomas Schilling

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