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         | Multiline             -- use multiline commands
  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 ExceptionMonad GHCi where
 185   gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
 186   gblock (GHCi m)   = GHCi $ \r -> gblock (m r)
 187   gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
 188   gmask f =
 189       GHCi $ \s -> gmask $ \io_restore ->
 190                              let
 191                                 g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
 192                              in
 193                                 unGHCi (f g_restore) s
 194
 195 instance MonadIO GHCi where
 196   liftIO = MonadUtils.liftIO
 197
 198 instance Haskeline.MonadException GHCi where
 199   catch = gcatch
 200   block = gblock
 201   unblock = gunblock
 202   -- XXX when Haskeline's MonadException changes, we can drop our
 203   -- deprecated block/unblock methods
 204
 205 instance ExceptionMonad (InputT GHCi) where
 206   gcatch = Haskeline.catch
 207   gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong
 208   gblock = Haskeline.block
 209   gunblock = Haskeline.unblock
 210
 211 -- for convenience...
 212 getPrelude :: GHCi Module
 213 getPrelude = getGHCiState >>= return . prelude
 214
 215 getDynFlags :: GhcMonad m => m DynFlags
 216 getDynFlags = do
 217   GHC.getSessionDynFlags
 218
 219 setDynFlags :: DynFlags -> GHCi [PackageId]
 220 setDynFlags dflags = do
 221   GHC.setSessionDynFlags dflags
 222
 223 isOptionSet :: GHCiOption -> GHCi Bool
 224 isOptionSet opt
 225  = do st <- getGHCiState
 226       return (opt `elem` options st)
 227
 228 setOption :: GHCiOption -> GHCi ()
 229 setOption opt
 230  = do st <- getGHCiState
 231       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 232
 233 unsetOption :: GHCiOption -> GHCi ()
 234 unsetOption opt
 235  = do st <- getGHCiState
 236       setGHCiState (st{ options = filter (/= opt) (options st) })
 237
 238 printForUser :: GhcMonad m => SDoc -> m ()
 239 printForUser doc = do
 240   unqual <- GHC.getPrintUnqual
 241   MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc
 242
 243 printForUserPartWay :: SDoc -> GHCi ()
 244 printForUserPartWay doc = do
 245   unqual <- GHC.getPrintUnqual
 246   liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
 247
 248 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
 249 runStmt expr step = do
 250   st <- getGHCiState
 251   reifyGHCi $ \x ->
 252     withProgName (progname st) $
 253     withArgs (args st) $
 254       reflectGHCi x $ do
 255         GHC.handleSourceError (\e -> do GHC.printException e
 256                                         return GHC.RunFailed) $ do
 257           GHC.runStmt expr step
 258
 259 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
 260 resume canLogSpan step = do
 261   st <- getGHCiState
 262   reifyGHCi $ \x ->
 263     withProgName (progname st) $
 264     withArgs (args st) $
 265       reflectGHCi x $ do
 266         GHC.resume canLogSpan step
 267
 268 -- --------------------------------------------------------------------------
 269 -- timing & statistics
 270
 271 timeIt :: InputT GHCi a -> InputT GHCi a
 272 timeIt action
 273   = do b <- lift $ isOptionSet ShowTiming
 274        if not b
 275           then action
 276           else do allocs1 <- liftIO $ getAllocations
 277                   time1   <- liftIO $ getCPUTime
 278                   a <- action
 279                   allocs2 <- liftIO $ getAllocations
 280                   time2   <- liftIO $ getCPUTime
 281                   liftIO $ printTimes (fromIntegral (allocs2 - allocs1))
 282                                   (time2 - time1)
 283                   return a
 284
 285 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 286         -- defined in ghc/rts/Stats.c
 287
 288 printTimes :: Integer -> Integer -> IO ()
 289 printTimes allocs psecs
 290    = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
 291             secs_str = showFFloat (Just 2) secs
 292         putStrLn (showSDoc (
 293                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 294                          text (show allocs) <+> text "bytes")))
 295
 296 -----------------------------------------------------------------------------
 297 -- reverting CAFs
 298
 299 revertCAFs :: GHCi ()
 300 revertCAFs = do
 301   liftIO rts_revertCAFs
 302   s <- getGHCiState
 303   when (not (ghc_e s)) $ liftIO turnOffBuffering
 304         -- Have to turn off buffering again, because we just
 305         -- reverted stdout, stderr & stdin to their defaults.
 306
 307 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 308         -- Make it "safe", just in case
 309
 310 -----------------------------------------------------------------------------
 311 -- To flush buffers for the *interpreted* computation we need
 312 -- to refer to *its* stdout/stderr handles
 313
 314 GLOBAL_VAR(stdin_ptr,  error "no stdin_ptr",  Ptr ())
 315 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
 316 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
 317
 318 -- After various attempts, I believe this is the least bad way to do
 319 -- what we want.  We know look up the address of the static stdin,
 320 -- stdout, and stderr closures in the loaded base package, and each
 321 -- time we need to refer to them we cast the pointer to a Handle.
 322 -- This avoids any problems with the CAF having been reverted, because
 323 -- we'll always get the current value.
 324 --
 325 -- The previous attempt that didn't work was to compile an expression
 326 -- like "hSetBuffering stdout NoBuffering" into an expression of type
 327 -- IO () and run this expression each time we needed it, but the
 328 -- problem is that evaluating the expression might cache the contents
 329 -- of the Handle rather than referring to it from its static address
 330 -- each time.  There's no safe workaround for this.
 331
 332 initInterpBuffering :: Ghc ()
 333 initInterpBuffering = do -- make sure these are linked
 334     dflags <- GHC.getSessionDynFlags
 335     liftIO $ do
 336       initDynLinker dflags
 337
 338         -- ToDo: we should really look up these names properly, but
 339         -- it's a fiddle and not all the bits are exposed via the GHC
 340         -- interface.
 341       mb_stdin_ptr  <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
 342       mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
 343       mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
 344
 345       let f ref (Just ptr) = writeIORef ref ptr
 346           f _   Nothing    = panic "interactiveUI:setBuffering2"
 347       zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
 348                   [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
 349
 350 flushInterpBuffers :: GHCi ()
 351 flushInterpBuffers
 352  = liftIO $ do getHandle stdout_ptr >>= hFlush
 353                getHandle stderr_ptr >>= hFlush
 354
 355 turnOffBuffering :: IO ()
 356 turnOffBuffering
 357  = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
 358       mapM_ (\h -> hSetBuffering h NoBuffering) hdls
 359
 360 getHandle :: IORef (Ptr ()) -> IO Handle
 361 getHandle ref = do
 362   (Ptr addr) <- readIORef ref
 363   case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)