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

Ian Lynagh's avatar
Ian Lynagh committed
4 5 6 7 8 9 10
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp
-- for details

mnislaih's avatar
mnislaih committed
11 12 13 14 15 16 17 18
-----------------------------------------------------------------------------
--
-- Monadery code used in InteractiveUI
--
-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------

19 20 21 22 23
module GhciMonad where

#include "HsVersions.h"

import qualified GHC
24
import GhcMonad         hiding (liftIO)
25
import Outputable       hiding (printForUser, printForUserPartWay)
26 27
import qualified Outputable
import Panic            hiding (showException)
28
import Util
Simon Marlow's avatar
Simon Marlow committed
29
import DynFlags
30
import HscTypes
31
import SrcLoc
32
import Module
33
import ObjLink
34
import Linker
35
import StaticFlags
36
import qualified MonadUtils
37

38
import Exception
39
import Numeric
40
import Data.Array
41 42 43
import Data.Int         ( Int64 )
import Data.IORef
import System.CPUTime
mnislaih's avatar
mnislaih committed
44
import System.Environment
45 46 47 48
import System.IO
import Control.Monad as Monad
import GHC.Exts

49 50 51 52
import System.Console.Haskeline (CompletionFunc, InputT)
import qualified System.Console.Haskeline as Haskeline
import Control.Monad.Trans as Trans

53 54 55
-----------------------------------------------------------------------------
-- GHCi monad

56
type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
57

58 59 60 61 62 63
data GHCiState = GHCiState
     { 
	progname       :: String,
	args	       :: [String],
        prompt         :: String,
	editor         :: String,
Simon Marlow's avatar
Simon Marlow committed
64
        stop           :: String,
65
	options        :: [GHCiOption],
vivian's avatar
vivian committed
66
        line_number    :: !Int,         -- input line
67 68
        break_ctr      :: !Int,
        breaks         :: ![(Int, BreakLocation)],
69
        tickarrays     :: ModuleEnv TickArray,
70 71 72
                -- tickarrays caches the TickArray for loaded modules,
                -- so that we don't rebuild it each time the user sets
                -- a breakpoint.
73 74 75
        -- ":" at the GHCi prompt repeats the last command, so we
        -- remember is here:
        last_command   :: Maybe Command,
Simon Marlow's avatar
Simon Marlow committed
76
        cmdqueue       :: [String],
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94

        remembered_ctx :: [InteractiveImport],
             -- the imports that the user has asked for, via import
             -- declarations and :module commands.  This list is
             -- persistent over :reloads (but any imports for modules
             -- that are not loaded are temporarily ignored).  After a
             -- :load, all the home-package imports are stripped from
             -- this list.

             -- See bugs #2049, #1873, #1360

        transient_ctx  :: [InteractiveImport],
             -- An import added automatically after a :load, usually of
             -- the most recently compiled module.  May be empty if
             -- there are no modules loaded.  This list is replaced by
             -- :load, :reload, and :add.  In between it may be modified
             -- by :module.

95
        ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
96 97
     }

98 99
type TickArray = Array Int [(BreakIndex,SrcSpan)]

100 101 102 103
data GHCiOption 
	= ShowTiming		-- show time/allocs after evaluation
	| ShowType		-- show the type of expressions
	| RevertCAFs		-- revert CAFs after every evaluation
vivian's avatar
vivian committed
104
        | Multiline             -- use multiline commands
105 106
	deriving Eq

107 108 109 110 111
data BreakLocation
   = BreakLocation
   { breakModule :: !GHC.Module
   , breakLoc    :: !SrcSpan
   , breakTick   :: {-# UNPACK #-} !Int
112
   , onBreakCmd  :: String
113
   } 
114 115 116 117

instance Eq BreakLocation where
  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
                 breakTick loc1   == breakTick loc2
118 119 120 121 122 123

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
124 125 126 127
   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
                if null (onBreakCmd loc)
                   then empty
                   else doubleQuotes (text (onBreakCmd loc))
128 129 130 131 132 133

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
134
   case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
135 136
     (nm:_) -> return (True, nm)
     [] -> do
137
      let oldCounter = break_ctr st
138
          newCounter = oldCounter + 1
139 140 141
      setGHCiState $ st { break_ctr = newCounter,
                          breaks = (oldCounter, brkLoc) : oldActiveBreaks
                        }
142 143
      return (False, oldCounter)

144
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
145

146 147 148 149 150 151 152 153 154 155 156 157 158
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
159 160 161

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

mnislaih's avatar
mnislaih committed
164 165 166
instance Functor GHCi where
    fmap f m = m >>= return . f

167
ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
168
ghciHandleGhcException = handleGhcException
169

Ian Lynagh's avatar
Ian Lynagh committed
170
getGHCiState :: GHCi GHCiState
171
getGHCiState   = GHCi $ \r -> liftIO $ readIORef r
Ian Lynagh's avatar
Ian Lynagh committed
172
setGHCiState :: GHCiState -> GHCi ()
173
setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
174 175
modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi ()
modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f
176 177 178 179

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

180 181 182 183 184
instance MonadUtils.MonadIO GHCi where
  liftIO = liftGhc . MonadUtils.liftIO

instance Trans.MonadIO Ghc where
  liftIO = MonadUtils.liftIO
185

186 187 188
instance HasDynFlags GHCi where
  getDynFlags = getSessionDynFlags

189 190 191 192
instance GhcMonad GHCi where
  setSession s' = liftGhc $ setSession s'
  getSession    = liftGhc $ getSession

193 194 195
instance HasDynFlags (InputT GHCi) where
  getDynFlags = lift getDynFlags

196 197 198 199 200 201 202
instance GhcMonad (InputT GHCi) where
  setSession = lift . setSession
  getSession = lift getSession

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

203 204
instance ExceptionMonad GHCi where
  gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
205 206
  gblock (GHCi m)   = GHCi $ \r -> gblock (m r)
  gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
207 208 209 210 211 212
  gmask f =
      GHCi $ \s -> gmask $ \io_restore ->
                             let
                                g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
                             in
                                unGHCi (f g_restore) s
213

214
instance MonadIO GHCi where
Ian Lynagh's avatar
Ian Lynagh committed
215
  liftIO = MonadUtils.liftIO
Ian Lynagh's avatar
Ian Lynagh committed
216

217 218 219 220
instance Haskeline.MonadException GHCi where
  catch = gcatch
  block = gblock
  unblock = gunblock
221 222
  -- XXX when Haskeline's MonadException changes, we can drop our 
  -- deprecated block/unblock methods
Ian Lynagh's avatar
Ian Lynagh committed
223

224
instance ExceptionMonad (InputT GHCi) where
225 226 227 228
  gcatch = Haskeline.catch
  gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong
  gblock = Haskeline.block
  gunblock = Haskeline.unblock
229

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

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) })

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
Ian Lynagh's avatar
Ian Lynagh committed
257
  liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
258

259
runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult)
260
runStmt expr step = do
261 262 263 264 265
  st <- getGHCiState
  reifyGHCi $ \x ->
    withProgName (progname st) $
    withArgs (args st) $
      reflectGHCi x $ do
266 267 268 269 270 271 272 273 274 275 276 277 278 279
        GHC.handleSourceError (\e -> do GHC.printException e; 
                                        return Nothing) $ do
          r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step
          return (Just r)

runDecls :: String -> GHCi [GHC.Name]
runDecls decls = do
  st <- getGHCiState
  reifyGHCi $ \x ->
    withProgName (progname st) $
    withArgs (args st) $
      reflectGHCi x $ do
        GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do
          GHC.runDeclsWithLocation (progname st) (line_number st) decls
mnislaih's avatar
mnislaih committed
280

281
resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
282 283 284 285 286 287 288
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
289

mnislaih's avatar
mnislaih committed
290
-- --------------------------------------------------------------------------
291 292
-- timing & statistics

293
timeIt :: InputT GHCi a -> InputT GHCi a
294
timeIt action
295
  = do b <- lift $ isOptionSet ShowTiming
296 297
       if not b 
	  then action 
298 299
	  else do allocs1 <- liftIO $ getAllocations
		  time1   <- liftIO $ getCPUTime
300
		  a <- action
301 302 303
		  allocs2 <- liftIO $ getAllocations
		  time2   <- liftIO $ getCPUTime
		  liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) 
304 305 306 307 308 309 310 311
				  (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
312
   = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
313 314 315 316 317 318 319 320
	    secs_str = showFFloat (Just 2) secs
	putStrLn (showSDoc (
		 parens (text (secs_str "") <+> text "secs" <> comma <+> 
			 text (show allocs) <+> text "bytes")))

-----------------------------------------------------------------------------
-- reverting CAFs
	
321
revertCAFs :: GHCi ()
322
revertCAFs = do
Ian Lynagh's avatar
Ian Lynagh committed
323
  liftIO rts_revertCAFs
324
  s <- getGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
325
  when (not (ghc_e s)) $ liftIO turnOffBuffering
326 327 328 329 330 331 332 333 334 335
	-- 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

336 337 338
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 ())
339

340 341 342 343 344 345 346 347 348 349 350 351 352
-- 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.
353

354 355 356 357
initInterpBuffering :: Ghc ()
initInterpBuffering = do -- make sure these are linked
    dflags <- GHC.getSessionDynFlags
    liftIO $ do
358
      initDynLinker dflags
359 360 361 362

        -- 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.
363 364 365
      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"
366 367

      let f ref (Just ptr) = writeIORef ref ptr
Ian Lynagh's avatar
Ian Lynagh committed
368
          f _   Nothing    = panic "interactiveUI:setBuffering2"
369 370
      zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
371 372 373

flushInterpBuffers :: GHCi ()
flushInterpBuffers
Ian Lynagh's avatar
Ian Lynagh committed
374 375
 = liftIO $ do getHandle stdout_ptr >>= hFlush
               getHandle stderr_ptr >>= hFlush
376 377 378

turnOffBuffering :: IO ()
turnOffBuffering
379 380 381 382 383 384
 = 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
385
  case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval)