X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=eaf452199eb1e7c38fd902e0d7e30ebd48a4ea22;hp=5c05122ed40bc1dfe50f18a07fd372d10261c084;hb=16b9e80dc14db24509f051f294b5b51943285090;hpb=4fa44a3ae9c36222ccb460ba3ed24e46bf7c70ae diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 5c05122..eaf4521 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -38,7 +38,7 @@ import Name import NameEnv import NameSet import qualified OccName -import LazyUniqFM +import UniqFM import Module import ListSetOps import DynFlags @@ -53,7 +53,7 @@ import qualified Maybes import UniqSet import Constants import FastString -import Config ( cProjectVersion ) +import Config -- Standard libraries import Control.Monad @@ -61,6 +61,7 @@ import Control.Monad import Data.Char import Data.IORef import Data.List +import qualified Data.Map as Map import Foreign import Control.Concurrent.MVar @@ -102,18 +103,18 @@ 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 @@ -244,11 +245,18 @@ 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. @@ -428,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 @@ -467,6 +480,10 @@ preloadLib dflags lib_paths framework_paths lib_spec = 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} @@ -526,8 +543,17 @@ 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 @@ -623,6 +649,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods 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) $$ @@ -647,7 +674,7 @@ getLinkDeps hsc_env hpt pls 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 }} @@ -682,7 +709,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods 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) @@ -852,7 +879,7 @@ 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 @@ -918,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" @@ -942,10 +971,11 @@ partOfGHCi :: [PackageName] 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 @@ -973,23 +1003,25 @@ linkPackages dflags new_pkgs = do 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') } @@ -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,13 +1053,14 @@ 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 (packageName pkg `notElem` partOfGHCi) $ do @@ -1041,11 +1080,12 @@ 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 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 @@ -1072,32 +1112,32 @@ loadFrameworks pkg -- 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)