Commit 1c7d0ac0 authored by Thomas Schilling's avatar Thomas Schilling
Browse files

Use 'GhcMonad' in GHC and split up checkModule into phases.

I'm not sure I covered all the ways of throwing errors in the code.
Some functions throw ProgramErrors, some error messages.  It's still
quite a mess, but we're getting closer.  The missing cases are mostly
errors that cannot be fixed by the API client either or are a result
of wrong usage, so are in any case fatal.

One function, 'getModuleInfo', still returns a 'Maybe', but the
documentation suggests it should always succeed.  So I may change that
soon.

The spit-up of of 'checkModule' has pros and cons.  The various forms
of 'checkModule*' now become:

 checkAndLoadModule ms False ~~>
    loadModule =<< typecheckModule =<< parseModule (ms_mod_name ms)

 checkAndLoadModule ms True ~~>
   loadModule =<< desugarModule =<< typecheckModule =<< parseModule (ms_mod_name ms)

 checkModule mn False ~~>
   typecheckModule =<< parseModule mn

 checkModule mn True ~~>
   desugarModule =<< typecheckModule =<< parseModule mn

The old APIs cannot easily be provided, since the result type would be
different depending on the second argument.  However, a more
convenient API can be modelled on top of these four functions
({parse,typecheck,desugar,load}Module).
parent 3a61d75c
......@@ -8,10 +8,16 @@
module GHC (
-- * Initialisation
Session,
defaultErrorHandler,
defaultCleanupHandler,
newSession,
-- * GHC Monad
Ghc, GhcT, GhcMonad(..),
runGhc, runGhcT, initGhcMonad,
gcatch, gbracket, gfinally,
clearWarnings, getWarnings, hasWarnings,
printExceptionAndWarnings, printWarnings,
handleSourceError,
-- * Flags and settings
DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
......@@ -19,7 +25,7 @@ module GHC (
parseDynamicFlags,
getSessionDynFlags,
setSessionDynFlags,
parseStaticFlags,
parseStaticFlags,
-- * Targets
Target(..), TargetId(..), Phase,
......@@ -30,18 +36,21 @@ module GHC (
guessTarget,
-- * Extending the program scope
extendGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
setGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
setGlobalTypeScope, -- :: Session -> [Id] -> IO ()
extendGlobalRdrScope,
setGlobalRdrScope,
extendGlobalTypeScope,
setGlobalTypeScope,
-- * Loading\/compiling the program
depanal,
load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
load, loadWithCompiler, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
workingDirectoryChanged,
checkModule, checkAndLoadModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
compileToCore, compileToCoreModule, compileToCoreSimplified,
parseModule, typecheckModule, desugarModule, loadModule,
ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract
TypecheckedSource, ParsedSource, RenamedSource, -- ditto
moduleInfo, renamedSource, typecheckedSource,
parsedSource, coreModule,
compileToCoreModule, compileToCoreSimplified,
compileCoreToObj,
-- * Parsing Haddock comments
......@@ -189,7 +198,7 @@ module GHC (
GhcException(..), showGhcException,
-- * Miscellaneous
sessionHscEnv,
--sessionHscEnv,
cyclicModuleErr,
) where
......@@ -235,7 +244,7 @@ import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
emptyInstEnv )
import FamInstEnv ( emptyFamInstEnv )
import SrcLoc
import CoreSyn
--import CoreSyn
import TidyPgm
import DriverPipeline
import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
......@@ -244,8 +253,8 @@ import Finder
import HscMain
import HscTypes
import DynFlags
import StaticFlags
import StaticFlagParser
import qualified StaticFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
import Module
......@@ -255,8 +264,9 @@ import Unique
import FiniteMap
import Panic
import Digraph
import Bag ( unitBag, listToBag )
import Bag ( unitBag, listToBag, emptyBag, isEmptyBag )
import ErrUtils
import MonadUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
import Outputable
......@@ -347,50 +357,120 @@ defaultErrorHandler dflags inner =
) $
inner
-- | Install a default cleanup handler to remove temporary files
-- deposited by a GHC run. This is seperate from
-- 'defaultErrorHandler', because you might want to override the error
-- handling, but still get the ordinary cleanup behaviour.
defaultCleanupHandler :: DynFlags -> IO a -> IO a
defaultCleanupHandler dflags inner =
-- | Install a default cleanup handler to remove temporary files deposited by
-- a GHC run. This is seperate from 'defaultErrorHandler', because you might
-- want to override the error handling, but still get the ordinary cleanup
-- behaviour.
defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
DynFlags -> m a -> m a
defaultCleanupHandler dflags inner =
-- make sure we clean up after ourselves
inner `onException`
(do cleanTempFiles dflags
inner `gonException`
(liftIO $ do
cleanTempFiles dflags
cleanTempDirs dflags
)
-- exceptions will be blocked while we clean the temporary files,
-- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further
-- signals.
-- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
-- ToDo: explain argument [[mb_top_dir]]
newSession :: Maybe FilePath -> IO Session
newSession mb_top_dir = do
-- | Print the error message and all warnings. Useful inside exception
-- handlers. Clears warnings after printing.
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
-- | Run function for the 'Ghc' monad.
--
-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
-- to this function will create a new session which should not be shared among
-- several threads.
--
-- Any errors not handled inside the 'Ghc' action are propagated as IO
-- exceptions.
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
flip unGhc session $ do
initGhcMonad mb_top_dir
ghc
-- XXX: unregister interrupt handlers here?
-- | Run function for 'GhcT' monad transformer.
--
-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
-- to this function will create a new session which should not be shared among
-- several threads.
runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
Maybe FilePath -- ^ See argument to 'initGhcMonad'.
-> 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
flip unGhcT session $ do
initGhcMonad mb_top_dir
ghct
-- | Initialise a GHC session.
--
-- If you implement a custom 'GhcMonad' you must call this function in the
-- monad run function. It will initialise the session variable and clear all
-- warnings.
--
-- The first argument should point to the directory where GHC's library files
-- reside. More precisely, this should be the output of @ghc --print-libdir@
-- of the version of GHC the module using this API is compiled with. For
-- portability, you should use the @ghc-paths@ package, available at
-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>.
initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad mb_top_dir = do
-- catch ^C
main_thread <- myThreadId
modifyMVar_ interruptTargetThread (return . (main_thread :))
installSignalHandlers
initStaticOpts
dflags0 <- initDynFlags defaultDynFlags
dflags <- initSysTools mb_top_dir dflags0
env <- newHscEnv dflags
ref <- newIORef env
return (Session ref)
-- tmp: this breaks the abstraction, but required because DriverMkDepend
-- needs to call the Finder. ToDo: untangle this.
sessionHscEnv :: Session -> IO HscEnv
sessionHscEnv (Session ref) = readIORef ref
main_thread <- liftIO $ myThreadId
liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :))
liftIO $ installSignalHandlers
liftIO $ StaticFlags.initStaticOpts
dflags0 <- liftIO $ initDynFlags defaultDynFlags
dflags <- liftIO $ initSysTools mb_top_dir dflags0
env <- liftIO $ newHscEnv dflags
setSession env
clearWarnings
-- -----------------------------------------------------------------------------
-- Flags & settings
-- | Grabs the DynFlags from the Session
getSessionDynFlags :: Session -> IO DynFlags
getSessionDynFlags s = withSession s (return . hsc_dflags)
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),
......@@ -403,17 +483,16 @@ getSessionDynFlags s = withSession s (return . hsc_dflags)
-- flags. If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
setSessionDynFlags (Session ref) dflags = do
hsc_env <- readIORef ref
(dflags', preload) <- initPackages dflags
writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
setSessionDynFlags dflags = do
(dflags', preload) <- liftIO $ initPackages dflags
modifySession (\h -> h{ hsc_dflags = dflags' })
return preload
-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
guessOutputFile :: Session -> IO ()
guessOutputFile s = modifySession s $ \env ->
guessOutputFile :: GhcMonad m => m ()
guessOutputFile = modifySession $ \env ->
let dflags = hsc_dflags env
mod_graph = hsc_mod_graph env
mainModuleSrcPath :: Maybe String
......@@ -445,47 +524,49 @@ guessOutputFile s = modifySession s $ \env ->
-- | Sets the targets for this session. Each target may be a module name
-- or a filename. The targets correspond to the set of root modules for
-- the program\/library. Unloading the current program is achieved by
-- setting the current set of targets to be empty, followed by load.
setTargets :: Session -> [Target] -> IO ()
setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
-- setting the current set of targets to be empty, followed by 'load'.
setTargets :: GhcMonad m => [Target] -> m ()
setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
-- | returns the current set of targets
getTargets :: Session -> IO [Target]
getTargets s = withSession s (return . hsc_targets)
-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets = withSession (return . hsc_targets)
-- | Add another target
addTarget :: Session -> Target -> IO ()
addTarget s target
= modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
-- | Add another target.
addTarget :: GhcMonad m => Target -> m ()
addTarget target
= modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
-- | Remove a target
removeTarget :: Session -> TargetId -> IO ()
removeTarget s target_id
= modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget target_id
= modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
where
filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
-- Attempts to guess what Target a string refers to. This function implements
-- the --make/GHCi command-line syntax for filenames:
-- | Attempts to guess what Target a string refers to. This function
-- implements the @--make@/GHCi command-line syntax for filenames:
--
-- - if the string looks like a Haskell source filename, then interpret it
-- as such
--
-- - if adding a .hs or .lhs suffix yields the name of an existing file,
-- then use that
--
-- - if the string looks like a Haskell source filename, then interpret
-- it as such
-- - if adding a .hs or .lhs suffix yields the name of an existing file,
-- then use that
-- - otherwise interpret the string as a module name
-- - otherwise interpret the string as a module name
--
guessTarget :: String -> Maybe Phase -> IO Target
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
guessTarget str (Just phase)
= return (Target (TargetFile str (Just phase)) True Nothing)
guessTarget str Nothing
| isHaskellSrcFilename file
= return (target (TargetFile file Nothing))
| otherwise
= do exists <- doesFileExist hs_file
= do exists <- liftIO $ doesFileExist hs_file
if exists
then return (target (TargetFile hs_file Nothing))
else do
exists <- doesFileExist lhs_file
exists <- liftIO $ doesFileExist lhs_file
if exists
then return (target (TargetFile lhs_file Nothing))
else do
......@@ -509,26 +590,26 @@ guessTarget str Nothing
-- -----------------------------------------------------------------------------
-- Extending the program scope
extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
extendGlobalRdrScope session rdrElts
= modifySession session $ \hscEnv ->
extendGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
extendGlobalRdrScope rdrElts
= modifySession $ \hscEnv ->
let global_rdr = hsc_global_rdr_env hscEnv
in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
setGlobalRdrScope session rdrElts
= modifySession session $ \hscEnv ->
setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
setGlobalRdrScope rdrElts
= modifySession $ \hscEnv ->
hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
extendGlobalTypeScope :: Session -> [Id] -> IO ()
extendGlobalTypeScope session ids
= modifySession session $ \hscEnv ->
extendGlobalTypeScope :: GhcMonad m => [Id] -> m ()
extendGlobalTypeScope ids
= modifySession $ \hscEnv ->
let global_type = hsc_global_type_env hscEnv
in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
setGlobalTypeScope :: Session -> [Id] -> IO ()
setGlobalTypeScope session ids
= modifySession session $ \hscEnv ->
setGlobalTypeScope :: GhcMonad m => [Id] -> m ()
setGlobalTypeScope ids
= modifySession $ \hscEnv ->
hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
-- -----------------------------------------------------------------------------
......@@ -543,67 +624,76 @@ parseHaddockComment string =
-- -----------------------------------------------------------------------------
-- Loading the program
-- Perform a dependency analysis starting from the current targets
-- | Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
depanal (Session ref) excluded_mods allow_dup_roots = do
hsc_env <- readIORef ref
depanal :: GhcMonad m =>
[ModuleName] -- ^ excluded modules
-> Bool -- ^ allow duplicate roots
-> m ModuleGraph
depanal excluded_mods allow_dup_roots = do
hsc_env <- getSession
let
dflags = hsc_dflags hsc_env
targets = hsc_targets hsc_env
old_graph = hsc_mod_graph hsc_env
showPass dflags "Chasing dependencies"
debugTraceMsg dflags 2 (hcat [
liftIO $ showPass dflags "Chasing dependencies"
liftIO $ debugTraceMsg dflags 2 (hcat [
text "Chasing modules from: ",
hcat (punctuate comma (map pprTarget targets))])
r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
case r of
Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
_ -> return ()
return r
{-
-- | The result of load.
data LoadResult
= LoadOk Errors -- ^ all specified targets were loaded successfully.
| LoadFailed Errors -- ^ not all modules were loaded.
type Errors = [String]
data ErrMsg = ErrMsg {
errMsgSeverity :: Severity, -- warning, error, etc.
errMsgSpans :: [SrcSpan],
errMsgShortDoc :: Doc,
errMsgExtraInfo :: Doc
}
-}
mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
return mod_graph
data LoadHowMuch
= LoadAllTargets
| LoadUpTo ModuleName
| LoadDependenciesOf ModuleName
-- | Try to load the program. Calls 'loadWithCompiler' with the default
-- compiler that just immediately logs all warnings and errors.
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load how_much =
loadWithCompiler defaultCompiler how_much
where
defaultCompiler env mod_summary mod_index mod_count
mb_old_iface mb_linkable =
handleSourceError logErrorsAndRethrowException $ do
home_mod_info <- compile env mod_summary mod_index mod_count
mb_old_iface mb_linkable
printWarnings
return home_mod_info
logErrorsAndRethrowException err = do
printExceptionAndWarnings err
throw err
-- | 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.
load :: Session -> LoadHowMuch -> IO SuccessFlag
load s 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.
mb_graph <- depanal s [] False
case mb_graph of
Just mod_graph -> load2 s how_much mod_graph
Nothing -> return Failed
load2 :: Session -> LoadHowMuch -> [ModSummary] -> IO SuccessFlag
load2 s@(Session ref) how_much mod_graph = do
guessOutputFile s
hsc_env <- readIORef ref
--
-- The first argument is a function that is called to compile a single module.
-- The arguments are the same as 'DriverPipeline.compile'. Use this function
-- to intercept warns and errors from a single module compilation. (Don't
-- forget to actually call 'DriverPipeline.compile' inside that function.
-- XXX: this could be enforced by changing 'ModuleCompiler' to return a static
-- capability which can only be obtained by calling 'DriverPipeline.compile'.)
loadWithCompiler :: GhcMonad m => ModuleCompiler -> LoadHowMuch -> m SuccessFlag
loadWithCompiler module_compiler 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.
mod_graph <- depanal [] False
load2 how_much mod_graph module_compiler
load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> ModuleCompiler
-> m SuccessFlag
load2 how_much mod_graph mod_comp = do
guessOutputFile
hsc_env <- getSession
let hpt1 = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
......@@ -627,7 +717,7 @@ load2 s@(Session ref) how_much mod_graph = do
checkMod m and_then
| m `elem` all_home_mods = and_then
| otherwise = do
errorMsg dflags (text "no such module:" <+>
liftIO $ errorMsg dflags (text "no such module:" <+>
quotes (ppr m))
return Failed
......@@ -656,15 +746,15 @@ load2 s@(Session ref) how_much mod_graph = do
(flattenSCCs mg2_with_srcimps)
stable_mods
evaluate pruned_hpt
liftIO $ evaluate pruned_hpt
-- before we unload anything, make sure we don't leave an old
-- interactive context around pointing to dead bindings. Also,
-- write the pruned HPT to allow the old HPT to be GC'd.
writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext,
hsc_HPT = pruned_hpt }
modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
hsc_HPT = pruned_hpt }
debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
text "Stable BCO:" <+> ppr stable_bco)
-- Unload any modules which are going to be re-linked this time around.
......@@ -672,7 +762,7 @@ load2 s@(Session ref) how_much mod_graph = do
| m <- stable_obj++stable_bco,
Just hmi <- [lookupUFM pruned_hpt m],
Just linkable <- [hm_linkable hmi] ]
unload hsc_env stable_linkables
liftIO $ unload hsc_env stable_linkables
-- We could at this point detect cycles which aren't broken by
-- a source-import, and complain immediately, but it seems better
......@@ -725,11 +815,12 @@ load2 s@(Session ref) how_much mod_graph = do
let cleanup = cleanTempFilesExcept dflags
(ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
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
<- upsweep mod_comp
(hsc_env { hsc_HPT = emptyHomePackageTable })
pruned_hpt stable_mods cleanup mg
-- Make modsDone be the summaries for each home module now
-- available; this should equal the domain of hpt3.
......@@ -744,10 +835,10 @@ load2 s@(Session ref) how_much mod_graph = do
then
-- Easy; just relink it all.
do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
-- Issue a warning for the confusing case where the user
-- said '-o foo' but we're not going to do any linking.
......@@ -764,22 +855,22 @@ load2 s@(Session ref) how_much mod_graph = do
when (ghcLink dflags == LinkBinary
&& isJust ofile && not do_linking) $
debugTraceMsg dflags 1 $
liftIO $ debugTraceMsg dflags 1 $
text ("Warning: output was redirected with -o, " ++
"but no output will be generated\n" ++
"because there is no " ++
moduleNameString (moduleName main_mod) ++ " module.")
-- link everything together
linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
loadFinish Succeeded linkresult ref hsc_env1
loadFinish Succeeded linkresult hsc_env1
else
-- Tricky. We need to back out the effects of compiling any
-- half-done cycles, both so as to clean up the top level envs
-- and to avoid telling the interactive linker to link them.
do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
let modsDone_names
= map ms_mod modsDone
......@@ -794,31 +885,33 @@ load2 s@(Session ref) how_much mod_graph = do
(hsc_HPT hsc_env1)
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
-- there should be no Nothings where linkables should be, now
ASSERT(all (isJust.hm_linkable)
(eltsUFM (hsc_HPT hsc_env))) do
-- Link everything together
linkresult <- link (ghcLink dflags) dflags False hpt4
linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
loadFinish Failed linkresult ref hsc_env4
loadFinish Failed linkresult hsc_env4
-- Finish up after a load.
-- If the link failed, unload everything and return.
loadFinish :: SuccessFlag -> SuccessFlag -> IORef HscEnv -> HscEnv -> IO SuccessFlag
loadFinish _all_ok Failed ref hsc_env
= do unload hsc_env []
writeIORef ref $! discardProg hsc_env
loadFinish :: GhcMonad m =>
SuccessFlag -> SuccessFlag -> HscEnv
-> m SuccessFlag
loadFinish _all_ok Failed hsc_env
= do liftIO $ unload hsc_env []
modifySession $ \_ -> discardProg hsc_env