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 -- Inferior Sessions Exceptions (used by the debugger)
124 data InfSessionException =
125 StopChildSession -- A child session requests to be stopped
126 | ChildSessionStopped String -- A child session has stopped
130 -- --------------------------------------------------------------------------
131 -- timing & statistics
133 timeIt :: GHCi a -> GHCi a
135 = do b <- isOptionSet ShowTiming
138 else do allocs1 <- io $ getAllocations
139 time1 <- io $ getCPUTime
141 allocs2 <- io $ getAllocations
142 time2 <- io $ getCPUTime
143 io $ printTimes (fromIntegral (allocs2 - allocs1))
147 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
148 -- defined in ghc/rts/Stats.c
150 printTimes :: Integer -> Integer -> IO ()
151 printTimes allocs psecs
152 = do let secs = (fromIntegral psecs / (10^12)) :: Float
153 secs_str = showFFloat (Just 2) secs
155 parens (text (secs_str "") <+> text "secs" <> comma <+>
156 text (show allocs) <+> text "bytes")))
158 -----------------------------------------------------------------------------
165 -- Have to turn off buffering again, because we just
166 -- reverted stdout, stderr & stdin to their defaults.
168 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
169 -- Make it "safe", just in case
171 -----------------------------------------------------------------------------
172 -- To flush buffers for the *interpreted* computation we need
173 -- to refer to *its* stdout/stderr handles
175 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
176 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
178 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
179 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
180 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush System.IO.stderr"
182 initInterpBuffering :: GHC.Session -> IO ()
183 initInterpBuffering session
184 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
187 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
188 other -> panic "interactiveUI:setBuffering"
190 maybe_hval <- GHC.compileExpr session flush_cmd
192 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
193 _ -> panic "interactiveUI:flush"
198 flushInterpBuffers :: GHCi ()
200 = io $ do Monad.join (readIORef flush_interp)
203 turnOffBuffering :: IO ()
205 = do Monad.join (readIORef turn_off_buffering)