X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FLinker.lhs;h=3a5ecf8a6d62f508d37cd0449d162112dcaedfcc;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=c971f91d82408ae4a8e8896a1be6f0307e750053;hpb=0ccda78f87045a3247325c6e8ae9149c3264ba70;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index c971f91..3a5ecf8 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -16,8 +16,9 @@ necessary. {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-} module Linker ( HValue, showLinkerState, - linkExpr, unload, extendLinkEnv, - linkPackages, + linkExpr, unload, extendLinkEnv, withExtendedLinkEnv, + extendLoadedPkgs, + linkPackages,initDynLinker ) where #include "HsVersions.h" @@ -29,7 +30,6 @@ import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..)) import Packages import DriverPhases ( isObjectFilename, isDynLibFilename ) -import Util ( getFileSuffix ) import Finder ( findModule, findObjectLinkableMaybe, FindResult(..) ) import HscTypes import Name ( Name, nameModule, isExternalName, isWiredInName ) @@ -41,20 +41,20 @@ import DynFlags ( DynFlags(..), getOpts ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Outputable import Panic ( GhcException(..) ) -import Util ( zipLazy, global ) +import Util ( zipLazy, global, joinFileExt, joinFileName, suffixOf ) import StaticFlags ( v_Ld_inputs ) import ErrUtils ( debugTraceMsg ) -- Standard libraries import Control.Monad ( when, filterM, foldM ) -import Data.IORef ( IORef, readIORef, writeIORef ) +import Data.IORef ( IORef, readIORef, writeIORef, modifyIORef ) import Data.List ( partition, nub ) import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO ) import System.Directory ( doesFileExist ) -import Control.Exception ( block, throwDyn ) +import Control.Exception ( block, throwDyn, bracket ) import Maybe ( isJust, fromJust ) #if __GLASGOW_HASKELL__ >= 503 @@ -125,6 +125,10 @@ emptyPLS dflags = PersistentLinkerState { \end{code} \begin{code} +extendLoadedPkgs :: [PackageId] -> IO () +extendLoadedPkgs pkgs + = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s}) + extendLinkEnv :: [(Name,HValue)] -> IO () -- Automatically discards shadowed bindings extendLinkEnv new_bindings @@ -133,6 +137,18 @@ extendLinkEnv new_bindings new_pls = pls { closure_env = new_closure_env } writeIORef v_PersistentLinkerState new_pls +withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a +withExtendedLinkEnv new_env action + = bracket set_new_env + reset_old_env + (const action) + where set_new_env = do pls <- readIORef v_PersistentLinkerState + let new_closure_env = extendClosureEnv (closure_env pls) new_env + new_pls = pls { closure_env = new_closure_env } + writeIORef v_PersistentLinkerState new_pls + return pls + reset_old_env pls = writeIORef v_PersistentLinkerState pls + -- filterNameMap removes from the environment all entries except -- those for a given set of modules; -- Note that this removes all *local* (i.e. non-isExternal) names too @@ -624,12 +640,9 @@ unload dflags linkables new_pls <- unload_wkr dflags linkables pls writeIORef v_PersistentLinkerState new_pls - debugTraceMsg dflags 3 (showSDoc - (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))) - debugTraceMsg dflags 3 (showSDoc - (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))) - - return () + debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)) + debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)) + return () unload_wkr :: DynFlags -> [Linkable] -- stable linkables @@ -760,8 +773,19 @@ linkPackage :: DynFlags -> PackageConfig -> IO () linkPackage dflags pkg = do let dirs = Packages.libraryDirs pkg - let libs = Packages.hsLibraries pkg ++ Packages.extraLibraries pkg - ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] + + let libs = Packages.hsLibraries 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 + -- 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. + ++ (if null (Packages.extraGHCiLibraries pkg) + then Packages.extraLibraries pkg + else Packages.extraGHCiLibraries pkg) + ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] classifieds <- mapM (locateOneObj dirs) libs -- Complication: all the .so's must be loaded before any of the .o's. @@ -827,8 +851,8 @@ locateOneObj dirs lib Just lib_path -> return (DLL (lib ++ "_dyn")) Nothing -> return (DLL lib) }} -- We assume where - mk_obj_path dir = dir ++ '/':lib ++ ".o" - mk_dyn_lib_path dir = dir ++ '/':mkSOName (lib ++ "_dyn") + mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o") + mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn") -- ---------------------------------------------------------------------------- @@ -843,16 +867,16 @@ loadDynamic paths rootname -- Tried all our known library paths, so let -- dlopen() search its own builtin paths now. where - mk_dll_path dir = dir ++ '/':mkSOName rootname + mk_dll_path dir = dir `joinFileName` mkSOName rootname #if defined(darwin_TARGET_OS) -mkSOName root = "lib" ++ root ++ ".dylib" +mkSOName root = ("lib" ++ root) `joinFileExt` "dylib" #elif defined(mingw32_TARGET_OS) -- Win32 DLLs have no .dll extension here, because addDLL tries -- both foo.dll and foo.drv mkSOName root = root #else -mkSOName root = "lib" ++ root ++ ".so" +mkSOName root = ("lib" ++ root) `joinFileExt` "so" #endif -- Darwin / MacOS X only: load a framework @@ -867,7 +891,7 @@ loadFramework extraPaths rootname -- Tried all our known library paths, but dlopen() -- has no built-in paths for frameworks: give up where - mk_fwk dir = dir ++ '/' : rootname ++ ".framework/" ++ rootname + mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname) -- sorry for the hardcoded paths, I hope they won't change anytime soon: defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] #endif