GhciMonad.hs 12 KB
Newer Older
1
{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
2 3
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

mnislaih's avatar
mnislaih committed
4 5 6 7 8 9 10 11
-----------------------------------------------------------------------------
--
-- Monadery code used in InteractiveUI
--
-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------

12 13 14 15 16
module GhciMonad where

#include "HsVersions.h"

import qualified GHC
17
import Outputable       hiding (printForUser, printForUserPartWay)
18 19
import qualified Outputable
import Panic            hiding (showException)
20
import Util
Simon Marlow's avatar
Simon Marlow committed
21
import DynFlags
22
import HscTypes hiding (liftIO)
23
import SrcLoc
24
import Module
25
import ObjLink
26
import Linker
27
import StaticFlags
28
import qualified MonadUtils
29

30
import Exception
31
-- import Data.Maybe
32
import Numeric
33
import Data.Array
34
-- import Data.Char
35 36
import Data.Int         ( Int64 )
import Data.IORef
37
-- import Data.List
38
import System.CPUTime
mnislaih's avatar
mnislaih committed
39
import System.Environment
40 41 42 43
import System.IO
import Control.Monad as Monad
import GHC.Exts

44 45 46 47
import System.Console.Haskeline (CompletionFunc, InputT)
import qualified System.Console.Haskeline as Haskeline
import Control.Monad.Trans as Trans

48 49 50
-----------------------------------------------------------------------------
-- GHCi monad

51
type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
52

53 54 55 56 57 58
data GHCiState = GHCiState
     { 
	progname       :: String,
	args	       :: [String],
        prompt         :: String,
	editor         :: String,
Simon Marlow's avatar
Simon Marlow committed
59
        stop           :: String,
60
	options        :: [GHCiOption],
mnislaih's avatar
mnislaih committed
61
        prelude        :: GHC.Module,
62 63
        break_ctr      :: !Int,
        breaks         :: ![(Int, BreakLocation)],
64
        tickarrays     :: ModuleEnv TickArray,
65 66 67
                -- tickarrays caches the TickArray for loaded modules,
                -- so that we don't rebuild it each time the user sets
                -- a breakpoint.
68 69 70
        -- ":" at the GHCi prompt repeats the last command, so we
        -- remember is here:
        last_command   :: Maybe Command,
Simon Marlow's avatar
Simon Marlow committed
71
        cmdqueue       :: [String],
72
        remembered_ctx :: [CtxtCmd],
73 74
             -- we remember the :module commands between :loads, so that
             -- on a :reload we can replay them.  See bugs #2049,
Thomas Schilling's avatar
Thomas Schilling committed
75
             -- \#1873, #1360. Previously we tried to remember modules that
76 77 78
             -- were supposed to be in the context but currently had errors,
             -- but this was complicated.  Just replaying the :module commands
             -- seems to be the right thing.
79
        ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
80 81
     }

82
data CtxtCmd
83 84 85 86
  = SetContext [String] [String]
  | AddModules [String] [String]
  | RemModules [String] [String]
  | Import     String
87

88 89
type TickArray = Array Int [(BreakIndex,SrcSpan)]

90 91 92 93 94 95
data GHCiOption 
	= ShowTiming		-- show time/allocs after evaluation
	| ShowType		-- show the type of expressions
	| RevertCAFs		-- revert CAFs after every evaluation
	deriving Eq

96 97 98 99 100
data BreakLocation
   = BreakLocation
   { breakModule :: !GHC.Module
   , breakLoc    :: !SrcSpan
   , breakTick   :: {-# UNPACK #-} !Int
101
   , onBreakCmd  :: String
102
   } 
103 104 105 106

instance Eq BreakLocation where
  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
                 breakTick loc1   == breakTick loc2
107 108 109 110 111 112

prettyLocations :: [(Int, BreakLocation)] -> SDoc
prettyLocations []   = text "No active breakpoints." 
prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs

instance Outputable BreakLocation where
113 114 115 116
   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
                if null (onBreakCmd loc)
                   then empty
                   else doubleQuotes (text (onBreakCmd loc))
117 118 119 120 121 122

recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
recordBreak brkLoc = do
   st <- getGHCiState
   let oldActiveBreaks = breaks st 
   -- don't store the same break point twice
123
   case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
124 125
     (nm:_) -> return (True, nm)
     [] -> do
126
      let oldCounter = break_ctr st
127
          newCounter = oldCounter + 1
128 129 130
      setGHCiState $ st { break_ctr = newCounter,
                          breaks = (oldCounter, brkLoc) : oldActiveBreaks
                        }
131 132
      return (False, oldCounter)

133
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
134

135 136 137 138 139 140 141 142 143 144 145 146 147
reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s

reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
reifyGHCi f = GHCi f'
  where
    -- f' :: IORef GHCiState -> Ghc a
    f' gs = reifyGhc (f'' gs)
    -- f'' :: IORef GHCiState -> Session -> IO a
    f'' gs s = f (s, gs)

startGHCi :: GHCi a -> GHCiState -> Ghc a
startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
148 149 150

instance Monad GHCi where
  (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
Ian Lynagh's avatar
Ian Lynagh committed
151
  return a  = GHCi $ \_ -> return a
152

mnislaih's avatar
mnislaih committed
153 154 155
instance Functor GHCi where
    fmap f m = m >>= return . f

156
ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
157
ghciHandleGhcException = handleGhcException
158

Ian Lynagh's avatar
Ian Lynagh committed
159
getGHCiState :: GHCi GHCiState
160
getGHCiState   = GHCi $ \r -> liftIO $ readIORef r
Ian Lynagh's avatar
Ian Lynagh committed
161
setGHCiState :: GHCiState -> GHCi ()
162 163 164 165 166
setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s

liftGhc :: Ghc a -> GHCi a
liftGhc m = GHCi $ \_ -> m

167 168 169 170 171
instance MonadUtils.MonadIO GHCi where
  liftIO = liftGhc . MonadUtils.liftIO

instance Trans.MonadIO Ghc where
  liftIO = MonadUtils.liftIO
172 173 174 175 176

instance GhcMonad GHCi where
  setSession s' = liftGhc $ setSession s'
  getSession    = liftGhc $ getSession

177 178 179 180 181 182 183 184 185 186 187
instance GhcMonad (InputT GHCi) where
  setSession = lift . setSession
  getSession = lift getSession

instance MonadUtils.MonadIO (InputT GHCi) where
  liftIO = Trans.liftIO

instance WarnLogMonad (InputT GHCi) where
  setWarnings = lift . setWarnings
  getWarnings = lift getWarnings

188 189
instance ExceptionMonad GHCi where
  gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
190 191
  gblock (GHCi m)   = GHCi $ \r -> gblock (m r)
  gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
192 193 194 195 196 197
  gmask f =
      GHCi $ \s -> gmask $ \io_restore ->
                             let
                                g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
                             in
                                unGHCi (f g_restore) s
198 199 200 201

instance WarnLogMonad GHCi where
  setWarnings warns = liftGhc $ setWarnings warns
  getWarnings = liftGhc $ getWarnings
202

203 204
instance MonadIO GHCi where
  liftIO = io
Ian Lynagh's avatar
Ian Lynagh committed
205

206 207 208 209
instance Haskeline.MonadException GHCi where
  catch = gcatch
  block = gblock
  unblock = gunblock
210 211
  -- XXX when Haskeline's MonadException changes, we can drop our 
  -- deprecated block/unblock methods
Ian Lynagh's avatar
Ian Lynagh committed
212

213
instance ExceptionMonad (InputT GHCi) where
214 215 216 217
  gcatch = Haskeline.catch
  gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong
  gblock = Haskeline.block
  gunblock = Haskeline.unblock
218

219 220 221
-- for convenience...
getPrelude :: GHCi Module
getPrelude = getGHCiState >>= return . prelude
222

223
getDynFlags :: GhcMonad m => m DynFlags
224
getDynFlags = do
225 226
  GHC.getSessionDynFlags

Ian Lynagh's avatar
Ian Lynagh committed
227
setDynFlags :: DynFlags -> GHCi [PackageId]
228
setDynFlags dflags = do 
229
  GHC.setSessionDynFlags dflags
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246

isOptionSet :: GHCiOption -> GHCi Bool
isOptionSet opt
 = do st <- getGHCiState
      return (opt `elem` options st)

setOption :: GHCiOption -> GHCi ()
setOption opt
 = do st <- getGHCiState
      setGHCiState (st{ options = opt : filter (/= opt) (options st) })

unsetOption :: GHCiOption -> GHCi ()
unsetOption opt
 = do st <- getGHCiState
      setGHCiState (st{ options = filter (/= opt) (options st) })

io :: IO a -> GHCi a
247
io = MonadUtils.liftIO
248

249
printForUser :: GhcMonad m => SDoc -> m ()
250
printForUser doc = do
251
  unqual <- GHC.getPrintUnqual
252
  MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc
253

254 255
printForUserPartWay :: SDoc -> GHCi ()
printForUserPartWay doc = do
256
  unqual <- GHC.getPrintUnqual
257 258
  io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc

mnislaih's avatar
mnislaih committed
259
runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
260
runStmt expr step = do
261 262 263 264 265 266 267 268
  st <- getGHCiState
  reifyGHCi $ \x ->
    withProgName (progname st) $
    withArgs (args st) $
      reflectGHCi x $ do
        GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
                                        return GHC.RunFailed) $ do
          GHC.runStmt expr step
mnislaih's avatar
mnislaih committed
269

270
resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
271 272 273 274 275 276 277
resume canLogSpan step = do
  st <- getGHCiState
  reifyGHCi $ \x ->
    withProgName (progname st) $
    withArgs (args st) $
      reflectGHCi x $ do
        GHC.resume canLogSpan step
mnislaih's avatar
mnislaih committed
278

mnislaih's avatar
mnislaih committed
279
-- --------------------------------------------------------------------------
280 281
-- timing & statistics

282
timeIt :: InputT GHCi a -> InputT GHCi a
283
timeIt action
284
  = do b <- lift $ isOptionSet ShowTiming
285 286
       if not b 
	  then action 
287 288
	  else do allocs1 <- liftIO $ getAllocations
		  time1   <- liftIO $ getCPUTime
289
		  a <- action
290 291 292
		  allocs2 <- liftIO $ getAllocations
		  time2   <- liftIO $ getCPUTime
		  liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) 
293 294 295 296 297 298 299 300
				  (time2 - time1)
		  return a

foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
	-- defined in ghc/rts/Stats.c

printTimes :: Integer -> Integer -> IO ()
printTimes allocs psecs
301
   = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
302 303 304 305 306 307 308 309
	    secs_str = showFFloat (Just 2) secs
	putStrLn (showSDoc (
		 parens (text (secs_str "") <+> text "secs" <> comma <+> 
			 text (show allocs) <+> text "bytes")))

-----------------------------------------------------------------------------
-- reverting CAFs
	
310
revertCAFs :: GHCi ()
311
revertCAFs = do
312 313 314
  io $ rts_revertCAFs
  s <- getGHCiState
  when (not (ghc_e s)) $ io turnOffBuffering
315 316 317 318 319 320 321 322 323 324
	-- Have to turn off buffering again, because we just 
	-- reverted stdout, stderr & stdin to their defaults.

foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()  
	-- Make it "safe", just in case

-----------------------------------------------------------------------------
-- To flush buffers for the *interpreted* computation we need
-- to refer to *its* stdout/stderr handles

325 326 327
GLOBAL_VAR(stdin_ptr,  error "no stdin_ptr",  Ptr ())
GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
328

329 330 331 332 333 334 335 336 337 338 339 340 341
-- After various attempts, I believe this is the least bad way to do
-- what we want.  We know look up the address of the static stdin,
-- stdout, and stderr closures in the loaded base package, and each
-- time we need to refer to them we cast the pointer to a Handle.
-- This avoids any problems with the CAF having been reverted, because
-- we'll always get the current value.
--
-- The previous attempt that didn't work was to compile an expression
-- like "hSetBuffering stdout NoBuffering" into an expression of type
-- IO () and run this expression each time we needed it, but the
-- problem is that evaluating the expression might cache the contents
-- of the Handle rather than referring to it from its static address
-- each time.  There's no safe workaround for this.
342

343 344 345 346
initInterpBuffering :: Ghc ()
initInterpBuffering = do -- make sure these are linked
    dflags <- GHC.getSessionDynFlags
    liftIO $ do
347
      initDynLinker dflags
348 349 350 351

        -- ToDo: we should really look up these names properly, but
        -- it's a fiddle and not all the bits are exposed via the GHC
        -- interface.
352 353 354
      mb_stdin_ptr  <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
      mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
      mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
355 356

      let f ref (Just ptr) = writeIORef ref ptr
Ian Lynagh's avatar
Ian Lynagh committed
357
          f _   Nothing    = panic "interactiveUI:setBuffering2"
358 359
      zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
360 361 362

flushInterpBuffers :: GHCi ()
flushInterpBuffers
363 364
 = io $ do getHandle stdout_ptr >>= hFlush
           getHandle stderr_ptr >>= hFlush
365 366 367

turnOffBuffering :: IO ()
turnOffBuffering
368 369 370 371 372 373 374
 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
      mapM_ (\h -> hSetBuffering h NoBuffering) hdls

getHandle :: IORef (Ptr ()) -> IO Handle
getHandle ref = do
  (Ptr addr) <- readIORef ref
  case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)