1 -----------------------------------------------------------------------------
3 -- Monadery code used in InteractiveUI
5 -- (c) The GHC Team 2005-2006
7 -----------------------------------------------------------------------------
11 #include "HsVersions.h"
14 import Outputable hiding (printForUser)
15 import qualified Outputable
16 import Panic hiding (showException)
24 import Control.Concurrent
25 import Control.Exception as Exception
28 import Data.Int ( Int64 )
34 import Control.Monad as Monad
37 -----------------------------------------------------------------------------
40 data GHCiState = GHCiState
46 session :: GHC.Session,
47 options :: [GHCiOption],
48 prelude :: GHC.Module,
49 resume :: [(SrcSpan, ThreadId, GHC.ResumeHandle)],
50 breaks :: !ActiveBreakPoints,
51 tickarrays :: ModuleEnv TickArray
52 -- tickarrays caches the TickArray for loaded modules,
53 -- so that we don't rebuild it each time the user sets
57 type TickArray = Array Int [(BreakIndex,SrcSpan)]
60 = ShowTiming -- show time/allocs after evaluation
61 | ShowType -- show the type of expressions
62 | RevertCAFs -- revert CAFs after every evaluation
65 data ActiveBreakPoints
67 { breakCounter :: !Int
68 , breakLocations :: ![(Int, BreakLocation)] -- break location uniquely numbered
71 instance Outputable ActiveBreakPoints where
72 ppr activeBrks = prettyLocations $ breakLocations activeBrks
74 emptyActiveBreakPoints :: ActiveBreakPoints
75 emptyActiveBreakPoints
76 = ActiveBreakPoints { breakCounter = 0, breakLocations = [] }
80 { breakModule :: !GHC.Module
81 , breakLoc :: !SrcSpan
82 , breakTick :: {-# UNPACK #-} !Int
86 prettyLocations :: [(Int, BreakLocation)] -> SDoc
87 prettyLocations [] = text "No active breakpoints."
88 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
90 instance Outputable BreakLocation where
91 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
93 getActiveBreakPoints :: GHCi ActiveBreakPoints
94 getActiveBreakPoints = liftM breaks getGHCiState
96 -- don't reset the counter back to zero?
97 discardActiveBreakPoints :: GHCi ()
98 discardActiveBreakPoints = do
100 let oldActiveBreaks = breaks st
101 newActiveBreaks = oldActiveBreaks { breakLocations = [] }
102 setGHCiState $ st { breaks = newActiveBreaks }
104 deleteBreak :: Int -> GHCi ()
105 deleteBreak identity = do
107 let oldActiveBreaks = breaks st
108 oldLocations = breakLocations oldActiveBreaks
109 newLocations = filter (\loc -> fst loc /= identity) oldLocations
110 newActiveBreaks = oldActiveBreaks { breakLocations = newLocations }
111 setGHCiState $ st { breaks = newActiveBreaks }
113 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
114 recordBreak brkLoc = do
116 let oldActiveBreaks = breaks st
117 let oldLocations = breakLocations oldActiveBreaks
118 -- don't store the same break point twice
119 case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
120 (nm:_) -> return (True, nm)
122 let oldCounter = breakCounter oldActiveBreaks
123 newCounter = oldCounter + 1
126 { breakCounter = newCounter
127 , breakLocations = (oldCounter, brkLoc) : oldLocations
129 setGHCiState $ st { breaks = newActiveBreaks }
130 return (False, oldCounter)
132 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
134 startGHCi :: GHCi a -> GHCiState -> IO a
135 startGHCi g state = do ref <- newIORef state; unGHCi g ref
137 instance Monad GHCi where
138 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
139 return a = GHCi $ \s -> return a
141 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
142 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
143 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
145 getGHCiState = GHCi $ \r -> readIORef r
146 setGHCiState s = GHCi $ \r -> writeIORef r s
148 -- for convenience...
149 getSession = getGHCiState >>= return . session
150 getPrelude = getGHCiState >>= return . prelude
152 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
153 no_saved_sess = error "no saved_ses"
154 saveSession = getSession >>= io . writeIORef saved_sess
155 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
156 restoreSession = readIORef saved_sess
160 io (GHC.getSessionDynFlags s)
161 setDynFlags dflags = do
163 io (GHC.setSessionDynFlags s dflags)
165 isOptionSet :: GHCiOption -> GHCi Bool
167 = do st <- getGHCiState
168 return (opt `elem` options st)
170 setOption :: GHCiOption -> GHCi ()
172 = do st <- getGHCiState
173 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
175 unsetOption :: GHCiOption -> GHCi ()
177 = do st <- getGHCiState
178 setGHCiState (st{ options = filter (/= opt) (options st) })
181 io m = GHCi { unGHCi = \s -> m >>= return }
183 popResume :: GHCi (Maybe (SrcSpan, ThreadId, GHC.ResumeHandle))
188 (x:xs) -> do setGHCiState $ st { resume = xs } ; return (Just x)
190 pushResume :: SrcSpan -> ThreadId -> GHC.ResumeHandle -> GHCi ()
191 pushResume span threadId resumeAction = do
193 let oldResume = resume st
194 setGHCiState $ st { resume = (span, threadId, resumeAction) : oldResume }
196 discardResumeContext :: GHCi ()
197 discardResumeContext = do
199 setGHCiState st { resume = [] }
201 printForUser :: SDoc -> GHCi ()
202 printForUser doc = do
203 session <- getSession
204 unqual <- io (GHC.getPrintUnqual session)
205 io $ Outputable.printForUser stdout unqual doc
207 -- --------------------------------------------------------------------------
208 -- timing & statistics
210 timeIt :: GHCi a -> GHCi a
212 = do b <- isOptionSet ShowTiming
215 else do allocs1 <- io $ getAllocations
216 time1 <- io $ getCPUTime
218 allocs2 <- io $ getAllocations
219 time2 <- io $ getCPUTime
220 io $ printTimes (fromIntegral (allocs2 - allocs1))
224 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
225 -- defined in ghc/rts/Stats.c
227 printTimes :: Integer -> Integer -> IO ()
228 printTimes allocs psecs
229 = do let secs = (fromIntegral psecs / (10^12)) :: Float
230 secs_str = showFFloat (Just 2) secs
232 parens (text (secs_str "") <+> text "secs" <> comma <+>
233 text (show allocs) <+> text "bytes")))
235 -----------------------------------------------------------------------------
242 -- Have to turn off buffering again, because we just
243 -- reverted stdout, stderr & stdin to their defaults.
245 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
246 -- Make it "safe", just in case
248 -----------------------------------------------------------------------------
249 -- To flush buffers for the *interpreted* computation we need
250 -- to refer to *its* stdout/stderr handles
252 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
253 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
255 command_sequence :: [String] -> String
256 command_sequence = unwords . intersperse "Prelude.>>"
258 no_buffer :: String -> String
259 no_buffer h = unwords ["System.IO.hSetBuffering",
261 "System.IO.NoBuffering"]
264 no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
266 flush_buffer :: String -> String
267 flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
270 flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
272 initInterpBuffering :: GHC.Session -> IO ()
273 initInterpBuffering session
274 = do -- we don't want to be fooled by any modules lying around in the current
275 -- directory when we compile these code fragments, so set the import
276 -- path to be empty while we compile them.
277 dflags <- GHC.getSessionDynFlags session
278 GHC.setSessionDynFlags session dflags{importPaths=[]}
280 maybe_hval <- GHC.compileExpr session no_buf_cmd
283 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
284 other -> panic "interactiveUI:setBuffering"
286 maybe_hval <- GHC.compileExpr session flush_cmd
288 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
289 _ -> panic "interactiveUI:flush"
291 GHC.setSessionDynFlags session dflags
292 GHC.workingDirectoryChanged session
296 flushInterpBuffers :: GHCi ()
298 = io $ do Monad.join (readIORef flush_interp)
301 turnOffBuffering :: IO ()
303 = do Monad.join (readIORef turn_off_buffering)