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
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
......
......@@ -9,9 +9,7 @@ module HscMain
( newHscEnv, hscCmmFile
, hscParseIdentifier
, hscSimplify
, evalComp
, hscNormalIface, hscWriteIface, hscOneShot
, CompState (..)
, hscNormalIface, hscWriteIface, hscGenHardCode
#ifdef GHCI
, hscStmt, hscTcExpr, hscKcType
, compileExpr
......@@ -20,14 +18,14 @@ module HscMain
, hscCompileBatch -- :: Compiler (HscStatus, ModIface, ModDetails)
, hscCompileNothing -- :: Compiler (HscStatus, ModIface, ModDetails)
, hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
, HscStatus (..)
, InteractiveStatus (..)
, HscStatus' (..)
, InteractiveStatus, NothingStatus, OneShotStatus, BatchStatus
-- The new interface
, parseFile
, typecheckModule'
, typecheckRenameModule
, deSugarModule
, hscParse
, hscTypecheck
, hscTypecheckRename
, hscDesugar
, makeSimpleIface
, makeSimpleDetails
) where
......@@ -90,6 +88,7 @@ import CmmTx
import CmmContFlowOpt
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
import Fingerprint ( Fingerprint )
import DynFlags
import ErrUtils
......@@ -102,7 +101,7 @@ import MkExternalCore ( emitExternalCore )
import FastString
import LazyUniqFM ( emptyUFM )
import UniqSupply ( initUs_ )
import Bag ( unitBag, emptyBag, unionBags )
import Bag ( unitBag )
import Exception
import MonadUtils
......@@ -141,7 +140,7 @@ newHscEnv dflags
hsc_type_env_var = Nothing,
hsc_global_rdr_env = emptyGlobalRdrEnv,
hsc_global_type_env = emptyNameEnv } ) }
knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
-- where templateHaskellNames are defined
......@@ -155,24 +154,49 @@ knownKeyNames = map getName wiredInThings
\begin{code}
-- | parse a file, returning the abstract syntax
parseFile :: GhcMonad m => HscEnv -> ModSummary -> m (Located (HsModule RdrName))
parseFile hsc_env mod_summary = do
((warns,errs), maybe_parsed) <- liftIO $ myParseModule dflags hspp_file hspp_buf
logWarnings warns
case maybe_parsed of
Nothing -> liftIO $ throwIO (mkSrcErr errs)
Just rdr_module
-> return rdr_module
where
dflags = hsc_dflags hsc_env
hspp_file = ms_hspp_file mod_summary
hspp_buf = ms_hspp_buf mod_summary
hscParse :: GhcMonad m =>
ModSummary
-> m (Located (HsModule RdrName))
hscParse mod_summary = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
src_filename = ms_hspp_file mod_summary
maybe_src_buf = ms_hspp_buf mod_summary
-------------------------- Parser ----------------
liftIO $ showPass dflags "Parser"
{-# SCC "Parser" #-} do
-- sometimes we already have the buffer in memory, perhaps
-- because we needed to parse the imports out of it, or get the
-- module name.
buf <- case maybe_src_buf of
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
let loc = mkSrcLoc (mkFastString src_filename) 1 0
case unP parseModule (mkPState buf loc dflags) of
PFailed span err ->
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
-- ToDo: free the string buffer later.
-- | Rename and typecheck a module
typecheckModule' :: GhcMonad m =>
HscEnv -> ModSummary -> Located (HsModule RdrName)
-> m TcGblEnv
typecheckModule' hsc_env mod_summary rdr_module = do
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
......@@ -185,11 +209,12 @@ type RenamedStuff =
Maybe (HsDoc Name), HaddockModInfo Name))
-- | Rename and typecheck a module, additionally returning the renamed syntax
typecheckRenameModule
:: GhcMonad m =>
HscEnv -> ModSummary -> Located (HsModule RdrName)
hscTypecheckRename ::
GhcMonad m =>
ModSummary -> Located (HsModule RdrName)
-> m (TcGblEnv, RenamedStuff)
typecheckRenameModule hsc_env mod_summary rdr_module = do
hscTypecheckRename mod_summary rdr_module = do
hsc_env <- getSession
tc_result
<- {-# SCC "Typecheck-Rename" #-}
ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
......@@ -204,8 +229,9 @@ typecheckRenameModule hsc_env mod_summary rdr_module = do
return (tc_result, rn_info)
-- | Convert a typechecked module to Core
deSugarModule :: GhcMonad m => HscEnv -> ModSummary -> TcGblEnv -> m ModGuts
deSugarModule hsc_env mod_summary tc_result = do
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
-- | Make a 'ModIface' from the results of typechecking. Used when
......@@ -213,17 +239,18 @@ deSugarModule hsc_env mod_summary tc_result = do
-- 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 :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
-> IO (ModIface,Bool)
makeSimpleIface hsc_env maybe_old_iface tc_result details = do
mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
makeSimpleIface :: GhcMonad m =>
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
-- | Make a 'ModDetails' from the results of typechecking. Used when
-- typechecking only, as opposed to full compilation.
makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
-- deSugarModule :: HscEnv -> TcGblEnv -> IO Core
makeSimpleDetails :: GhcMonad m => TcGblEnv -> m ModDetails
makeSimpleDetails tc_result =
withSession $ \hsc_env -> liftIO $ mkBootModDetailsTc hsc_env tc_result
\end{code}
%************************************************************************
......@@ -266,64 +293,30 @@ error. This is the only thing that isn't caught by the type-system.
\begin{code}
-- Status of a compilation to hard-code or nothing.
data HscStatus
data HscStatus' a
= HscNoRecomp
| HscRecomp Bool -- Has stub files.
-- This is a hack. We can't compile C files here
-- since it's done in DriverPipeline. For now we
-- just return True if we want the caller to compile
-- them for us.
-- Status of a compilation to byte-code.
data InteractiveStatus
= InteractiveNoRecomp
| InteractiveRecomp Bool -- Same as HscStatus
CompiledByteCode
ModBreaks
-- I want Control.Monad.State! --Lemmih 03/07/2006
newtype Comp a = Comp {runComp :: CompState -> IORef Messages -> IO (a, CompState)}
instance Monad Comp where
g >>= fn = Comp $ \s r -> runComp g s r >>= \(a,s') -> runComp (fn a) s' r
return a = Comp $ \s _ -> return (a,s)
fail = error
evalComp :: Comp a -> CompState -> IO (Messages, a)
evalComp comp st = do r <- newIORef emptyMessages
(val,_st') <- runComp comp st r
msgs <- readIORef r
return (msgs, val)
logMsgs :: Messages -> Comp ()
logMsgs (warns', errs') = Comp $ \s r -> do
(warns, errs) <- readIORef r
writeIORef r $! ( warns' `unionBags` warns
, errs' `unionBags` errs )
return ((), s)
data CompState
= CompState
{ compHscEnv :: HscEnv
, compModSummary :: ModSummary
, compOldIface :: Maybe ModIface
}
get :: Comp CompState
get = Comp $ \s _ -> return (s,s)
modify :: (CompState -> CompState) -> Comp ()
modify f = Comp $ \s _ -> return ((), f s)
gets :: (CompState -> a) -> Comp a
gets getter = do st <- get
return (getter st)
instance MonadIO Comp where
liftIO ioA = Comp $ \s _ -> do a <- ioA; return (a,s)
type NoRecomp result = ModIface -> Comp result
| HscRecomp
Bool -- Has stub files. This is a hack. We can't compile C files here
-- since it's done in DriverPipeline. For now we just return True
-- if we want the caller to compile them for us.
a
-- This is a bit ugly. Since we use a typeclass below and would like to avoid
-- functional dependencies, we have to parameterise the typeclass over the
-- result type. Therefore we need to artificially distinguish some types. We
-- do this by adding type tags which will simply be ignored by the caller.
data HscOneShotTag = HscOneShotTag
data HscNothingTag = HscNothingTag
type OneShotStatus = HscStatus' HscOneShotTag
type BatchStatus = HscStatus' ()
type InteractiveStatus = HscStatus' (CompiledByteCode, ModBreaks)
type NothingStatus = HscStatus' HscNothingTag
type OneShotResult = OneShotStatus
type BatchResult = (BatchStatus, ModIface, ModDetails)
type NothingResult = (NothingStatus, ModIface, ModDetails)
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.
......@@ -335,14 +328,77 @@ type Compiler result = GhcMonad m =>
-> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs)
-> m result
class HsCompiler a where
-- | The main interface.
hscCompile :: GhcMonad m =>
HscEnv -> ModSummary -> Bool
-> Maybe ModIface -> Maybe (Int, Int)
-> m a
-- | Called when no recompilation is necessary.
hscNoRecomp :: GhcMonad m =>
ModIface -> m a
-- | Called to recompile the module.
hscRecompile :: GhcMonad m =>
ModSummary -> Maybe Fingerprint -> m a
-- | Code generation for Boot modules.
hscGenBootOutput :: GhcMonad m =>
TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a
-- | Code generation for normal modules.
hscGenOutput :: GhcMonad m =>
ModGuts -> ModSummary -> Maybe Fingerprint -> m a
genericHscCompile :: (HsCompiler a, GhcMonad m) =>
(Maybe (Int,Int) -> Bool -> ModSummary -> m ())
-> HscEnv -> ModSummary -> Bool
-> Maybe ModIface -> Maybe (Int, Int)
-> m a
genericHscCompile hscMessage
hsc_env mod_summary source_unchanged
mb_old_iface0 mb_mod_index =
withTempSession (\_ -> hsc_env) $ do
(recomp_reqd, mb_checked_iface)
<- {-# SCC "checkOldIface" #-}
liftIO $ 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 iface
_otherwise
-> do hscMessage mb_mod_index True mod_summary
hscRecompile mod_summary mb_old_hash
genericHscRecompile :: (HsCompiler a, GhcMonad m) =>
ModSummary -> Maybe Fingerprint
-> m a
genericHscRecompile mod_summary mb_old_hash
| ExtCoreFile <- ms_hsc_src mod_summary =
panic "GHC does not currently support reading External Core files"
| otherwise = do
tc_result <- hscFileFrontEnd mod_summary
case ms_hsc_src mod_summary of
HsBootFile ->
hscGenBootOutput tc_result mod_summary mb_old_hash
_other -> do
guts <- hscDesugar mod_summary tc_result
hscGenOutput guts mod_summary mb_old_hash
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------
-- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: Compiler HscStatus
hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
= do
instance HsCompiler OneShotResult where
hscCompile 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
......@@ -350,141 +406,143 @@ hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
mod = ms_mod mod_summary
hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
---
hscCompilerOneShot' hsc_env' mod_summary src_changed mb_old_iface mb_i_of_n
genericHscCompile oneShotMsg hsc_env' mod_summary src_changed
mb_old_iface mb_i_of_n
hscNoRecomp _old_iface = do
withSession (liftIO . dumpIfaceStats)
return HscNoRecomp
hscRecompile = genericHscRecompile
hscGenBootOutput tc_result mod_summary mb_old_iface = do
(iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
hscWriteIface iface changed mod_summary
return (HscRecomp False HscOneShotTag)
hscGenOutput guts0 mod_summary mb_old_iface = do
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 HscOneShotTag)
hscCompilerOneShot' :: Compiler HscStatus
hscCompilerOneShot'
= hscCompiler norecompOneShot oneShotMsg (genComp backend boot_backend)
where
backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot
boot_backend inp = hscSimpleIface inp >>= hscWriteIface >> return (Just (HscRecomp False))
-- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: Compiler OneShotStatus
hscCompileOneShot = hscCompile
--------------------------------------------------------------
instance HsCompiler BatchResult where
hscCompile = genericHscCompile batchMsg
hscNoRecomp iface = do
details <- genModDetails iface
return (HscNoRecomp, iface, details)
hscRecompile = genericHscRecompile
hscGenBootOutput tc_result mod_summary mb_old_iface = do
(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
hscWriteIface iface changed mod_summary
hasStub <- hscGenHardCode cgguts mod_summary
return (HscRecomp hasStub (), iface, details)
-- Compile Haskell, boot and extCore in batch mode.
hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
hscCompileBatch
= hscCompiler norecompBatch batchMsg (genComp backend boot_backend)
where
backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscBatch
boot_backend inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing