compiler/ghci/GhciMonad.hs

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