X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=eaf452199eb1e7c38fd902e0d7e30ebd48a4ea22;hp=804d6c097afd9d63c95cab5325545a40c697cc63;hb=16b9e80dc14db24509f051f294b5b51943285090;hpb=9181d6e98088505d25703b6fbd753b449ca8e5a8 diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 804d6c0..eaf4521 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -1,25 +1,15 @@ % % (c) The University of Glasgow 2005-2006 % - --- -------------------------------------- --- The dynamic linker for GHCi --- -------------------------------------- - -This module deals with the top-level issues of dynamic linking, -calling the object-code linker and the byte-code linker where -necessary. - - \begin{code} -{-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-} +-- | The dynamic linker for GHCi. +-- +-- This module deals with the top-level issues of dynamic linking, +-- calling the object-code linker and the byte-code linker where +-- necessary. -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, withExtendedLinkEnv, @@ -48,24 +38,22 @@ import Name import NameEnv import NameSet import qualified OccName -import LazyUniqFM +import UniqFM import Module import ListSetOps import DynFlags import BasicTypes import Outputable -import PackageConfig import Panic import Util import StaticFlags import ErrUtils -import DriverPhases import SrcLoc import qualified Maybes import UniqSet import Constants import FastString -import Config ( cProjectVersion ) +import Config -- Standard libraries import Control.Monad @@ -73,14 +61,17 @@ import Control.Monad import Data.Char import Data.IORef import Data.List +import qualified Data.Map as Map import Foreign +import Control.Concurrent.MVar import System.FilePath import System.IO import System.Directory -import Control.Exception -import Data.Maybe +import Distribution.Package hiding (depends, PackageId) + +import Exception \end{code} @@ -98,7 +89,7 @@ The PersistentLinkerState maps Names to actual closures (for interpreted code only), for use during linking. \begin{code} -GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState) +GLOBAL_MVAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState) GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised data PersistentLinkerState @@ -112,22 +103,22 @@ 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, -- The currently loaded interpreted modules (home package) - bcos_loaded :: [Linkable], + bcos_loaded :: ![Linkable], -- And the currently-loaded compiled modules (home package) - objs_loaded :: [Linkable], + objs_loaded :: ![Linkable], -- The currently-loaded packages; always object code -- Held, as usual, in dependency order; though I am not sure if -- that is really important - pkgs_loaded :: [PackageId] + pkgs_loaded :: ![PackageId] } emptyPLS :: DynFlags -> PersistentLinkerState -emptyPLS dflags = PersistentLinkerState { +emptyPLS _ = PersistentLinkerState { closure_env = emptyNameEnv, itbl_env = emptyNameEnv, pkgs_loaded = init_pkgs, @@ -144,34 +135,33 @@ emptyPLS dflags = PersistentLinkerState { \begin{code} extendLoadedPkgs :: [PackageId] -> IO () -extendLoadedPkgs pkgs - = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s}) +extendLoadedPkgs pkgs = + modifyMVar_ v_PersistentLinkerState $ \s -> + return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } extendLinkEnv :: [(Name,HValue)] -> IO () -- Automatically discards shadowed bindings -extendLinkEnv new_bindings - = do pls <- readIORef v_PersistentLinkerState - let new_closure_env = extendClosureEnv (closure_env pls) new_bindings - new_pls = pls { closure_env = new_closure_env } - writeIORef v_PersistentLinkerState new_pls +extendLinkEnv new_bindings = + modifyMVar_ v_PersistentLinkerState $ \pls -> + let new_closure_env = extendClosureEnv (closure_env pls) new_bindings + in return pls{ closure_env = new_closure_env } deleteFromLinkEnv :: [Name] -> IO () -deleteFromLinkEnv to_remove - = do pls <- readIORef v_PersistentLinkerState - let new_closure_env = delListFromNameEnv (closure_env pls) to_remove - new_pls = pls { closure_env = new_closure_env } - writeIORef v_PersistentLinkerState new_pls +deleteFromLinkEnv to_remove = + modifyMVar_ v_PersistentLinkerState $ \pls -> + let new_closure_env = delListFromNameEnv (closure_env pls) to_remove + in return pls{ closure_env = new_closure_env } -- | Given a data constructor in the heap, find its Name. -- The info tables for data constructors have a field which records -- the source name of the constructor as a Ptr Word8 (UTF-8 encoded -- string). The format is: -- --- Package:Module.Name +-- > Package:Module.Name -- -- We use this string to lookup the interpreter's internal representation of the name -- using the lookupOrig. - +-- dataConInfoPtrToName :: Ptr () -> TcM (Either String Name) dataConInfoPtrToName x = do theString <- liftIO $ do @@ -230,13 +220,12 @@ dataConInfoPtrToName x = do -} getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8) - getConDescAddress ptr = do -#ifdef GHCI_TABLES_NEXT_TO_CODE + getConDescAddress ptr + | ghciTablesNextToCode = do offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE) return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord)) -#else + | otherwise = peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB -#endif -- parsing names is a little bit fiddly because we have a string in the form: -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). @@ -256,22 +245,38 @@ dataConInfoPtrToName x = do where (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) - parseModOcc acc str + -- We only look for dots if str could start with a module name, + -- i.e. if it starts with an upper case character. + -- Otherwise we might think that "X.:->" is the module name in + -- "X.:->.+", whereas actually "X" is the module name and + -- ":->.+" is a constructor name. + parseModOcc acc str@(c : _) + | isUpper $ chr $ fromIntegral c = case break (== dot) str of (top, []) -> (acc, top) - (top, _:bot) -> parseModOcc (top : acc) bot - + (top, _ : bot) -> parseModOcc (top : acc) bot + parseModOcc acc str = (acc, str) +-- | Get the 'HValue' associated with the given name. +-- +-- May cause loading the module that contains the name. +-- +-- Throws a 'ProgramError' if loading fails or the name cannot be found. getHValue :: HscEnv -> Name -> IO HValue getHValue hsc_env name = do - when (isExternalName name) $ do - ok <- linkDependencies hsc_env noSrcSpan [nameModule name] - when (failed ok) $ throwDyn (ProgramError "") - pls <- readIORef v_PersistentLinkerState - lookupName (closure_env pls) name + pls <- modifyMVar v_PersistentLinkerState $ \pls -> do + if (isExternalName name) then do + (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name] + if (failed ok) then ghcError (ProgramError "") + else return (pls', pls') + else + return (pls, pls) + lookupName (closure_env pls) name -linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag -linkDependencies hsc_env span needed_mods = do +linkDependencies :: HscEnv -> PersistentLinkerState + -> SrcSpan -> [Module] + -> IO (PersistentLinkerState, SuccessFlag) +linkDependencies hsc_env pls span needed_mods = do let hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env -- The interpreter and dynamic linker can only handle object code built @@ -281,40 +286,33 @@ linkDependencies hsc_env span needed_mods = do maybe_normal_osuf <- checkNonStdWay dflags span -- Find what packages and linkables are required - eps <- readIORef (hsc_EPS hsc_env) - (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps) + (lnks, pkgs) <- getLinkDeps hsc_env hpt pls maybe_normal_osuf span needed_mods -- Link the packages and modules required - linkPackages dflags pkgs - linkModules dflags lnks + pls1 <- linkPackages' dflags pkgs pls + linkModules dflags pls1 lnks -- | Temporarily extend the linker state. -withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a +withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) => + [(Name,HValue)] -> m a -> m a withExtendedLinkEnv new_env action - = bracket set_new_env - reset_old_env - (const action) - where set_new_env = do - pls <- readIORef v_PersistentLinkerState - let new_closure_env = extendClosureEnv (closure_env pls) new_env - new_pls = pls { closure_env = new_closure_env } - writeIORef v_PersistentLinkerState new_pls - return (closure_env pls) - + = gbracket (liftIO $ extendLinkEnv new_env) + (\_ -> reset_old_env) + (\_ -> action) + where -- Remember that the linker state might be side-effected -- during the execution of the IO action, and we don't want to -- lose those changes (we might have linked a new module or -- package), so the reset action only removes the names we -- added earlier. - reset_old_env env = do - modifyIORef v_PersistentLinkerState $ \pls -> + reset_old_env = liftIO $ do + modifyMVar_ v_PersistentLinkerState $ \pls -> let cur = closure_env pls new = delListFromNameEnv cur (map fst new_env) - in - pls{ closure_env = new } + in return pls{ closure_env = new } -- filterNameMap removes from the environment all entries except -- those for a given set of modules; @@ -332,10 +330,10 @@ filterNameMap mods env \begin{code} +-- | Display the persistent linker state. showLinkerState :: IO () --- Display the persistent linker state showLinkerState - = do pls <- readIORef v_PersistentLinkerState + = do pls <- readMVar v_PersistentLinkerState printDump (vcat [text "----- Linker state -----", text "Pkgs:" <+> ppr (pkgs_loaded pls), text "Objs:" <+> ppr (objs_loaded pls), @@ -351,40 +349,43 @@ showLinkerState %* * %************************************************************************ -We initialise the dynamic linker by - -a) calling the C initialisation procedure - -b) Loading any packages specified on the command line, - -c) Loading any packages specified on the command line, - now held in the -l options in v_Opt_l - -d) Loading any .o/.dll files specified on the command line, - now held in v_Ld_inputs - -e) Loading any MacOS frameworks - \begin{code} +-- | Initialise the dynamic linker. This entails +-- +-- a) Calling the C initialisation procedure, +-- +-- b) Loading any packages specified on the command line, +-- +-- c) Loading any packages specified on the command line, now held in the +-- @-l@ options in @v_Opt_l@, +-- +-- d) Loading any @.o\/.dll@ files specified on the command line, now held +-- in @v_Ld_inputs@, +-- +-- e) Loading any MacOS frameworks. +-- +-- NOTE: This function is idempotent; if called more than once, it does +-- nothing. This is useful in Template Haskell, where we call it before +-- trying to link. +-- initDynLinker :: DynFlags -> IO () --- This function is idempotent; if called more than once, it does nothing --- This is useful in Template Haskell, where we call it before trying to link -initDynLinker dflags - = do { done <- readIORef v_InitLinkerDone - ; if done then return () - else do { writeIORef v_InitLinkerDone True - ; reallyInitDynLinker dflags } - } - -reallyInitDynLinker dflags - = do { -- Initialise the linker state - ; writeIORef v_PersistentLinkerState (emptyPLS dflags) +initDynLinker dflags = + modifyMVar_ v_PersistentLinkerState $ \pls0 -> do + done <- readIORef v_InitLinkerDone + if done then return pls0 + else do writeIORef v_InitLinkerDone True + reallyInitDynLinker dflags + +reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState +reallyInitDynLinker dflags = + do { -- Initialise the linker state + let pls0 = emptyPLS dflags -- (a) initialise the C dynamic linker ; initObjLinker -- (b) Load packages from the command-line - ; linkPackages dflags (preloadPackages (pkgState dflags)) + ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0 -- (c) Link libraries from the command-line ; let optl = getOpts dflags opt_l @@ -407,7 +408,7 @@ reallyInitDynLinker dflags ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ] ++ map DLL minus_ls ++ map Framework frameworks - ; if null cmdline_lib_specs then return () + ; if null cmdline_lib_specs then return pls else do { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs @@ -415,7 +416,9 @@ reallyInitDynLinker dflags ; ok <- resolveObjs ; if succeeded ok then maybePutStrLn dflags "done" - else throwDyn (InstallationError "linking extra libraries/objects failed") + else ghcError (ProgramError "linking extra libraries/objects failed") + + ; return pls }} classifyLdInput :: FilePath -> IO (Maybe LibrarySpec) @@ -433,8 +436,13 @@ preloadLib dflags lib_paths framework_paths lib_spec Object static_ish -> do b <- preload_static lib_paths static_ish maybePutStrLn dflags (if b then "done" - else "not found") - + else "not found") + + Archive static_ish + -> do b <- preload_static_archive lib_paths static_ish + maybePutStrLn dflags (if b then "done" + else "not found") + DLL dll_unadorned -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned case maybe_errstr of @@ -447,31 +455,35 @@ preloadLib dflags lib_paths framework_paths lib_spec Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec -#ifdef darwin_TARGET_OS Framework framework + | isDarwinTarget -> do maybe_errstr <- loadFramework framework_paths framework case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm framework_paths lib_spec -#endif + | otherwise -> panic "preloadLib Framework" + where preloadFailed :: String -> [String] -> LibrarySpec -> IO () preloadFailed sys_errmsg paths spec - = do maybePutStr dflags - ("failed.\nDynamic linker error message was:\n " - ++ sys_errmsg ++ "\nWhilst trying to load: " - ++ showLS spec ++ "\nDirectories to search are:\n" - ++ unlines (map (" "++) paths) ) - give_up + = do maybePutStr dflags "failed.\n" + ghcError $ + CmdLineError ( + "user specified .o/.so/.DLL could not be loaded (" + ++ sys_errmsg ++ ")\nWhilst trying to load: " + ++ showLS spec ++ "\nAdditional directories searched:" + ++ (if null paths then " (none)" else + (concat (intersperse "\n" (map (" "++) paths))))) -- Not interested in the paths in the static case. - preload_static paths name + preload_static _paths name = do b <- doesFileExist name if not b then return False else loadObj name >> return True - - give_up = throwDyn $ - CmdLineError "user specified .o/.so/.DLL could not be loaded." + preload_static_archive _paths name + = do b <- doesFileExist name + if not b then return False + else loadArchive name >> return True \end{code} @@ -482,37 +494,36 @@ preloadLib dflags lib_paths framework_paths lib_spec %************************************************************************ \begin{code} -linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue - --- Link a single expression, *including* first linking packages and +-- | Link a single expression, /including/ first linking packages and -- modules that this expression depends on. -- --- Raises an IO exception if it can't find a compiled version of the --- dependents to link. +-- Raises an IO exception ('ProgramError') if it can't find a compiled +-- version of the dependents to link. -- --- Note: This function side-effects the linker state (Pepe) - +linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue linkExpr hsc_env span root_ul_bco = do { -- Initialise the linker (if it's not been done already) let dflags = hsc_dflags hsc_env ; initDynLinker dflags + -- Take lock for the actual work. + ; modifyMVar v_PersistentLinkerState $ \pls0 -> do { + -- Link the packages and modules required - ; ok <- linkDependencies hsc_env span needed_mods + ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods ; if failed ok then - throwDyn (ProgramError "") + ghcError (ProgramError "") else do { -- Link the expression itself - pls <- readIORef v_PersistentLinkerState - ; let ie = itbl_env pls + let ie = itbl_env pls ce = closure_env pls -- Link the necessary packages and linkables ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco] - ; return root_hval - }} + ; return (pls, root_hval) + }}} where free_names = nameSetToList (bcoFreeNames root_ul_bco) @@ -526,34 +537,46 @@ linkExpr hsc_env span root_ul_bco -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. -dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg))) +dieWith :: SrcSpan -> Message -> IO a +dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg))) checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String) checkNonStdWay dflags srcspan = do - tag <- readIORef v_Build_tag - if null tag then return Nothing else do + let tag = buildTag dflags + if null tag {- || tag == "dyn" -} then return Nothing else do + -- see #3604: object files compiled for way "dyn" need to link to the + -- dynamic packages, so we can't load them into a statically-linked GHCi. + -- we have to treat "dyn" in the same way as "prof". + -- + -- In the future when GHCi is dynamically linked we should be able to relax + -- this, but they we may have to make it possible to load either ordinary + -- .o files or -dynamic .o files into GHCi (currently that's not possible + -- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn + -- whereas we have __stginit_base_Prelude_. let default_osuf = phaseInputExt StopLn if objectSuf dflags == default_osuf then failNonStd srcspan else return (Just default_osuf) +failNonStd :: SrcSpan -> IO (Maybe String) failNonStd srcspan = dieWith srcspan $ ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$ ptext (sLit "You need to build the program twice: once the normal way, and then") $$ ptext (sLit "in the desired way using -osuf to set the object file suffix.") -getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable +getLinkDeps :: HscEnv -> HomePackageTable + -> PersistentLinkerState -> Maybe String -- the "normal" object suffix -> SrcSpan -- for error messages -> [Module] -- If you need these -> IO ([Linkable], [PackageId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files -getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods +getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods -- Find all the packages and linkables that a set of modules depends on - = do { pls <- readIORef v_PersistentLinkerState ; + = do { -- 1. Find the dependent home-pkg-modules/packages from each iface (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet; @@ -622,10 +645,11 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods link_boot_mod_error mod = - throwDyn (ProgramError (showSDoc ( + ghcError (ProgramError (showSDoc ( text "module" <+> ppr mod <+> text "cannot be linked; it is only available as a boot module"))) + no_obj :: Outputable a => a -> IO b no_obj mod = dieWith span $ ptext (sLit "cannot find object file for module ") <> quotes (ppr mod) $$ @@ -637,8 +661,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods get_linkable maybe_normal_osuf mod_name -- A home-package module | Just mod_info <- lookupUFM hpt mod_name - = ASSERT(isJust (hm_linkable mod_info)) - adjust_linkable (fromJust (hm_linkable mod_info)) + = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) | otherwise = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... @@ -651,7 +674,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods -- ...and then find the linkable for it mb_lnk <- findObjectLinkableMaybe mod loc ; case mb_lnk of { - Nothing -> no_obj mod ; + Nothing -> no_obj mod ; Just lnk -> adjust_linkable lnk }} @@ -670,6 +693,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods ptext (sLit "cannot find normal object file ") <> quotes (text new_file) $$ while_linking_expr else return (DotO new_file) + adjust_ul _ _ = panic "adjust_ul" \end{code} @@ -682,21 +706,22 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods %************************************************************************ \begin{code} -linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag -linkModules dflags linkables - = block $ do -- don't want to be interrupted by ^C in here +linkModules :: DynFlags -> PersistentLinkerState -> [Linkable] + -> IO (PersistentLinkerState, SuccessFlag) +linkModules dflags pls linkables + = mask_ $ do -- don't want to be interrupted by ^C in here let (objs, bcos) = partition isObjectLinkable (concatMap partitionLinkable linkables) -- Load objects first; they can't depend on BCOs - ok_flag <- dynLinkObjs dflags objs + (pls1, ok_flag) <- dynLinkObjs dflags pls objs if failed ok_flag then - return Failed + return (pls1, Failed) else do - dynLinkBCOs bcos - return Succeeded + pls2 <- dynLinkBCOs pls1 bcos + return (pls2, Succeeded) -- HACK to support f-x-dynamic in the interpreter; no other purpose @@ -707,17 +732,16 @@ partitionLinkable li li_uls_bco = filter isInterpretable li_uls in case (li_uls_obj, li_uls_bco) of - (objs@(_:_), bcos@(_:_)) - -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}] - other - -> [li] + (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, + li {linkableUnlinked=li_uls_bco}] + _ -> [li] findModuleLinkable_maybe :: [Linkable] -> Module -> 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) + _ -> pprPanic "findModuleLinkable" (ppr mod) linkableInSet :: Linkable -> [Linkable] -> Bool linkableInSet l objs_loaded = @@ -734,18 +758,15 @@ linkableInSet l objs_loaded = %************************************************************************ \begin{code} -dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag - -- Side-effects the PersistentLinkerState - -dynLinkObjs dflags objs - = do pls <- readIORef v_PersistentLinkerState - +dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable] + -> IO (PersistentLinkerState, SuccessFlag) +dynLinkObjs dflags pls objs = do -- Load the object files and link them let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs pls1 = pls { objs_loaded = objs_loaded' } unlinkeds = concatMap linkableUnlinked new_objs - mapM loadObj (map nameOfObject unlinkeds) + mapM_ loadObj (map nameOfObject unlinkeds) -- Link the all together ok <- resolveObjs @@ -753,12 +774,10 @@ dynLinkObjs dflags objs -- If resolving failed, unload all our -- object modules and carry on if succeeded ok then do - writeIORef v_PersistentLinkerState pls1 - return Succeeded + return (pls1, Succeeded) else do pls2 <- unload_wkr dflags [] pls1 - writeIORef v_PersistentLinkerState pls2 - return Failed + return (pls2, Failed) rmDupLinkables :: [Linkable] -- Already loaded @@ -781,10 +800,8 @@ rmDupLinkables already ls %************************************************************************ \begin{code} -dynLinkBCOs :: [Linkable] -> IO () - -- Side-effects the persistent linker state -dynLinkBCOs bcos - = do pls <- readIORef v_PersistentLinkerState +dynLinkBCOs :: PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState +dynLinkBCOs pls bcos = do let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos pls1 = pls { bcos_loaded = bcos_loaded' } @@ -800,14 +817,13 @@ dynLinkBCOs bcos gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos - -- What happens to these linked_bcos? + (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos + -- XXX What happens to these linked_bcos? let pls2 = pls1 { closure_env = final_gce, itbl_env = final_ie } - writeIORef v_PersistentLinkerState pls2 - return () + return pls2 -- Link a bunch of BCOs and return them + updated closure env. linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env @@ -846,31 +862,32 @@ linkSomeBCOs toplevs_only ie ce_in ul_bcos \begin{code} -- --------------------------------------------------------------------------- --- Unloading old objects ready for a new compilation sweep. +-- | 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 +-- 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, +-- * 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. +-- * otherwise, we unload it. -- --- * we also implicitly unload all temporary bindings at this point. - -unload :: DynFlags -> [Linkable] -> IO () --- The 'linkables' are the ones to *keep* - +-- * we also implicitly unload all temporary bindings at this point. +-- +unload :: DynFlags + -> [Linkable] -- ^ The linkables to *keep*. + -> IO () unload dflags linkables - = block $ do -- block, so we're safe from Ctrl-C in here + = mask_ $ do -- mask, so we're safe from Ctrl-C in here -- Initialise the linker (if it's not been done already) initDynLinker dflags - pls <- readIORef v_PersistentLinkerState - new_pls <- unload_wkr dflags linkables pls - writeIORef v_PersistentLinkerState new_pls + new_pls + <- modifyMVar v_PersistentLinkerState $ \pls -> do + pls1 <- unload_wkr dflags linkables pls + return (pls1, pls1) debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)) debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)) @@ -883,7 +900,7 @@ unload_wkr :: DynFlags -- Does the core unload business -- (the wrapper blocks exceptions and deals with the PLS get and put) -unload_wkr dflags linkables pls +unload_wkr _ linkables pls = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) @@ -901,7 +918,7 @@ unload_wkr dflags linkables pls where maybeUnload :: [Linkable] -> Linkable -> IO Bool maybeUnload keep_linkables lnk - | linkableInSet lnk linkables = return True + | linkableInSet lnk keep_linkables = return True | otherwise = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk] -- The components of a BCO linkable may contain @@ -928,6 +945,8 @@ data LibrarySpec -- file in all the directories specified in -- v_Library_paths before giving up. + | Archive FilePath -- Full path name of a .a file, including trailing .a + | DLL String -- "Unadorned" name of a .DLL/.so -- e.g. On unix "qt" denotes "libqt.so" -- On WinDoze "burble" denotes "burble.DLL" @@ -948,54 +967,67 @@ data LibrarySpec -- of DLL handles that rts/Linker.c maintains, and that in turn is -- used by lookupSymbol. So we must call addDLL for each library -- just to get the DLL handle into the list. +partOfGHCi :: [PackageName] partOfGHCi | isWindowsTarget || isDarwinTarget = [] - | otherwise = [ "base", "haskell98", "template-haskell", "editline" ] + | otherwise = map PackageName + ["base", "template-haskell", "editline"] +showLS :: LibrarySpec -> String showLS (Object nm) = "(static) " ++ nm +showLS (Archive nm) = "(static archive) " ++ nm showLS (DLL nm) = "(dynamic) " ++ nm showLS (DLLPath nm) = "(dynamic) " ++ nm showLS (Framework nm) = "(framework) " ++ nm -linkPackages :: DynFlags -> [PackageId] -> IO () --- Link exactly the specified packages, and their dependents --- (unless of course they are already linked) --- The dependents are linked automatically, and it doesn't matter --- what order you specify the input packages. +-- | Link exactly the specified packages, and their dependents (unless of +-- course they are already linked). The dependents are linked +-- automatically, and it doesn't matter what order you specify the input +-- packages. -- +linkPackages :: DynFlags -> [PackageId] -> IO () -- NOTE: in fact, since each module tracks all the packages it depends on, --- we don't really need to use the package-config dependencies. +-- we don't really need to use the package-config dependencies. +-- -- However we do need the package-config stuff (to find aux libs etc), -- and following them lets us load libraries in the right order, which -- perhaps makes the error message a bit more localised if we get a link -- failure. So the dependency walking code is still here. -linkPackages dflags new_pkgs - = do { pls <- readIORef v_PersistentLinkerState - ; let pkg_map = pkgIdMap (pkgState dflags) - - ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs +linkPackages dflags new_pkgs = do + -- It's probably not safe to try to load packages concurrently, so we take + -- a lock. + modifyMVar_ v_PersistentLinkerState $ \pls -> do + linkPackages' dflags new_pkgs pls + +linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState + -> IO PersistentLinkerState +linkPackages' dflags new_pks pls = do + pkgs' <- link (pkgs_loaded pls) new_pks + return $! pls { pkgs_loaded = pkgs' } + where + pkg_map = pkgIdMap (pkgState dflags) + ipid_map = installedPackageIdMap (pkgState dflags) - ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' }) - } - where - link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId] - link pkg_map pkgs new_pkgs - = foldM (link_one pkg_map) pkgs new_pkgs + link :: [PackageId] -> [PackageId] -> IO [PackageId] + link pkgs new_pkgs = + foldM link_one pkgs new_pkgs - link_one pkg_map pkgs new_pkg + link_one pkgs new_pkg | new_pkg `elem` pkgs -- Already linked = return pkgs | Just pkg_cfg <- lookupPackage pkg_map new_pkg = do { -- Link dependents first - pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg)) + pkgs' <- link pkgs [ Maybes.expectJust "link_one" $ + Map.lookup ipid ipid_map + | ipid <- depends pkg_cfg ] -- Now link the package itself ; linkPackage dflags pkg_cfg ; return (new_pkg : pkgs') } | otherwise - = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) + = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) linkPackage :: DynFlags -> PackageConfig -> IO () @@ -1004,6 +1036,12 @@ linkPackage dflags pkg let dirs = Packages.libraryDirs pkg let libs = Packages.hsLibraries pkg + -- The FFI GHCi import lib isn't needed as + -- compiler/ghci/Linker.lhs + rts/Linker.c link the + -- interpreted references to FFI to the compiled FFI. + -- We therefore filter it out so that we don't get + -- duplicate symbol errors. + libs' = filter ("HSffi" /=) libs -- Because of slight differences between the GHC dynamic linker and -- the native system linker some packages have to link with a -- different list of libraries when using GHCi. Examples include: libs @@ -1015,16 +1053,17 @@ linkPackage dflags pkg then Packages.extraLibraries pkg else Packages.extraGHCiLibraries pkg) ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] - classifieds <- mapM (locateOneObj dirs) libs + classifieds <- mapM (locateOneObj dirs) libs' -- Complication: all the .so's must be loaded before any of the .o's. let dlls = [ dll | DLL dll <- classifieds ] objs = [ obj | Object obj <- classifieds ] + archs = [ arch | Archive arch <- classifieds ] - maybePutStr dflags ("Loading package " ++ display (package pkg) ++ " ... ") + maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ") -- See comments with partOfGHCi - when (pkgName (package pkg) `notElem` partOfGHCi) $ do + when (packageName pkg `notElem` partOfGHCi) $ do loadFrameworks pkg -- When a library A needs symbols from a library B, the order in -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the @@ -1041,21 +1080,24 @@ linkPackage dflags pkg -- Ordering isn't important here, because we do one final link -- step to resolve everything. mapM_ loadObj objs + mapM_ loadArchive archs maybePutStr dflags "linking ... " ok <- resolveObjs if succeeded ok then maybePutStrLn dflags "done." - else throwDyn (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'")) + else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'")) +load_dyn :: [FilePath] -> FilePath -> IO () load_dyn dirs dll = do r <- loadDynamic dirs dll case r of Nothing -> return () - Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: " + Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: " ++ dll ++ " (" ++ err ++ ")" )) -#ifndef darwin_TARGET_OS -loadFrameworks pkg = return () -#else -loadFrameworks pkg = mapM_ load frameworks + +loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO () +loadFrameworks pkg + | isDarwinTarget = mapM_ load frameworks + | otherwise = return () where fw_dirs = Packages.frameworkDirs pkg frameworks = Packages.frameworks pkg @@ -1063,50 +1105,45 @@ loadFrameworks pkg = mapM_ load frameworks load fw = do r <- loadFramework fw_dirs fw case r of Nothing -> return () - Just err -> throwDyn (CmdLineError ("can't load framework: " + Just err -> ghcError (CmdLineError ("can't load framework: " ++ fw ++ " (" ++ err ++ ")" )) -#endif -- Try to find an object file for a given library in the given paths. -- If it isn't present, we assume it's a dynamic library. -#ifndef __PIC__ --- When the GHC package was not compiled as dynamic library (=__PIC__ not set), --- we search for .o libraries first. -locateOneObj :: [FilePath] -> String -> IO LibrarySpec -locateOneObj dirs lib - = do { mb_obj_path <- findFile mk_obj_path dirs - ; case mb_obj_path of - Just obj_path -> return (Object obj_path) - Nothing -> - do { mb_lib_path <- findFile mk_dyn_lib_path dirs - ; case mb_lib_path of - Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion)) - Nothing -> return (DLL lib) }} -- We assume - where - mk_obj_path dir = dir lib <.> "o" - mk_dyn_lib_path dir = dir mkSOName (lib ++ "-ghc" ++ cProjectVersion) -#else --- When the GHC package was compiled as dynamic library (=__PIC__ set), --- we search for .so libraries first. locateOneObj :: [FilePath] -> String -> IO LibrarySpec locateOneObj dirs lib - = do { mb_lib_path <- findFile mk_dyn_lib_path dirs - ; case mb_lib_path of - Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion)) - Nothing -> - do { mb_obj_path <- findFile mk_obj_path dirs - ; case mb_obj_path of - Just obj_path -> return (Object obj_path) - Nothing -> return (DLL lib) }} -- We assume + | not ("HS" `isPrefixOf` lib) + -- For non-Haskell libraries (e.g. gmp, iconv) we assume dynamic library + = assumeDll + | not isDynamicGhcLib + -- When the GHC package was not compiled as dynamic library + -- (=DYNAMIC not set), we search for .o libraries or, if they + -- don't exist, .a libraries. + = findObject `orElse` findArchive `orElse` assumeDll + | otherwise + -- When the GHC package was compiled as dynamic library (=DYNAMIC set), + -- we search for .so libraries first. + = findDll `orElse` findObject `orElse` findArchive `orElse` assumeDll where mk_obj_path dir = dir (lib <.> "o") - mk_dyn_lib_path dir = dir mkSOName (lib ++ "-ghc" ++ cProjectVersion) -#endif + mk_arch_path dir = dir ("lib" ++ lib <.> "a") + dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion + mk_dyn_lib_path dir = dir mkSOName dyn_lib_name + findObject = liftM (fmap Object) $ findFile mk_obj_path dirs + findArchive = liftM (fmap Archive) $ findFile mk_arch_path dirs + findDll = liftM (fmap DLL) $ findFile mk_dyn_lib_path dirs + assumeDll = return (DLL lib) + infixr `orElse` + f `orElse` g = do m <- f + case m of + Just x -> return x + Nothing -> g -- ---------------------------------------------------------------------------- -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) -- return Nothing == success, else Just error message from dlopen +loadDynamic :: [FilePath] -> FilePath -> IO (Maybe String) loadDynamic paths rootname = do { mb_dll <- findFile mk_dll_path paths ; case mb_dll of @@ -1117,22 +1154,20 @@ loadDynamic paths rootname where mk_dll_path dir = dir mkSOName rootname -#if defined(darwin_TARGET_OS) -mkSOName root = ("lib" ++ root) <.> "dylib" -#elif defined(mingw32_TARGET_OS) --- Win32 DLLs have no .dll extension here, because addDLL tries --- both foo.dll and foo.drv -mkSOName root = root -#else -mkSOName root = ("lib" ++ root) <.> "so" -#endif +mkSOName :: FilePath -> FilePath +mkSOName root + | isDarwinTarget = ("lib" ++ root) <.> "dylib" + | isWindowsTarget = -- Win32 DLLs have no .dll extension here, because + -- addDLL tries both foo.dll and foo.drv + root + | otherwise = ("lib" ++ root) <.> "so" -- Darwin / MacOS X only: load a framework -- a framework is a dynamic library packaged inside a directory of the same -- name. They are searched for in different paths than normal libraries. -#ifdef darwin_TARGET_OS +loadFramework :: [FilePath] -> FilePath -> IO (Maybe String) loadFramework extraPaths rootname - = do { either_dir <- Control.Exception.try getHomeDirectory + = do { either_dir <- tryIO getHomeDirectory ; let homeFrameworkPath = case either_dir of Left _ -> [] Right dir -> [dir ++ "/Library/Frameworks"] @@ -1147,7 +1182,6 @@ loadFramework extraPaths rootname mk_fwk dir = dir (rootname ++ ".framework/" ++ rootname) -- sorry for the hardcoded paths, I hope they won't change anytime soon: defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] -#endif \end{code} %************************************************************************ @@ -1160,7 +1194,7 @@ loadFramework extraPaths rootname findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path -> [FilePath] -- Directories to look in -> IO (Maybe FilePath) -- The first file path to match -findFile mk_file_path [] +findFile _ [] = return Nothing findFile mk_file_path (dir:dirs) = do { let file_path = mk_file_path dir @@ -1172,9 +1206,11 @@ findFile mk_file_path (dir:dirs) \end{code} \begin{code} +maybePutStr :: DynFlags -> String -> IO () maybePutStr dflags s | verbosity dflags > 0 = putStr s | otherwise = return () +maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s | otherwise = return () \end{code}