X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=697cbc8d91e0751089da1827ae6c2af9ba1dd207;hb=5bbb7af7ff683e60d99aaad3b78da034bf80cbc7;hp=892171c1edf5136942457c4915cc1991434e514b;hpb=d51f42f602bf9a6d1b356c41228a534c88723f65;p=ghc-hetmet.git diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 892171c..697cbc8 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -31,6 +31,7 @@ module Linker ( HValue, getHValue, showLinkerState, #include "HsVersions.h" +import LoadIface import ObjLink import ByteCodeLink import ByteCodeItbls @@ -60,6 +61,7 @@ import StaticFlags import ErrUtils import DriverPhases import SrcLoc +import qualified Maybes import UniqSet import Constants import FastString @@ -228,13 +230,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"). @@ -292,22 +293,22 @@ linkDependencies hsc_env span needed_mods = do withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a withExtendedLinkEnv new_env action - = bracket set_new_env - reset_old_env - (const action) + = 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 (closure_env 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 env = do + reset_old_env = do modifyIORef v_PersistentLinkerState $ \pls -> let cur = closure_env pls new = delListFromNameEnv cur (map fst new_env) @@ -395,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 @@ -446,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 @@ -538,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 @@ -553,10 +554,10 @@ 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) = 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 ; @@ -585,29 +586,39 @@ 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 = @@ -615,18 +626,12 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods 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 @@ -662,7 +667,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods 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} @@ -896,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 @@ -944,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 @@ -1019,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 @@ -1043,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 @@ -1063,15 +1065,14 @@ 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. -#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 + | 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) @@ -1080,14 +1081,9 @@ locateOneObj dirs lib ; case mb_lib_path of Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion)) Nothing -> return (DLL lib) }} -- We assume - where - 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 + | 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)) @@ -1099,7 +1095,6 @@ locateOneObj dirs lib 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) @@ -1115,20 +1110,16 @@ loadDynamic paths rootname where mk_dll_path dir = dir mkSOName rootname -#if defined(darwin_TARGET_OS) -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) <.> "so" -#endif +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 { either_dir <- Control.Exception.try getHomeDirectory ; let homeFrameworkPath = case either_dir of @@ -1145,7 +1136,6 @@ loadFramework extraPaths rootname 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} %************************************************************************