GhciMonad.hs 11 KB
Newer Older
1 2 3
{-# OPTIONS -fno-cse #-}
-- -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 23
import HscTypes
import SrcLoc
24
import Module
25
import ObjLink
26
import Linker
27
import StaticFlags
28
import MonadUtils       ( MonadIO, liftIO )
29

30
import Exception
31
import Data.Maybe
32
import Numeric
33
import Data.Array
34 35 36
import Data.Char
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 44 45 46
import System.IO
import Control.Monad as Monad
import GHC.Exts

-----------------------------------------------------------------------------
-- GHCi monad

47
type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String])
48

49 50 51 52 53 54
data GHCiState = GHCiState
     { 
	progname       :: String,
	args	       :: [String],
        prompt         :: String,
	editor         :: String,
Simon Marlow's avatar
Simon Marlow committed
55
        stop           :: String,
56
	options        :: [GHCiOption],
mnislaih's avatar
mnislaih committed
57
        prelude        :: GHC.Module,
58 59
        break_ctr      :: !Int,
        breaks         :: ![(Int, BreakLocation)],
60
        tickarrays     :: ModuleEnv TickArray,
61 62 63
                -- tickarrays caches the TickArray for loaded modules,
                -- so that we don't rebuild it each time the user sets
                -- a breakpoint.
64 65 66
        -- ":" at the GHCi prompt repeats the last command, so we
        -- remember is here:
        last_command   :: Maybe Command,
Simon Marlow's avatar
Simon Marlow committed
67
        cmdqueue       :: [String],
mnislaih's avatar
mnislaih committed
68
        remembered_ctx :: [(CtxtCmd, [String], [String])],
69 70
             -- 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
71
             -- \#1873, #1360. Previously we tried to remember modules that
72 73 74
             -- 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.
75
        ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
76 77
     }

78 79 80 81 82
data CtxtCmd
  = SetContext
  | AddModules
  | RemModules

83 84
type TickArray = Array Int [(BreakIndex,SrcSpan)]

85 86 87 88 89 90
data GHCiOption 
	= ShowTiming		-- show time/allocs after evaluation
	| ShowType		-- show the type of expressions
	| RevertCAFs		-- revert CAFs after every evaluation
	deriving Eq

91 92 93 94 95
data BreakLocation
   = BreakLocation
   { breakModule :: !GHC.Module
   , breakLoc    :: !SrcSpan
   , breakTick   :: {-# UNPACK #-} !Int
96
   , onBreakCmd  :: String
97
   } 
98 99 100 101

instance Eq BreakLocation where
  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
                 breakTick loc1   == breakTick loc2
102 103 104 105 106 107

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
108 109 110 111
   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
                if null (onBreakCmd loc)
                   then empty
                   else doubleQuotes (text (onBreakCmd loc))
112 113 114 115 116 117

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
118
   case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
119 120
     (nm:_) -> return (True, nm)
     [] -> do
121
      let oldCounter = break_ctr st
122
          newCounter = oldCounter + 1
123 124 125
      setGHCiState $ st { break_ctr = newCounter,
                          breaks = (oldCounter, brkLoc) : oldActiveBreaks
                        }
126 127
      return (False, oldCounter)

128
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
129

130 131 132 133 134 135 136 137 138 139 140 141 142
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
143 144 145

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

mnislaih's avatar
mnislaih committed
148 149 150
instance Functor GHCi where
    fmap f m = m >>= return . f

151
ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
152
ghciHandleGhcException = handleGhcException
153

Ian Lynagh's avatar
Ian Lynagh committed
154
getGHCiState :: GHCi GHCiState
155
getGHCiState   = GHCi $ \r -> liftIO $ readIORef r
Ian Lynagh's avatar
Ian Lynagh committed
156
setGHCiState :: GHCiState -> GHCi ()
157 158 159 160 161 162 163 164 165 166 167 168 169 170
setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s

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

instance MonadIO GHCi where
  liftIO m = liftGhc $ liftIO m

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

instance ExceptionMonad GHCi where
  gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
171 172
  gblock (GHCi m)   = GHCi $ \r -> gblock (m r)
  gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
173 174 175 176

instance WarnLogMonad GHCi where
  setWarnings warns = liftGhc $ setWarnings warns
  getWarnings = liftGhc $ getWarnings
177 178

-- for convenience...
Ian Lynagh's avatar
Ian Lynagh committed
179
getPrelude :: GHCi Module
180 181
getPrelude = getGHCiState >>= return . prelude

182
GLOBAL_VAR(saved_sess, no_saved_sess, Session)
Ian Lynagh's avatar
Ian Lynagh committed
183 184

no_saved_sess :: Session
185
no_saved_sess = error "no saved_ses"
Ian Lynagh's avatar
Ian Lynagh committed
186 187

saveSession :: GHCi ()
188 189 190 191
saveSession =
    liftGhc $ do
      reifyGhc $ \s ->
        writeIORef saved_sess s
Ian Lynagh's avatar
Ian Lynagh committed
192 193

splatSavedSession :: GHCi ()
194
splatSavedSession = io (writeIORef saved_sess no_saved_sess)
Ian Lynagh's avatar
Ian Lynagh committed
195

196 197 198 199 200 201 202
-- restoreSession :: IO Session
-- restoreSession = readIORef saved_sess

withRestoredSession :: Ghc a -> IO a
withRestoredSession ghc = do
    s <- readIORef saved_sess
    reflectGhc ghc s
203

Ian Lynagh's avatar
Ian Lynagh committed
204
getDynFlags :: GHCi DynFlags
205
getDynFlags = do
206 207
  GHC.getSessionDynFlags

Ian Lynagh's avatar
Ian Lynagh committed
208
setDynFlags :: DynFlags -> GHCi [PackageId]
209
setDynFlags dflags = do 
210
  GHC.setSessionDynFlags dflags
211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227

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
228
io = liftIO
229

230 231
printForUser :: SDoc -> GHCi ()
printForUser doc = do
232
  unqual <- GHC.getPrintUnqual
233
  io $ Outputable.printForUser stdout unqual doc
234

235 236
printForUserPartWay :: SDoc -> GHCi ()
printForUserPartWay doc = do
237
  unqual <- GHC.getPrintUnqual
238 239
  io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc

mnislaih's avatar
mnislaih committed
240
runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
241
runStmt expr step = do
242 243 244 245 246 247 248 249
  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
250 251

resume :: GHC.SingleStep -> GHCi GHC.RunResult
252
resume step = GHC.resume step
mnislaih's avatar
mnislaih committed
253

mnislaih's avatar
mnislaih committed
254
-- --------------------------------------------------------------------------
255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
-- timing & statistics

timeIt :: GHCi a -> GHCi a
timeIt action
  = do b <- isOptionSet ShowTiming
       if not b 
	  then action 
	  else do allocs1 <- io $ getAllocations
		  time1   <- io $ getCPUTime
		  a <- action
		  allocs2 <- io $ getAllocations
		  time2   <- io $ getCPUTime
		  io $ printTimes (fromIntegral (allocs2 - allocs1)) 
				  (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
276
   = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
277 278 279 280 281 282 283 284
	    secs_str = showFFloat (Just 2) secs
	putStrLn (showSDoc (
		 parens (text (secs_str "") <+> text "secs" <> comma <+> 
			 text (show allocs) <+> text "bytes")))

-----------------------------------------------------------------------------
-- reverting CAFs
	
285
revertCAFs :: GHCi ()
286
revertCAFs = do
287 288 289
  io $ rts_revertCAFs
  s <- getGHCiState
  when (not (ghc_e s)) $ io turnOffBuffering
290 291 292 293 294 295 296 297 298 299
	-- 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

300 301 302
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 ())
303

304 305 306 307 308 309 310 311 312 313 314 315 316
-- 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.
317

318 319 320 321
initInterpBuffering :: Ghc ()
initInterpBuffering = do -- make sure these are linked
    dflags <- GHC.getSessionDynFlags
    liftIO $ do
322
      initDynLinker dflags
323 324 325 326 327 328 329 330 331

        -- 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.
      mb_stdin_ptr  <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
      mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
      mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"

      let f ref (Just ptr) = writeIORef ref ptr
Ian Lynagh's avatar
Ian Lynagh committed
332
          f _   Nothing    = panic "interactiveUI:setBuffering2"
333 334
      zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
                 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
335 336 337 338
      return ()

flushInterpBuffers :: GHCi ()
flushInterpBuffers
339 340
 = io $ do getHandle stdout_ptr >>= hFlush
           getHandle stderr_ptr >>= hFlush
341 342 343

turnOffBuffering :: IO ()
turnOffBuffering
344 345 346 347 348 349 350
 = 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)