+-----------------------------------------------------------------------------
+--
+-- Monadery code used in InteractiveUI
+--
+-- (c) The GHC Team 2005-2006
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module GhciMonad where
#include "HsVersions.h"
import qualified GHC
-import {-#SOURCE#-} Debugger
-import Breakpoints
-import Outputable
-import Panic hiding (showException)
+import Outputable hiding (printForUser)
+import qualified Outputable
+import Panic hiding (showException)
import Util
+import DynFlags
+import HscTypes
+import SrcLoc
+import Module
+import ObjLink
+import Data.Maybe
import Numeric
import Control.Exception as Exception
+import Data.Array
import Data.Char
-import Data.Dynamic
import Data.Int ( Int64 )
import Data.IORef
+import Data.List
import Data.Typeable
import System.CPUTime
import System.IO
args :: [String],
prompt :: String,
editor :: String,
+ stop :: String,
session :: GHC.Session,
options :: [GHCiOption],
prelude :: GHC.Module,
- bkptTable :: IORef (BkptTable GHC.Module),
- topLevel :: Bool
+ break_ctr :: !Int,
+ breaks :: ![(Int, BreakLocation)],
+ tickarrays :: ModuleEnv TickArray,
+ -- tickarrays caches the TickArray for loaded modules,
+ -- so that we don't rebuild it each time the user sets
+ -- a breakpoint.
+ cmdqueue :: [String]
}
+type TickArray = Array Int [(BreakIndex,SrcSpan)]
+
data GHCiOption
= ShowTiming -- show time/allocs after evaluation
| ShowType -- show the type of expressions
| RevertCAFs -- revert CAFs after every evaluation
deriving Eq
+data BreakLocation
+ = BreakLocation
+ { breakModule :: !GHC.Module
+ , breakLoc :: !SrcSpan
+ , breakTick :: {-# UNPACK #-} !Int
+ , onBreakCmd :: String
+ }
+
+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) <+>
+ if null (onBreakCmd loc)
+ then empty
+ else doubleQuotes (text (onBreakCmd loc))
+
+recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
+recordBreak brkLoc = do
+ st <- getGHCiState
+ let oldActiveBreaks = breaks st
+ -- don't store the same break point twice
+ case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
+ (nm:_) -> return (True, nm)
+ [] -> do
+ let oldCounter = break_ctr st
+ newCounter = oldCounter + 1
+ setGHCiState $ st { break_ctr = newCounter,
+ breaks = (oldCounter, brkLoc) : oldActiveBreaks
+ }
+ return (False, oldCounter)
+
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
startGHCi :: GHCi a -> GHCiState -> IO a
(GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
return a = GHCi $ \s -> return a
+instance Functor GHCi where
+ fmap f m = m >>= return . f
+
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)
io :: IO a -> GHCi a
io m = GHCi { unGHCi = \s -> m >>= return }
-isTopLevel :: GHCi Bool
-isTopLevel = getGHCiState >>= return . topLevel
-
-getBkptTable :: GHCi (BkptTable GHC.Module)
-getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
- io$ readIORef table_ref
-
-setBkptTable :: BkptTable GHC.Module -> GHCi ()
-setBkptTable new_table = do
- table_ref <- getGHCiState >>= return . bkptTable
- io$ writeIORef table_ref new_table
-
-modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
-modifyBkptTable f = do
- bt <- getBkptTable
- new_bt <- io . evaluate$ f bt
- setBkptTable new_bt
-
-showForUser :: SDoc -> GHCi String
-showForUser doc = do
+printForUser :: SDoc -> GHCi ()
+printForUser doc = do
session <- getSession
unqual <- io (GHC.getPrintUnqual session)
- return $! showSDocForUser unqual doc
+ io $ Outputable.printForUser stdout unqual doc
------------------------------------------------------------------------------
--- User code exception handling
-
--- This hierarchy of exceptions is used to signal interruption of a child session
-data BkptException = StopChildSession -- A child debugging session requests to be stopped
- | ChildSessionStopped String
- deriving Typeable
-
--- This is the exception handler for exceptions generated by the
--- user's code and exceptions coming from children sessions;
--- 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 (DynException dyn)
- | Just StopChildSession <- fromDynamic dyn
- -- propagate to the parent session
- = ASSERTM (liftM not isTopLevel) >> throwDyn StopChildSession
-
- | Just (ChildSessionStopped msg) <- fromDynamic dyn
- -- Revert CAFs and display some message
- = ASSERTM (isTopLevel) >>
- io (revertCAFs >> putStrLn msg) >>
- return False
-
-handler exception = do
- flushInterpBuffers
- io installSignalHandlers
- ghciHandle handler (showException exception >> return False)
-
-showException (DynException dyn) =
- case fromDynamic dyn of
- Nothing -> io (putStrLn ("*** Exception: (unknown)"))
- Just Interrupted -> io (putStrLn "Interrupted.")
- Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
- Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
- Just other_ghc_ex -> io (print other_ghc_ex)
-
-showException other_exception
- = io (putStrLn ("*** Exception: " ++ show other_exception))
-
------------------------------------------------------------------------------
--- recursive exception handlers
-
--- Don't forget to unblock async exceptions in the handler, or if we're
--- in an exception loop (eg. let a = error a in a) the ^C exception
--- may never be delivered. Thanks to Marcin for pointing out the bug.
-
-ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
-ghciHandle h (GHCi m) = GHCi $ \s ->
- Exception.catch (m s)
- (\e -> unGHCi (ghciUnblock (h e)) s)
-
-ghciUnblock :: GHCi a -> GHCi a
-ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
-
------------------------------------------------------------------------------
+-- --------------------------------------------------------------------------
-- timing & statistics
timeIt :: GHCi a -> GHCi a
-- 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 = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
- " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
-flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush System.IO.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 :: Session -> IO ()
+-- 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.Session -> IO ()
initInterpBuffering session
- = do 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"
-
+ = do -- make sure these are linked
+ mb_hval1 <- GHC.compileExpr session "System.IO.stdout"
+ mb_hval2 <- GHC.compileExpr session "System.IO.stderr"
+ mb_hval3 <- GHC.compileExpr session "System.IO.stdin"
+ when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $
+ panic "interactiveUI:setBuffering"
+
+ -- 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 ref 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