\begin{code}
module CmLink ( Linkable(..), Unlinked(..),
filterModuleLinkables,
- findModuleLinkable,
+ findModuleLinkable_maybe,
modname_of_linkable, is_package_linkable,
LinkResult(..),
link,
unload,
PersistentLinkerState{-abstractly!-}, emptyPLS,
- lookupClosure
+#ifdef GHCI
+ linkExpr
+#endif
) where
import Outputable ( SDoc )
import Digraph ( SCC(..), flattenSCC )
import DriverUtil
-import Module ( ModuleName, PackageName )
+import Module ( ModuleName )
import RdrName
import FiniteMap
import Outputable
+import ErrUtils ( showPass )
+import CmdLineOpts ( DynFlags(..) )
import Panic ( panic )
import Exception
+import Monad
import IO
#include "HsVersions.h"
= 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
\begin{code}
link :: GhciMode -- interactive or batch
+ -> DynFlags -- dynamic flags
-> Bool -- attempt linking in batch mode?
-> [Linkable] -- only contains LMs, not LPs
-> PersistentLinkerState
-- 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
+ verb = verbosity dflags
getOfiles (LP _) = panic "CmLink.link(getOfiles): shouldn't get package linkables"
- getOfiles (LM _ us) = map nameOfObject (filter isObject us)
+ getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+
+link' Interactive dflags batch_attempt_linking linkables pls1
+ = do showPass dflags "Linking"
+ pls2 <- unload pls1
+ linkObjs linkables pls2
-link' Interactive batch_attempt_linking linkables pls1
- = linkObjs linkables pls1
-
ppLinkableSCC :: SCC Linkable -> SDoc
ppLinkableSCC = ppr . flattenSCC
-modname_of_linkable (LM nm _) = nm
-modname_of_linkable (LP _) = panic "modname_of_linkable: package"
+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
+is_package_linkable (LP _) = True
+is_package_linkable (LM _ _ _) = False
filterModuleLinkables :: (ModuleName -> Bool)
-> [Linkable]
filterModuleLinkables p [] = []
filterModuleLinkables p (li:lis)
= case li of
- LP _ -> retain
- LM modnm _ -> if p modnm then retain else dump
+ LP _ -> retain
+ 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"
-unload = panic "CmLink.unload: no interpreter"
+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 (l@(LM _ _ uls) : ls) pls
| all isObject uls = do
mapM_ loadObj [ file | DotO file <- uls ]
linkObjs ls pls
linkInterpretedCode [] mods ul_trees pls = linkFinish pls mods ul_trees
-linkInterpretedCode (LM m uls : ls) mods ul_trees pls
+linkInterpretedCode (LM _ m uls : ls) mods ul_trees pls
| all isInterpretable uls =
linkInterpretedCode ls (m:mods) (uls++ul_trees) pls
-- various environments any previous versions of these modules.
linkFinish pls mods ul_trees = do
resolveObjs
- let itbl_env' = filterRdrNameEnv mods (itbl_env pls)
- closure_env' = filterRdrNameEnv mods (closure_env pls)
+ let itbl_env' = filterNameMap mods (itbl_env pls)
+ closure_env' = filterNameMap mods (closure_env pls)
stuff = [ (trees,itbls) | Trees trees itbls <- ul_trees ]
(ibinds, new_itbl_env, new_closure_env) <-
- linkIModules closure_env' itbl_env' stuff
+ linkIModules itbl_env' closure_env' stuff
let new_pls = PersistentLinkerState {
closure_env = new_closure_env,
itbl_env = new_itbl_env
}
- putStrLn (showSDoc (vcat (map ppr (keysFM new_closure_env))))
return (LinkOK new_pls)
-- purge the current "linked image"
unload :: PersistentLinkerState -> IO PersistentLinkerState
unload pls = return pls{ closure_env = emptyFM, itbl_env = emptyFM }
-lookupClosure :: RdrName -> PersistentLinkerState -> Maybe HValue
-lookupClosure nm PersistentLinkerState{ closure_env = cenv } =
- case lookupFM cenv nm of
- Nothing -> Nothing
- Just hv -> Just hv
+linkExpr :: PersistentLinkerState -> UnlinkedIExpr -> IO HValue
+linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } expr
+ = iExprToHValue ie ce expr
#endif
\end{code}
projects / ghc-hetmet.git / blobdiff