X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCmLink.lhs;h=8bce437c4bc89e051ec65b14d07d48ded7bb6593;hb=870bb1e805c60dcff9321fcccca000fd6466d31e;hp=3ec42dd77c89cf7a88a35b2abd16e0de84f8039f;hpb=803963adcff2a811b7ec494e37ab8b2e318bff45;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 3ec42dd..8bce437 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -6,23 +6,34 @@ \begin{code} module CmLink ( Linkable(..), Unlinked(..), filterModuleLinkables, + findModuleLinkable_maybe, modname_of_linkable, is_package_linkable, LinkResult(..), link, - PersistentLinkerState{-abstractly!-}, emptyPLS ) -where - -import StgInterp ( linkIModules, ClosureEnv, ItblEnv ) -import Linker ( loadObj, resolveObjs ) -import CmStaticInfo ( PackageConfigInfo ) -import Module ( ModuleName, PackageName ) -import InterpSyn ( UnlinkedIBind, HValue, binder ) -import Module ( Module ) + unload, + PersistentLinkerState{-abstractly!-}, emptyPLS, +#ifdef GHCI + linkExpr +#endif + ) where + + +import Interpreter +import DriverPipeline +import CmTypes +import CmStaticInfo ( GhciMode(..) ) import Outputable ( SDoc ) -import FiniteMap ( emptyFM ) import Digraph ( SCC(..), flattenSCC ) +import Module ( ModuleName ) +import FiniteMap import Outputable -import Panic ( panic ) +import ErrUtils ( showPass ) +import CmdLineOpts ( DynFlags(..) ) +import Panic ( panic, GhcException(..) ) + +import Exception +import Monad +import IO #include "HsVersions.h" \end{code} @@ -30,6 +41,8 @@ import Panic ( panic ) \begin{code} data PersistentLinkerState = PersistentLinkerState { + +#ifdef GHCI -- Current global mapping from RdrNames to closure addresses closure_env :: ClosureEnv, @@ -42,93 +55,104 @@ data PersistentLinkerState -- 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] -data Unlinked - = DotO FilePath - | DotA FilePath - | DotDLL FilePath - | Trees [UnlinkedIBind] ItblEnv -- bunch of interpretable bindings, + - -- a mapping from DataCons to their itbls - -instance Outputable Unlinked where - ppr (DotO path) = text "DotO" <+> text path - ppr (DotA path) = text "DotA" <+> text path - ppr (DotDLL path) = text "DotDLL" <+> text path - ppr (Trees binds _) = text "Trees" <+> ppr (map binder binds) - - -isObject (DotO _) = True -isObject (DotA _) = True -isObject (DotDLL _) = True -isObject _ = False +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) -isInterpretable (Trees _ _) = True -isInterpretable _ = False - -data Linkable - = LM ModuleName [Unlinked] - | LP PackageName - -instance Outputable Linkable where - ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds - ppr (LP package_nm) = text "LinkableP" <+> ptext package_nm emptyPLS :: IO PersistentLinkerState +#ifdef GHCI emptyPLS = return (PersistentLinkerState { closure_env = emptyFM, itbl_env = emptyFM }) +#else +emptyPLS = return (PersistentLinkerState {}) +#endif \end{code} \begin{code} -link :: PackageConfigInfo - -> [SCC Linkable] +link :: GhciMode -- interactive or batch + -> DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> [Linkable] -- only contains LMs, not LPs -> PersistentLinkerState -> IO LinkResult -#ifndef GHCI_NOTYET ---link = panic "CmLink.link: not implemented" -link pci groups pls1 - = do putStrLn "Hello from the Linker!" - putStrLn (showSDoc (vcat (map ppLinkableSCC groups))) - putStrLn "Bye-bye from the Linker!" +-- For the moment, in the batch linker, we don't bother to tell doLink +-- which packages to link -- it just tries all that are available. +-- batch_attempt_linking should only be *looked at* in batch mode. It +-- should only be True if the upsweep was successful and someone +-- exports main, i.e., we have good reason to believe that linking +-- will succeed. + +-- There will be (ToDo: are) two lists passed to link. These +-- correspond to +-- +-- 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 +-- 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 +-- if the module was recompiled). + +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 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 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) -ppLinkableSCC :: SCC Linkable -> SDoc -ppLinkableSCC = ppr . flattenSCC - -#else +link' Interactive dflags batch_attempt_linking linkables pls1 + = do showPass dflags "Linking" + pls2 <- unload pls1 + linkObjs linkables pls2 -link pci [] pls = return (LinkOK pls) -link pci (groupSCC:groups) pls = do - let group = flattenSCC groupSCC - -- the group is either all objects or all interpretable, for now - if all isObject group - then do mapM loadObj [ file | DotO file <- group ] - resolveObjs - link pci groups pls - else if all isInterpretable group - then do (new_closure_env, new_itbl_env) <- - linkIModules (closure_env pls) - (itbl_env pls) - [ trees | Trees trees <- group ] - link pci groups (PersistentLinkerState{ - closure_env=new_closure_env, - itbl_env=new_itbl_env}) - else - return (LinkErrs pls (ptext SLIT("linker: group must contain all objects or all interpreted modules"))) -#endif +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] @@ -136,9 +160,68 @@ filterModuleLinkables :: (ModuleName -> Bool) 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" +lookupClosure = panic "CmLink.lookupClosure: no interpreter" +#else +linkObjs [] pls = linkFinish pls [] [] +linkObjs (l@(LM _ _ uls) : ls) pls + | all isObject uls = do + mapM_ loadObj [ file | DotO file <- uls ] + linkObjs ls pls + | all isInterpretable uls = linkInterpretedCode (l:ls) [] [] pls + | otherwise = invalidLinkable +linkObjs _ pls = + throwDyn (OtherError "CmLink.linkObjs: found package linkable") + + +linkInterpretedCode [] mods ul_trees pls = linkFinish pls mods ul_trees +linkInterpretedCode (LM _ m uls : ls) mods ul_trees pls + | all isInterpretable uls = + linkInterpretedCode ls (m:mods) (uls++ul_trees) pls + + | any isObject uls + = 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") + + +-- 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_bcos = do + resolveObjs + let itbl_env' = filterNameMap mods (itbl_env pls) + closure_env' = filterNameMap mods (closure_env pls) + stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ] + + (ibinds, new_itbl_env, new_closure_env) <- + linkIModules itbl_env' closure_env' stuff + + let new_pls = PersistentLinkerState { + 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}