+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
-----------------------------------------------------------------------------
--
-- Monadery code used in InteractiveUI
#include "HsVersions.h"
import qualified GHC
-import Outputable hiding (printForUser)
+import Outputable hiding (printForUser, printForUserPartWay)
import qualified Outputable
import Panic hiding (showException)
import Util
import HscTypes
import SrcLoc
import Module
+import ObjLink
+import Linker
+import StaticFlags
+import MonadUtils ( MonadIO, liftIO )
+import Exception
+import Data.Maybe
import Numeric
-import Control.Exception as Exception
import Data.Array
import Data.Char
import Data.Int ( Int64 )
import Data.IORef
import Data.List
-import Data.Typeable
import System.CPUTime
+import System.Environment
import System.IO
import Control.Monad as Monad
import GHC.Exts
-----------------------------------------------------------------------------
-- GHCi monad
+type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String])
+
data GHCiState = GHCiState
{
progname :: String,
prompt :: String,
editor :: String,
stop :: String,
- session :: GHC.Session,
options :: [GHCiOption],
prelude :: GHC.Module,
break_ctr :: !Int,
breaks :: ![(Int, BreakLocation)],
- tickarrays :: ModuleEnv TickArray
+ tickarrays :: ModuleEnv TickArray,
-- tickarrays caches the TickArray for loaded modules,
-- so that we don't rebuild it each time the user sets
-- a breakpoint.
+ -- ":" at the GHCi prompt repeats the last command, so we
+ -- remember is here:
+ last_command :: Maybe Command,
+ cmdqueue :: [String],
+ remembered_ctx :: [(CtxtCmd, [String], [String])],
+ -- we remember the :module commands between :loads, so that
+ -- on a :reload we can replay them. See bugs #2049,
+ -- \#1873, #1360. Previously we tried to remember modules that
+ -- were supposed to be in the context but currently had errors,
+ -- but this was complicated. Just replaying the :module commands
+ -- seems to be the right thing.
+ ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
}
+data CtxtCmd
+ = SetContext
+ | AddModules
+ | RemModules
+
type TickArray = Array Int [(BreakIndex,SrcSpan)]
data GHCiOption
{ breakModule :: !GHC.Module
, breakLoc :: !SrcSpan
, breakTick :: {-# UNPACK #-} !Int
+ , onBreakCmd :: String
}
- deriving Eq
+
+instance Eq BreakLocation where
+ loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
+ breakTick loc1 == breakTick loc2
prettyLocations :: [(Int, BreakLocation)] -> SDoc
prettyLocations [] = text "No active breakpoints."
prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
instance Outputable BreakLocation where
- ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
+ ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
+ if null (onBreakCmd loc)
+ then empty
+ else doubleQuotes (text (onBreakCmd loc))
recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
recordBreak brkLoc = do
}
return (False, oldCounter)
-newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
+newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
-startGHCi :: GHCi a -> GHCiState -> IO a
-startGHCi g state = do ref <- newIORef state; unGHCi g ref
+reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
+
+reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
+reifyGHCi f = GHCi f'
+ where
+ -- f' :: IORef GHCiState -> Ghc a
+ f' gs = reifyGhc (f'' gs)
+ -- f'' :: IORef GHCiState -> Session -> IO a
+ f'' gs s = f (s, gs)
+
+startGHCi :: GHCi a -> GHCiState -> Ghc a
+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
instance Monad GHCi where
(GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
- return a = GHCi $ \s -> return a
+ return a = GHCi $ \_ -> return a
+
+instance Functor GHCi where
+ fmap f m = m >>= return . f
+
+ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
+ghciHandleGhcException = handleGhcException
-ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
-ghciHandleDyn h (GHCi m) = GHCi $ \s ->
- Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
+getGHCiState :: GHCi GHCiState
+getGHCiState = GHCi $ \r -> liftIO $ readIORef r
+setGHCiState :: GHCiState -> GHCi ()
+setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
-getGHCiState = GHCi $ \r -> readIORef r
-setGHCiState s = GHCi $ \r -> writeIORef r s
+liftGhc :: Ghc a -> GHCi a
+liftGhc m = GHCi $ \_ -> m
+
+instance MonadIO GHCi where
+ liftIO m = liftGhc $ liftIO m
+
+instance GhcMonad GHCi where
+ setSession s' = liftGhc $ setSession s'
+ getSession = liftGhc $ getSession
+
+instance ExceptionMonad GHCi where
+ gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
+ gblock (GHCi m) = GHCi $ \r -> gblock (m r)
+ gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
+
+instance WarnLogMonad GHCi where
+ setWarnings warns = liftGhc $ setWarnings warns
+ getWarnings = liftGhc $ getWarnings
-- for convenience...
-getSession = getGHCiState >>= return . session
+getPrelude :: GHCi Module
getPrelude = getGHCiState >>= return . prelude
-GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
+GLOBAL_VAR(saved_sess, no_saved_sess, Session)
+
+no_saved_sess :: Session
no_saved_sess = error "no saved_ses"
-saveSession = getSession >>= io . writeIORef saved_sess
+
+saveSession :: GHCi ()
+saveSession =
+ liftGhc $ do
+ reifyGhc $ \s ->
+ writeIORef saved_sess s
+
+splatSavedSession :: GHCi ()
splatSavedSession = io (writeIORef saved_sess no_saved_sess)
-restoreSession = readIORef saved_sess
+-- restoreSession :: IO Session
+-- restoreSession = readIORef saved_sess
+
+withRestoredSession :: Ghc a -> IO a
+withRestoredSession ghc = do
+ s <- readIORef saved_sess
+ reflectGhc ghc s
+
+getDynFlags :: GHCi DynFlags
getDynFlags = do
- s <- getSession
- io (GHC.getSessionDynFlags s)
+ GHC.getSessionDynFlags
+
+setDynFlags :: DynFlags -> GHCi [PackageId]
setDynFlags dflags = do
- s <- getSession
- io (GHC.setSessionDynFlags s dflags)
+ GHC.setSessionDynFlags dflags
isOptionSet :: GHCiOption -> GHCi Bool
isOptionSet opt
setGHCiState (st{ options = filter (/= opt) (options st) })
io :: IO a -> GHCi a
-io m = GHCi { unGHCi = \s -> m >>= return }
+io = liftIO
printForUser :: SDoc -> GHCi ()
printForUser doc = do
- session <- getSession
- unqual <- io (GHC.getPrintUnqual session)
+ unqual <- GHC.getPrintUnqual
io $ Outputable.printForUser stdout unqual doc
+printForUserPartWay :: SDoc -> GHCi ()
+printForUserPartWay doc = do
+ unqual <- GHC.getPrintUnqual
+ io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
+
+runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
+runStmt expr step = do
+ st <- getGHCiState
+ reifyGHCi $ \x ->
+ withProgName (progname st) $
+ withArgs (args st) $
+ reflectGHCi x $ do
+ GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
+ return GHC.RunFailed) $ do
+ GHC.runStmt expr step
+
+resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
+resume canLogSpan step = GHC.resume canLogSpan step
+
-- --------------------------------------------------------------------------
-- timing & statistics
printTimes :: Integer -> Integer -> IO ()
printTimes allocs psecs
- = do let secs = (fromIntegral psecs / (10^12)) :: Float
+ = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
secs_str = showFFloat (Just 2) secs
putStrLn (showSDoc (
parens (text (secs_str "") <+> text "secs" <> comma <+>
-----------------------------------------------------------------------------
-- reverting CAFs
-revertCAFs :: IO ()
+revertCAFs :: GHCi ()
revertCAFs = do
- rts_revertCAFs
- turnOffBuffering
+ io $ rts_revertCAFs
+ s <- getGHCiState
+ when (not (ghc_e s)) $ io turnOffBuffering
-- Have to turn off buffering again, because we just
-- reverted stdout, stderr & stdin to their defaults.
-- 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 ())
-
-command_sequence :: [String] -> String
-command_sequence = unwords . intersperse "Prelude.>>"
-
-no_buffer :: String -> String
-no_buffer h = unwords ["System.IO.hSetBuffering",
- "System.IO." ++ h,
- "System.IO.NoBuffering"]
-
-no_buf_cmd :: String
-no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
-
-flush_buffer :: String -> String
-flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
-
-flush_cmd :: String
-flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
+GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
+GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
+GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
-initInterpBuffering :: GHC.Session -> IO ()
-initInterpBuffering session
- = do -- we don't want to be fooled by any modules lying around in the current
- -- directory when we compile these code fragments, so set the import
- -- path to be empty while we compile them.
- dflags <- GHC.getSessionDynFlags session
- GHC.setSessionDynFlags session dflags{importPaths=[]}
-
- maybe_hval <- GHC.compileExpr session no_buf_cmd
-
- case maybe_hval of
- Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
- other -> panic "interactiveUI:setBuffering"
-
- maybe_hval <- GHC.compileExpr session flush_cmd
- case maybe_hval of
- Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
- _ -> panic "interactiveUI:flush"
-
- GHC.setSessionDynFlags session dflags
- GHC.workingDirectoryChanged session
+-- After various attempts, I believe this is the least bad way to do
+-- what we want. We know look up the address of the static stdin,
+-- stdout, and stderr closures in the loaded base package, and each
+-- time we need to refer to them we cast the pointer to a Handle.
+-- This avoids any problems with the CAF having been reverted, because
+-- we'll always get the current value.
+--
+-- The previous attempt that didn't work was to compile an expression
+-- like "hSetBuffering stdout NoBuffering" into an expression of type
+-- IO () and run this expression each time we needed it, but the
+-- problem is that evaluating the expression might cache the contents
+-- of the Handle rather than referring to it from its static address
+-- each time. There's no safe workaround for this.
+
+initInterpBuffering :: Ghc ()
+initInterpBuffering = do -- make sure these are linked
+ dflags <- GHC.getSessionDynFlags
+ liftIO $ do
+ initDynLinker dflags
+
+ -- ToDo: we should really look up these names properly, but
+ -- it's a fiddle and not all the bits are exposed via the GHC
+ -- interface.
+ mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
+ mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
+ mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
+
+ let f ref (Just ptr) = writeIORef ref ptr
+ f _ Nothing = panic "interactiveUI:setBuffering2"
+ zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
+ [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
return ()
-
flushInterpBuffers :: GHCi ()
flushInterpBuffers
- = io $ do Monad.join (readIORef flush_interp)
- return ()
+ = io $ do getHandle stdout_ptr >>= hFlush
+ getHandle stderr_ptr >>= hFlush
turnOffBuffering :: IO ()
turnOffBuffering
- = do Monad.join (readIORef turn_off_buffering)
- return ()
+ = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
+ mapM_ (\h -> hSetBuffering h NoBuffering) hdls
+
+getHandle :: IORef (Ptr ()) -> IO Handle
+getHandle ref = do
+ (Ptr addr) <- readIORef ref
+ case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)
projects / ghc-hetmet.git / blobdiff