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