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