X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=125c899c5a2a7d5fc8329bb5d92b159c4d95ebb4;hb=3355c9d53b220ccb110e5a3c81a1a8b2c9c41555;hp=ace5ed34765290869ec2dccf81ba4ebc36d423a1;hpb=bb9056764f84f1ee452cea6906e89f6764ef561f;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index ace5ed3..125c899 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ -{-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-} +{-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.131 2002/08/05 09:18:27 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.146 2003/02/19 15:54:07 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -9,72 +9,72 @@ ----------------------------------------------------------------------------- module InteractiveUI ( interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO () - LibrarySpec(..), ghciWelcomeMsg ) where #include "../includes/config.h" #include "HsVersions.h" -import Packages - import CompManager -import CmTypes ( Linkable, isObjectLinkable, ModSummary(..) ) -import CmLink ( findModuleLinkable_maybe ) - -import HscTypes ( TyThing(..), showModMsg, InteractiveContext(..) ) +import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable, + isObjectLinkable ) import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) ) import MkIface ( ifaceTyThing ) import DriverFlags import DriverState -import DriverUtil ( handle, remove_spaces ) -import Linker -import Finder ( flushPackageCache ) +import DriverUtil ( remove_spaces, handle ) +import Linker ( initLinker, showLinkerState, linkLibraries, + linkPackages ) import Util -import Id ( isRecordSelector, recordSelectorFieldLabel, - isDataConWrapId, isDataConId, idName ) +import IdInfo ( GlobalIdDetails(..) ) +import Id ( isImplicitId, idName ) import Class ( className ) import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) ) +import DataCon ( dataConName ) import FieldLabel ( fieldLabelTyCon ) import SrcLoc ( isGoodSrcLoc ) -import Module ( moduleName ) -import NameEnv ( nameEnvElts ) +import Module ( showModMsg, lookupModuleEnv ) import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName, NamedThing(..) ) import OccName ( isSymOcc ) -import BasicTypes ( defaultFixity ) +import BasicTypes ( defaultFixity, SuccessFlag(..) ) +import Packages import Outputable import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset ) -import Panic ( GhcException(..), showGhcException ) +import Panic hiding ( showException ) import Config #ifndef mingw32_TARGET_OS -import Posix +import System.Posix #endif -import Exception -import Dynamic #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS -import Readline +import Control.Concurrent ( yield ) -- Used in readline loop +import System.Console.Readline as Readline #endif -import Concurrent -import IOExts -import SystemExts + +--import SystemExts + +import Control.Exception as Exception +import Data.Dynamic +import Control.Concurrent import Numeric -import List -import System -import CPUTime -import Directory -import IO -import Char -import Monad +import Data.List +import System.Cmd +import System.CPUTime +import System.Environment +import System.Directory +import System.IO as IO +import Data.Char +import Control.Monad as Monad + +import GHC.Exts ( unsafeCoerce# ) -import GlaExts ( unsafeCoerce# ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -import Foreign ( nullPtr ) -import CString ( CString, peekCString, withCString ) +import GHC.Posix ( setNonBlockingFD ) ----------------------------------------------------------------------------- @@ -89,14 +89,14 @@ GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)]) builtin_commands :: [(String, String -> GHCi Bool)] builtin_commands = [ - ("add", keepGoing addModule), + ("add", keepGoingPaths addModule), ("browse", keepGoing browseCmd), ("cd", keepGoing changeDirectory), ("def", keepGoing defineMacro), ("help", keepGoing help), ("?", keepGoing help), ("info", keepGoing info), - ("load", keepGoing loadModule), + ("load", keepGoingPaths loadModule), ("module", keepGoing setContext), ("reload", keepGoing reloadModule), ("set", keepGoing setCmd), @@ -110,6 +110,9 @@ builtin_commands = [ keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) keepGoing a str = a str >> return False +keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool) +keepGoingPaths a str = a (toArgs str) >> return False + shortHelpText = "use :? for help.\n" -- NOTE: spaces at the end of each line to workaround CPP/string gap bug. @@ -149,42 +152,28 @@ helpText = "\ \ (eg. -v2, -fglasgow-exts, etc.)\n\ \" -interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO () -interactiveUI cmstate paths cmdline_libs = do +interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO () +interactiveUI cmstate paths cmdline_objs = do hFlush stdout hSetBuffering stdout NoBuffering dflags <- getDynFlags - -- link in the available packages - pkgs <- getPackageInfo initLinker - linkPackages dflags cmdline_libs pkgs - - (cmstate, maybe_hval) - <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering" - case maybe_hval of - Just hval -> do - let action = unsafeCoerce# hval :: IO () - action -- do it now - writeIORef turn_off_buffering action -- and save it for later - _ -> panic "interactiveUI:buffering" - - (cmstate, maybe_hval) - <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr" - case maybe_hval of - Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ()) - _ -> panic "interactiveUI:stderr" - - (cmstate, maybe_hval) - <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout" - case maybe_hval of - Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ()) - _ -> panic "interactiveUI:stdout" + + -- link packages requested explicitly on the command-line + expl <- readIORef v_ExplicitPackages + linkPackages dflags expl + + -- link libraries from the command-line + linkLibraries dflags cmdline_objs + + -- Initialise buffering for the *interpreted* I/O system + cmstate <- initInterpBuffering cmstate dflags -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. - hSetBuffering stdin NoBuffering + hSetBuffering stdin NoBuffering -- initial context is just the Prelude cmstate <- cmSetContext cmstate dflags [] ["Prelude"] @@ -206,7 +195,6 @@ interactiveUI cmstate paths cmdline_libs = do return () - runGHCi :: [FilePath] -> DynFlags -> GHCi () runGHCi paths dflags = do read_dot_files <- io (readIORef v_Read_DotGHCi) @@ -243,7 +231,7 @@ runGHCi paths dflags = do -- perform a :load for files given on the GHCi command line when (not (null paths)) $ ghciHandle showException $ - loadModule (unwords paths) + loadModule paths -- enter the interactive loop #if defined(mingw32_TARGET_OS) @@ -314,7 +302,7 @@ fileLoop hdl prompt = do l <- io (IO.try (hGetLine hdl)) case l of Left e | isEOFError e -> return () - | otherwise -> throw e + | otherwise -> io (ioError e) Right l -> case remove_spaces l of "" -> fileLoop hdl prompt @@ -338,7 +326,10 @@ readlineLoop = do cmstate <- getCmState (mod,imports) <- io (cmGetContext cmstate) io yield - l <- io (readline (mkPrompt mod imports)) + l <- io (readline (mkPrompt mod imports) + `finally` setNonBlockingFD 0) + -- readline sometimes puts stdin into blocking mode, + -- so we need to put it back for the IO library case l of Nothing -> return () Just l -> @@ -350,16 +341,23 @@ readlineLoop = do if quit then return () else readlineLoop #endif --- Top level exception handler, just prints out the exception --- and carries on. runCommand :: String -> GHCi Bool -runCommand c = - ghciHandle ( \exception -> do - flushEverything - showException exception - return False - ) $ - doCommand c +runCommand c = ghciHandle handler (doCommand c) + +-- This is the exception handler for exceptions generated by the +-- user's code; it normally just prints out the exception. The +-- handler must be recursive, in case showing the exception causes +-- more exceptions to be raised. +-- +-- Bugfix: if the user closed stdout or stderr, the flushing will fail, +-- raising another exception. We therefore don't put the recursive +-- handler arond the flushing operation, so if stderr is closed +-- GHCi will just die gracefully rather than going into an infinite loop. +handler :: Exception -> GHCi Bool +handler exception = do + flushInterpBuffers + io installSignalHandlers + ghciHandle handler (showException exception >> return False) showException (DynException dyn) = case fromDynamic dyn of @@ -399,9 +397,10 @@ finishEvalExpr names cmstate <- getCmState when b (mapM_ (showTypeOfName cmstate) names) + flushInterpBuffers + io installSignalHandlers b <- isOptionSet RevertCAFs io (when b revertCAFs) - flushEverything return True showTypeOfName :: CmState -> Name -> GHCi () @@ -411,12 +410,6 @@ showTypeOfName cmstate n Nothing -> return () Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str)) -flushEverything :: GHCi () -flushEverything - = io $ do Monad.join (readIORef flush_stdout) - Monad.join (readIORef flush_stderr) - return () - specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do @@ -433,6 +426,46 @@ specialCommand str = do noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments")) + +----------------------------------------------------------------------------- +-- To flush buffers for the *interpreted* computation we need +-- to refer to *its* stdout/stderr handles + +GLOBAL_VAR(flush_interp, error "no flush_interp", IO ()) +GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) + +no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++ + " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering" +flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr" + +initInterpBuffering :: CmState -> DynFlags -> IO CmState +initInterpBuffering cmstate dflags + = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd + + case maybe_hval of + Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ()) + other -> panic "interactiveUI:setBuffering" + + (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd + case maybe_hval of + Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) + _ -> panic "interactiveUI:flush" + + turnOffBuffering -- Turn it off right now + + return cmstate + + +flushInterpBuffers :: GHCi () +flushInterpBuffers + = io $ do Monad.join (readIORef flush_interp) + return () + +turnOffBuffering :: IO () +turnOffBuffering + = do Monad.join (readIORef turn_off_buffering) + return () + ----------------------------------------------------------------------------- -- Commands @@ -470,6 +503,8 @@ info s = do showTyThing (AClass cl) = hcat [ppr cl, text " is a class", showSrcLoc (className cl)] + showTyThing (ADataCon dc) + = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)] showTyThing (ATyCon ty) | isPrimTyCon ty = hcat [ppr ty, text " is a primitive type constructor"] @@ -479,13 +514,10 @@ info s = do = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)] idDescr id - | isRecordSelector id = - case tyConClass_maybe (fieldLabelTyCon ( - recordSelectorFieldLabel id)) of - Nothing -> text "record selector" - Just c -> text "method in class " <> ppr c - | isDataConWrapId id = text "data constructor" - | otherwise = text "variable" + = case globalIdDetails id of + RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl) + ClassOpId cls -> text "method in class" <+> ppr cls + otherwise -> text "variable" -- also print out the source location for home things showSrcLoc name @@ -499,9 +531,8 @@ info s = do setCmState cms return () -addModule :: String -> GHCi () -addModule str = do - let files = words str +addModule :: [FilePath] -> GHCi () +addModule files = do state <- getGHCiState dflags <- io (getDynFlags) io (revertCAFs) -- always revert CAFs on load/add. @@ -563,11 +594,11 @@ undefineMacro macro_name = do io (writeIORef commands (filter ((/= macro_name) . fst) cmds)) -loadModule :: String -> GHCi () -loadModule str = timeIt (loadModule' str) +loadModule :: [FilePath] -> GHCi () +loadModule fs = timeIt (loadModule' fs) -loadModule' str = do - let files = words str +loadModule' :: [FilePath] -> GHCi () +loadModule' files = do state <- getGHCiState dflags <- io getDynFlags @@ -620,9 +651,9 @@ modulesLoadedMsg ok mods dflags = | otherwise = hsep ( punctuate comma (map text mods)) <> text "." case ok of - False -> + Failed -> io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) - True -> + Succeeded -> io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))) @@ -675,8 +706,9 @@ browseModule m exports_only = do things' = filter wantToSee things - wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id) - wantToSee _ = True + wantToSee (AnId id) = not (isImplicitId id) + wantToSee (ADataCon _) = False -- They'll come via their TyCon + wantToSee _ = True thing_names = map getName things @@ -698,7 +730,7 @@ browseModule m exports_only = do rn_decl{ tcdCons = DataCons (filter conIsVisible cons) } other -> other where - conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names + conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names io (putStrLn (showSDocForUser unqual ( vcat (map (ppr . thingDecl) things'))) @@ -809,18 +841,25 @@ setOptions wds = mapM_ setOpt plus_opts -- now, the GHC flags - pkgs_before <- io (readIORef v_Packages) + pkgs_before <- io (readIORef v_ExplicitPackages) leftovers <- io (processArgs static_flags minus_opts []) - pkgs_after <- io (readIORef v_Packages) + pkgs_after <- io (readIORef v_ExplicitPackages) -- update things if the users wants more packages - when (pkgs_before /= pkgs_after) $ - newPackages (pkgs_after \\ pkgs_before) + let new_packages = pkgs_after \\ pkgs_before + when (not (null new_packages)) $ + newPackages new_packages + + -- don't forget about the extra command-line flags from the + -- extra_ghc_opts fields in the new packages + new_package_details <- io (getPackageDetails new_packages) + let pkg_extra_opts = concatMap extra_ghc_opts new_package_details + pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts []) -- then, dynamic flags io $ do restoreDynFlags - leftovers <- processArgs dynamic_flags leftovers [] + leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) [] saveDynFlags if (not (null leftovers)) @@ -874,43 +913,40 @@ optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r" -newPackages new_pkgs = do - state <- getGHCiState - dflags <- io getDynFlags +newPackages new_pkgs = do -- The new packages are already in v_Packages + state <- getGHCiState + dflags <- io getDynFlags cmstate1 <- io (cmUnload (cmstate state) dflags) setGHCiState state{ cmstate = cmstate1, targets = [] } - - io $ do - pkgs <- getPackageInfo - flushPackageCache pkgs - - new_pkg_info <- getPackageDetails new_pkgs - mapM_ (linkPackage dflags) (reverse new_pkg_info) - + io (linkPackages dflags new_pkgs) setContextAfterLoad [] ------------------------------------------------------------------------------ +-- --------------------------------------------------------------------------- -- code for `:show' showCmd str = case words str of ["modules" ] -> showModules ["bindings"] -> showBindings + ["linker"] -> io showLinkerState _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]") showModules = do cms <- getCmState - let mg = cmGetModuleGraph cms - ls = cmGetLinkables cms - maybe_linkables = map (findModuleLinkable_maybe ls) - (map (moduleName.ms_mod) mg) - zipWithM showModule mg maybe_linkables - return () + let (mg, hpt) = cmGetModInfo cms + mapM_ (showModule hpt) mg + -showModule :: ModSummary -> Maybe Linkable -> GHCi () -showModule m (Just l) = do - io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m))) -showModule _ Nothing = panic "missing linkable" +showModule :: HomePackageTable -> ModSummary -> GHCi () +showModule hpt mod_summary + = case lookupModuleEnv hpt mod of + Nothing -> panic "missing linkable" + Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn)) + where + obj_linkable = isObjectLinkable (hm_linkable mod_info) + where + mod = ms_mod mod_summary + locn = ms_location mod_summary showBindings = do cms <- getCmState @@ -921,6 +957,7 @@ showBindings = do io (mapM_ showBinding (cmGetBindings cms)) return () + ----------------------------------------------------------------------------- -- GHCi monad @@ -939,10 +976,6 @@ data GHCiOption | RevertCAFs -- revert CAFs after every evaluation deriving Eq -GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ()) -GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ()) -GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) - newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a } startGHCi :: GHCi a -> GHCiState -> IO a @@ -991,225 +1024,12 @@ io m = GHCi { unGHCi = \s -> m >>= return } ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a ghciHandle h (GHCi m) = GHCi $ \s -> Exception.catch (m s) - (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s) + (\e -> unGHCi (ghciUnblock (h e)) s) ghciUnblock :: GHCi a -> GHCi a ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) ----------------------------------------------------------------------------- --- package loader - --- Left: full path name of a .o file, including trailing .o --- Right: "unadorned" name of a .DLL/.so --- e.g. On unix "qt" denotes "libqt.so" --- On WinDoze "burble" denotes "burble.DLL" --- addDLL is platform-specific and adds the lib/.so/.DLL --- suffixes platform-dependently; we don't do that here. --- --- For dynamic objects only, try to find the object file in all the --- directories specified in v_Library_Paths before giving up. - -data LibrarySpec = Object FilePath | DLL String -#ifdef darwin_TARGET_OS - | Framework String -#endif - --- Packages that don't need loading, because the compiler shares them with --- the interpreted program. -dont_load_these = [ "rts" ] - --- Packages that are already linked into GHCi. For mingw32, we only --- skip gmp and rts, since std and after need to load the msvcrt.dll --- library which std depends on. -loaded_in_ghci -# ifndef mingw32_TARGET_OS - = [ "std", "concurrent", "posix", "text", "util" ] -# else - = [ ] -# endif - -showLS (Object nm) = "(static) " ++ nm -showLS (DLL nm) = "(dynamic) " ++ nm -#ifdef darwin_TARGET_OS -showLS (Framework nm) = "(framework) " ++ nm -#endif - -linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO () -linkPackages dflags cmdline_lib_specs pkgs - = do mapM_ (linkPackage dflags) (reverse pkgs) - lib_paths <- readIORef v_Library_paths - mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs - if (null cmdline_lib_specs) - then return () - else do maybePutStr dflags "final link ... " - - ok <- resolveObjs - if ok then maybePutStrLn dflags "done." - else throwDyn (InstallationError - "linking extra libraries/objects failed") - where - preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO () - preloadLib dflags lib_paths lib_spec - = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") - case lib_spec of - Object static_ish - -> do b <- preload_static lib_paths static_ish - maybePutStrLn dflags (if b then "done." - else "not found") - DLL dll_unadorned - -> -- We add "" to the set of paths to try, so that - -- if none of the real paths match, we force addDLL - -- to look in the default dynamic-link search paths. - do maybe_errstr <- loadDynamic (lib_paths++[""]) - dll_unadorned - case maybe_errstr of - Nothing -> return () - Just mm -> preloadFailed mm lib_paths lib_spec - maybePutStrLn dflags "done" - - 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 - - -- not interested in the paths in the static case. - 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." - -linkPackage :: DynFlags -> PackageConfig -> IO () -linkPackage dflags pkg - | name pkg `elem` dont_load_these = return () - | otherwise - = do - let dirs = library_dirs pkg - let libs = hs_libraries pkg ++ extra_libraries pkg - classifieds <- mapM (locateOneObj dirs) libs -#ifdef darwin_TARGET_OS - let fwDirs = framework_dirs pkg - let frameworks= extra_frameworks pkg -#endif - - -- Complication: all the .so's must be loaded before any of the .o's. - let dlls = [ dll | DLL dll <- classifieds ] - objs = [ obj | Object obj <- classifieds ] - - maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ") - - -- If this package is already part of the GHCi binary, we'll already - -- have the right DLLs for this package loaded, so don't try to - -- load them again. - when (name pkg `notElem` loaded_in_ghci) $ do -#ifdef darwin_TARGET_OS - loadFrameworks fwDirs frameworks -#endif - loadDynamics dirs dlls - - -- After loading all the DLLs, we can load the static objects. - mapM_ loadObj objs - - maybePutStr dflags "linking ... " - ok <- resolveObjs - if ok then maybePutStrLn dflags "done." - else panic ("can't load package `" ++ name pkg ++ "'") - -loadDynamics dirs [] = return () -loadDynamics dirs (dll:dlls) = do - r <- loadDynamic dirs dll - case r of - Nothing -> loadDynamics dirs dlls - Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: " - ++ dll ++ " (" ++ err ++ ")" )) -#ifdef darwin_TARGET_OS -loadFrameworks dirs [] = return () -loadFrameworks dirs (fw:fws) = do - r <- loadFramework dirs fw - case r of - Nothing -> loadFrameworks dirs fws - 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 [] lib - = return (DLL lib) -- we assume -locateOneObj (d:ds) lib - = do let path = d ++ '/':lib ++ ".o" - b <- doesFileExist path - if b then return (Object path) else locateOneObj ds lib - --- ---------------------------------------------------------------------------- --- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) - -#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS) -loadDynamic paths rootname = addDLL rootname - -- ignore paths on windows (why? --SDM) - -#else - --- return Nothing == success, else Just error message from dlopen -loadDynamic (path:paths) rootname = do - let dll = path ++ '/':mkSOName rootname - b <- doesFileExist dll - if not b - then loadDynamic paths rootname - else addDLL dll -loadDynamic [] rootname = do - -- tried all our known library paths, let dlopen() search its - -- own builtin paths now. - addDLL (mkSOName rootname) - -#ifdef darwin_TARGET_OS -mkSOName root = "lib" ++ root ++ ".dylib" -#else -mkSOName root = "lib" ++ root ++ ".so" -#endif - -#endif - --- 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 - = loadFramework' (extraPaths ++ defaultFrameworkPaths) where - defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] - - loadFramework' (path:paths) = do - let dll = path ++ '/' : rootname ++ ".framework/" ++ rootname - b <- doesFileExist dll - if not b - then loadFramework' paths - else addDLL dll - loadFramework' [] = do - -- tried all our known library paths, but dlopen() - -- has no built-in paths for frameworks: give up - return $ Just $ "not found" -#endif - -addDLL :: String -> IO (Maybe String) -addDLL str = do - maybe_errmsg <- withCString str $ \dll -> c_addDLL dll - if maybe_errmsg == nullPtr - then return Nothing - else do str <- peekCString maybe_errmsg - return (Just str) - -foreign import ccall "addDLL" unsafe - c_addDLL :: CString -> IO CString - ------------------------------------------------------------------------------ -- timing & statistics timeIt :: GHCi a -> GHCi a @@ -1225,7 +1045,7 @@ timeIt action io $ printTimes (allocs2 - allocs1) (time2 - time1) return a -foreign import "getAllocations" getAllocations :: IO Int +foreign import ccall "getAllocations" getAllocations :: IO Int printTimes :: Int -> Integer -> IO () printTimes allocs psecs @@ -1236,28 +1056,14 @@ printTimes allocs psecs int allocs <+> text "bytes"))) ----------------------------------------------------------------------------- --- utils - -looksLikeModuleName [] = False -looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs - -isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.' - -maybePutStr dflags s | verbosity dflags > 0 = putStr s - | otherwise = return () - -maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s - | otherwise = return () - ------------------------------------------------------------------------------ -- reverting CAFs revertCAFs :: IO () revertCAFs = do rts_revertCAFs - Monad.join (readIORef turn_off_buffering) - -- have to do this again, because we just reverted - -- stdout, stderr & stdin to their defaults. + turnOffBuffering + -- Have to turn off buffering again, because we just + -- reverted stdout, stderr & stdin to their defaults. foreign import ccall "revertCAFs" rts_revertCAFs :: IO () - -- make it "safe", just in case + -- Make it "safe", just in case