\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
+ linkExpr
+#endif
) where
import DriverPipeline
import CmTypes
import CmStaticInfo ( GhciMode(..) )
-import Module ( ModuleName, PackageName )
import Outputable ( SDoc )
-import FiniteMap
import Digraph ( SCC(..), flattenSCC )
+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"
data PersistentLinkerState
= PersistentLinkerState {
+
#ifdef GHCI
-- Current global mapping from RdrNames to closure addresses
closure_env :: ClosureEnv,
-- 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
= 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}
+-----------------------------------------------------------------------------
+-- 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.
+--
+
+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
-- 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
-- Linker for interactive mode
#ifndef GHCI
-linkObjs = panic "CmLink.linkObjs: no interpreter"
+linkObjs = panic "CmLink.linkObjs: 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")
+ = 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}
projects / ghc-hetmet.git / blobdiff