X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=3cfd5d2ffa8d9053957fd4560173705b628e2afd;hb=b0c44859840c251bac0d199fad94645031579096;hp=8660650e0d960ee0a37d2413deb7041f0b9eb199;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 8660650..3cfd5d2 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.134 2002/09/13 15:02:32 simonpj Exp $ +-- $Id: InteractiveUI.hs,v 1.142 2002/12/27 12:20:06 panne Exp $ -- -- GHC Interactive User Interface -- @@ -23,8 +23,8 @@ import MkIface ( ifaceTyThing ) import DriverFlags import DriverState import DriverUtil ( remove_spaces, handle ) -import Linker ( initLinker, showLinkerState, linkLibraries ) -import Finder ( flushPackageCache ) +import Linker ( initLinker, showLinkerState, linkLibraries, + linkPackages ) import Util import Id ( isRecordSelector, recordSelectorFieldLabel, isDataConWrapId, isDataConId, idName ) @@ -37,6 +37,7 @@ import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName, NamedThing(..) ) import OccName ( isSymOcc ) import BasicTypes ( defaultFixity, SuccessFlag(..) ) +import Packages import Outputable import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset ) @@ -70,10 +71,10 @@ import Control.Monad as Monad import GHC.Exts ( unsafeCoerce# ) -import Foreign ( nullPtr ) -import Foreign.C.String ( CString, peekCString, withCString ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import GHC.Posix ( setNonBlockingFD ) + ----------------------------------------------------------------------------- ghciWelcomeMsg = "\ @@ -154,11 +155,13 @@ interactiveUI cmstate paths cmdline_objs = do dflags <- getDynFlags - -- Link in the available packages initLinker - -- Now that demand-loading works, we don't really need to pre-load the packages - -- pkgs <- getPackages - -- linkPackages dflags pkgs + + -- 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 @@ -295,7 +298,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 @@ -319,7 +322,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 -> @@ -331,16 +337,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 - flushInterpBuffers - 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 @@ -824,18 +836,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)) @@ -894,13 +913,10 @@ newPackages new_pkgs = do -- The new packages are already in v_Packages dflags <- io getDynFlags cmstate1 <- io (cmUnload (cmstate state) dflags) setGHCiState state{ cmstate = cmstate1, targets = [] } - - io $ do pkgs <- getPackageInfo - flushPackageCache pkgs - + io (linkPackages dflags new_pkgs) setContextAfterLoad [] ------------------------------------------------------------------------------ +-- --------------------------------------------------------------------------- -- code for `:show' showCmd str = @@ -1003,7 +1019,7 @@ 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) @@ -1035,14 +1051,6 @@ printTimes allocs psecs int allocs <+> text "bytes"))) ----------------------------------------------------------------------------- --- utils - -looksLikeModuleName [] = False -looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs - -isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.' - ------------------------------------------------------------------------------ -- reverting CAFs revertCAFs :: IO ()