1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 -----------------------------------------------------------------------------
6 -- Monadery code used in InteractiveUI
8 -- (c) The GHC Team 2005-2006
10 -----------------------------------------------------------------------------
12 module GhciMonad where
14 #include "HsVersions.h"
17 import Outputable hiding (printForUser, printForUserPartWay)
18 import qualified Outputable
19 import Panic hiding (showException)
33 import Data.Int ( Int64 )
37 import System.Directory
38 import System.Environment
40 import Control.Monad as Monad
43 -----------------------------------------------------------------------------
46 type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String])
48 data GHCiState = GHCiState
55 session :: GHC.Session,
56 options :: [GHCiOption],
57 prelude :: GHC.Module,
59 breaks :: ![(Int, BreakLocation)],
60 tickarrays :: ModuleEnv TickArray,
61 -- tickarrays caches the TickArray for loaded modules,
62 -- so that we don't rebuild it each time the user sets
64 -- ":" at the GHCi prompt repeats the last command, so we
66 last_command :: Maybe Command,
68 remembered_ctx :: [(CtxtCmd, [String], [String])],
69 -- we remember the :module commands between :loads, so that
70 -- on a :reload we can replay them. See bugs #2049,
71 -- \#1873, #1360. Previously we tried to remember modules that
72 -- were supposed to be in the context but currently had errors,
73 -- but this was complicated. Just replaying the :module commands
74 -- seems to be the right thing.
75 virtual_path :: FilePath,
76 ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
84 type TickArray = Array Int [(BreakIndex,SrcSpan)]
87 = ShowTiming -- show time/allocs after evaluation
88 | ShowType -- show the type of expressions
89 | RevertCAFs -- revert CAFs after every evaluation
94 { breakModule :: !GHC.Module
95 , breakLoc :: !SrcSpan
96 , breakTick :: {-# UNPACK #-} !Int
97 , onBreakCmd :: String
100 instance Eq BreakLocation where
101 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
102 breakTick loc1 == breakTick loc2
104 prettyLocations :: [(Int, BreakLocation)] -> SDoc
105 prettyLocations [] = text "No active breakpoints."
106 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
108 instance Outputable BreakLocation where
109 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
110 if null (onBreakCmd loc)
112 else doubleQuotes (text (onBreakCmd loc))
114 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
115 recordBreak brkLoc = do
117 let oldActiveBreaks = breaks st
118 -- don't store the same break point twice
119 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
120 (nm:_) -> return (True, nm)
122 let oldCounter = break_ctr st
123 newCounter = oldCounter + 1
124 setGHCiState $ st { break_ctr = newCounter,
125 breaks = (oldCounter, brkLoc) : oldActiveBreaks
127 return (False, oldCounter)
129 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
131 startGHCi :: GHCi a -> GHCiState -> IO a
132 startGHCi g state = do ref <- newIORef state; unGHCi g ref
134 instance Monad GHCi where
135 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
136 return a = GHCi $ \_ -> return a
138 instance Functor GHCi where
139 fmap f m = m >>= return . f
141 ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
142 ghciHandleGhcException h (GHCi m) = GHCi $ \s ->
143 handleGhcException (\e -> unGHCi (h e) s) (m s)
145 getGHCiState :: GHCi GHCiState
146 getGHCiState = GHCi $ \r -> readIORef r
147 setGHCiState :: GHCiState -> GHCi ()
148 setGHCiState s = GHCi $ \r -> writeIORef r s
150 -- for convenience...
151 getSession :: GHCi Session
152 getSession = getGHCiState >>= return . session
153 getPrelude :: GHCi Module
154 getPrelude = getGHCiState >>= return . prelude
156 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
158 no_saved_sess :: Session
159 no_saved_sess = error "no saved_ses"
161 saveSession :: GHCi ()
162 saveSession = getSession >>= io . writeIORef saved_sess
164 splatSavedSession :: GHCi ()
165 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
167 restoreSession :: IO Session
168 restoreSession = readIORef saved_sess
170 getDynFlags :: GHCi DynFlags
173 io (GHC.getSessionDynFlags s)
174 setDynFlags :: DynFlags -> GHCi [PackageId]
175 setDynFlags dflags = do
177 io (GHC.setSessionDynFlags s dflags)
179 isOptionSet :: GHCiOption -> GHCi Bool
181 = do st <- getGHCiState
182 return (opt `elem` options st)
184 setOption :: GHCiOption -> GHCi ()
186 = do st <- getGHCiState
187 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
189 unsetOption :: GHCiOption -> GHCi ()
191 = do st <- getGHCiState
192 setGHCiState (st{ options = filter (/= opt) (options st) })
195 io m = GHCi (\_ -> m)
197 printForUser :: SDoc -> GHCi ()
198 printForUser doc = do
199 session <- getSession
200 unqual <- io (GHC.getPrintUnqual session)
201 io $ Outputable.printForUser stdout unqual doc
203 printForUserPartWay :: SDoc -> GHCi ()
204 printForUserPartWay doc = do
205 session <- getSession
206 unqual <- io (GHC.getPrintUnqual session)
207 io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
209 withVirtualPath :: GHCi a -> GHCi a
210 withVirtualPath m = do
211 ghci_wd <- io getCurrentDirectory -- Store the cwd of GHCi
213 io$ setCurrentDirectory (virtual_path st)
214 result <- m -- Evaluate in the virtual wd..
215 vwd <- io getCurrentDirectory
216 setGHCiState (st{ virtual_path = vwd}) -- Update the virtual path
217 io$ setCurrentDirectory ghci_wd -- ..and restore GHCi wd
220 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
221 runStmt expr step = withVirtualPath$ do
222 session <- getSession
224 io$ withProgName (progname st) $ withArgs (args st) $
225 GHC.runStmt session expr step
227 resume :: GHC.SingleStep -> GHCi GHC.RunResult
228 resume step = withVirtualPath$ do
229 session <- getSession
230 io$ GHC.resume session step
233 -- --------------------------------------------------------------------------
234 -- timing & statistics
236 timeIt :: GHCi a -> GHCi a
238 = do b <- isOptionSet ShowTiming
241 else do allocs1 <- io $ getAllocations
242 time1 <- io $ getCPUTime
244 allocs2 <- io $ getAllocations
245 time2 <- io $ getCPUTime
246 io $ printTimes (fromIntegral (allocs2 - allocs1))
250 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
251 -- defined in ghc/rts/Stats.c
253 printTimes :: Integer -> Integer -> IO ()
254 printTimes allocs psecs
255 = do let secs = (fromIntegral psecs / (10^12)) :: Float
256 secs_str = showFFloat (Just 2) secs
258 parens (text (secs_str "") <+> text "secs" <> comma <+>
259 text (show allocs) <+> text "bytes")))
261 -----------------------------------------------------------------------------
264 revertCAFs :: GHCi ()
268 when (not (ghc_e s)) $ io turnOffBuffering
269 -- Have to turn off buffering again, because we just
270 -- reverted stdout, stderr & stdin to their defaults.
272 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
273 -- Make it "safe", just in case
275 -----------------------------------------------------------------------------
276 -- To flush buffers for the *interpreted* computation we need
277 -- to refer to *its* stdout/stderr handles
279 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
280 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
281 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
283 -- After various attempts, I believe this is the least bad way to do
284 -- what we want. We know look up the address of the static stdin,
285 -- stdout, and stderr closures in the loaded base package, and each
286 -- time we need to refer to them we cast the pointer to a Handle.
287 -- This avoids any problems with the CAF having been reverted, because
288 -- we'll always get the current value.
290 -- The previous attempt that didn't work was to compile an expression
291 -- like "hSetBuffering stdout NoBuffering" into an expression of type
292 -- IO () and run this expression each time we needed it, but the
293 -- problem is that evaluating the expression might cache the contents
294 -- of the Handle rather than referring to it from its static address
295 -- each time. There's no safe workaround for this.
297 initInterpBuffering :: GHC.Session -> IO ()
298 initInterpBuffering session
299 = do -- make sure these are linked
300 dflags <- GHC.getSessionDynFlags session
303 -- ToDo: we should really look up these names properly, but
304 -- it's a fiddle and not all the bits are exposed via the GHC
306 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
307 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
308 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
310 let f ref (Just ptr) = writeIORef ref ptr
311 f _ Nothing = panic "interactiveUI:setBuffering2"
312 zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
313 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
316 flushInterpBuffers :: GHCi ()
318 = io $ do getHandle stdout_ptr >>= hFlush
319 getHandle stderr_ptr >>= hFlush
321 turnOffBuffering :: IO ()
323 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
324 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
326 getHandle :: IORef (Ptr ()) -> IO Handle
328 (Ptr addr) <- readIORef ref
329 case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)