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