import NameEnv
import NameSet
import qualified OccName
-import LazyUniqFM
+import UniqFM
import Module
import ListSetOps
import DynFlags
import UniqSet
import Constants
import FastString
-import Config ( cProjectVersion )
+import Config
-- Standard libraries
import Control.Monad
import Data.Char
import Data.IORef
import Data.List
+import qualified Data.Map as Map
import Foreign
import Control.Concurrent.MVar
-- 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
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.
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
= do b <- doesFileExist name
if not b then return False
else loadObj name >> return True
+ preload_static_archive _paths name
+ = do b <- doesFileExist name
+ if not b then return False
+ else loadArchive name >> return True
\end{code}
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
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) $$
-- ...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
}}
linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
-> IO (PersistentLinkerState, SuccessFlag)
linkModules dflags pls linkables
- = block $ do -- don't want to be interrupted by ^C in here
+ = mask_ $ do -- don't want to be interrupted by ^C in here
let (objs, bcos) = partition isObjectLinkable
(concatMap partitionLinkable linkables)
-> [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
-- 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"
partOfGHCi
| isWindowsTarget || isDarwinTarget = []
| otherwise = map PackageName
- ["base", "haskell98", "template-haskell", "editline"]
+ ["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] -> PersistentLinkerState
-> IO PersistentLinkerState
linkPackages' dflags new_pks pls = do
- let pkg_map = pkgIdMap (pkgState dflags)
-
- pkgs' <- link pkg_map (pkgs_loaded pls) new_pks
-
+ pkgs' <- link (pkgs_loaded pls) new_pks
return $! 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
+ pkg_map = pkgIdMap (pkgState dflags)
+ ipid_map = installedPackageIdMap (pkgState dflags)
+
+ 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') }
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
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 (packageName pkg `notElem` partOfGHCi) $ do
-- 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 ghcError (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
-- If it isn't present, we assume it's a dynamic library.
locateOneObj :: [FilePath] -> String -> IO LibrarySpec
locateOneObj dirs lib
- | not picIsOn
- -- When the GHC package was not compiled as dynamic library
- -- (=__PIC__ not set), we search for .o libraries first.
- = 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 _ -> return (DLL dyn_lib_name)
- Nothing -> return (DLL lib) }} -- We assume
- | otherwise
- -- When the GHC package was compiled as dynamic library (=__PIC__ set),
+ | 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.
- = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
- ; case mb_lib_path of
- Just _ -> 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
+ = findDll `orElse` findObject `orElse` findArchive `orElse` assumeDll
where
mk_obj_path dir = dir </> (lib <.> "o")
+ 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)
projects / ghc-hetmet.git / blobdiff