Commit f7828a36 authored by simonmar's avatar simonmar
Browse files

[project @ 2001-08-01 12:07:50 by simonmar]

Signification cleanup & rewrite of CmLink.

Fixes at least one bug: the PersistentLinkerState could sometimes get
out of step with the RTS's idea of which modules were loaded, leading
to an unloadObj failure when we try to unload the same module twice.
This could happen if a ^C exception is received in the middle of a
:load.

Fixed by keeping the part of the linker's state that must match up
with the RTS's internal state entirely private to CmLink, stored in a
global variable.  The operations in CmLink which manipulate this state
are now wrapped by Exception.block, and so are safe from ^C
exceptions.
parent fe5ab8f5
%
% (c) The University of Glasgow, 2000
% (c) The University of Glasgow, 2001
%
\section[CmLink]{Linker for GHCI}
\section[CmLink]{The compilation manager's linker}
\begin{code}
module CmLink ( Linkable(..), Unlinked(..),
filterModuleLinkables,
findModuleLinkable_maybe,
LinkResult(..),
link,
unload,
PersistentLinkerState{-abstractly!-}, emptyPLS,
module CmLink (
LinkResult(..), link, unload,
filterModuleLinkables,
findModuleLinkable_maybe,
PersistentLinkerState{-abstractly!-}, emptyPLS,
#ifdef GHCI
delListFromClosureEnv,
addListToClosureEnv,
linkExpr
delListFromClosureEnv,
addListToClosureEnv,
linkExpr
#endif
) where
......@@ -28,85 +29,110 @@ import DriverPipeline
import CmTypes
import HscTypes ( GhciMode(..) )
import Outputable ( SDoc )
import Digraph ( SCC(..), flattenSCC )
import Name ( Name )
import Module ( ModuleName )
import FiniteMap
import Outputable
import ErrUtils ( showPass )
import CmdLineOpts ( DynFlags(..) )
import Panic ( panic )
import Util
import Exception ( block )
import IOExts
import List
import Monad
import IO
#include "HsVersions.h"
\end{code}
\begin{code}
data PersistentLinkerState
= PersistentLinkerState {
-- ---------------------------------------------------------------------------
-- The Linker's state
-- The PersistentLinkerState maps Names to actual closures (for
-- interpreted code only), for use during linking.
data PersistentLinkerState
= PersistentLinkerState {
#ifdef GHCI
-- Current global mapping from RdrNames to closure addresses
closure_env :: ClosureEnv,
-- the current global mapping from RdrNames of DataCons to
-- the current global mapping from RdrNames of DataCons to
-- info table addresses.
-- When a new Unlinked is linked into the running image, or an existing
-- module in the image is replaced, the itbl_env must be updated
-- appropriately.
itbl_env :: ItblEnv,
-- list of objects we've loaded (we'll need to unload them again
-- before re-loading the same module), together with the ClockTime
-- of the linkable they were loaded from.
objects_loaded :: [Linkable]
-- the currently loaded interpreted modules
bcos_loaded :: [Linkable]
-- notionally here, but really lives in the C part of the linker:
-- object_symtab :: FiniteMap String Addr
#else
dummy :: () -- sigh, can't have an empty record
#endif
}
data LinkResult
= LinkOK PersistentLinkerState
| LinkErrs PersistentLinkerState [SDoc]
emptyPLS :: IO PersistentLinkerState
#ifdef GHCI
emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
itbl_env = emptyFM,
bcos_loaded = [] })
#else
emptyPLS = return (PersistentLinkerState {})
#endif
-- We also keep track of which object modules are currently loaded
-- into the dynamic linker, so that we can unload them again later.
--
-- This state *must* match the actual state of the dyanmic linker at
-- all times, which is why we keep it private here and don't
-- put it in the PersistentLinkerState.
--
GLOBAL_VAR(v_ObjectsLoaded, [], [Linkable])
-- ---------------------------------------------------------------------------
-- Utils
findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
findModuleLinkable_maybe lis mod
findModuleLinkable_maybe lis mod
= case [LM time nm us | LM time nm us <- lis, nm == mod] of
[] -> Nothing
[li] -> Just li
many -> pprPanic "findModuleLinkable" (ppr mod)
filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
filterModuleLinkables p [] = []
filterModuleLinkables p (li:lis)
= case li of
LM _ modnm _ -> if p modnm then retain else dump
where
dump = filterModuleLinkables p lis
retain = li : dump
emptyPLS :: IO PersistentLinkerState
#ifdef GHCI
emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
itbl_env = emptyFM,
objects_loaded = [] })
#else
emptyPLS = return (PersistentLinkerState {})
#endif
linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
case findModuleLinkable_maybe objs_loaded (linkableModName l) of
Nothing -> False
Just m -> linkableTime l == linkableTime m
-- These two are used to add/remove entries from the closure env for
-- new bindings made at the prompt.
#ifdef GHCI
delListFromClosureEnv :: PersistentLinkerState -> [Name]
-> IO PersistentLinkerState
delListFromClosureEnv pls names
= return pls{ closure_env = delListFromFM (closure_env pls) names }
addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)]
addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)]
-> IO PersistentLinkerState
addListToClosureEnv pls new_bindings
= return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
#endif
-----------------------------------------------------------------------------
-- ---------------------------------------------------------------------------
-- Unloading old objects ready for a new compilation sweep.
--
-- The compilation manager provides us with a list of linkables that it
......@@ -124,45 +150,60 @@ unload :: GhciMode
-> DynFlags
-> [Linkable] -- stable linkables
-> PersistentLinkerState
-> IO PersistentLinkerState
-> IO PersistentLinkerState
unload Batch dflags linkables pls = return pls
#ifdef GHCI
unload Interactive dflags linkables pls
= do new_loaded <- filterM maybeUnload (objects_loaded pls)
let mods_retained = map linkableModName new_loaded
itbl_env' = filterNameMap mods_retained (itbl_env pls)
closure_env' = filterNameMap mods_retained (closure_env pls)
let verb = verbosity dflags
when (verb >= 3) $ do
hPutStrLn stderr (showSDoc
(text "CmLink.unload: retaining" <+> ppr mods_retained))
return pls{ objects_loaded = new_loaded,
itbl_env = itbl_env',
closure_env = closure_env' }
= block $ do -- block, so we're safe from Ctrl-C in here
objs_loaded <- readIORef v_ObjectsLoaded
objs_loaded' <- filterM (maybeUnload objs_to_keep) objs_loaded
writeIORef v_ObjectsLoaded objs_loaded'
bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
let objs_retained = map linkableModName objs_loaded'
bcos_retained = map linkableModName bcos_loaded'
itbl_env' = filterNameMap bcos_retained (itbl_env pls)
closure_env' = filterNameMap bcos_retained (closure_env pls)
let verb = verbosity dflags
when (verb >= 3) $ do
hPutStrLn stderr (showSDoc
(text "CmLink.unload: retaining objs" <+> ppr objs_retained))
hPutStrLn stderr (showSDoc
(text "CmLink.unload: retaining bcos" <+> ppr bcos_retained))
return pls{ itbl_env = itbl_env',
closure_env = closure_env',
bcos_loaded = bcos_loaded' }
where
maybeUnload :: Linkable -> IO Bool
maybeUnload (LM time mod objs) = do
case findModuleLinkable_maybe linkables mod of
Nothing -> do unloadObjs; return False
Just l | linkableTime l /= time -> do unloadObjs; return False
| otherwise -> return True
where
unloadObjs = mapM unloadObj [ f | DotO f <- objs ]
(objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
maybeUnload :: [Linkable] -> Linkable -> IO Bool
maybeUnload keep_linkables l@(LM time mod objs)
| linkableInSet l linkables
= return True
| otherwise
= do mapM unloadObj [ f | DotO f <- objs ]
return False
#else
unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter"
#endif
-----------------------------------------------------------------------------
-- Linking
data LinkResult
= LinkOK PersistentLinkerState
| LinkErrs PersistentLinkerState [SDoc]
link :: GhciMode -- interactive or batch
-> DynFlags -- dynamic flags
-> Bool -- attempt linking in batch mode?
-> [Linkable]
-> PersistentLinkerState
-> PersistentLinkerState
-> IO LinkResult
-- For the moment, in the batch linker, we don't bother to tell doLink
......@@ -177,11 +218,11 @@ link :: GhciMode -- interactive or batch
--
-- 1. The list of all linkables in the current home package. This is
-- used by the batch linker to link the program, and by the interactive
-- linker to decide which modules from the previous link it can
-- linker to decide which modules from the previous link it can
-- throw away.
-- 2. The list of modules on which we just called "compile". This list
-- is used by the interactive linker to decide which modules need
-- to be actually linked this time around (or unlinked and re-linked
-- to be actually linked this time around (or unlinked and re-linked
-- if the module was recompiled).
link mode dflags batch_attempt_linking linkables pls1
......@@ -190,7 +231,7 @@ link mode dflags batch_attempt_linking linkables pls1
hPutStrLn stderr "CmLink.link: linkables are ..."
hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
res <- link' mode dflags batch_attempt_linking linkables pls1
when (verb >= 3) $
when (verb >= 3) $
hPutStrLn stderr "CmLink.link: done"
return res
......@@ -212,59 +253,45 @@ link' Batch dflags batch_attempt_linking linkables pls1
verb = verbosity dflags
getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
#ifdef GHCI
link' Interactive dflags batch_attempt_linking linkables pls
= do showPass dflags "Linking"
let (objs, bcos) = partition (isObject.head.linkableUnlinked) linkables
linkObjs (objs ++ bcos) pls
-- get the objects first
block $ do -- don't want to be interrupted by ^C in here
filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
filterModuleLinkables p [] = []
filterModuleLinkables p (li:lis)
= case li of
LM _ modnm _ -> if p modnm then retain else dump
where
dump = filterModuleLinkables p lis
retain = li : dump
-- Always load objects first. Objects aren't allowed to
-- depend on BCOs.
let (objs, bcos) = partition isObjectLinkable linkables
-----------------------------------------------------------------------------
-- Linker for interactive mode
objs_loaded <- readIORef v_ObjectsLoaded
objs_loaded' <- linkObjs objs objs_loaded
writeIORef v_ObjectsLoaded objs_loaded'
#ifndef GHCI
linkObjs = panic "CmLink.linkObjs: no interpreter"
#else
linkObjs [] pls = linkFinish pls []
linkObjs (l@(LM _ m uls) : ls) pls
| all isObject uls = do
if isLoaded l pls then linkObjs ls pls else do
let objs = [ file | DotO file <- uls ]
mapM_ loadObj objs
linkObjs ls pls{objects_loaded = l : objects_loaded pls}
| all isInterpretable uls = linkInterpretedCode (l:ls) [] pls
| otherwise = invalidLinkable
isLoaded :: Linkable -> PersistentLinkerState -> Bool
isLoaded l pls =
case findModuleLinkable_maybe (objects_loaded pls) (linkableModName l) of
Nothing -> False
Just m -> linkableTime l == linkableTime m
linkInterpretedCode [] ul_trees pls = linkFinish pls ul_trees
linkInterpretedCode (l@(LM _ m uls) : ls) ul_trees pls
| all isInterpretable uls =
if isLoaded l pls then linkInterpretedCode ls ul_trees pls else
linkInterpretedCode ls (uls++ul_trees)
pls{objects_loaded = l : objects_loaded pls}
| any isObject uls
= panic "linkInterpretedCode: trying to link object code to interpreted code"
| otherwise = invalidLinkable
-- resolve symbols within the object files
resolveObjs
-- finally link the interpreted linkables
linkBCOs bcos [] pls
#endif
invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code"
-----------------------------------------------------------------------------
-- Linker for interactive mode
#ifdef GHCI
linkObjs [] objs_loaded = return objs_loaded
linkObjs (l@(LM _ m uls) : ls) objs_loaded
| linkableInSet l objs_loaded = linkObjs ls objs_loaded -- already loaded
| otherwise = do mapM_ loadObj [ file | DotO file <- uls ]
linkObjs ls (l:objs_loaded)
linkBCOs [] ul_trees pls = linkFinish pls ul_trees
linkBCOs (l@(LM _ m uls) : ls) ul_trees pls
| linkableInSet l (bcos_loaded pls)
= linkBCOs ls ul_trees pls
| otherwise
= linkBCOs ls (uls++ul_trees) pls{bcos_loaded = l : bcos_loaded pls}
-- link all the interpreted code in one go.
linkFinish pls ul_bcos = do
resolveObjs
let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
......@@ -275,7 +302,12 @@ linkFinish pls ul_bcos = do
itbl_env = new_itbl_env
}
return (LinkOK new_pls)
#endif
-- ---------------------------------------------------------------------------
-- Link a single expression
#ifdef GHCI
linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
= linkIExpr ie ce bcos
......
......@@ -432,7 +432,7 @@ cmLoadModule cmstate1 rootnames
-- unload any modules which aren't going to be re-linked this
-- time around.
pls2 <- unload ghci_mode dflags stable_linkables pls1
pls2 <- CmLink.unload ghci_mode dflags stable_linkables pls1
-- We could at this point detect cycles which aren't broken by
-- a source-import, and complain immediately, but it seems better
......
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