22109c428dc8025a91f25ff9cc5cfe2ff31213c5
[ghc.git] / ghc / GhciMonad.hs
1 {-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}
2 {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
3 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4
5 -----------------------------------------------------------------------------
6 --
7 -- Monadery code used in InteractiveUI
8 --
9 -- (c) The GHC Team 2005-2006
10 --
11 -----------------------------------------------------------------------------
12
13 module GhciMonad (
14 GHCi(..), startGHCi,
15 GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,
16 GHCiOption(..), isOptionSet, setOption, unsetOption,
17 Command,
18 BreakLocation(..),
19 TickArray,
20 getDynFlags,
21
22 runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,
23
24 printForUser, printForUserPartWay, prettyLocations,
25 initInterpBuffering, turnOffBuffering, flushInterpBuffers,
26 ) where
27
28 #include "HsVersions.h"
29
30 import qualified GHC
31 import GhcMonad hiding (liftIO)
32 import Outputable hiding (printForUser, printForUserPartWay)
33 import qualified Outputable
34 import Util
35 import DynFlags
36 import FastString
37 import HscTypes
38 import SrcLoc
39 import Module
40 import ObjLink
41 import Linker
42
43 import Exception
44 import Numeric
45 import Data.Array
46 import Data.Int ( Int64 )
47 import Data.IORef
48 import System.CPUTime
49 import System.Environment
50 import System.IO
51 import Control.Applicative (Applicative(..))
52 import Control.Monad
53 import GHC.Exts
54
55 import System.Console.Haskeline (CompletionFunc, InputT)
56 import qualified System.Console.Haskeline as Haskeline
57 import Control.Monad.Trans.Class
58 import Control.Monad.IO.Class
59
60 -----------------------------------------------------------------------------
61 -- GHCi monad
62
63 type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
64
65 data GHCiState = GHCiState
66 {
67 progname :: String,
68 args :: [String],
69 prompt :: String,
70 prompt2 :: String,
71 editor :: String,
72 stop :: String,
73 options :: [GHCiOption],
74 line_number :: !Int, -- input line
75 break_ctr :: !Int,
76 breaks :: ![(Int, BreakLocation)],
77 tickarrays :: ModuleEnv TickArray,
78 -- tickarrays caches the TickArray for loaded modules,
79 -- so that we don't rebuild it each time the user sets
80 -- a breakpoint.
81 -- available ghci commands
82 ghci_commands :: [Command],
83 -- ":" at the GHCi prompt repeats the last command, so we
84 -- remember is here:
85 last_command :: Maybe Command,
86 cmdqueue :: [String],
87
88 remembered_ctx :: [InteractiveImport],
89 -- the imports that the user has asked for, via import
90 -- declarations and :module commands. This list is
91 -- persistent over :reloads (but any imports for modules
92 -- that are not loaded are temporarily ignored). After a
93 -- :load, all the home-package imports are stripped from
94 -- this list.
95
96 -- See bugs #2049, #1873, #1360
97
98 transient_ctx :: [InteractiveImport],
99 -- An import added automatically after a :load, usually of
100 -- the most recently compiled module. May be empty if
101 -- there are no modules loaded. This list is replaced by
102 -- :load, :reload, and :add. In between it may be modified
103 -- by :module.
104
105 ghc_e :: Bool, -- True if this is 'ghc -e' (or runghc)
106
107 -- help text to display to a user
108 short_help :: String,
109 long_help :: String,
110 lastErrorLocations :: IORef [(FastString, Int)]
111 }
112
113 type TickArray = Array Int [(BreakIndex,SrcSpan)]
114
115 data GHCiOption
116 = ShowTiming -- show time/allocs after evaluation
117 | ShowType -- show the type of expressions
118 | RevertCAFs -- revert CAFs after every evaluation
119 | Multiline -- use multiline commands
120 deriving Eq
121
122 data BreakLocation
123 = BreakLocation
124 { breakModule :: !GHC.Module
125 , breakLoc :: !SrcSpan
126 , breakTick :: {-# UNPACK #-} !Int
127 , onBreakCmd :: String
128 }
129
130 instance Eq BreakLocation where
131 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
132 breakTick loc1 == breakTick loc2
133
134 prettyLocations :: [(Int, BreakLocation)] -> SDoc
135 prettyLocations [] = text "No active breakpoints."
136 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
137
138 instance Outputable BreakLocation where
139 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
140 if null (onBreakCmd loc)
141 then empty
142 else doubleQuotes (text (onBreakCmd loc))
143
144 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
145 recordBreak brkLoc = do
146 st <- getGHCiState
147 let oldActiveBreaks = breaks st
148 -- don't store the same break point twice
149 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
150 (nm:_) -> return (True, nm)
151 [] -> do
152 let oldCounter = break_ctr st
153 newCounter = oldCounter + 1
154 setGHCiState $ st { break_ctr = newCounter,
155 breaks = (oldCounter, brkLoc) : oldActiveBreaks
156 }
157 return (False, oldCounter)
158
159 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
160
161 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
162 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
163
164 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
165 reifyGHCi f = GHCi f'
166 where
167 -- f' :: IORef GHCiState -> Ghc a
168 f' gs = reifyGhc (f'' gs)
169 -- f'' :: IORef GHCiState -> Session -> IO a
170 f'' gs s = f (s, gs)
171
172 startGHCi :: GHCi a -> GHCiState -> Ghc a
173 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
174
175 instance Functor GHCi where
176 fmap = liftM
177
178 instance Applicative GHCi where
179 pure = return
180 (<*>) = ap
181
182 instance Monad GHCi where
183 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
184 return a = GHCi $ \_ -> return a
185
186 getGHCiState :: GHCi GHCiState
187 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
188 setGHCiState :: GHCiState -> GHCi ()
189 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
190 modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi ()
191 modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f
192
193 liftGhc :: Ghc a -> GHCi a
194 liftGhc m = GHCi $ \_ -> m
195
196 instance MonadIO GHCi where
197 liftIO = liftGhc . liftIO
198
199 instance HasDynFlags GHCi where
200 getDynFlags = getSessionDynFlags
201
202 instance GhcMonad GHCi where
203 setSession s' = liftGhc $ setSession s'
204 getSession = liftGhc $ getSession
205
206 instance HasDynFlags (InputT GHCi) where
207 getDynFlags = lift getDynFlags
208
209 instance GhcMonad (InputT GHCi) where
210 setSession = lift . setSession
211 getSession = lift getSession
212
213 instance ExceptionMonad GHCi where
214 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
215 gmask f =
216 GHCi $ \s -> gmask $ \io_restore ->
217 let
218 g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
219 in
220 unGHCi (f g_restore) s
221
222 instance Haskeline.MonadException Ghc where
223 controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
224 run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
225 in fmap (flip unGhc s) $ f run'
226
227 instance Haskeline.MonadException GHCi where
228 controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
229 run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
230 in fmap (flip unGHCi s) $ f run'
231
232 instance ExceptionMonad (InputT GHCi) where
233 gcatch = Haskeline.catch
234 gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
235
236 isOptionSet :: GHCiOption -> GHCi Bool
237 isOptionSet opt
238 = do st <- getGHCiState
239 return (opt `elem` options st)
240
241 setOption :: GHCiOption -> GHCi ()
242 setOption opt
243 = do st <- getGHCiState
244 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
245
246 unsetOption :: GHCiOption -> GHCi ()
247 unsetOption opt
248 = do st <- getGHCiState
249 setGHCiState (st{ options = filter (/= opt) (options st) })
250
251 printForUser :: GhcMonad m => SDoc -> m ()
252 printForUser doc = do
253 unqual <- GHC.getPrintUnqual
254 dflags <- getDynFlags
255 liftIO $ Outputable.printForUser dflags stdout unqual doc
256
257 printForUserPartWay :: SDoc -> GHCi ()
258 printForUserPartWay doc = do
259 unqual <- GHC.getPrintUnqual
260 dflags <- getDynFlags
261 liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
262
263 -- | Run a single Haskell expression
264 runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult)
265 runStmt expr step = do
266 st <- getGHCiState
267 reifyGHCi $ \x ->
268 withProgName (progname st) $
269 withArgs (args st) $
270 reflectGHCi x $ do
271 GHC.handleSourceError (\e -> do GHC.printException e;
272 return Nothing) $ do
273 r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step
274 return (Just r)
275
276 runDecls :: String -> GHCi [GHC.Name]
277 runDecls decls = do
278 st <- getGHCiState
279 reifyGHCi $ \x ->
280 withProgName (progname st) $
281 withArgs (args st) $
282 reflectGHCi x $ do
283 GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do
284 GHC.runDeclsWithLocation (progname st) (line_number st) decls
285
286 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
287 resume canLogSpan step = do
288 st <- getGHCiState
289 reifyGHCi $ \x ->
290 withProgName (progname st) $
291 withArgs (args st) $
292 reflectGHCi x $ do
293 GHC.resume canLogSpan step
294
295 -- --------------------------------------------------------------------------
296 -- timing & statistics
297
298 timeIt :: InputT GHCi a -> InputT GHCi a
299 timeIt action
300 = do b <- lift $ isOptionSet ShowTiming
301 if not b
302 then action
303 else do allocs1 <- liftIO $ getAllocations
304 time1 <- liftIO $ getCPUTime
305 a <- action
306 allocs2 <- liftIO $ getAllocations
307 time2 <- liftIO $ getCPUTime
308 dflags <- getDynFlags
309 liftIO $ printTimes dflags (fromIntegral (allocs2 - allocs1))
310 (time2 - time1)
311 return a
312
313 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
314 -- defined in ghc/rts/Stats.c
315
316 printTimes :: DynFlags -> Integer -> Integer -> IO ()
317 printTimes dflags allocs psecs
318 = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
319 secs_str = showFFloat (Just 2) secs
320 putStrLn (showSDoc dflags (
321 parens (text (secs_str "") <+> text "secs" <> comma <+>
322 text (separateThousands allocs) <+> text "bytes")))
323 where
324 separateThousands n = reverse . sep . reverse . show $ n
325 where sep n'
326 | length n' <= 3 = n'
327 | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')
328
329 -----------------------------------------------------------------------------
330 -- reverting CAFs
331
332 revertCAFs :: GHCi ()
333 revertCAFs = do
334 liftIO rts_revertCAFs
335 s <- getGHCiState
336 when (not (ghc_e s)) $ liftIO turnOffBuffering
337 -- Have to turn off buffering again, because we just
338 -- reverted stdout, stderr & stdin to their defaults.
339
340 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
341 -- Make it "safe", just in case
342
343 -----------------------------------------------------------------------------
344 -- To flush buffers for the *interpreted* computation we need
345 -- to refer to *its* stdout/stderr handles
346
347 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
348 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
349 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
350
351 -- After various attempts, I believe this is the least bad way to do
352 -- what we want. We know look up the address of the static stdin,
353 -- stdout, and stderr closures in the loaded base package, and each
354 -- time we need to refer to them we cast the pointer to a Handle.
355 -- This avoids any problems with the CAF having been reverted, because
356 -- we'll always get the current value.
357 --
358 -- The previous attempt that didn't work was to compile an expression
359 -- like "hSetBuffering stdout NoBuffering" into an expression of type
360 -- IO () and run this expression each time we needed it, but the
361 -- problem is that evaluating the expression might cache the contents
362 -- of the Handle rather than referring to it from its static address
363 -- each time. There's no safe workaround for this.
364
365 initInterpBuffering :: Ghc ()
366 initInterpBuffering = do -- make sure these are linked
367 dflags <- GHC.getSessionDynFlags
368 liftIO $ do
369 initDynLinker dflags
370
371 -- ToDo: we should really look up these names properly, but
372 -- it's a fiddle and not all the bits are exposed via the GHC
373 -- interface.
374 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
375 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
376 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
377
378 let f ref (Just ptr) = writeIORef ref ptr
379 f _ Nothing = panic "interactiveUI:setBuffering2"
380 zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
381 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
382
383 flushInterpBuffers :: GHCi ()
384 flushInterpBuffers
385 = liftIO $ do getHandle stdout_ptr >>= hFlush
386 getHandle stderr_ptr >>= hFlush
387
388 turnOffBuffering :: IO ()
389 turnOffBuffering
390 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
391 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
392
393 getHandle :: IORef (Ptr ()) -> IO Handle
394 getHandle ref = do
395 (Ptr addr) <- readIORef ref
396 case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval)
397