3 #include "HsVersions.h"
6 import {-#SOURCE#-} Debugger
9 import Panic hiding (showException)
13 import Control.Exception as Exception
16 import Data.Int ( Int64 )
21 import Control.Monad as Monad
24 -----------------------------------------------------------------------------
27 data GHCiState = GHCiState
33 session :: GHC.Session,
34 options :: [GHCiOption],
35 prelude :: GHC.Module,
36 bkptTable :: IORef (BkptTable GHC.Module),
41 = ShowTiming -- show time/allocs after evaluation
42 | ShowType -- show the type of expressions
43 | RevertCAFs -- revert CAFs after every evaluation
46 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
48 startGHCi :: GHCi a -> GHCiState -> IO a
49 startGHCi g state = do ref <- newIORef state; unGHCi g ref
51 instance Monad GHCi where
52 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
53 return a = GHCi $ \s -> return a
55 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
56 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
57 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
59 getGHCiState = GHCi $ \r -> readIORef r
60 setGHCiState s = GHCi $ \r -> writeIORef r s
63 getSession = getGHCiState >>= return . session
64 getPrelude = getGHCiState >>= return . prelude
66 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
67 no_saved_sess = error "no saved_ses"
68 saveSession = getSession >>= io . writeIORef saved_sess
69 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
70 restoreSession = readIORef saved_sess
74 io (GHC.getSessionDynFlags s)
75 setDynFlags dflags = do
77 io (GHC.setSessionDynFlags s dflags)
79 isOptionSet :: GHCiOption -> GHCi Bool
81 = do st <- getGHCiState
82 return (opt `elem` options st)
84 setOption :: GHCiOption -> GHCi ()
86 = do st <- getGHCiState
87 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
89 unsetOption :: GHCiOption -> GHCi ()
91 = do st <- getGHCiState
92 setGHCiState (st{ options = filter (/= opt) (options st) })
95 io m = GHCi { unGHCi = \s -> m >>= return }
97 isTopLevel :: GHCi Bool
98 isTopLevel = getGHCiState >>= return . topLevel
100 getBkptTable :: GHCi (BkptTable GHC.Module)
101 getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
102 io$ readIORef table_ref
104 setBkptTable :: BkptTable GHC.Module -> GHCi ()
105 setBkptTable new_table = do
106 table_ref <- getGHCiState >>= return . bkptTable
107 io$ writeIORef table_ref new_table
109 modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
110 modifyBkptTable f = do
112 new_bt <- io . evaluate$ f bt
115 showForUser :: SDoc -> GHCi String
117 session <- getSession
118 unqual <- io (GHC.getPrintUnqual session)
119 return $! showSDocForUser unqual doc
121 -----------------------------------------------------------------------------
122 -- User code exception handling
124 -- This hierarchy of exceptions is used to signal interruption of a child session
125 data BkptException = StopChildSession -- A child debugging session requests to be stopped
126 | ChildSessionStopped String
129 -- This is the exception handler for exceptions generated by the
130 -- user's code and exceptions coming from children sessions;
131 -- it normally just prints out the exception. The
132 -- handler must be recursive, in case showing the exception causes
133 -- more exceptions to be raised.
135 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
136 -- raising another exception. We therefore don't put the recursive
137 -- handler arond the flushing operation, so if stderr is closed
138 -- GHCi will just die gracefully rather than going into an infinite loop.
139 handler :: Exception -> GHCi Bool
140 handler (DynException dyn)
141 | Just StopChildSession <- fromDynamic dyn
142 -- propagate to the parent session
143 = do ASSERTM (liftM not isTopLevel)
144 throwDyn StopChildSession
146 | Just (ChildSessionStopped msg) <- fromDynamic dyn
147 -- Revert CAFs and display some message
148 = do ASSERTM (isTopLevel)
149 io (revertCAFs >> putStrLn msg)
152 handler exception = do
154 io installSignalHandlers
155 ghciHandle handler (showException exception >> return False)
157 showException (DynException dyn) =
158 case fromDynamic dyn of
159 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
160 Just Interrupted -> io (putStrLn "Interrupted.")
161 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
162 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
163 Just other_ghc_ex -> io (print other_ghc_ex)
165 showException other_exception
166 = io (putStrLn ("*** Exception: " ++ show other_exception))
168 -----------------------------------------------------------------------------
169 -- recursive exception handlers
171 -- Don't forget to unblock async exceptions in the handler, or if we're
172 -- in an exception loop (eg. let a = error a in a) the ^C exception
173 -- may never be delivered. Thanks to Marcin for pointing out the bug.
175 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
176 ghciHandle h (GHCi m) = GHCi $ \s ->
177 Exception.catch (m s)
178 (\e -> unGHCi (ghciUnblock (h e)) s)
180 ghciUnblock :: GHCi a -> GHCi a
181 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
183 -----------------------------------------------------------------------------
184 -- timing & statistics
186 timeIt :: GHCi a -> GHCi a
188 = do b <- isOptionSet ShowTiming
191 else do allocs1 <- io $ getAllocations
192 time1 <- io $ getCPUTime
194 allocs2 <- io $ getAllocations
195 time2 <- io $ getCPUTime
196 io $ printTimes (fromIntegral (allocs2 - allocs1))
200 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
201 -- defined in ghc/rts/Stats.c
203 printTimes :: Integer -> Integer -> IO ()
204 printTimes allocs psecs
205 = do let secs = (fromIntegral psecs / (10^12)) :: Float
206 secs_str = showFFloat (Just 2) secs
208 parens (text (secs_str "") <+> text "secs" <> comma <+>
209 text (show allocs) <+> text "bytes")))
211 -----------------------------------------------------------------------------
218 -- Have to turn off buffering again, because we just
219 -- reverted stdout, stderr & stdin to their defaults.
221 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
222 -- Make it "safe", just in case
224 -----------------------------------------------------------------------------
225 -- To flush buffers for the *interpreted* computation we need
226 -- to refer to *its* stdout/stderr handles
228 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
229 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
231 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
232 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
233 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush System.IO.stderr"
235 initInterpBuffering :: GHC.Session -> IO ()
236 initInterpBuffering session
237 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
240 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
241 other -> panic "interactiveUI:setBuffering"
243 maybe_hval <- GHC.compileExpr session flush_cmd
245 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
246 _ -> panic "interactiveUI:flush"
251 flushInterpBuffers :: GHCi ()
253 = io $ do Monad.join (readIORef flush_interp)
256 turnOffBuffering :: IO ()
258 = do Monad.join (readIORef turn_off_buffering)