X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCmLink.lhs;h=58d4580c737827849c4168e1834d303af73dada1;hb=69eaf10e95fbe96e763888288a86f9009442f56d;hp=0e46c88177d3cdd47f945bf177ad6ff536ae79be;hpb=f212eb91f4286baf6d67f95b37e61ddd0c5e06e1;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 0e46c88..58d4580 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -6,28 +6,39 @@ \begin{code} module CmLink ( Linkable(..), Unlinked(..), filterModuleLinkables, - findModuleLinkable, - modname_of_linkable, is_package_linkable, + findModuleLinkable_maybe, LinkResult(..), link, unload, - PersistentLinkerState{-abstractly!-}, emptyPLS + PersistentLinkerState{-abstractly!-}, emptyPLS, +#ifdef GHCI + updateClosureEnv, + linkExpr +#endif ) where +#ifdef GHCI +import ByteCodeLink ( linkIModules, linkIExpr ) +#endif + import Interpreter import DriverPipeline import CmTypes import CmStaticInfo ( GhciMode(..) ) -import Module ( ModuleName, PackageName ) import Outputable ( SDoc ) -import FiniteMap import Digraph ( SCC(..), flattenSCC ) +import Name ( Name ) +import Module ( ModuleName ) +import FiniteMap import Outputable -import Exception -import DriverUtil -import Panic ( panic ) +import ErrUtils ( showPass ) +import CmdLineOpts ( DynFlags(..) ) +import Panic ( panic, GhcException(..) ) +import Exception +import List +import Monad import IO #include "HsVersions.h" @@ -37,6 +48,7 @@ import IO data PersistentLinkerState = PersistentLinkerState { + #ifdef GHCI -- Current global mapping from RdrNames to closure addresses closure_env :: ClosureEnv, @@ -46,7 +58,12 @@ data PersistentLinkerState -- 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 + 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] -- notionally here, but really lives in the C part of the linker: -- object_symtab :: FiniteMap String Addr @@ -60,26 +77,86 @@ data LinkResult = LinkOK PersistentLinkerState | LinkErrs PersistentLinkerState [SDoc] -findModuleLinkable :: [Linkable] -> ModuleName -> Linkable -findModuleLinkable lis mod - = case [LM nm us | LM nm us <- lis, nm == mod] of - [li] -> li - other -> pprPanic "findModuleLinkable" (ppr mod) +findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable +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) emptyPLS :: IO PersistentLinkerState #ifdef GHCI emptyPLS = return (PersistentLinkerState { closure_env = emptyFM, - itbl_env = emptyFM }) + itbl_env = emptyFM, + objects_loaded = [] }) #else emptyPLS = return (PersistentLinkerState {}) #endif -\end{code} -\begin{code} +#ifdef GHCI +updateClosureEnv :: PersistentLinkerState -> [(Name,HValue)] + -> IO PersistentLinkerState +updateClosureEnv 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 +-- considers "stable", i.e. won't be recompiled this time around. For +-- each of the modules current linked in memory, +-- +-- * if the linkable is stable (and it's the same one - the +-- user may have recompiled the module on the side), we keep it, +-- +-- * otherwise, we unload it. +-- +-- * we also implicitly unload all temporary bindings at this point. + +unload :: GhciMode + -> DynFlags + -> [Linkable] -- stable linkables + -> 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' } + 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 ] +#else +unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter" +#endif +----------------------------------------------------------------------------- +-- Linking + link :: GhciMode -- interactive or batch + -> DynFlags -- dynamic flags -> Bool -- attempt linking in batch mode? - -> [Linkable] -- only contains LMs, not LPs + -> [Linkable] -> PersistentLinkerState -> IO LinkResult @@ -102,44 +179,48 @@ link :: GhciMode -- interactive or batch -- to be actually linked this time around (or unlinked and re-linked -- if the module was recompiled). -link Batch batch_attempt_linking linkables pls1 +link mode dflags batch_attempt_linking linkables pls1 + = do let verb = verbosity dflags + when (verb >= 3) $ do + 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) $ + hPutStrLn stderr "CmLink.link: done" + return res + +link' Batch dflags batch_attempt_linking linkables pls1 | batch_attempt_linking - = do hPutStrLn stderr "CmLink.link(batch): linkables are ..." - hPutStrLn stderr (showSDoc (vcat (map ppr linkables))) - let o_files = concatMap getOfiles linkables + = do let o_files = concatMap getOfiles linkables + when (verb >= 1) $ + hPutStrLn stderr "ghc: linking ..." + -- don't showPass in Batch mode; doLink will do that for us. doLink o_files -- doLink only returns if it succeeds - hPutStrLn stderr "CmLink.link(batch): done" return (LinkOK pls1) | otherwise - = do hPutStrLn stderr "CmLink.link(batch): upsweep (partially?) failed OR main not exported;" - hPutStrLn stderr " -- not doing linking" + = do when (verb >= 3) $ do + hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR" + hPutStrLn stderr " Main.main not exported; not linking." return (LinkOK pls1) where - getOfiles (LP _) = panic "CmLink.link(getOfiles): shouldn't get package linkables" - getOfiles (LM _ us) = map nameOfObject (filter isObject us) + verb = verbosity dflags + getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) -link Interactive batch_attempt_linking linkables pls1 - = linkObjs linkables pls1 +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 - -modname_of_linkable (LM nm _) = nm -modname_of_linkable (LP _) = panic "modname_of_linkable: package" - -is_package_linkable (LP _) = True -is_package_linkable (LM _ _) = False - -filterModuleLinkables :: (ModuleName -> Bool) - -> [Linkable] - -> [Linkable] +filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] filterModuleLinkables p [] = [] filterModuleLinkables p (li:lis) = case li of - LP _ -> retain - LM modnm _ -> if p modnm then retain else dump + LM _ modnm _ -> if p modnm then retain else dump where dump = filterModuleLinkables p lis retain = li : dump @@ -148,53 +229,54 @@ filterModuleLinkables p (li:lis) -- Linker for interactive mode #ifndef GHCI -linkObjs = panic "CmLink.linkObjs: no interpreter" +linkObjs = panic "CmLink.linkObjs: no interpreter" #else -linkObjs [] pls = linkFinish pls [] [] -linkObjs (l@(LM _ uls) : ls) pls +linkObjs [] pls = linkFinish pls [] +linkObjs (l@(LM _ m uls) : ls) pls | all isObject uls = do - mapM_ loadObj [ file | DotO file <- uls ] - linkObjs ls pls - | all isInterpretable uls = linkInterpretedCode (l:ls) [] [] pls + 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 -linkObjs _ pls = - throwDyn (OtherError "CmLink.linkObjs: found package linkable") +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 [] mods ul_trees pls = linkFinish pls mods ul_trees -linkInterpretedCode (LM m uls : ls) mods ul_trees pls +linkInterpretedCode [] ul_trees pls = linkFinish pls ul_trees +linkInterpretedCode (l@(LM _ m uls) : ls) ul_trees pls | all isInterpretable uls = - linkInterpretedCode ls (m:mods) (uls++ul_trees) pls - + 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") + = throwDyn (OtherError + "can't link object code that depends on interpreted code") | otherwise = invalidLinkable -linkInterpretedCode _ _ _ pls = - throwDyn (OtherError "CmLink.linkInterpretedCode: found package linkable") -invalidLinkable = throwDyn (OtherError "linkable doesn't contain entirely objects interpreted code") +invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code" --- link all the interpreted code in one go. We first remove from the --- various environments any previous versions of these modules. -linkFinish pls mods ul_trees = do - let itbl_env' = filterRdrNameEnv mods (itbl_env pls) - closure_env' = filterRdrNameEnv mods (closure_env pls) - stuff = [ (trees,itbls) | Trees trees itbls <- ul_trees ] +-- link all the interpreted code in one go. +linkFinish pls ul_bcos = do + resolveObjs + + let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ] (ibinds, new_itbl_env, new_closure_env) <- - linkIModules closure_env' itbl_env' stuff + linkIModules (itbl_env pls) (closure_env pls) stuff - let new_pls = PersistentLinkerState { - closure_env = new_closure_env, - itbl_env = new_itbl_env - } - resolveObjs + let new_pls = pls { closure_env = new_closure_env, + itbl_env = new_itbl_env + } return (LinkOK new_pls) --- purge the current "linked image" -unload :: PersistentLinkerState -> IO PersistentLinkerState -unload pls = return pls{ closure_env = emptyFM, itbl_env = emptyFM } - +linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue +linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos + = linkIExpr ie ce bcos #endif \end{code}