X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCmLink.lhs;h=c7ac67e579f12bdb25a7c9059d9075c6668e60e0;hb=e9c95834686f00fdff2f0f22a03be234e5f7fe12;hp=9b1045d8445e2eb48b936356b509b706616e14cf;hpb=1c62b517711ac232a8024d91fd4b317a6804d28e;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 9b1045d..c7ac67e 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -1,101 +1,140 @@ % -% (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(..), - updateClosureEnv, - link, - unload, - PersistentLinkerState{-abstractly!-}, emptyPLS, +module CmLink ( + LinkResult(..), link, unload, + + filterModuleLinkables, + findModuleLinkable_maybe, + + PersistentLinkerState{-abstractly!-}, emptyPLS, + #ifdef GHCI - linkExpr + delListFromClosureEnv, + addListToClosureEnv, + linkExpr #endif ) where +#ifdef GHCI +import ByteCodeLink ( linkIModules, linkIExpr ) +#endif + import Interpreter import DriverPipeline import CmTypes -import CmStaticInfo ( GhciMode(..) ) -import Outputable ( SDoc ) -import Digraph ( SCC(..), flattenSCC ) +import HscTypes ( GhciMode(..) ) import Name ( Name ) import Module ( ModuleName ) import FiniteMap import Outputable import ErrUtils ( showPass ) import CmdLineOpts ( DynFlags(..) ) -import Panic ( panic, GhcException(..) ) +import Util + +#ifdef GHCI +import Exception ( block ) +#endif -import Exception +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 {dummy=()}) +#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 +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 -emptyPLS = return (PersistentLinkerState { closure_env = emptyFM, - itbl_env = emptyFM, - objects_loaded = [] }) -#else -emptyPLS = return (PersistentLinkerState {}) -#endif +delListFromClosureEnv :: PersistentLinkerState -> [Name] + -> IO PersistentLinkerState +delListFromClosureEnv pls names + = return pls{ closure_env = delListFromFM (closure_env pls) names } -updateClosureEnv :: PersistentLinkerState -> [(Name,HValue)] +addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)] -> IO PersistentLinkerState -updateClosureEnv pls new_bindings +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 @@ -107,50 +146,66 @@ updateClosureEnv pls new_bindings -- -- * otherwise, we unload it. -- +-- * we also implicitly unload all temporary bindings at this point. 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 + | LinkFailed PersistentLinkerState + 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 @@ -165,11 +220,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 @@ -178,7 +233,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 @@ -200,64 +255,51 @@ 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 - -ppLinkableSCC :: SCC Linkable -> SDoc -ppLinkableSCC = ppr . flattenSCC - -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 + block $ do -- don't want to be interrupted by ^C in here + + -- Always load objects first. Objects aren't allowed to + -- depend on BCOs. + let (objs, bcos) = partition isObjectLinkable linkables + + objs_loaded <- readIORef v_ObjectsLoaded + objs_loaded' <- linkObjs objs objs_loaded + writeIORef v_ObjectsLoaded objs_loaded' + + -- resolve symbols within the object files + ok <- resolveObjs + -- if resolving failed, unload all our object modules and + -- carry on. + if (not ok) + then do pls <- unload Interactive dflags [] pls + return (LinkFailed pls) + else do + + -- finally link the interpreted linkables + linkBCOs bcos [] pls +#endif ----------------------------------------------------------------------------- -- Linker for interactive mode -#ifndef GHCI -linkObjs = panic "CmLink.linkObjs: no interpreter" -lookupClosure = panic "CmLink.lookupClosure: 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 - = throwDyn (OtherError - "can't link object code that depends on interpreted code") - | otherwise = invalidLinkable - -invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code" - +#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 ] @@ -268,7 +310,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