1 -----------------------------------------------------------------------------
3 -- Monadery code used in InteractiveUI
5 -- (c) The GHC Team 2005-2006
7 -----------------------------------------------------------------------------
11 #include "HsVersions.h"
15 import Panic hiding (showException)
22 import Control.Exception as Exception
25 import Data.Int ( Int64 )
31 import Control.Monad as Monad
34 -----------------------------------------------------------------------------
37 data GHCiState = GHCiState
43 session :: GHC.Session,
44 options :: [GHCiOption],
45 prelude :: GHC.Module,
47 resume :: [IO GHC.RunResult],
48 breaks :: !ActiveBreakPoints
52 = ShowTiming -- show time/allocs after evaluation
53 | ShowType -- show the type of expressions
54 | RevertCAFs -- revert CAFs after every evaluation
57 data ActiveBreakPoints
59 { breakCounter :: !Int
60 , breakLocations :: ![(Int, BreakLocation)] -- break location uniquely numbered
63 instance Outputable ActiveBreakPoints where
64 ppr activeBrks = prettyLocations $ breakLocations activeBrks
66 emptyActiveBreakPoints :: ActiveBreakPoints
67 emptyActiveBreakPoints
68 = ActiveBreakPoints { breakCounter = 0, breakLocations = [] }
72 { breakModule :: !GHC.Module
73 , breakLoc :: !SrcSpan
74 , breakTick :: {-# UNPACK #-} !Int
78 prettyLocations :: [(Int, BreakLocation)] -> SDoc
79 prettyLocations [] = text "No active breakpoints."
80 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
82 instance Outputable BreakLocation where
83 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
85 getActiveBreakPoints :: GHCi ActiveBreakPoints
86 getActiveBreakPoints = liftM breaks getGHCiState
88 -- don't reset the counter back to zero?
89 clearActiveBreakPoints :: GHCi ()
90 clearActiveBreakPoints = do
92 let oldActiveBreaks = breaks st
93 newActiveBreaks = oldActiveBreaks { breakLocations = [] }
94 setGHCiState $ st { breaks = newActiveBreaks }
96 deleteBreak :: Int -> GHCi ()
97 deleteBreak identity = do
99 let oldActiveBreaks = breaks st
100 oldLocations = breakLocations oldActiveBreaks
101 newLocations = filter (\loc -> fst loc /= identity) oldLocations
102 newActiveBreaks = oldActiveBreaks { breakLocations = newLocations }
103 setGHCiState $ st { breaks = newActiveBreaks }
105 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
106 recordBreak brkLoc = do
108 let oldActiveBreaks = breaks st
109 let oldLocations = breakLocations oldActiveBreaks
110 -- don't store the same break point twice
111 case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
112 (nm:_) -> return (True, nm)
114 let oldCounter = breakCounter oldActiveBreaks
115 newCounter = oldCounter + 1
118 { breakCounter = newCounter
119 , breakLocations = (oldCounter, brkLoc) : oldLocations
121 setGHCiState $ st { breaks = newActiveBreaks }
122 return (False, oldCounter)
124 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
126 startGHCi :: GHCi a -> GHCiState -> IO a
127 startGHCi g state = do ref <- newIORef state; unGHCi g ref
129 instance Monad GHCi where
130 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
131 return a = GHCi $ \s -> return a
133 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
134 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
135 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
137 getGHCiState = GHCi $ \r -> readIORef r
138 setGHCiState s = GHCi $ \r -> writeIORef r s
140 -- for convenience...
141 getSession = getGHCiState >>= return . session
142 getPrelude = getGHCiState >>= return . prelude
144 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
145 no_saved_sess = error "no saved_ses"
146 saveSession = getSession >>= io . writeIORef saved_sess
147 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
148 restoreSession = readIORef saved_sess
152 io (GHC.getSessionDynFlags s)
153 setDynFlags dflags = do
155 io (GHC.setSessionDynFlags s dflags)
157 isOptionSet :: GHCiOption -> GHCi Bool
159 = do st <- getGHCiState
160 return (opt `elem` options st)
162 setOption :: GHCiOption -> GHCi ()
164 = do st <- getGHCiState
165 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
167 unsetOption :: GHCiOption -> GHCi ()
169 = do st <- getGHCiState
170 setGHCiState (st{ options = filter (/= opt) (options st) })
173 io m = GHCi { unGHCi = \s -> m >>= return }
175 isTopLevel :: GHCi Bool
176 isTopLevel = getGHCiState >>= return . topLevel
178 getResume :: GHCi (Maybe (IO GHC.RunResult))
183 (x:_) -> return $ Just x
190 (_:xs) -> setGHCiState $ st { resume = xs }
192 pushResume :: IO GHC.RunResult -> GHCi ()
193 pushResume resumeAction = do
195 let oldResume = resume st
196 setGHCiState $ st { resume = resumeAction : oldResume }
198 showForUser :: SDoc -> GHCi String
200 session <- getSession
201 unqual <- io (GHC.getPrintUnqual session)
202 return $! showSDocForUser unqual doc
204 -- --------------------------------------------------------------------------
205 -- timing & statistics
207 timeIt :: GHCi a -> GHCi a
209 = do b <- isOptionSet ShowTiming
212 else do allocs1 <- io $ getAllocations
213 time1 <- io $ getCPUTime
215 allocs2 <- io $ getAllocations
216 time2 <- io $ getCPUTime
217 io $ printTimes (fromIntegral (allocs2 - allocs1))
221 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
222 -- defined in ghc/rts/Stats.c
224 printTimes :: Integer -> Integer -> IO ()
225 printTimes allocs psecs
226 = do let secs = (fromIntegral psecs / (10^12)) :: Float
227 secs_str = showFFloat (Just 2) secs
229 parens (text (secs_str "") <+> text "secs" <> comma <+>
230 text (show allocs) <+> text "bytes")))
232 -----------------------------------------------------------------------------
239 -- Have to turn off buffering again, because we just
240 -- reverted stdout, stderr & stdin to their defaults.
242 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
243 -- Make it "safe", just in case
245 -----------------------------------------------------------------------------
246 -- To flush buffers for the *interpreted* computation we need
247 -- to refer to *its* stdout/stderr handles
249 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
250 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
252 command_sequence :: [String] -> String
253 command_sequence = unwords . intersperse "Prelude.>>"
255 no_buffer :: String -> String
256 no_buffer h = unwords ["System.IO.hSetBuffering",
258 "System.IO.NoBuffering"]
261 no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
263 flush_buffer :: String -> String
264 flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
267 flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
269 initInterpBuffering :: GHC.Session -> IO ()
270 initInterpBuffering session
271 = do -- we don't want to be fooled by any modules lying around in the current
272 -- directory when we compile these code fragments, so set the import
273 -- path to be empty while we compile them.
274 dflags <- GHC.getSessionDynFlags session
275 GHC.setSessionDynFlags session dflags{importPaths=[]}
277 maybe_hval <- GHC.compileExpr session no_buf_cmd
280 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
281 other -> panic "interactiveUI:setBuffering"
283 maybe_hval <- GHC.compileExpr session flush_cmd
285 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
286 _ -> panic "interactiveUI:flush"
288 GHC.setSessionDynFlags session dflags
289 GHC.workingDirectoryChanged session
293 flushInterpBuffers :: GHCi ()
295 = io $ do Monad.join (readIORef flush_interp)
298 turnOffBuffering :: IO ()
300 = do Monad.join (readIORef turn_off_buffering)