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, [String], [String])],
  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
  84   | AddModules
  85   | RemModules
  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 WarnLogMonad (InputT GHCi) where
 184   setWarnings = lift . setWarnings
 185   getWarnings = lift getWarnings
 186
 187 instance ExceptionMonad GHCi where
 188   gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
 189   gblock (GHCi m)   = GHCi $ \r -> gblock (m r)
 190   gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
 191
 192 instance WarnLogMonad GHCi where
 193   setWarnings warns = liftGhc $ setWarnings warns
 194   getWarnings = liftGhc $ getWarnings
 195
 196 instance MonadIO GHCi where
 197   liftIO = io
 198
 199 instance Haskeline.MonadException GHCi where
 200   catch = gcatch
 201   block = gblock
 202   unblock = gunblock
 203
 204 instance ExceptionMonad (InputT GHCi) where
 205     gcatch = Haskeline.catch
 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 io :: IO a -> GHCi a
 237 io = MonadUtils.liftIO
 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   io $ 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.printExceptionAndWarnings e
 257                                         return GHC.RunFailed) $ do
 258           GHC.runStmt 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   io $ rts_revertCAFs
 303   s <- getGHCiState
 304   when (not (ghc_e s)) $ io 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  = io $ 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)