X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=45cbdc095fd468851ed0b9e272e10fa35c69b6b4;hb=a8407757462804dfd51708d6cfdda0417a91bf8e;hp=419cb4f968d079aaf4d8c59e8dd29445ccff61c1;hpb=740618f2b7d822f53528d271ccfb617c8ce84c55;p=ghc-hetmet.git diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 419cb4f..45cbdc0 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 @@ -51,6 +51,7 @@ import ErrUtils import SrcLoc import qualified Maybes import UniqSet +import FiniteMap import Constants import FastString import Config ( cProjectVersion ) @@ -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 @@ -527,7 +528,16 @@ dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg))) checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String) checkNonStdWay dflags srcspan = do let tag = buildTag dflags - if null tag then return Nothing else do + 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 @@ -682,7 +692,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 +862,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 @@ -973,23 +983,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_one pkg_map pkgs new_pkg + link :: [PackageId] -> [PackageId] -> IO [PackageId] + link pkgs new_pkgs = + foldM link_one pkgs new_pkgs + + 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" $ + lookupFM ipid_map ipid + | ipid <- depends pkg_cfg ] -- Now link the package itself ; linkPackage dflags pkg_cfg ; return (new_pkg : pkgs') } @@ -1021,7 +1033,7 @@ linkPackage dflags pkg let dlls = [ dll | DLL dll <- classifieds ] objs = [ obj | Object obj <- 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 @@ -1045,7 +1057,7 @@ linkPackage dflags pkg 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,23 +1084,20 @@ loadFrameworks pkg -- If it isn't present, we assume it's a dynamic library. locateOneObj :: [FilePath] -> String -> IO LibrarySpec locateOneObj dirs lib - | not picIsOn + | not isDynamicGhcLib -- When the GHC package was not compiled as dynamic library - -- (=__PIC__ not set), we search for .o libraries first. + -- (=DYNAMIC not set), we search for .o libraries. = 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), + Nothing -> return (DLL lib) } + + | 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)) + Just _ -> return (DLL dyn_lib_name) Nothing -> do { mb_obj_path <- findFile mk_obj_path dirs ; case mb_obj_path of