X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FGhciMonad.hs;h=5043d983acef19dadcc24fd1b116d8e6158d4339;hp=04c5ffa7361dbcdc10c5f528ff9033677dda7f23;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=8bc615fdb45b8e3f2f3ef2167bbb379bf619aab2 diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index 04c5ffa..5043d98 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -1,20 +1,41 @@ +----------------------------------------------------------------------------- +-- +-- 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 @@ -30,19 +51,64 @@ data GHCiState = GHCiState 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 @@ -52,6 +118,9 @@ instance Monad GHCi where (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) @@ -94,92 +163,13 @@ unsetOption opt 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 @@ -224,35 +214,57 @@ foreign import ccall "revertCAFs" rts_revertCAFs :: IO () -- 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)