diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/ghci/Linker.hs | 86 | ||||
| -rw-r--r-- | compiler/ghci/ObjLink.hs | 47 |
2 files changed, 80 insertions, 53 deletions
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 9fa89fec5e..13085090ef 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -299,39 +299,47 @@ linkCmdLineLibs dflags = do linkCmdLineLibs' :: DynFlags -> PersistentLinkerState -> IO PersistentLinkerState linkCmdLineLibs' dflags@(DynFlags { ldInputs = cmdline_ld_inputs , libraryPaths = lib_paths}) pls = - do { -- (c) Link libraries from the command-line - ; let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] - ; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls - - -- (d) Link .o files from the command-line - ; classified_ld_inputs <- mapM (classifyLdInput dflags) - [ f | FileOption _ f <- cmdline_ld_inputs ] - - -- (e) Link any MacOS frameworks - ; let platform = targetPlatform dflags - ; let (framework_paths, frameworks) = - if platformUsesFrameworks platform - then (frameworkPaths dflags, cmdlineFrameworks dflags) - else ([],[]) - - -- Finally do (c),(d),(e) - ; let cmdline_lib_specs = catMaybes classified_ld_inputs - ++ libspecs - ++ map Framework frameworks - ; if null cmdline_lib_specs then return pls - else do - - { pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls - cmdline_lib_specs - ; maybePutStr dflags "final link ... " - ; ok <- resolveObjs - - ; if succeeded ok then maybePutStrLn dflags "done" - else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") - - ; return pls1 - }} - + do -- (c) Link libraries from the command-line + let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] + libspecs <- mapM (locateLib dflags False lib_paths) minus_ls + + -- (d) Link .o files from the command-line + classified_ld_inputs <- mapM (classifyLdInput dflags) + [ f | FileOption _ f <- cmdline_ld_inputs ] + + -- (e) Link any MacOS frameworks + let platform = targetPlatform dflags + let (framework_paths, frameworks) = + if platformUsesFrameworks platform + then (frameworkPaths dflags, cmdlineFrameworks dflags) + else ([],[]) + + -- Finally do (c),(d),(e) + let cmdline_lib_specs = catMaybes classified_ld_inputs + ++ libspecs + ++ map Framework frameworks + if null cmdline_lib_specs then return pls + else do + + -- Add directories to library search paths + let all_paths = let paths = framework_paths + ++ lib_paths + ++ [ takeDirectory dll | DLLPath dll <- libspecs ] + in nub $ map normalise paths + pathCache <- mapM addLibrarySearchPath all_paths + + pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls + cmdline_lib_specs + maybePutStr dflags "final link ... " + ok <- resolveObjs + + -- DLLs are loaded, reset the search paths + mapM_ removeLibrarySearchPath $ reverse pathCache + + if succeeded ok then maybePutStrLn dflags "done" + else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") + + return pls1 {- Note [preload packages] @@ -1021,7 +1029,7 @@ data LibrarySpec | DLL String -- "Unadorned" name of a .DLL/.so -- e.g. On unix "qt" denotes "libqt.so" - -- On WinDoze "burble" denotes "burble.DLL" + -- On Windows "burble" denotes "burble.DLL" or "libburble.dll" -- loadDLL is platform-specific and adds the lib/.so/.DLL -- suffixes platform-dependently @@ -1115,7 +1123,7 @@ linkPackage dflags pkg -- 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 - -- that are actually gnu ld scripts, and the possability that the .a + -- that are actually gnu ld scripts, and the possibility that the .a -- libs do not exactly match the .so/.dll equivalents. So if the -- package file provides an "extra-ghci-libraries" field then we use -- that instead of the "extra-libraries" field. @@ -1135,6 +1143,11 @@ linkPackage dflags pkg objs = [ obj | Object obj <- classifieds ] archs = [ arch | Archive arch <- classifieds ] + -- Add directories to library search paths + let dll_paths = map takeDirectory known_dlls + all_paths = nub $ map normalise $ dll_paths ++ dirs + pathCache <- mapM addLibrarySearchPath all_paths + maybePutStr dflags ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") @@ -1143,6 +1156,9 @@ linkPackage dflags pkg loadFrameworks platform pkg mapM_ load_dyn (known_dlls ++ map (mkSOName platform) dlls) + -- DLLs are loaded, reset the search paths + mapM_ removeLibrarySearchPath $ reverse pathCache + -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link -- step to resolve everything. diff --git a/compiler/ghci/ObjLink.hs b/compiler/ghci/ObjLink.hs index c9cf78cc4d..d5d4980387 100644 --- a/compiler/ghci/ObjLink.hs +++ b/compiler/ghci/ObjLink.hs @@ -9,14 +9,16 @@ -- | Primarily, this module consists of an interface to the C-land -- dynamic linker. module ObjLink ( - initObjLinker, -- :: IO () - loadDLL, -- :: String -> IO (Maybe String) - loadArchive, -- :: String -> IO () - loadObj, -- :: String -> IO () - unloadObj, -- :: String -> IO () - insertSymbol, -- :: String -> String -> Ptr a -> IO () - lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) - resolveObjs -- :: IO SuccessFlag + initObjLinker, -- :: IO () + loadDLL, -- :: String -> IO (Maybe String) + loadArchive, -- :: String -> IO () + loadObj, -- :: String -> IO () + unloadObj, -- :: String -> IO () + insertSymbol, -- :: String -> String -> Ptr a -> IO () + lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) + resolveObjs, -- :: IO SuccessFlag + addLibrarySearchPath, -- :: CFilePath -> IO (Ptr ()) + removeLibrarySearchPath -- :: Ptr() -> IO Bool ) where import Panic @@ -29,7 +31,7 @@ import Foreign.C import Foreign ( nullPtr ) import GHC.Exts ( Ptr(..) ) import System.Posix.Internals ( CFilePath, withFilePath ) -import System.FilePath ( dropExtension ) +import System.FilePath ( dropExtension, normalise ) -- --------------------------------------------------------------------------- @@ -75,7 +77,7 @@ loadDLL str0 = do str | isWindowsHost = dropExtension str0 | otherwise = str0 -- - maybe_errmsg <- withFilePath str $ \dll -> c_addDLL dll + maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll if maybe_errmsg == nullPtr then return Nothing else do str <- peekCString maybe_errmsg @@ -99,6 +101,13 @@ unloadObj str = r <- c_unloadObj c_str when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed")) +addLibrarySearchPath :: String -> IO (Ptr ()) +addLibrarySearchPath str = + withFilePath str c_addLibrarySearchPath + +removeLibrarySearchPath :: Ptr () -> IO Bool +removeLibrarySearchPath = c_removeLibrarySearchPath + resolveObjs :: IO SuccessFlag resolveObjs = do r <- c_resolveObjs @@ -108,11 +117,13 @@ resolveObjs = do -- Foreign declarations to RTS entry points which does the real work; -- --------------------------------------------------------------------------- -foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString -foreign import ccall unsafe "initLinker" initObjLinker :: IO () -foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CFilePath -> CString -> Ptr a -> IO () -foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) -foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int -foreign import ccall unsafe "loadObj" c_loadObj :: CFilePath -> IO Int -foreign import ccall unsafe "unloadObj" c_unloadObj :: CFilePath -> IO Int -foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int +foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString +foreign import ccall unsafe "initLinker" initObjLinker :: IO () +foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CFilePath -> CString -> Ptr a -> IO () +foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) +foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int +foreign import ccall unsafe "loadObj" c_loadObj :: CFilePath -> IO Int +foreign import ccall unsafe "unloadObj" c_unloadObj :: CFilePath -> IO Int +foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int +foreign import ccall unsafe "addLibrarySearchPath" c_addLibrarySearchPath :: CFilePath -> IO (Ptr ()) +foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr() -> IO Bool |