1 -----------------------------------------------------------------------------
3 -- Monadery code used in InteractiveUI
5 -- (c) The GHC Team 2005-2006
7 -----------------------------------------------------------------------------
11 #include "HsVersions.h"
14 import Outputable hiding (printForUser, printForUserPartWay)
15 import qualified Outputable
16 import Panic hiding (showException)
27 import Control.Exception as Exception
30 import Data.Int ( Int64 )
35 import System.Directory
36 import System.Environment
38 import Control.Monad as Monad
41 -----------------------------------------------------------------------------
44 type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String])
46 data GHCiState = GHCiState
53 session :: GHC.Session,
54 options :: [GHCiOption],
55 prelude :: GHC.Module,
57 breaks :: ![(Int, BreakLocation)],
58 tickarrays :: ModuleEnv TickArray,
59 -- tickarrays caches the TickArray for loaded modules,
60 -- so that we don't rebuild it each time the user sets
62 -- ":" at the GHCi prompt repeats the last command, so we
64 last_command :: Maybe Command,
66 remembered_ctx :: [(CtxtCmd, [String], [String])],
67 -- we remember the :module commands between :loads, so that
68 -- on a :reload we can replay them. See bugs #2049,
69 -- #1873, #1360. Previously we tried to remember modules that
70 -- were supposed to be in the context but currently had errors,
71 -- but this was complicated. Just replaying the :module commands
72 -- seems to be the right thing.
73 virtual_path :: FilePath,
74 ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
82 type TickArray = Array Int [(BreakIndex,SrcSpan)]
85 = ShowTiming -- show time/allocs after evaluation
86 | ShowType -- show the type of expressions
87 | RevertCAFs -- revert CAFs after every evaluation
92 { breakModule :: !GHC.Module
93 , breakLoc :: !SrcSpan
94 , breakTick :: {-# UNPACK #-} !Int
95 , onBreakCmd :: String
98 instance Eq BreakLocation where
99 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
100 breakTick loc1 == breakTick loc2
102 prettyLocations :: [(Int, BreakLocation)] -> SDoc
103 prettyLocations [] = text "No active breakpoints."
104 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
106 instance Outputable BreakLocation where
107 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
108 if null (onBreakCmd loc)
110 else doubleQuotes (text (onBreakCmd loc))
112 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
113 recordBreak brkLoc = do
115 let oldActiveBreaks = breaks st
116 -- don't store the same break point twice
117 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
118 (nm:_) -> return (True, nm)
120 let oldCounter = break_ctr st
121 newCounter = oldCounter + 1
122 setGHCiState $ st { break_ctr = newCounter,
123 breaks = (oldCounter, brkLoc) : oldActiveBreaks
125 return (False, oldCounter)
127 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
129 startGHCi :: GHCi a -> GHCiState -> IO a
130 startGHCi g state = do ref <- newIORef state; unGHCi g ref
132 instance Monad GHCi where
133 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
134 return a = GHCi $ \_ -> return a
136 instance Functor GHCi where
137 fmap f m = m >>= return . f
139 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
140 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
141 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
143 getGHCiState :: GHCi GHCiState
144 getGHCiState = GHCi $ \r -> readIORef r
145 setGHCiState :: GHCiState -> GHCi ()
146 setGHCiState s = GHCi $ \r -> writeIORef r s
148 -- for convenience...
149 getSession :: GHCi Session
150 getSession = getGHCiState >>= return . session
151 getPrelude :: GHCi Module
152 getPrelude = getGHCiState >>= return . prelude
154 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
156 no_saved_sess :: Session
157 no_saved_sess = error "no saved_ses"
159 saveSession :: GHCi ()
160 saveSession = getSession >>= io . writeIORef saved_sess
162 splatSavedSession :: GHCi ()
163 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
165 restoreSession :: IO Session
166 restoreSession = readIORef saved_sess
168 getDynFlags :: GHCi DynFlags
171 io (GHC.getSessionDynFlags s)
172 setDynFlags :: DynFlags -> GHCi [PackageId]
173 setDynFlags dflags = do
175 io (GHC.setSessionDynFlags s dflags)
177 isOptionSet :: GHCiOption -> GHCi Bool
179 = do st <- getGHCiState
180 return (opt `elem` options st)
182 setOption :: GHCiOption -> GHCi ()
184 = do st <- getGHCiState
185 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
187 unsetOption :: GHCiOption -> GHCi ()
189 = do st <- getGHCiState
190 setGHCiState (st{ options = filter (/= opt) (options st) })
193 io m = GHCi (\_ -> m)
195 printForUser :: SDoc -> GHCi ()
196 printForUser doc = do
197 session <- getSession
198 unqual <- io (GHC.getPrintUnqual session)
199 io $ Outputable.printForUser stdout unqual doc
201 printForUserPartWay :: SDoc -> GHCi ()
202 printForUserPartWay doc = do
203 session <- getSession
204 unqual <- io (GHC.getPrintUnqual session)
205 io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
207 withVirtualPath :: GHCi a -> GHCi a
208 withVirtualPath m = do
209 ghci_wd <- io getCurrentDirectory -- Store the cwd of GHCi
211 io$ setCurrentDirectory (virtual_path st)
212 result <- m -- Evaluate in the virtual wd..
213 vwd <- io getCurrentDirectory
214 setGHCiState (st{ virtual_path = vwd}) -- Update the virtual path
215 io$ setCurrentDirectory ghci_wd -- ..and restore GHCi wd
218 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
219 runStmt expr step = withVirtualPath$ do
220 session <- getSession
222 io$ withProgName (progname st) $ withArgs (args st) $
223 GHC.runStmt session expr step
225 resume :: GHC.SingleStep -> GHCi GHC.RunResult
226 resume step = withVirtualPath$ do
227 session <- getSession
228 io$ GHC.resume session step
231 -- --------------------------------------------------------------------------
232 -- timing & statistics
234 timeIt :: GHCi a -> GHCi a
236 = do b <- isOptionSet ShowTiming
239 else do allocs1 <- io $ getAllocations
240 time1 <- io $ getCPUTime
242 allocs2 <- io $ getAllocations
243 time2 <- io $ getCPUTime
244 io $ printTimes (fromIntegral (allocs2 - allocs1))
248 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
249 -- defined in ghc/rts/Stats.c
251 printTimes :: Integer -> Integer -> IO ()
252 printTimes allocs psecs
253 = do let secs = (fromIntegral psecs / (10^12)) :: Float
254 secs_str = showFFloat (Just 2) secs
256 parens (text (secs_str "") <+> text "secs" <> comma <+>
257 text (show allocs) <+> text "bytes")))
259 -----------------------------------------------------------------------------
262 revertCAFs :: GHCi ()
266 when (not (ghc_e s)) $ io turnOffBuffering
267 -- Have to turn off buffering again, because we just
268 -- reverted stdout, stderr & stdin to their defaults.
270 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
271 -- Make it "safe", just in case
273 -----------------------------------------------------------------------------
274 -- To flush buffers for the *interpreted* computation we need
275 -- to refer to *its* stdout/stderr handles
277 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
278 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
279 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
281 -- After various attempts, I believe this is the least bad way to do
282 -- what we want. We know look up the address of the static stdin,
283 -- stdout, and stderr closures in the loaded base package, and each
284 -- time we need to refer to them we cast the pointer to a Handle.
285 -- This avoids any problems with the CAF having been reverted, because
286 -- we'll always get the current value.
288 -- The previous attempt that didn't work was to compile an expression
289 -- like "hSetBuffering stdout NoBuffering" into an expression of type
290 -- IO () and run this expression each time we needed it, but the
291 -- problem is that evaluating the expression might cache the contents
292 -- of the Handle rather than referring to it from its static address
293 -- each time. There's no safe workaround for this.
295 initInterpBuffering :: GHC.Session -> IO ()
296 initInterpBuffering session
297 = do -- make sure these are linked
298 mb_hval1 <- GHC.compileExpr session "System.IO.stdout"
299 mb_hval2 <- GHC.compileExpr session "System.IO.stderr"
300 mb_hval3 <- GHC.compileExpr session "System.IO.stdin"
301 when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $
302 panic "interactiveUI:setBuffering"
304 -- ToDo: we should really look up these names properly, but
305 -- it's a fiddle and not all the bits are exposed via the GHC
307 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
308 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
309 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
311 let f ref (Just ptr) = writeIORef ref ptr
312 f _ Nothing = panic "interactiveUI:setBuffering2"
313 zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
314 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
317 flushInterpBuffers :: GHCi ()
319 = io $ do getHandle stdout_ptr >>= hFlush
320 getHandle stderr_ptr >>= hFlush
322 turnOffBuffering :: IO ()
324 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
325 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
327 getHandle :: IORef (Ptr ()) -> IO Handle
329 (Ptr addr) <- readIORef ref
330 case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)