X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=5ab741622fb955a32881d10c94f8fd577b9f4a6a;hb=7eb5e29b4a7b6fef55512bc7bf3308e712ca3eba;hp=bce79c257f011d546e8c516d9be517de8675887a;hpb=0169d632bbff08b6031cda428acad0de35fcaa86;p=ghc-hetmet.git diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index bce79c2..5ab7416 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -14,6 +14,13 @@ necessary. \begin{code} {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, @@ -56,6 +63,7 @@ import SrcLoc import UniqSet import Constants import FastString +import Config ( cProjectVersion ) -- Standard libraries import Control.Monad @@ -65,6 +73,7 @@ import Data.IORef import Data.List import Foreign +import System.FilePath import System.IO import System.Directory @@ -161,7 +170,7 @@ deleteFromLinkEnv to_remove -- We use this string to lookup the interpreter's internal representation of the name -- using the lookupOrig. -dataConInfoPtrToName :: Ptr () -> TcM Name +dataConInfoPtrToName :: Ptr () -> TcM (Either String Name) dataConInfoPtrToName x = do theString <- ioToTcRn $ do let ptr = castPtr x :: Ptr StgInfoTable @@ -173,7 +182,8 @@ dataConInfoPtrToName x = do occFS = mkFastStringByteList occ occName = mkOccNameFS OccName.dataName occFS modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) - lookupOrig modName occName + return (Left$ showSDoc$ ppr modName <> dot <> ppr occName ) + `recoverM` (Right `fmap` lookupOrig modName occName) where @@ -648,7 +658,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods return lnk adjust_ul osuf (DotO file) = do - let new_file = replaceFilenameSuffix file osuf + let new_file = replaceExtension file osuf ok <- doesFileExist new_file if (not ok) then dieWith span $ @@ -1057,6 +1067,9 @@ loadFrameworks pkg = mapM_ load frameworks -- Try to find an object file for a given library in the given paths. -- If it isn't present, we assume it's a dynamic library. +#ifndef __PIC__ +-- When the GHC package was not compiled as dynamic library (=__PIC__ not set), +-- we search for .o libraries first. locateOneObj :: [FilePath] -> String -> IO LibrarySpec locateOneObj dirs lib = do { mb_obj_path <- findFile mk_obj_path dirs @@ -1065,12 +1078,28 @@ locateOneObj dirs lib Nothing -> do { mb_lib_path <- findFile mk_dyn_lib_path dirs ; case mb_lib_path of - Just lib_path -> return (DLL (lib ++ "_dyn")) + Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion)) Nothing -> return (DLL lib) }} -- We assume where - mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o") - mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn") - + mk_obj_path dir = dir lib <.> "o" + mk_dyn_lib_path dir = dir mkSOName (lib ++ "-ghc" ++ cProjectVersion) +#else +-- When the GHC package was compiled as dynamic library (=__PIC__ set), +-- we search for .so libraries first. +locateOneObj :: [FilePath] -> String -> IO LibrarySpec +locateOneObj dirs lib + = do { mb_lib_path <- findFile mk_dyn_lib_path dirs + ; case mb_lib_path of + Just lib_path -> 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 + where + mk_obj_path dir = dir (lib <.> "o") + mk_dyn_lib_path dir = dir mkSOName (lib ++ "-ghc" ++ cProjectVersion) +#endif -- ---------------------------------------------------------------------------- -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) @@ -1084,16 +1113,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 `joinFileName` mkSOName rootname + mk_dll_path dir = dir mkSOName rootname #if defined(darwin_TARGET_OS) -mkSOName root = ("lib" ++ root) `joinFileExt` "dylib" +mkSOName root = ("lib" ++ root) <.> "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) `joinFileExt` "so" +mkSOName root = ("lib" ++ root) <.> "so" #endif -- Darwin / MacOS X only: load a framework @@ -1101,15 +1130,20 @@ mkSOName root = ("lib" ++ root) `joinFileExt` "so" -- name. They are searched for in different paths than normal libraries. #ifdef darwin_TARGET_OS loadFramework extraPaths rootname - = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths) - ; case mb_fwk of - Just fwk_path -> loadDLL fwk_path - Nothing -> return (Just "not found") } - -- Tried all our known library paths, but dlopen() - -- has no built-in paths for frameworks: give up + = do { either_dir <- Control.Exception.try getHomeDirectory + ; let homeFrameworkPath = case either_dir of + Left _ -> [] + Right dir -> [dir ++ "/Library/Frameworks"] + ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths + ; mb_fwk <- findFile mk_fwk ps + ; case mb_fwk of + Just fwk_path -> loadDLL fwk_path + Nothing -> return (Just "not found") } + -- Tried all our known library paths, but dlopen() + -- has no built-in paths for frameworks: give up where - mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname) - -- sorry for the hardcoded paths, I hope they won't change anytime soon: + mk_fwk dir = dir (rootname ++ ".framework/" ++ rootname) + -- sorry for the hardcoded paths, I hope they won't change anytime soon: defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] #endif \end{code}