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