diff options
Diffstat (limited to 'compiler/ghci/Linker.hs')
| -rw-r--r-- | compiler/ghci/Linker.hs | 339 |
1 files changed, 248 insertions, 91 deletions
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index aee7684157..9f1307d798 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -20,6 +21,8 @@ module Linker ( getHValue, showLinkerState, #include "HsVersions.h" +import GhcPrelude + import GHCi import GHCi.RemoteTypes import LoadIface @@ -51,8 +54,8 @@ import FileCleanup -- Standard libraries import Control.Monad -import Control.Applicative((<|>)) +import Data.Char (isSpace) import Data.IORef import Data.List import Data.Maybe @@ -60,10 +63,19 @@ import Control.Concurrent.MVar import System.FilePath import System.Directory +import System.IO.Unsafe +import System.Environment (lookupEnv) + +#if defined(mingw32_HOST_OS) +import System.Win32.Info (getSystemDirectory) +#endif import Exception -import Foreign (Ptr) -- needed for 2nd stage +-- needed for 2nd stage +#if STAGE >= 2 +import Foreign (Ptr) +#endif {- ********************************************************************** @@ -75,35 +87,45 @@ import Foreign (Ptr) -- needed for 2nd stage The persistent linker state *must* match the actual state of the C dynamic linker at all times, so we keep it in a private global variable. -The global IORef used for PersistentLinkerState actually contains another MVar. -The reason for this is that we want to allow another loaded copy of the GHC -library to side-effect the PLS and for those changes to be reflected here. +The global IORef used for PersistentLinkerState actually contains another MVar, +which in turn contains a Maybe PersistentLinkerState. The MVar serves to ensure +mutual exclusion between multiple loaded copies of the GHC library. The Maybe +may be Nothing to indicate that the linker has not yet been initialised. The PersistentLinkerState maps Names to actual closures (for interpreted code only), for use during linking. -} #if STAGE < 2 -GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState) -GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised +GLOBAL_VAR_M( v_PersistentLinkerState + , newMVar Nothing + , MVar (Maybe PersistentLinkerState)) #else SHARED_GLOBAL_VAR_M( v_PersistentLinkerState , getOrSetLibHSghcPersistentLinkerState , "getOrSetLibHSghcPersistentLinkerState" - , newMVar (panic "Dynamic linker not initialised") - , MVar PersistentLinkerState) --- Set True when dynamic linker is initialised -SHARED_GLOBAL_VAR( v_InitLinkerDone - , getOrSetLibHSghcInitLinkerDone - , "getOrSetLibHSghcInitLinkerDone" - , False - , Bool) + , newMVar Nothing + , MVar (Maybe PersistentLinkerState)) #endif +uninitialised :: a +uninitialised = panic "Dynamic linker not initialised" + modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO () -modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f +modifyPLS_ f = readIORef v_PersistentLinkerState + >>= flip modifyMVar_ (fmap pure . f . fromMaybe uninitialised) modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a -modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f +modifyPLS f = readIORef v_PersistentLinkerState + >>= flip modifyMVar (fmapFst pure . f . fromMaybe uninitialised) + where fmapFst f = fmap (\(x, y) -> (f x, y)) + +readPLS :: IO PersistentLinkerState +readPLS = readIORef v_PersistentLinkerState + >>= fmap (fromMaybe uninitialised) . readMVar + +modifyMbPLS_ + :: (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO () +modifyMbPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f data PersistentLinkerState = PersistentLinkerState { @@ -158,10 +180,10 @@ extendLoadedPkgs pkgs = extendLinkEnv :: [(Name,ForeignHValue)] -> IO () extendLinkEnv new_bindings = - modifyPLS_ $ \pls -> do - let ce = closure_env pls - let new_ce = extendClosureEnv ce new_bindings - return pls{ closure_env = new_ce } + modifyPLS_ $ \pls@PersistentLinkerState{..} -> do + let new_ce = extendClosureEnv closure_env new_bindings + return $! pls{ closure_env = new_ce } + -- strictness is important for not retaining old copies of the pls deleteFromLinkEnv :: [Name] -> IO () deleteFromLinkEnv to_remove = @@ -243,7 +265,7 @@ withExtendedLinkEnv new_env action -- | Display the persistent linker state. showLinkerState :: DynFlags -> IO () showLinkerState dflags - = do pls <- readIORef v_PersistentLinkerState >>= readMVar + = do pls <- readPLS putLogMsg dflags NoReason SevDump noSrcSpan (defaultDumpStyle dflags) (vcat [text "----- Linker state -----", @@ -278,11 +300,10 @@ showLinkerState dflags -- initDynLinker :: HscEnv -> IO () initDynLinker hsc_env = - modifyPLS_ $ \pls0 -> do - done <- readIORef v_InitLinkerDone - if done then return pls0 - else do writeIORef v_InitLinkerDone True - reallyInitDynLinker hsc_env + modifyMbPLS_ $ \pls -> do + case pls of + Just _ -> return pls + Nothing -> Just <$> reallyInitDynLinker hsc_env reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState reallyInitDynLinker hsc_env = do @@ -310,7 +331,8 @@ linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState linkCmdLineLibs' hsc_env pls = do let dflags@(DynFlags { ldInputs = cmdline_ld_inputs - , libraryPaths = lib_paths}) = hsc_dflags hsc_env + , libraryPaths = lib_paths_base}) + = hsc_dflags hsc_env -- (c) Link libraries from the command-line let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] @@ -325,8 +347,18 @@ linkCmdLineLibs' hsc_env pls = minus_ls = case os of OSMinGW32 -> "pthread" : minus_ls_1 _ -> minus_ls_1 + -- See Note [Fork/Exec Windows] + gcc_paths <- getGCCPaths dflags os + + lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base - libspecs <- mapM (locateLib hsc_env False lib_paths) minus_ls + maybePutStrLn dflags "Search directories (user):" + maybePutStr dflags (unlines $ map (" "++) lib_paths_env) + maybePutStrLn dflags "Search directories (gcc):" + maybePutStr dflags (unlines $ map (" "++) gcc_paths) + + libspecs + <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls -- (d) Link .o files from the command-line classified_ld_inputs <- mapM (classifyLdInput dflags) @@ -350,10 +382,12 @@ linkCmdLineLibs' hsc_env pls = -- on Windows. On Unix OSes this function is a NOP. let all_paths = let paths = takeDirectory (fst $ sPgm_c $ settings dflags) : framework_paths - ++ lib_paths + ++ lib_paths_base ++ [ takeDirectory dll | DLLPath dll <- libspecs ] in nub $ map normalise paths - pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths + let lib_paths = nub $ lib_paths_base ++ gcc_paths + all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths + pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls cmdline_lib_specs @@ -483,9 +517,17 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do = do b <- doesFileExist name if not b then return False else do if dynamicGhc - then panic "Loading archives not supported" + then throwGhcExceptionIO $ + CmdLineError dynamic_msg else loadArchive hsc_env name return True + where + dynamic_msg = unlines + [ "User-specified static library could not be loaded (" + ++ name ++ ")" + , "Loading static libraries is not supported in this configuration." + , "Try using a dynamic library instead." + ] {- ********************************************************************** @@ -722,15 +764,6 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) adjust_ul _ l@(BCOs {}) = return l -#if !MIN_VERSION_filepath(1,4,1) - stripExtension :: String -> FilePath -> Maybe FilePath - stripExtension [] path = Just path - stripExtension ext@(x:_) path = stripSuffix dotExt path - where dotExt = if isExtSeparator x then ext else '.':ext - - stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] - stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys) -#endif @@ -895,16 +928,14 @@ dynLoadObjs hsc_env pls objs = do -- can resolve dependencies when it loads this -- library. ldInputs = - concatMap - (\(lp, l) -> - [ Option ("-L" ++ lp) - , Option "-Xlinker" - , Option "-rpath" - , Option "-Xlinker" - , Option lp - , Option ("-l" ++ l) - ]) - (temp_sos pls) + concatMap (\l -> [ Option ("-l" ++ l) ]) + (nub $ snd <$> temp_sos pls) + ++ concatMap (\lp -> [ Option ("-L" ++ lp) + , Option "-Xlinker" + , Option "-rpath" + , Option "-Xlinker" + , Option lp ]) + (nub $ fst <$> temp_sos pls) ++ concatMap (\lp -> [ Option ("-L" ++ lp) @@ -1072,15 +1103,19 @@ unload_wkr :: HscEnv -- Does the core unload business -- (the wrapper blocks exceptions and deals with the PLS get and put) -unload_wkr hsc_env keep_linkables pls = do +unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..} = do + -- NB. careful strictness here to avoid keeping the old PLS when + -- we're unloading some code. -fghci-leak-check with the tests in + -- testsuite/ghci can detect space leaks here. + let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables discard keep l = not (linkableInSet l keep) (objs_to_unload, remaining_objs_loaded) = - partition (discard objs_to_keep) (objs_loaded pls) + partition (discard objs_to_keep) objs_loaded (bcos_to_unload, remaining_bcos_loaded) = - partition (discard bcos_to_keep) (bcos_loaded pls) + partition (discard bcos_to_keep) bcos_loaded mapM_ unloadObjs objs_to_unload mapM_ unloadObjs bcos_to_unload @@ -1091,7 +1126,7 @@ unload_wkr hsc_env keep_linkables pls = do filter (not . null . linkableObjs) bcos_to_unload))) $ purgeLookupSymbolCache hsc_env - let bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded + let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded -- Note that we want to remove all *local* -- (i.e. non-isExternal) names too (these are the @@ -1099,13 +1134,13 @@ unload_wkr hsc_env keep_linkables pls = do keep_name (n,_) = isExternalName n && nameModule n `elemModuleSet` bcos_retained - itbl_env' = filterNameEnv keep_name (itbl_env pls) - closure_env' = filterNameEnv keep_name (closure_env pls) + itbl_env' = filterNameEnv keep_name itbl_env + closure_env' = filterNameEnv keep_name closure_env - new_pls = pls { itbl_env = itbl_env', - closure_env = closure_env', - bcos_loaded = remaining_bcos_loaded, - objs_loaded = remaining_objs_loaded } + !new_pls = pls { itbl_env = itbl_env', + closure_env = closure_env', + bcos_loaded = remaining_bcos_loaded, + objs_loaded = remaining_objs_loaded } return new_pls where @@ -1250,9 +1285,14 @@ linkPackage hsc_env pkg then Packages.extraLibraries pkg else Packages.extraGHCiLibraries pkg) ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] - - hs_classifieds <- mapM (locateLib hsc_env True dirs) hs_libs' - extra_classifieds <- mapM (locateLib hsc_env False dirs) extra_libs + -- See Note [Fork/Exec Windows] + gcc_paths <- getGCCPaths dflags (platformOS platform) + dirs_env <- addEnvPaths "LIBRARY_PATH" dirs + + hs_classifieds + <- mapM (locateLib hsc_env True dirs_env gcc_paths) hs_libs' + extra_classifieds + <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs let classifieds = hs_classifieds ++ extra_classifieds -- Complication: all the .so's must be loaded before any of the .o's. @@ -1264,7 +1304,8 @@ linkPackage hsc_env pkg -- Add directories to library search paths let dll_paths = map takeDirectory known_dlls all_paths = nub $ map normalise $ dll_paths ++ dirs - pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths + all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths + pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env maybePutStr dflags ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") @@ -1306,8 +1347,8 @@ load_dyn hsc_env dll = do r <- loadDLL hsc_env dll case r of Nothing -> return () - Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: " - ++ dll ++ " (" ++ err ++ ")" )) + Just err -> cmdLineErrorIO ("can't load .so/.DLL for: " + ++ dll ++ " (" ++ err ++ ")") loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO () loadFrameworks hsc_env platform pkg @@ -1319,8 +1360,8 @@ loadFrameworks hsc_env platform pkg load fw = do r <- loadFramework hsc_env fw_dirs fw case r of Nothing -> return () - Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: " - ++ fw ++ " (" ++ err ++ ")" )) + Just err -> cmdLineErrorIO ("can't load framework: " + ++ fw ++ " (" ++ err ++ ")" ) -- Try to find an object file for a given library in the given paths. -- If it isn't present, we assume that addDLL in the RTS can find it, @@ -1328,25 +1369,40 @@ loadFrameworks hsc_env platform pkg -- standard system search path. -- For GHCi we tend to prefer dynamic libraries over static ones as -- they are easier to load and manage, have less overhead. -locateLib :: HscEnv -> Bool -> [FilePath] -> String -> IO LibrarySpec -locateLib hsc_env is_hs dirs lib +locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String + -> IO LibrarySpec +locateLib hsc_env is_hs lib_dirs gcc_dirs lib | not is_hs -- For non-Haskell libraries (e.g. gmp, iconv): - -- first look in library-dirs for a dynamic library (libfoo.so) + -- first look in library-dirs for a dynamic library (on User paths only) + -- (libfoo.so) + -- then try looking for import libraries on Windows (on User paths only) + -- (.dll.a, .lib) + -- first look in library-dirs for a dynamic library (on GCC paths only) + -- (libfoo.so) + -- then check for system dynamic libraries (e.g. kernel32.dll on windows) + -- then try looking for import libraries on Windows (on GCC paths only) + -- (.dll.a, .lib) -- then look in library-dirs for a static library (libfoo.a) -- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so) - -- then check for system dynamic libraries (e.g. kernel32.dll on windows) -- then try looking for import libraries on Windows (.dll.a, .lib) - -- then try "gcc --print-file-name" to search gcc's search path -- then look in library-dirs and inplace GCC for a static library (libfoo.a) + -- then try "gcc --print-file-name" to search gcc's search path -- for a dynamic library (#5289) -- otherwise, assume loadDLL can find it -- - = findDll `orElse` - findSysDll `orElse` - tryImpLib `orElse` - tryGcc `orElse` - findArchive `orElse` + -- The logic is a bit complicated, but the rationale behind it is that + -- loading a shared library for us is O(1) while loading an archive is + -- O(n). Loading an import library is also O(n) so in general we prefer + -- shared libraries because they are simpler and faster. + -- + = findDll user `orElse` + tryImpLib user `orElse` + findDll gcc `orElse` + findSysDll `orElse` + tryImpLib gcc `orElse` + findArchive `orElse` + tryGcc `orElse` assumeDll | loading_dynamic_hs_libs -- search for .so libraries first. @@ -1367,11 +1423,15 @@ locateLib hsc_env is_hs dirs lib where dflags = hsc_dflags hsc_env + dirs = lib_dirs ++ gcc_dirs + gcc = False + user = True obj_file = lib <.> "o" dyn_obj_file = lib <.> "dyn_o" arch_files = [ "lib" ++ lib ++ lib_tag <.> "a" , lib <.> "a" -- native code has no lib_tag + , "lib" ++ lib, lib ] lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" @@ -1393,19 +1453,26 @@ locateLib hsc_env is_hs dirs lib findObject = liftM (fmap Object) $ findFile dirs obj_file findDynObject = liftM (fmap Object) $ findFile dirs dyn_obj_file - findArchive = let local name = liftM (fmap Archive) $ findFile dirs name - linked name = liftM (fmap Archive) $ searchForLibUsingGcc dflags name dirs - check name = apply [local name, linked name] - in apply (map check arch_files) + findArchive = let local name = liftM (fmap Archive) $ findFile dirs name + in apply (map local arch_files) findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file - findDll = liftM (fmap DLLPath) $ findFile dirs dyn_lib_file - findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary hsc_env so_name - tryGcc = let short = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name dirs - full = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs - in liftM2 (<|>) short full - tryImpLib = case os of - OSMinGW32 -> let check name = liftM (fmap Archive) $ searchForLibUsingGcc dflags name dirs - in apply (map check import_libs) + findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs + in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file + findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ + findSystemLibrary hsc_env so_name + tryGcc = let search = searchForLibUsingGcc dflags + dllpath = liftM (fmap DLLPath) + short = dllpath $ search so_name lib_dirs + full = dllpath $ search lib_so_name lib_dirs + gcc name = liftM (fmap Archive) $ search name lib_dirs + files = import_libs ++ arch_files + in apply $ short : full : map gcc files + tryImpLib re = case os of + OSMinGW32 -> + let dirs' = if re == user then lib_dirs else gcc_dirs + implib name = liftM (fmap Archive) $ + findFile dirs' name + in apply (map implib import_libs) _ -> return Nothing assumeDll = return (DLL lib) @@ -1435,6 +1502,96 @@ searchForLibUsingGcc dflags so dirs = do then return Nothing else return (Just file) +-- | Retrieve the list of search directory GCC and the System use to find +-- libraries and components. See Note [Fork/Exec Windows]. +getGCCPaths :: DynFlags -> OS -> IO [FilePath] +getGCCPaths dflags os + = case os of + OSMinGW32 -> + do gcc_dirs <- getGccSearchDirectory dflags "libraries" + sys_dirs <- getSystemDirectories + return $ nub $ gcc_dirs ++ sys_dirs + _ -> return [] + +-- | Cache for the GCC search directories as this can't easily change +-- during an invocation of GHC. (Maybe with some env. variable but we'll) +-- deal with that highly unlikely scenario then. +{-# NOINLINE gccSearchDirCache #-} +gccSearchDirCache :: IORef [(String, [String])] +gccSearchDirCache = unsafePerformIO $ newIORef [] + +-- Note [Fork/Exec Windows] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- fork/exec is expensive on Windows, for each time we ask GCC for a library we +-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1. +-- So instead get a list of location that GCC would search and use findDirs +-- which hopefully is written in an optimized mannor to take advantage of +-- caching. At the very least we remove the overhead of the fork/exec and waits +-- which dominate a large percentage of startup time on Windows. +getGccSearchDirectory :: DynFlags -> String -> IO [FilePath] +getGccSearchDirectory dflags key = do + cache <- readIORef gccSearchDirCache + case lookup key cache of + Just x -> return x + Nothing -> do + str <- askLd dflags [Option "--print-search-dirs"] + let line = dropWhile isSpace str + name = key ++ ": =" + if null line + then return [] + else do let val = split $ find name line + dirs <- filterM doesDirectoryExist val + modifyIORef' gccSearchDirCache ((key, dirs):) + return val + where split :: FilePath -> [FilePath] + split r = case break (==';') r of + (s, [] ) -> [s] + (s, (_:xs)) -> s : split xs + + find :: String -> String -> String + find r x = let lst = lines x + val = filter (r `isPrefixOf`) lst + in if null val + then [] + else case break (=='=') (head val) of + (_ , []) -> [] + (_, (_:xs)) -> xs + +-- | Get a list of system search directories, this to alleviate pressure on +-- the findSysDll function. +getSystemDirectories :: IO [FilePath] +#if defined(mingw32_HOST_OS) +getSystemDirectories = fmap (:[]) getSystemDirectory +#else +getSystemDirectories = return [] +#endif + +-- | Merge the given list of paths with those in the environment variable +-- given. If the variable does not exist then just return the identity. +addEnvPaths :: String -> [String] -> IO [String] +addEnvPaths name list + = do -- According to POSIX (chapter 8.3) a zero-length prefix means current + -- working directory. Replace empty strings in the env variable with + -- `working_dir` (see also #14695). + working_dir <- getCurrentDirectory + values <- lookupEnv name + case values of + Nothing -> return list + Just arr -> return $ list ++ splitEnv working_dir arr + where + splitEnv :: FilePath -> String -> [String] + splitEnv working_dir value = + case break (== envListSep) value of + (x, [] ) -> + [if null x then working_dir else x] + (x, (_:xs)) -> + (if null x then working_dir else x) : splitEnv working_dir xs +#if defined(mingw32_HOST_OS) + envListSep = ';' +#else + envListSep = ':' +#endif + -- ---------------------------------------------------------------------------- -- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) |