X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=5801a3859d0fe10d6d1fb3f9651a4576f929a807;hb=dc813469cfae2d6ae2defe44bf014faf3ded2b32;hp=ded3bd8c514ae321730d213da33c5e941c17e552;hpb=84c55de442784d8b46a1cf2ca7f650d17020d98a;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index ded3bd8..5801a38 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,31 +1,30 @@ {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.119 2002/04/11 08:39:27 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.139 2002/12/12 13:21:46 ross Exp $ -- -- GHC Interactive User Interface -- -- (c) The GHC Team 2000 -- ----------------------------------------------------------------------------- -module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where +module InteractiveUI ( + interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO () + 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 ) @@ -33,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 ) @@ -46,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 ( peekCString ) +import Foreign.C.String ( CString, peekCString, withCString ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) + +import GHC.Posix ( setNonBlockingFD ) ----------------------------------------------------------------------------- @@ -145,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"] @@ -199,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) @@ -239,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." @@ -258,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 @@ -273,10 +267,10 @@ interactiveLoop is_tty = do checkPerms :: String -> IO Bool checkPerms name = - DriverUtil.handle (\_ -> return False) $ do #ifdef mingw32_TARGET_OS - doesFileExist name + return True #else + DriverUtil.handle (\_ -> return False) $ do st <- getFileStatus name me <- getRealUserID if fileOwner st /= me then do @@ -301,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 @@ -325,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 -> @@ -337,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 @@ -386,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 () @@ -398,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 @@ -420,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 @@ -607,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))) @@ -685,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'))) @@ -793,7 +830,7 @@ setProg _ = do setOptions wds = do -- first, deal with the GHCi opts (+s, +t, etc.) let (plus_opts, minus_opts) = partition isPlus wds - mapM setOpt plus_opts + mapM_ setOpt plus_opts -- now, the GHC flags pkgs_before <- io (readIORef v_Packages) @@ -801,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)) @@ -827,7 +871,7 @@ unsetOptions str then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'")) else do - mapM unsetOpt plus_opts + mapM_ unsetOpt plus_opts -- can't do GHC flags for now if (not (null minus_opts)) @@ -861,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' @@ -881,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 @@ -903,9 +945,10 @@ showBindings = do unqual = cmGetPrintUnqual cms showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b))) - io (mapM showBinding (cmGetBindings cms)) + io (mapM_ showBinding (cmGetBindings cms)) return () + ----------------------------------------------------------------------------- -- GHCi monad @@ -924,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 @@ -975,153 +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. - -type LibrarySpec - = Either FilePath String - -showLS (Left nm) = "(static) " ++ nm -showLS (Right 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 - Left static_ish - -> do b <- preload_static lib_paths static_ish - maybePutStrLn dflags (if b then "done." - else "not found") - Right 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 <- preload_dynamic (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 - - -- return Nothing == success, else Just error message from addDLL - preload_dynamic [] name - = return Nothing - preload_dynamic (path:paths) rootname - = do -- addDLL returns NULL on success - maybe_errmsg <- addDLL path rootname - if maybe_errmsg == nullPtr - then preload_dynamic paths rootname - else do str <- peekCString maybe_errmsg - return (Just str) - - give_up - = (throwDyn . CmdLineError) - "user specified .o/.so/.DLL could not be loaded." - --- Packages that don't need loading, because the compiler shares them with --- the interpreted program. -dont_load_these = [ "gmp", "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 - -linkPackage :: DynFlags -> PackageConfig -> IO () -linkPackage dflags pkg - | name pkg `elem` dont_load_these = return () - | otherwise - = do - -- For each obj, try obj.o and if that fails, obj.so. - -- Complication: all the .so's must be loaded before any of the .o's. - let dirs = library_dirs pkg - let objs = hs_libraries pkg ++ extra_libraries pkg - classifieds <- mapM (locateOneObj dirs) objs - - -- Don't load the .so libs if this is a package GHCi is already - -- linked against, because we'll already have the .so linked in. - let (so_libs, obj_libs) = partition isRight classifieds - let sos_first | name pkg `elem` loaded_in_ghci = obj_libs - | otherwise = so_libs ++ obj_libs - - maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ") - mapM loadClassified sos_first - maybePutStr dflags "linking ... " - ok <- resolveObjs - if ok then maybePutStrLn dflags "done." - else panic ("can't load package `" ++ name pkg ++ "'") - where - isRight (Right _) = True - isRight (Left _) = False - -loadClassified :: LibrarySpec -> IO () -loadClassified (Left obj_absolute_filename) - = do loadObj obj_absolute_filename -loadClassified (Right dll_unadorned) - = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me - if maybe_errmsg == nullPtr - then return () - else do str <- peekCString maybe_errmsg - throwDyn (CmdLineError ("can't load .so/.DLL for: " - ++ dll_unadorned ++ " (" ++ str ++ ")" )) - -locateOneObj :: [FilePath] -> String -> IO LibrarySpec -locateOneObj [] obj - = return (Right obj) -- we assume -locateOneObj (d:ds) obj - = do let path = d ++ '/':obj ++ ".o" - b <- doesFileExist path - if b then return (Left path) else locateOneObj ds obj - ------------------------------------------------------------------------------ -- timing & statistics timeIt :: GHCi a -> GHCi a @@ -1137,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 @@ -1148,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