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