X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=697cbc8d91e0751089da1827ae6c2af9ba1dd207;hb=5bbb7af7ff683e60d99aaad3b78da034bf80cbc7;hp=976fe92a888231a19a9d2aadbadd2343048a5211;hpb=05e066c439c22f05de5fbcc0d11c515444ca0f16;p=ghc-hetmet.git diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 976fe92..697cbc8 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -1,5 +1,5 @@ % -% (c) The University of Glasgow 2005 +% (c) The University of Glasgow 2005-2006 % -- -------------------------------------- @@ -12,65 +12,75 @@ necessary. \begin{code} - {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-} -module Linker ( HValue, showLinkerState, - linkExpr, unload, extendLinkEnv, withExtendedLinkEnv, - extendLoadedPkgs, - linkPackages,initDynLinker +{-# 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, + extendLoadedPkgs, + linkPackages,initDynLinker, + dataConInfoPtrToName ) where #include "HsVersions.h" -import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker ) -import ByteCodeLink ( HValue, ClosureEnv, extendClosureEnv, linkBCO ) -import ByteCodeItbls ( ItblEnv ) -import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..)) - +import LoadIface +import ObjLink +import ByteCodeLink +import ByteCodeItbls +import ByteCodeAsm +import CgInfoTbls +import SMRep +import IfaceEnv +import TcRnMonad import Packages -import DriverPhases ( isObjectFilename, isDynLibFilename ) -import Finder ( findHomeModule, findObjectLinkableMaybe, - FindResult(..) ) +import DriverPhases +import Finder import HscTypes -import Name ( Name, nameModule, isExternalName, isWiredInName ) +import Name import NameEnv -import NameSet ( nameSetToList ) -import UniqFM ( lookupUFM ) +import NameSet +import qualified OccName +import LazyUniqFM import Module -import ListSetOps ( minusList ) -import DynFlags ( DynFlags(..), getOpts ) -import BasicTypes ( SuccessFlag(..), succeeded, failed ) +import ListSetOps +import DynFlags +import BasicTypes import Outputable -import PackageConfig ( rtsPackageId ) -import Panic ( GhcException(..) ) -import Util ( zipLazy, global, joinFileExt, joinFileName, - replaceFilenameSuffix ) -import StaticFlags ( v_Ld_inputs, v_Build_tag ) -import ErrUtils ( debugTraceMsg, mkLocMessage ) -import DriverPhases ( phaseInputExt, Phase(..) ) -import SrcLoc ( SrcSpan ) +import PackageConfig +import Panic +import Util +import StaticFlags +import ErrUtils +import DriverPhases +import SrcLoc +import qualified Maybes +import UniqSet +import Constants +import FastString +import Config ( cProjectVersion ) -- Standard libraries -import Control.Monad ( when, filterM, foldM ) - -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, bracket ) -import Maybe ( fromJust ) -#ifdef DEBUG -import Maybe ( isJust ) -#endif - -#if __GLASGOW_HASKELL__ >= 503 -import GHC.IOBase ( IO(..) ) -#else -import PrelIOBase ( IO(..) ) -#endif +import Control.Monad + +import Data.Char +import Data.IORef +import Data.List +import Foreign + +import System.FilePath +import System.IO +import System.Directory + +import Control.Exception +import Data.Maybe \end{code} @@ -123,6 +133,7 @@ emptyPLS dflags = PersistentLinkerState { pkgs_loaded = init_pkgs, bcos_loaded = [], objs_loaded = [] } + -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- @@ -144,17 +155,165 @@ extendLinkEnv new_bindings new_pls = pls { closure_env = new_closure_env } writeIORef v_PersistentLinkerState new_pls +deleteFromLinkEnv :: [Name] -> IO () +deleteFromLinkEnv to_remove + = do pls <- readIORef v_PersistentLinkerState + let new_closure_env = delListFromNameEnv (closure_env pls) to_remove + new_pls = pls { closure_env = new_closure_env } + writeIORef v_PersistentLinkerState new_pls + +-- | Given a data constructor in the heap, find its Name. +-- The info tables for data constructors have a field which records +-- the source name of the constructor as a Ptr Word8 (UTF-8 encoded +-- string). The format is: +-- +-- Package:Module.Name +-- +-- We use this string to lookup the interpreter's internal representation of the name +-- using the lookupOrig. + +dataConInfoPtrToName :: Ptr () -> TcM (Either String Name) +dataConInfoPtrToName x = do + theString <- liftIO $ do + let ptr = castPtr x :: Ptr StgInfoTable + conDescAddress <- getConDescAddress ptr + peekArray0 0 conDescAddress + let (pkg, mod, occ) = parse theString + pkgFS = mkFastStringByteList pkg + modFS = mkFastStringByteList mod + occFS = mkFastStringByteList occ + occName = mkOccNameFS OccName.dataName occFS + modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) + return (Left$ showSDoc$ ppr modName <> dot <> ppr occName ) + `recoverM` (Right `fmap` lookupOrig modName occName) + + where + + {- To find the string in the constructor's info table we need to consider + the layout of info tables relative to the entry code for a closure. + + An info table can be next to the entry code for the closure, or it can + be separate. The former (faster) is used in registerised versions of ghc, + and the latter (portable) is for non-registerised versions. + + The diagrams below show where the string is to be found relative to + the normal info table of the closure. + + 1) Code next to table: + + -------------- + | | <- pointer to the start of the string + -------------- + | | <- the (start of the) info table structure + | | + | | + -------------- + | entry code | + | .... | + + In this case the pointer to the start of the string can be found in + the memory location _one word before_ the first entry in the normal info + table. + + 2) Code NOT next to table: + + -------------- + info table structure -> | *------------------> -------------- + | | | entry code | + | | | .... | + -------------- + ptr to start of str -> | | + -------------- + + In this case the pointer to the start of the string can be found + in the memory location: info_table_ptr + info_table_size + -} + + getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8) + getConDescAddress ptr + | ghciTablesNextToCode = do + offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE) + return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord)) + | otherwise = + peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB + + -- parsing names is a little bit fiddly because we have a string in the form: + -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). + -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. + -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas + -- this is not the conventional way of writing Haskell names. We stick with + -- convention, even though it makes the parsing code more troublesome. + -- Warning: this code assumes that the string is well formed. + parse :: [Word8] -> ([Word8], [Word8], [Word8]) + parse input + = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) + where + dot = fromIntegral (ord '.') + (pkg, rest1) = break (== fromIntegral (ord ':')) input + (mod, occ) + = (concat $ intersperse [dot] $ reverse modWords, occWord) + where + (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) + parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) + parseModOcc acc str + = case break (== dot) str of + (top, []) -> (acc, top) + (top, _:bot) -> parseModOcc (top : acc) bot + + +getHValue :: HscEnv -> Name -> IO HValue +getHValue hsc_env name = do + when (isExternalName name) $ do + ok <- linkDependencies hsc_env noSrcSpan [nameModule name] + when (failed ok) $ throwDyn (ProgramError "") + pls <- readIORef v_PersistentLinkerState + lookupName (closure_env pls) name + +linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag +linkDependencies hsc_env span needed_mods = do + let hpt = hsc_HPT hsc_env + dflags = hsc_dflags hsc_env + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + maybe_normal_osuf <- checkNonStdWay dflags span + + -- Find what packages and linkables are required + eps <- readIORef (hsc_EPS hsc_env) + (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps) + maybe_normal_osuf span needed_mods + + -- Link the packages and modules required + linkPackages dflags pkgs + linkModules dflags lnks + + +-- | Temporarily extend the linker state. + 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 (closure_env pls) - reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env }) + = bracket_ set_new_env + reset_old_env + 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 () + + -- Remember that the linker state might be side-effected + -- during the execution of the IO action, and we don't want to + -- lose those changes (we might have linked a new module or + -- package), so the reset action only removes the names we + -- added earlier. + reset_old_env = do + modifyIORef v_PersistentLinkerState $ \pls -> + let cur = closure_env pls + new = delListFromNameEnv cur (map fst new_env) + in + pls{ closure_env = new } -- filterNameMap removes from the environment all entries except -- those for a given set of modules; @@ -237,13 +396,12 @@ reallyInitDynLinker dflags ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs -- (e) Link any MacOS frameworks -#ifdef darwin_TARGET_OS - ; let framework_paths = frameworkPaths dflags - ; let frameworks = cmdlineFrameworks dflags -#else - ; let frameworks = [] - ; let framework_paths = [] -#endif + ; let framework_paths + | isDarwinTarget = frameworkPaths dflags + | otherwise = [] + ; let frameworks + | isDarwinTarget = cmdlineFrameworks dflags + | otherwise = [] -- Finally do (c),(d),(e) ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ] ++ map DLL minus_ls @@ -288,13 +446,14 @@ preloadLib dflags lib_paths framework_paths lib_spec Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec -#ifdef darwin_TARGET_OS Framework framework + | isDarwinTarget -> do maybe_errstr <- loadFramework framework_paths framework case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm framework_paths lib_spec -#endif + | otherwise -> panic "preloadLib Framework" + where preloadFailed :: String -> [String] -> LibrarySpec -> IO () preloadFailed sys_errmsg paths spec @@ -330,6 +489,8 @@ linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue -- -- Raises an IO exception if it can't find a compiled version of the -- dependents to link. +-- +-- Note: This function side-effects the linker state (Pepe) linkExpr hsc_env span root_ul_bco = do { @@ -337,20 +498,8 @@ linkExpr hsc_env span root_ul_bco let dflags = hsc_dflags hsc_env ; initDynLinker dflags - -- The interpreter and dynamic linker can only handle object code built - -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. - -- So here we check the build tag: if we're building a non-standard way - -- then we need to find & link object files built the "normal" way. - ; maybe_normal_osuf <- checkNonStdWay dflags span - - -- Find what packages and linkables are required - ; eps <- readIORef (hsc_EPS hsc_env) - ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps) - maybe_normal_osuf span needed_mods - -- Link the packages and modules required - ; linkPackages dflags pkgs - ; ok <- linkModules dflags lnks + ; ok <- linkDependencies hsc_env span needed_mods ; if failed ok then throwDyn (ProgramError "") else do { @@ -365,7 +514,6 @@ linkExpr hsc_env span root_ul_bco ; return root_hval }} where - hpt = hsc_HPT hsc_env free_names = nameSetToList (bcoFreeNames root_ul_bco) needed_mods :: [Module] @@ -391,9 +539,9 @@ checkNonStdWay dflags srcspan = do else return (Just default_osuf) failNonStd srcspan = dieWith srcspan $ - ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$ - ptext SLIT("You need to build the program twice: once the normal way, and then") $$ - ptext SLIT("in the desired way using -osuf to set the object file suffix.") + ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$ + ptext (sLit "You need to build the program twice: once the normal way, and then") $$ + ptext (sLit "in the desired way using -osuf to set the object file suffix.") getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable @@ -406,19 +554,20 @@ getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods -- Find all the packages and linkables that a set of modules depends on = do { pls <- readIORef v_PersistentLinkerState ; - let { -- 1. Find the dependent home-pkg-modules/packages from each iface - (mods_s, pkgs_s) = unzip (map get_deps mods) ; + (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet; + let { -- 2. Exclude ones already linked -- Main reason: avoid findModule calls in get_linkable - mods_needed = nub (concat mods_s) `minusList` linked_mods ; - pkgs_needed = nub (concat pkgs_s) `minusList` pkgs_loaded pls ; + mods_needed = mods_s `minusList` linked_mods ; + pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; linked_mods = map (moduleName.linkableModule) (objs_loaded pls ++ bcos_loaded pls) } ; +-- putStrLn (showSDoc (ppr mods_s)) ; -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot -- compilation) we may need to use maybe_getFileLinkable @@ -429,30 +578,60 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags - get_deps :: Module -> ([ModuleName],[PackageId]) - -- Get the things needed for the specified module - -- This is rather similar to the code in RnNames.importsFromImportDecl - get_deps mod - | pkg /= this_pkg - = ([], pkg : dep_pkgs deps) - | otherwise - = (moduleName mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) - where - pkg = modulePackageId mod - deps = mi_deps (get_iface mod) + -- The ModIface contains the transitive closure of the module dependencies + -- within the current package, *except* for boot modules: if we encounter + -- a boot module, we have to find its real interface and discover the + -- dependencies of that. Hence we need to traverse the dependency + -- tree recursively. See bug #936, testcase ghci/prog007. + follow_deps :: [Module] -- modules to follow + -> UniqSet ModuleName -- accum. module dependencies + -> UniqSet PackageId -- accum. package dependencies + -> IO ([ModuleName], [PackageId]) -- result + follow_deps [] acc_mods acc_pkgs + = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs) + follow_deps (mod:mods) acc_mods acc_pkgs + = do + mb_iface <- initIfaceCheck hsc_env $ + loadInterface msg mod (ImportByUser False) + iface <- case mb_iface of + Maybes.Failed err -> ghcError (ProgramError (showSDoc err)) + Maybes.Succeeded iface -> return iface + + when (mi_boot iface) $ link_boot_mod_error mod + + let + pkg = modulePackageId mod + deps = mi_deps iface + + pkg_deps = dep_pkgs deps + (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps) + where is_boot (m,True) = Left m + is_boot (m,False) = Right m + + boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps + acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps) + acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps + -- + if pkg /= this_pkg + then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg) + else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) + acc_mods' acc_pkgs' + where + msg = text "need to link module" <+> ppr mod <+> + text "due to use of Template Haskell" + - get_iface mod = case lookupIfaceByModule dflags hpt pit mod of - Just iface -> iface - Nothing -> pprPanic "getLinkDeps" (no_iface mod) - no_iface mod = ptext SLIT("No iface for") <+> ppr mod - -- This one is a GHC bug + link_boot_mod_error mod = + throwDyn (ProgramError (showSDoc ( + text "module" <+> ppr mod <+> + text "cannot be linked; it is only available as a boot module"))) no_obj mod = dieWith span $ - ptext SLIT("cannot find object file for module ") <> + ptext (sLit "cannot find object file for module ") <> quotes (ppr mod) $$ while_linking_expr - while_linking_expr = ptext SLIT("while linking an interpreted expression") + while_linking_expr = ptext (sLit "while linking an interpreted expression") -- This one is a build-system bug @@ -484,11 +663,11 @@ 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 $ - ptext SLIT("cannot find normal object file ") + ptext (sLit "cannot find normal object file ") <> quotes (text new_file) $$ while_linking_expr else return (DotO new_file) \end{code} @@ -641,13 +820,11 @@ linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO - linkSomeBCOs toplevs_only ie ce_in ul_bcos = do let nms = map unlinkedBCOName ul_bcos hvals <- fixIO ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs) in mapM (linkBCO ie ce_out) ul_bcos ) - let ce_all_additions = zip nms hvals ce_top_additions = filter (isExternalName.fst) ce_all_additions ce_additions = if toplevs_only then ce_top_additions @@ -724,7 +901,7 @@ unload_wkr dflags linkables pls where maybeUnload :: [Linkable] -> Linkable -> IO Bool maybeUnload keep_linkables lnk - | linkableInSet lnk linkables = return True + | linkableInSet lnk keep_linkables = return True | otherwise = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk] -- The components of a BCO linkable may contain @@ -772,11 +949,8 @@ data LibrarySpec -- used by lookupSymbol. So we must call addDLL for each library -- just to get the DLL handle into the list. partOfGHCi -# if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS) - = [ ] -# else - = [ "base", "haskell98", "template-haskell", "readline" ] -# endif + | isWindowsTarget || isDarwinTarget = [] + | otherwise = [ "base", "haskell98", "template-haskell", "editline" ] showLS (Object nm) = "(static) " ++ nm showLS (DLL nm) = "(dynamic) " ++ nm @@ -847,7 +1021,7 @@ linkPackage dflags pkg let dlls = [ dll | DLL dll <- classifieds ] objs = [ obj | Object obj <- classifieds ] - maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ") + maybePutStr dflags ("Loading package " ++ display (package pkg) ++ " ... ") -- See comments with partOfGHCi when (pkgName (package pkg) `notElem` partOfGHCi) $ do @@ -871,17 +1045,17 @@ linkPackage dflags pkg maybePutStr dflags "linking ... " ok <- resolveObjs if succeeded ok then maybePutStrLn dflags "done." - else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'")) + else throwDyn (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'")) load_dyn dirs dll = do r <- loadDynamic dirs dll case r of Nothing -> return () Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: " ++ dll ++ " (" ++ err ++ ")" )) -#ifndef darwin_TARGET_OS -loadFrameworks pkg = return () -#else -loadFrameworks pkg = mapM_ load frameworks + +loadFrameworks pkg + | isDarwinTarget = mapM_ load frameworks + | otherwise = return () where fw_dirs = Packages.frameworkDirs pkg frameworks = Packages.frameworks pkg @@ -891,24 +1065,36 @@ loadFrameworks pkg = mapM_ load frameworks Nothing -> return () Just err -> throwDyn (CmdLineError ("can't load framework: " ++ fw ++ " (" ++ err ++ ")" )) -#endif -- 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. 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 lib_path -> return (DLL (lib ++ "_dyn")) + Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion)) + Nothing -> return (DLL lib) }} -- We assume + | otherwise + -- When the GHC package was compiled as dynamic library (=__PIC__ set), + -- we search for .so libraries first. + = 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 `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) -- ---------------------------------------------------------------------------- -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) @@ -922,34 +1108,34 @@ 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 - -#if defined(darwin_TARGET_OS) -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) `joinFileExt` "so" -#endif + mk_dll_path dir = dir mkSOName rootname + +mkSOName root + | isDarwinTarget = ("lib" ++ root) <.> "dylib" + | isWindowsTarget = -- Win32 DLLs have no .dll extension here, because + -- addDLL tries both foo.dll and foo.drv + root + | otherwise = ("lib" ++ root) <.> "so" -- Darwin / MacOS X only: load a framework -- a framework is a dynamic library packaged inside a directory of the same -- 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} %************************************************************************