1 -----------------------------------------------------------------------------
3 -- Monadery code used in InteractiveUI
5 -- (c) The GHC Team 2005-2006
7 -----------------------------------------------------------------------------
11 #include "HsVersions.h"
15 import Panic hiding (showException)
23 import Control.Concurrent
24 import Control.Exception as Exception
27 import Data.Int ( Int64 )
33 import Control.Monad as Monad
36 -----------------------------------------------------------------------------
39 data GHCiState = GHCiState
45 session :: GHC.Session,
46 options :: [GHCiOption],
47 prelude :: GHC.Module,
48 resume :: [(SrcSpan, ThreadId, GHC.ResumeHandle)],
49 breaks :: !ActiveBreakPoints,
50 tickarrays :: ModuleEnv TickArray
51 -- tickarrays caches the TickArray for loaded modules,
52 -- so that we don't rebuild it each time the user sets
56 type TickArray = Array Int [(BreakIndex,SrcSpan)]
59 = ShowTiming -- show time/allocs after evaluation
60 | ShowType -- show the type of expressions
61 | RevertCAFs -- revert CAFs after every evaluation
64 data ActiveBreakPoints
66 { breakCounter :: !Int
67 , breakLocations :: ![(Int, BreakLocation)] -- break location uniquely numbered
70 instance Outputable ActiveBreakPoints where
71 ppr activeBrks = prettyLocations $ breakLocations activeBrks
73 emptyActiveBreakPoints :: ActiveBreakPoints
74 emptyActiveBreakPoints
75 = ActiveBreakPoints { breakCounter = 0, breakLocations = [] }
79 { breakModule :: !GHC.Module
80 , breakLoc :: !SrcSpan
81 , breakTick :: {-# UNPACK #-} !Int
85 prettyLocations :: [(Int, BreakLocation)] -> SDoc
86 prettyLocations [] = text "No active breakpoints."
87 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
89 instance Outputable BreakLocation where
90 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
92 getActiveBreakPoints :: GHCi ActiveBreakPoints
93 getActiveBreakPoints = liftM breaks getGHCiState
95 -- don't reset the counter back to zero?
96 discardActiveBreakPoints :: GHCi ()
97 discardActiveBreakPoints = do
99 let oldActiveBreaks = breaks st
100 newActiveBreaks = oldActiveBreaks { breakLocations = [] }
101 setGHCiState $ st { breaks = newActiveBreaks }
103 deleteBreak :: Int -> GHCi ()
104 deleteBreak identity = do
106 let oldActiveBreaks = breaks st
107 oldLocations = breakLocations oldActiveBreaks
108 newLocations = filter (\loc -> fst loc /= identity) oldLocations
109 newActiveBreaks = oldActiveBreaks { breakLocations = newLocations }
110 setGHCiState $ st { breaks = newActiveBreaks }
112 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
113 recordBreak brkLoc = do
115 let oldActiveBreaks = breaks st
116 let oldLocations = breakLocations oldActiveBreaks
117 -- don't store the same break point twice
118 case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
119 (nm:_) -> return (True, nm)
121 let oldCounter = breakCounter oldActiveBreaks
122 newCounter = oldCounter + 1
125 { breakCounter = newCounter
126 , breakLocations = (oldCounter, brkLoc) : oldLocations
128 setGHCiState $ st { breaks = newActiveBreaks }
129 return (False, oldCounter)
131 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
133 startGHCi :: GHCi a -> GHCiState -> IO a
134 startGHCi g state = do ref <- newIORef state; unGHCi g ref
136 instance Monad GHCi where
137 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
138 return a = GHCi $ \s -> return a
140 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
141 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
142 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
144 getGHCiState = GHCi $ \r -> readIORef r
145 setGHCiState s = GHCi $ \r -> writeIORef r s
147 -- for convenience...
148 getSession = getGHCiState >>= return . session
149 getPrelude = getGHCiState >>= return . prelude
151 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
152 no_saved_sess = error "no saved_ses"
153 saveSession = getSession >>= io . writeIORef saved_sess
154 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
155 restoreSession = readIORef saved_sess
159 io (GHC.getSessionDynFlags s)
160 setDynFlags dflags = do
162 io (GHC.setSessionDynFlags s dflags)
164 isOptionSet :: GHCiOption -> GHCi Bool
166 = do st <- getGHCiState
167 return (opt `elem` options st)
169 setOption :: GHCiOption -> GHCi ()
171 = do st <- getGHCiState
172 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
174 unsetOption :: GHCiOption -> GHCi ()
176 = do st <- getGHCiState
177 setGHCiState (st{ options = filter (/= opt) (options st) })
180 io m = GHCi { unGHCi = \s -> m >>= return }
182 popResume :: GHCi (Maybe (SrcSpan, ThreadId, GHC.ResumeHandle))
187 (x:xs) -> do setGHCiState $ st { resume = xs } ; return (Just x)
189 pushResume :: SrcSpan -> ThreadId -> GHC.ResumeHandle -> GHCi ()
190 pushResume span threadId resumeAction = do
192 let oldResume = resume st
193 setGHCiState $ st { resume = (span, threadId, resumeAction) : oldResume }
195 discardResumeContext :: GHCi ()
196 discardResumeContext = do
198 setGHCiState st { resume = [] }
200 showForUser :: SDoc -> GHCi String
202 session <- getSession
203 unqual <- io (GHC.getPrintUnqual session)
204 return $! showSDocForUser unqual doc
206 -- --------------------------------------------------------------------------
207 -- timing & statistics
209 timeIt :: GHCi a -> GHCi a
211 = do b <- isOptionSet ShowTiming
214 else do allocs1 <- io $ getAllocations
215 time1 <- io $ getCPUTime
217 allocs2 <- io $ getAllocations
218 time2 <- io $ getCPUTime
219 io $ printTimes (fromIntegral (allocs2 - allocs1))
223 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
224 -- defined in ghc/rts/Stats.c
226 printTimes :: Integer -> Integer -> IO ()
227 printTimes allocs psecs
228 = do let secs = (fromIntegral psecs / (10^12)) :: Float
229 secs_str = showFFloat (Just 2) secs
231 parens (text (secs_str "") <+> text "secs" <> comma <+>
232 text (show allocs) <+> text "bytes")))
234 -----------------------------------------------------------------------------
241 -- Have to turn off buffering again, because we just
242 -- reverted stdout, stderr & stdin to their defaults.
244 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
245 -- Make it "safe", just in case
247 -----------------------------------------------------------------------------
248 -- To flush buffers for the *interpreted* computation we need
249 -- to refer to *its* stdout/stderr handles
251 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
252 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
254 command_sequence :: [String] -> String
255 command_sequence = unwords . intersperse "Prelude.>>"
257 no_buffer :: String -> String
258 no_buffer h = unwords ["System.IO.hSetBuffering",
260 "System.IO.NoBuffering"]
263 no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
265 flush_buffer :: String -> String
266 flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
269 flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
271 initInterpBuffering :: GHC.Session -> IO ()
272 initInterpBuffering session
273 = do -- we don't want to be fooled by any modules lying around in the current
274 -- directory when we compile these code fragments, so set the import
275 -- path to be empty while we compile them.
276 dflags <- GHC.getSessionDynFlags session
277 GHC.setSessionDynFlags session dflags{importPaths=[]}
279 maybe_hval <- GHC.compileExpr session no_buf_cmd
282 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
283 other -> panic "interactiveUI:setBuffering"
285 maybe_hval <- GHC.compileExpr session flush_cmd
287 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
288 _ -> panic "interactiveUI:flush"
290 GHC.setSessionDynFlags session dflags
291 GHC.workingDirectoryChanged session
295 flushInterpBuffers :: GHCi ()
297 = io $ do Monad.join (readIORef flush_interp)
300 turnOffBuffering :: IO ()
302 = do Monad.join (readIORef turn_off_buffering)