X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCmLink.lhs;h=9371eb446b851b36d01a23b0dd2dd87d51a1c0d0;hb=57c3ca2603ef0f2358d8d246bff1dd47ef97e843;hp=247d2f50a195f3110cd09aeee9a61af4c5f6aaac;hpb=c271b64780a6504e7ccd4cc422dfc90678ea966f;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 247d2f5..9371eb4 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -7,31 +7,39 @@ module CmLink ( Linkable(..), Unlinked(..), filterModuleLinkables, findModuleLinkable_maybe, - modname_of_linkable, is_package_linkable, LinkResult(..), link, unload, PersistentLinkerState{-abstractly!-}, emptyPLS, #ifdef GHCI + 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 DriverUtil -import Module ( ModuleName, PackageName ) -import RdrName +import Name ( Name ) +import Module ( ModuleName ) import FiniteMap import Outputable -import Panic ( panic ) +import ErrUtils ( showPass ) +import CmdLineOpts ( DynFlags(..) ) +import Panic ( panic, GhcException(..) ) import Exception +import List +import Monad import IO #include "HsVersions.h" @@ -41,6 +49,7 @@ import IO data PersistentLinkerState = PersistentLinkerState { + #ifdef GHCI -- Current global mapping from RdrNames to closure addresses closure_env :: ClosureEnv, @@ -50,7 +59,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 @@ -75,16 +89,80 @@ findModuleLinkable_maybe lis 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 +delListFromClosureEnv :: PersistentLinkerState -> [Name] + -> IO PersistentLinkerState +delListFromClosureEnv pls names + = return pls{ closure_env = delListFromFM (closure_env pls) names } + +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 +-- 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 @@ -107,48 +185,47 @@ link :: GhciMode -- interactive or batch -- to be actually linked this time around (or unlinked and re-linked -- if the module was recompiled). -link mode batch_attempt_linking linkables pls1 - = do hPutStrLn stderr "CmLink.link: linkables are ..." - hPutStrLn stderr (showSDoc (vcat (map ppr linkables))) - res <- link' mode batch_attempt_linking linkables pls1 - hPutStrLn stderr "CmLink.link: done" +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 batch_attempt_linking linkables pls1 +link' Batch dflags batch_attempt_linking linkables pls1 | batch_attempt_linking = 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 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" + 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 where dump = filterModuleLinkables p lis @@ -159,58 +236,52 @@ filterModuleLinkables p (li:lis) #ifndef GHCI linkObjs = panic "CmLink.linkObjs: no interpreter" -unload = panic "CmLink.unload: no interpreter" -lookupClosure = panic "CmLink.lookupClosure: 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") + = panic "linkInterpretedCode: trying to link object code to 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 +-- link all the interpreted code in one go. +linkFinish pls ul_bcos = do resolveObjs - let itbl_env' = filterRdrNameEnv mods (itbl_env pls) - closure_env' = filterRdrNameEnv mods (closure_env pls) - stuff = [ (trees,itbls) | Trees trees itbls <- ul_trees ] + + let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ] (ibinds, new_itbl_env, new_closure_env) <- - linkIModules itbl_env' closure_env' stuff + linkIModules (itbl_env pls) (closure_env pls) stuff - let new_pls = PersistentLinkerState { - closure_env = new_closure_env, - itbl_env = new_itbl_env - } - putStrLn (showSDoc (vcat (map ppr (keysFM new_closure_env)))) + 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 -> UnlinkedIExpr -> IO HValue -linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } expr - = iExprToHValue ie ce expr +linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue +linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos + = linkIExpr ie ce bcos #endif \end{code}