X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=c566b8f3f52663f30533e863b8241ef40f66ae31;hb=85255a966b21172ce5a26c8a9cb0cdaf7315be95;hp=759469f1cf03d3fa1bc134749cca57c89802ed37;hpb=ba58376a6bcbf50e0d6464456a96932e0c261abf;p=ghc-hetmet.git diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 759469f..c566b8f 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -14,12 +14,8 @@ 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 +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, withExtendedLinkEnv, @@ -79,6 +75,8 @@ import System.FilePath import System.IO import System.Directory +import Distribution.Package hiding (depends) + import Control.Exception import Data.Maybe \end{code} @@ -127,7 +125,7 @@ data PersistentLinkerState } emptyPLS :: DynFlags -> PersistentLinkerState -emptyPLS dflags = PersistentLinkerState { +emptyPLS _ = PersistentLinkerState { closure_env = emptyNameEnv, itbl_env = emptyNameEnv, pkgs_loaded = init_pkgs, @@ -230,13 +228,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"). @@ -294,22 +291,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) @@ -376,6 +373,7 @@ initDynLinker dflags ; reallyInitDynLinker dflags } } +reallyInitDynLinker :: DynFlags -> IO () reallyInitDynLinker dflags = do { -- Initialise the linker state ; writeIORef v_PersistentLinkerState (emptyPLS dflags) @@ -466,7 +464,7 @@ preloadLib dflags lib_paths framework_paths lib_spec give_up -- 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 @@ -527,6 +525,7 @@ 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 :: SrcSpan -> Message -> IO a dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg))) @@ -539,6 +538,7 @@ 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") $$ @@ -552,7 +552,7 @@ 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 ; -- 1. Find the dependent home-pkg-modules/packages from each iface @@ -671,6 +671,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods 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} @@ -708,17 +709,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 = @@ -801,8 +801,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 } @@ -884,7 +884,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) @@ -902,7 +902,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 @@ -949,10 +949,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 | isWindowsTarget || isDarwinTarget = [] - | otherwise = [ "base", "haskell98", "template-haskell", "editline" ] + | 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 @@ -1025,7 +1028,7 @@ linkPackage dflags 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 @@ -1048,12 +1051,14 @@ linkPackage dflags pkg if succeeded ok then maybePutStrLn dflags "done." else throwDyn (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: " ++ dll ++ " (" ++ err ++ ")" )) +loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO () loadFrameworks pkg | isDarwinTarget = mapM_ load frameworks | otherwise = return () @@ -1069,30 +1074,25 @@ loadFrameworks pkg -- 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) Nothing -> do { mb_lib_path <- findFile mk_dyn_lib_path dirs ; 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 + Just _ -> 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)) + Just _ -> return (DLL (lib ++ "-ghc" ++ cProjectVersion)) Nothing -> do { mb_obj_path <- findFile mk_obj_path dirs ; case mb_obj_path of @@ -1101,12 +1101,12 @@ 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) -- 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 @@ -1117,6 +1117,7 @@ loadDynamic paths rootname where 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 @@ -1127,6 +1128,7 @@ mkSOName root -- 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. +loadFramework :: [FilePath] -> FilePath -> IO (Maybe String) loadFramework extraPaths rootname = do { either_dir <- Control.Exception.try getHomeDirectory ; let homeFrameworkPath = case either_dir of @@ -1155,7 +1157,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 @@ -1167,9 +1169,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}