X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=21a206490e66ebdb8ab6b1090d6e525f118e9329;hp=fe009c2fefba77ed3ee38ec3950401c281182fca;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=37f22a833c33c3ab504778fd91a39d8d48fa3766 diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index fe009c2..21a2064 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -14,6 +14,9 @@ necessary. \begin{code} {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-} +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, @@ -24,6 +27,7 @@ module Linker ( HValue, getHValue, showLinkerState, #include "HsVersions.h" +import LoadIface import ObjLink import ByteCodeLink import ByteCodeItbls @@ -40,22 +44,22 @@ import Name import NameEnv import NameSet import qualified OccName -import UniqFM +import LazyUniqFM import Module import ListSetOps import DynFlags import BasicTypes import Outputable -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 @@ -65,11 +69,13 @@ import Data.IORef import Data.List import Foreign +import System.FilePath import System.IO import System.Directory -import Control.Exception -import Data.Maybe +import Distribution.Package hiding (depends, PackageId) + +import Exception \end{code} @@ -116,7 +122,7 @@ data PersistentLinkerState } emptyPLS :: DynFlags -> PersistentLinkerState -emptyPLS dflags = PersistentLinkerState { +emptyPLS _ = PersistentLinkerState { closure_env = emptyNameEnv, itbl_env = emptyNameEnv, pkgs_loaded = init_pkgs, @@ -161,9 +167,9 @@ 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 + theString <- liftIO $ do let ptr = castPtr x :: Ptr StgInfoTable conDescAddress <- getConDescAddress ptr peekArray0 0 conDescAddress @@ -173,7 +179,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 @@ -218,13 +225,12 @@ dataConInfoPtrToName x = do -} getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8) - getConDescAddress ptr = do -#ifdef GHCI_TABLES_NEXT_TO_CODE + getConDescAddress ptr + | ghciTablesNextToCode = do offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE) return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord)) -#else + | otherwise = peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB -#endif -- 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"). @@ -254,7 +260,7 @@ 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 "") + when (failed ok) $ ghcError (ProgramError "") pls <- readIORef v_PersistentLinkerState lookupName (closure_env pls) name @@ -278,17 +284,32 @@ linkDependencies hsc_env span needed_mods = do linkModules dflags lnks -withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a +-- | Temporarily extend the linker state. + +withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) => + [(Name,HValue)] -> m a -> m 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 }) + = gbracket set_new_env + (\_ -> reset_old_env) + (\_ -> action) + where set_new_env = do + pls <- liftIO $ readIORef v_PersistentLinkerState + let new_closure_env = extendClosureEnv (closure_env pls) new_env + new_pls = pls { closure_env = new_closure_env } + liftIO $ 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 = liftIO $ 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; @@ -350,6 +371,7 @@ initDynLinker dflags ; reallyInitDynLinker dflags } } +reallyInitDynLinker :: DynFlags -> IO () reallyInitDynLinker dflags = do { -- Initialise the linker state ; writeIORef v_PersistentLinkerState (emptyPLS dflags) @@ -371,13 +393,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 @@ -390,7 +411,7 @@ reallyInitDynLinker dflags ; ok <- resolveObjs ; if succeeded ok then maybePutStrLn dflags "done" - else throwDyn (InstallationError "linking extra libraries/objects failed") + else ghcError (ProgramError "linking extra libraries/objects failed") }} classifyLdInput :: FilePath -> IO (Maybe LibrarySpec) @@ -422,31 +443,31 @@ 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 - = do maybePutStr dflags - ("failed.\nDynamic linker error message was:\n " - ++ sys_errmsg ++ "\nWhilst trying to load: " - ++ showLS spec ++ "\nDirectories to search are:\n" - ++ unlines (map (" "++) paths) ) - give_up + = do maybePutStr dflags "failed.\n" + ghcError $ + CmdLineError ( + "user specified .o/.so/.DLL could not be loaded (" + ++ sys_errmsg ++ ")\nWhilst trying to load: " + ++ showLS spec ++ "\nAdditional directories searched:" + ++ (if null paths then " (none)" else + (concat (intersperse "\n" (map (" "++) paths))))) -- Not interested in the paths in the static case. - preload_static paths name + preload_static _paths name = do b <- doesFileExist name if not b then return False else loadObj name >> return True - - give_up = throwDyn $ - CmdLineError "user specified .o/.so/.DLL could not be loaded." \end{code} @@ -476,7 +497,7 @@ linkExpr hsc_env span root_ul_bco -- Link the packages and modules required ; ok <- linkDependencies hsc_env span needed_mods ; if failed ok then - throwDyn (ProgramError "") + ghcError (ProgramError "") else do { -- Link the expression itself @@ -501,7 +522,8 @@ linkExpr hsc_env span root_ul_bco -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. -dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg))) +dieWith :: SrcSpan -> Message -> IO a +dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg))) checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String) @@ -513,10 +535,11 @@ checkNonStdWay dflags srcspan = do then failNonStd srcspan else return (Just default_osuf) +failNonStd :: SrcSpan -> IO (Maybe String) 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 @@ -526,13 +549,13 @@ getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable -> IO ([Linkable], [PackageId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files -getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods +getLinkDeps hsc_env hpt _ 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) = follow_deps mods emptyUniqSet emptyUniqSet; + (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 = mods_s `minusList` linked_mods ; @@ -561,55 +584,58 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods follow_deps :: [Module] -- modules to follow -> UniqSet ModuleName -- accum. module dependencies -> UniqSet PackageId -- accum. package dependencies - -> ([ModuleName], [PackageId]) -- result + -> IO ([ModuleName], [PackageId]) -- result follow_deps [] acc_mods acc_pkgs - = (uniqSetToList acc_mods, uniqSetToList acc_pkgs) + = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs - | pkg /= this_pkg - = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg) - | mi_boot iface - = link_boot_mod_error mod - | otherwise - = follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs' - where - pkg = modulePackageId mod - iface = get_iface 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 + = 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" link_boot_mod_error mod = - throwDyn (ProgramError (showSDoc ( + ghcError (ProgramError (showSDoc ( text "module" <+> ppr mod <+> text "cannot be linked; it is only available as a boot module"))) - 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 - 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 get_linkable maybe_normal_osuf mod_name -- A home-package module | Just mod_info <- lookupUFM hpt mod_name - = ASSERT(isJust (hm_linkable mod_info)) - adjust_linkable (fromJust (hm_linkable mod_info)) + = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) | otherwise = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... @@ -634,13 +660,14 @@ 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) + adjust_ul _ _ = panic "adjust_ul" \end{code} @@ -678,17 +705,16 @@ partitionLinkable li li_uls_bco = filter isInterpretable li_uls in case (li_uls_obj, li_uls_bco) of - (objs@(_:_), bcos@(_:_)) - -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}] - other - -> [li] + (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, + li {linkableUnlinked=li_uls_bco}] + _ -> [li] findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable findModuleLinkable_maybe lis mod = case [LM time nm us | LM time nm us <- lis, nm == mod] of [] -> Nothing [li] -> Just li - many -> pprPanic "findModuleLinkable" (ppr mod) + _ -> pprPanic "findModuleLinkable" (ppr mod) linkableInSet :: Linkable -> [Linkable] -> Bool linkableInSet l objs_loaded = @@ -716,7 +742,7 @@ dynLinkObjs dflags objs pls1 = pls { objs_loaded = objs_loaded' } unlinkeds = concatMap linkableUnlinked new_objs - mapM loadObj (map nameOfObject unlinkeds) + mapM_ loadObj (map nameOfObject unlinkeds) -- Link the all together ok <- resolveObjs @@ -771,8 +797,8 @@ dynLinkBCOs bcos gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos - -- What happens to these linked_bcos? + (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos + -- XXX What happens to these linked_bcos? let pls2 = pls1 { closure_env = final_gce, itbl_env = final_ie } @@ -854,7 +880,7 @@ unload_wkr :: DynFlags -- Does the core unload business -- (the wrapper blocks exceptions and deals with the PLS get and put) -unload_wkr dflags linkables pls +unload_wkr _ linkables pls = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) @@ -872,7 +898,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 @@ -919,13 +945,13 @@ data LibrarySpec -- of DLL handles that rts/Linker.c maintains, and that in turn is -- used by lookupSymbol. So we must call addDLL for each library -- just to get the DLL handle into the list. +partOfGHCi :: [PackageName] partOfGHCi -# if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS) - = [ ] -# else - = [ "base", "haskell98", "template-haskell", "readline" ] -# endif + | isWindowsTarget || isDarwinTarget = [] + | otherwise = map PackageName + ["base", "haskell98", "template-haskell", "editline"] +showLS :: LibrarySpec -> String showLS (Object nm) = "(static) " ++ nm showLS (DLL nm) = "(dynamic) " ++ nm showLS (DLLPath nm) = "(dynamic) " ++ nm @@ -969,7 +995,7 @@ linkPackages dflags new_pkgs ; return (new_pkg : pkgs') } | otherwise - = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) + = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) linkPackage :: DynFlags -> PackageConfig -> IO () @@ -995,10 +1021,10 @@ 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 + when (packageName pkg `notElem` partOfGHCi) $ do loadFrameworks pkg -- When a library A needs symbols from a library B, the order in -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the @@ -1019,17 +1045,19 @@ 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 ghcError (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'")) +load_dyn :: [FilePath] -> FilePath -> IO () load_dyn dirs dll = do r <- loadDynamic dirs dll case r of Nothing -> return () - Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: " + Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: " ++ dll ++ " (" ++ err ++ ")" )) -#ifndef darwin_TARGET_OS -loadFrameworks pkg = return () -#else -loadFrameworks pkg = mapM_ load frameworks + +loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO () +loadFrameworks pkg + | isDarwinTarget = mapM_ load frameworks + | otherwise = return () where fw_dirs = Packages.frameworkDirs pkg frameworks = Packages.frameworks pkg @@ -1037,31 +1065,45 @@ loadFrameworks pkg = mapM_ load frameworks load fw = do r <- loadFramework fw_dirs fw case r of Nothing -> return () - Just err -> throwDyn (CmdLineError ("can't load framework: " + Just err -> ghcError (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 _ -> return (DLL dyn_lib_name) + 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 _ -> 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") + dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion + mk_dyn_lib_path dir = dir mkSOName dyn_lib_name -- ---------------------------------------------------------------------------- -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) -- return Nothing == success, else Just error message from dlopen +loadDynamic :: [FilePath] -> FilePath -> IO (Maybe String) loadDynamic paths rootname = do { mb_dll <- findFile mk_dll_path paths ; case mb_dll of @@ -1070,34 +1112,36 @@ 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 :: FilePath -> FilePath +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 :: [FilePath] -> FilePath -> IO (Maybe String) 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 <- tryIO 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} %************************************************************************ @@ -1110,7 +1154,7 @@ loadFramework extraPaths rootname findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path -> [FilePath] -- Directories to look in -> IO (Maybe FilePath) -- The first file path to match -findFile mk_file_path [] +findFile _ [] = return Nothing findFile mk_file_path (dir:dirs) = do { let file_path = mk_file_path dir @@ -1122,9 +1166,11 @@ findFile mk_file_path (dir:dirs) \end{code} \begin{code} +maybePutStr :: DynFlags -> String -> IO () maybePutStr dflags s | verbosity dflags > 0 = putStr s | otherwise = return () +maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s | otherwise = return () \end{code}