X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=5801a3859d0fe10d6d1fb3f9651a4576f929a807;hb=dc813469cfae2d6ae2defe44bf014faf3ded2b32;hp=91344406656a8d55dc2769e8d2b356265239e676;hpb=2ac92d88dfb9a8864fb619225cb997bd23b1b8e1;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 9134440..5801a38 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.124 2002/05/01 17:56:54 sof Exp $ +-- $Id: InteractiveUI.hs,v 1.139 2002/12/12 13:21:46 ross Exp $ -- -- GHC Interactive User Interface -- @@ -9,27 +9,22 @@ ----------------------------------------------------------------------------- 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 ) +import Finder ( flushFinderCache ) import Util import Id ( isRecordSelector, recordSelectorFieldLabel, isDataConWrapId, isDataConId, idName ) @@ -37,12 +32,12 @@ import Class ( className ) import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) ) 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 ) @@ -50,31 +45,37 @@ import Panic ( GhcException(..), showGhcException ) 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 GlaExts ( unsafeCoerce# ) +import GHC.Exts ( unsafeCoerce# ) import Foreign ( nullPtr ) -import CString ( CString, peekCString, withCString ) +import Foreign.C.String ( CString, peekCString, withCString ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) + +import GHC.Posix ( setNonBlockingFD ) ----------------------------------------------------------------------------- @@ -149,39 +150,23 @@ 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 + -- packages are loaded "on-demand" now 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 -> unsafeCoerce# hval :: IO () - _ -> 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" + 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"] @@ -203,7 +188,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,8 +227,14 @@ runGHCi paths dflags = do loadModule (unwords paths) -- enter the interactive loop +#if defined(mingw32_TARGET_OS) + -- always show prompt, since hIsTerminalDevice returns True for Consoles + -- only, which we may or may not be running under (cf. Emacs sub-shells.) + interactiveLoop True +#else is_tty <- io (hIsTerminalDevice stdin) interactiveLoop is_tty +#endif -- and finally, exit io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." @@ -262,7 +252,7 @@ interactiveLoop is_tty = do then readlineLoop else fileLoop stdin False -- turn off prompt for non-TTY input #else - fileLoop stdin True + fileLoop stdin is_tty #endif @@ -305,7 +295,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 @@ -329,7 +319,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 -> @@ -341,16 +334,22 @@ 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 + ghciHandle handler (showException exception >> return False) showException (DynException dyn) = case fromDynamic dyn of @@ -390,9 +389,9 @@ finishEvalExpr names cmstate <- getCmState when b (mapM_ (showTypeOfName cmstate) names) + flushInterpBuffers b <- isOptionSet RevertCAFs io (when b revertCAFs) - flushEverything return True showTypeOfName :: CmState -> Name -> GHCi () @@ -402,12 +401,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 @@ -424,6 +417,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 @@ -611,9 +644,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))) @@ -689,7 +722,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'))) @@ -805,13 +838,20 @@ setOptions wds = pkgs_after <- io (readIORef v_Packages) -- 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)) @@ -865,18 +905,12 @@ 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) + setContextAfterLoad [] ----------------------------------------------------------------------------- -- code for `:show' @@ -885,21 +919,25 @@ 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 @@ -910,6 +948,7 @@ showBindings = do io (mapM_ showBinding (cmGetBindings cms)) return () + ----------------------------------------------------------------------------- -- GHCi monad @@ -928,9 +967,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 ()) - newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a } startGHCi :: GHCi a -> GHCiState -> IO a @@ -979,179 +1015,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 - --- 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 - -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 - - -- 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) $ - 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 ++ ")" )) - --- 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) - -#ifdef mingw32_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) - -mkSOName root = "lib" ++ root ++ ".so" - -#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 @@ -1167,7 +1036,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 @@ -1178,20 +1047,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 -foreign import revertCAFs :: IO () -- make it "safe", just in case +revertCAFs :: IO () +revertCAFs = do + rts_revertCAFs + 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