From: simonmar Date: Wed, 1 Aug 2001 12:07:50 +0000 (+0000) Subject: [project @ 2001-08-01 12:07:50 by simonmar] X-Git-Tag: Approximately_9120_patches~1382 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=f7828a360867e52b4055cfd5a1223347612ba919;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 4b592f5..7c69ebe 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -1,20 +1,21 @@ % -% (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 diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 107fe7d..4623970 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -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