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)
26 import Control.Exception as Exception
29 import Data.Int ( Int64 )
35 import Control.Monad as Monad
38 -----------------------------------------------------------------------------
41 data GHCiState = GHCiState
48 session :: GHC.Session,
49 options :: [GHCiOption],
50 prelude :: GHC.Module,
52 breaks :: ![(Int, BreakLocation)],
53 tickarrays :: ModuleEnv TickArray
54 -- tickarrays caches the TickArray for loaded modules,
55 -- so that we don't rebuild it each time the user sets
59 type TickArray = Array Int [(BreakIndex,SrcSpan)]
62 = ShowTiming -- show time/allocs after evaluation
63 | ShowType -- show the type of expressions
64 | RevertCAFs -- revert CAFs after every evaluation
69 { breakModule :: !GHC.Module
70 , breakLoc :: !SrcSpan
71 , breakTick :: {-# UNPACK #-} !Int
75 prettyLocations :: [(Int, BreakLocation)] -> SDoc
76 prettyLocations [] = text "No active breakpoints."
77 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
79 instance Outputable BreakLocation where
80 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
82 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
83 recordBreak brkLoc = do
85 let oldActiveBreaks = breaks st
86 -- don't store the same break point twice
87 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
88 (nm:_) -> return (True, nm)
90 let oldCounter = break_ctr st
91 newCounter = oldCounter + 1
92 setGHCiState $ st { break_ctr = newCounter,
93 breaks = (oldCounter, brkLoc) : oldActiveBreaks
95 return (False, oldCounter)
97 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
99 startGHCi :: GHCi a -> GHCiState -> IO a
100 startGHCi g state = do ref <- newIORef state; unGHCi g ref
102 instance Monad GHCi where
103 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
104 return a = GHCi $ \s -> return a
106 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
107 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
108 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
110 getGHCiState = GHCi $ \r -> readIORef r
111 setGHCiState s = GHCi $ \r -> writeIORef r s
113 -- for convenience...
114 getSession = getGHCiState >>= return . session
115 getPrelude = getGHCiState >>= return . prelude
117 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
118 no_saved_sess = error "no saved_ses"
119 saveSession = getSession >>= io . writeIORef saved_sess
120 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
121 restoreSession = readIORef saved_sess
125 io (GHC.getSessionDynFlags s)
126 setDynFlags dflags = do
128 io (GHC.setSessionDynFlags s dflags)
130 isOptionSet :: GHCiOption -> GHCi Bool
132 = do st <- getGHCiState
133 return (opt `elem` options st)
135 setOption :: GHCiOption -> GHCi ()
137 = do st <- getGHCiState
138 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
140 unsetOption :: GHCiOption -> GHCi ()
142 = do st <- getGHCiState
143 setGHCiState (st{ options = filter (/= opt) (options st) })
146 io m = GHCi { unGHCi = \s -> m >>= return }
148 printForUser :: SDoc -> GHCi ()
149 printForUser doc = do
150 session <- getSession
151 unqual <- io (GHC.getPrintUnqual session)
152 io $ Outputable.printForUser stdout unqual doc
154 -- --------------------------------------------------------------------------
155 -- timing & statistics
157 timeIt :: GHCi a -> GHCi a
159 = do b <- isOptionSet ShowTiming
162 else do allocs1 <- io $ getAllocations
163 time1 <- io $ getCPUTime
165 allocs2 <- io $ getAllocations
166 time2 <- io $ getCPUTime
167 io $ printTimes (fromIntegral (allocs2 - allocs1))
171 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
172 -- defined in ghc/rts/Stats.c
174 printTimes :: Integer -> Integer -> IO ()
175 printTimes allocs psecs
176 = do let secs = (fromIntegral psecs / (10^12)) :: Float
177 secs_str = showFFloat (Just 2) secs
179 parens (text (secs_str "") <+> text "secs" <> comma <+>
180 text (show allocs) <+> text "bytes")))
182 -----------------------------------------------------------------------------
189 -- Have to turn off buffering again, because we just
190 -- reverted stdout, stderr & stdin to their defaults.
192 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
193 -- Make it "safe", just in case
195 -----------------------------------------------------------------------------
196 -- To flush buffers for the *interpreted* computation we need
197 -- to refer to *its* stdout/stderr handles
199 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
200 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
201 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
203 -- After various attempts, I believe this is the least bad way to do
204 -- what we want. We know look up the address of the static stdin,
205 -- stdout, and stderr closures in the loaded base package, and each
206 -- time we need to refer to them we cast the pointer to a Handle.
207 -- This avoids any problems with the CAF having been reverted, because
208 -- we'll always get the current value.
210 -- The previous attempt that didn't work was to compile an expression
211 -- like "hSetBuffering stdout NoBuffering" into an expression of type
212 -- IO () and run this expression each time we needed it, but the
213 -- problem is that evaluating the expression might cache the contents
214 -- of the Handle rather than referring to it from its static address
215 -- each time. There's no safe workaround for this.
217 initInterpBuffering :: GHC.Session -> IO ()
218 initInterpBuffering session
219 = do -- make sure these are linked
220 mb_hval1 <- GHC.compileExpr session "System.IO.stdout"
221 mb_hval2 <- GHC.compileExpr session "System.IO.stderr"
222 mb_hval3 <- GHC.compileExpr session "System.IO.stdin"
223 when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $
224 panic "interactiveUI:setBuffering"
226 -- ToDo: we should really look up these names properly, but
227 -- it's a fiddle and not all the bits are exposed via the GHC
229 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
230 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
231 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
233 let f ref (Just ptr) = writeIORef ref ptr
234 f ref Nothing = panic "interactiveUI:setBuffering2"
235 zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
236 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
239 flushInterpBuffers :: GHCi ()
241 = io $ do getHandle stdout_ptr >>= hFlush
242 getHandle stderr_ptr >>= hFlush
244 turnOffBuffering :: IO ()
246 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
247 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
249 getHandle :: IORef (Ptr ()) -> IO Handle
251 (Ptr addr) <- readIORef ref
252 case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)