1 -----------------------------------------------------------------------------
3 -- Monadery code used in InteractiveUI
5 -- (c) The GHC Team 2005-2006
7 -----------------------------------------------------------------------------
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module GhciMonad where
18 #include "HsVersions.h"
21 import Outputable hiding (printForUser, printForUserPartWay)
22 import qualified Outputable
23 import Panic hiding (showException)
34 import Control.Exception as Exception
37 import Data.Int ( Int64 )
43 import Control.Monad as Monad
46 -----------------------------------------------------------------------------
49 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
51 data GHCiState = GHCiState
58 session :: GHC.Session,
59 options :: [GHCiOption],
60 prelude :: GHC.Module,
62 breaks :: ![(Int, BreakLocation)],
63 tickarrays :: ModuleEnv TickArray,
64 -- tickarrays caches the TickArray for loaded modules,
65 -- so that we don't rebuild it each time the user sets
67 -- ":" at the GHCi prompt repeats the last command, so we
69 last_command :: Maybe Command,
71 remembered_ctx :: Maybe ([Module],[Module])
72 -- modules we want to add to the context, but can't
73 -- because they currently have errors. Set by :reload.
76 type TickArray = Array Int [(BreakIndex,SrcSpan)]
79 = ShowTiming -- show time/allocs after evaluation
80 | ShowType -- show the type of expressions
81 | RevertCAFs -- revert CAFs after every evaluation
86 { breakModule :: !GHC.Module
87 , breakLoc :: !SrcSpan
88 , breakTick :: {-# UNPACK #-} !Int
89 , onBreakCmd :: String
92 instance Eq BreakLocation where
93 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
94 breakTick loc1 == breakTick loc2
96 prettyLocations :: [(Int, BreakLocation)] -> SDoc
97 prettyLocations [] = text "No active breakpoints."
98 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
100 instance Outputable BreakLocation where
101 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
102 if null (onBreakCmd loc)
104 else doubleQuotes (text (onBreakCmd loc))
106 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
107 recordBreak brkLoc = do
109 let oldActiveBreaks = breaks st
110 -- don't store the same break point twice
111 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
112 (nm:_) -> return (True, nm)
114 let oldCounter = break_ctr st
115 newCounter = oldCounter + 1
116 setGHCiState $ st { break_ctr = newCounter,
117 breaks = (oldCounter, brkLoc) : oldActiveBreaks
119 return (False, oldCounter)
121 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
123 startGHCi :: GHCi a -> GHCiState -> IO a
124 startGHCi g state = do ref <- newIORef state; unGHCi g ref
126 instance Monad GHCi where
127 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
128 return a = GHCi $ \s -> return a
130 instance Functor GHCi where
131 fmap f m = m >>= return . f
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 printForUser :: SDoc -> GHCi ()
176 printForUser doc = do
177 session <- getSession
178 unqual <- io (GHC.getPrintUnqual session)
179 io $ Outputable.printForUser stdout unqual doc
181 printForUserPartWay :: SDoc -> GHCi ()
182 printForUserPartWay doc = do
183 session <- getSession
184 unqual <- io (GHC.getPrintUnqual session)
185 io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
187 -- --------------------------------------------------------------------------
188 -- timing & statistics
190 timeIt :: GHCi a -> GHCi a
192 = do b <- isOptionSet ShowTiming
195 else do allocs1 <- io $ getAllocations
196 time1 <- io $ getCPUTime
198 allocs2 <- io $ getAllocations
199 time2 <- io $ getCPUTime
200 io $ printTimes (fromIntegral (allocs2 - allocs1))
204 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
205 -- defined in ghc/rts/Stats.c
207 printTimes :: Integer -> Integer -> IO ()
208 printTimes allocs psecs
209 = do let secs = (fromIntegral psecs / (10^12)) :: Float
210 secs_str = showFFloat (Just 2) secs
212 parens (text (secs_str "") <+> text "secs" <> comma <+>
213 text (show allocs) <+> text "bytes")))
215 -----------------------------------------------------------------------------
222 -- Have to turn off buffering again, because we just
223 -- reverted stdout, stderr & stdin to their defaults.
225 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
226 -- Make it "safe", just in case
228 -----------------------------------------------------------------------------
229 -- To flush buffers for the *interpreted* computation we need
230 -- to refer to *its* stdout/stderr handles
232 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
233 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
234 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
236 -- After various attempts, I believe this is the least bad way to do
237 -- what we want. We know look up the address of the static stdin,
238 -- stdout, and stderr closures in the loaded base package, and each
239 -- time we need to refer to them we cast the pointer to a Handle.
240 -- This avoids any problems with the CAF having been reverted, because
241 -- we'll always get the current value.
243 -- The previous attempt that didn't work was to compile an expression
244 -- like "hSetBuffering stdout NoBuffering" into an expression of type
245 -- IO () and run this expression each time we needed it, but the
246 -- problem is that evaluating the expression might cache the contents
247 -- of the Handle rather than referring to it from its static address
248 -- each time. There's no safe workaround for this.
250 initInterpBuffering :: GHC.Session -> IO ()
251 initInterpBuffering session
252 = do -- make sure these are linked
253 mb_hval1 <- GHC.compileExpr session "System.IO.stdout"
254 mb_hval2 <- GHC.compileExpr session "System.IO.stderr"
255 mb_hval3 <- GHC.compileExpr session "System.IO.stdin"
256 when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $
257 panic "interactiveUI:setBuffering"
259 -- ToDo: we should really look up these names properly, but
260 -- it's a fiddle and not all the bits are exposed via the GHC
262 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
263 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
264 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
266 let f ref (Just ptr) = writeIORef ref ptr
267 f ref Nothing = panic "interactiveUI:setBuffering2"
268 zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
269 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
272 flushInterpBuffers :: GHCi ()
274 = io $ do getHandle stdout_ptr >>= hFlush
275 getHandle stderr_ptr >>= hFlush
277 turnOffBuffering :: IO ()
279 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
280 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
282 getHandle :: IORef (Ptr ()) -> IO Handle
284 (Ptr addr) <- readIORef ref
285 case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)