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.Exception as Exception
27 import Data.Int ( Int64 )
33 import Control.Monad as Monad
36 -----------------------------------------------------------------------------
39 data GHCiState = GHCiState
46 session :: GHC.Session,
47 options :: [GHCiOption],
48 prelude :: GHC.Module,
50 breaks :: ![(Int, BreakLocation)],
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
67 { breakModule :: !GHC.Module
68 , breakLoc :: !SrcSpan
69 , breakTick :: {-# UNPACK #-} !Int
73 prettyLocations :: [(Int, BreakLocation)] -> SDoc
74 prettyLocations [] = text "No active breakpoints."
75 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
77 instance Outputable BreakLocation where
78 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
80 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
81 recordBreak brkLoc = do
83 let oldActiveBreaks = breaks st
84 -- don't store the same break point twice
85 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
86 (nm:_) -> return (True, nm)
88 let oldCounter = break_ctr st
89 newCounter = oldCounter + 1
90 setGHCiState $ st { break_ctr = newCounter,
91 breaks = (oldCounter, brkLoc) : oldActiveBreaks
93 return (False, oldCounter)
95 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
97 startGHCi :: GHCi a -> GHCiState -> IO a
98 startGHCi g state = do ref <- newIORef state; unGHCi g ref
100 instance Monad GHCi where
101 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
102 return a = GHCi $ \s -> return a
104 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
105 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
106 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
108 getGHCiState = GHCi $ \r -> readIORef r
109 setGHCiState s = GHCi $ \r -> writeIORef r s
111 -- for convenience...
112 getSession = getGHCiState >>= return . session
113 getPrelude = getGHCiState >>= return . prelude
115 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
116 no_saved_sess = error "no saved_ses"
117 saveSession = getSession >>= io . writeIORef saved_sess
118 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
119 restoreSession = readIORef saved_sess
123 io (GHC.getSessionDynFlags s)
124 setDynFlags dflags = do
126 io (GHC.setSessionDynFlags s dflags)
128 isOptionSet :: GHCiOption -> GHCi Bool
130 = do st <- getGHCiState
131 return (opt `elem` options st)
133 setOption :: GHCiOption -> GHCi ()
135 = do st <- getGHCiState
136 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
138 unsetOption :: GHCiOption -> GHCi ()
140 = do st <- getGHCiState
141 setGHCiState (st{ options = filter (/= opt) (options st) })
144 io m = GHCi { unGHCi = \s -> m >>= return }
146 printForUser :: SDoc -> GHCi ()
147 printForUser doc = do
148 session <- getSession
149 unqual <- io (GHC.getPrintUnqual session)
150 io $ Outputable.printForUser stdout unqual doc
152 -- --------------------------------------------------------------------------
153 -- timing & statistics
155 timeIt :: GHCi a -> GHCi a
157 = do b <- isOptionSet ShowTiming
160 else do allocs1 <- io $ getAllocations
161 time1 <- io $ getCPUTime
163 allocs2 <- io $ getAllocations
164 time2 <- io $ getCPUTime
165 io $ printTimes (fromIntegral (allocs2 - allocs1))
169 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
170 -- defined in ghc/rts/Stats.c
172 printTimes :: Integer -> Integer -> IO ()
173 printTimes allocs psecs
174 = do let secs = (fromIntegral psecs / (10^12)) :: Float
175 secs_str = showFFloat (Just 2) secs
177 parens (text (secs_str "") <+> text "secs" <> comma <+>
178 text (show allocs) <+> text "bytes")))
180 -----------------------------------------------------------------------------
187 -- Have to turn off buffering again, because we just
188 -- reverted stdout, stderr & stdin to their defaults.
190 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
191 -- Make it "safe", just in case
193 -----------------------------------------------------------------------------
194 -- To flush buffers for the *interpreted* computation we need
195 -- to refer to *its* stdout/stderr handles
197 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
198 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
200 command_sequence :: [String] -> String
201 command_sequence = unwords . intersperse "Prelude.>>"
203 no_buffer :: String -> String
204 no_buffer h = unwords ["System.IO.hSetBuffering",
206 "System.IO.NoBuffering"]
209 no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
211 flush_buffer :: String -> String
212 flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
215 flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
217 initInterpBuffering :: GHC.Session -> IO ()
218 initInterpBuffering session
219 = do -- we don't want to be fooled by any modules lying around in the current
220 -- directory when we compile these code fragments, so set the import
221 -- path to be empty while we compile them.
222 dflags <- GHC.getSessionDynFlags session
223 GHC.setSessionDynFlags session dflags{importPaths=[]}
225 maybe_hval <- GHC.compileExpr session no_buf_cmd
228 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
229 other -> panic "interactiveUI:setBuffering"
231 maybe_hval <- GHC.compileExpr session flush_cmd
233 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
234 _ -> panic "interactiveUI:flush"
236 GHC.setSessionDynFlags session dflags
237 GHC.workingDirectoryChanged session
241 flushInterpBuffers :: GHCi ()
243 = io $ do Monad.join (readIORef flush_interp)
246 turnOffBuffering :: IO ()
248 = do Monad.join (readIORef turn_off_buffering)