compiler/ghci/GhciMonad.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Monadery code used in InteractiveUI
   4 --
   5 -- (c) The GHC Team 2005-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module GhciMonad where
  10
  11 #include "HsVersions.h"
  12
  13 import qualified GHC
  14 import Outputable       hiding (printForUser)
  15 import qualified Outputable
  16 import Panic            hiding (showException)
  17 import Util
  18 import DynFlags
  19 import HscTypes
  20 import SrcLoc
  21 import Module
  22 import ObjLink
  23
  24 import Data.Maybe
  25 import Numeric
  26 import Control.Exception as Exception
  27 import Data.Array
  28 import Data.Char
  29 import Data.Int         ( Int64 )
  30 import Data.IORef
  31 import Data.List
  32 import Data.Typeable
  33 import System.CPUTime
  34 import System.IO
  35 import Control.Monad as Monad
  36 import GHC.Exts
  37
  38 -----------------------------------------------------------------------------
  39 -- GHCi monad
  40
  41 data GHCiState = GHCiState
  42      {
  43         progname       :: String,
  44         args           :: [String],
  45         prompt         :: String,
  46         editor         :: String,
  47         stop           :: String,
  48         session        :: GHC.Session,
  49         options        :: [GHCiOption],
  50         prelude        :: GHC.Module,
  51         break_ctr      :: !Int,
  52         breaks         :: ![(Int, BreakLocation)],
  53         tickarrays     :: ModuleEnv TickArray,
  54                 -- tickarrays caches the TickArray for loaded modules,
  55                 -- so that we don't rebuild it each time the user sets
  56                 -- a breakpoint.
  57         cmdqueue       :: [String]
  58      }
  59
  60 type TickArray = Array Int [(BreakIndex,SrcSpan)]
  61
  62 data GHCiOption
  63         = ShowTiming            -- show time/allocs after evaluation
  64         | ShowType              -- show the type of expressions
  65         | RevertCAFs            -- revert CAFs after every evaluation
  66         deriving Eq
  67
  68 data BreakLocation
  69    = BreakLocation
  70    { breakModule :: !GHC.Module
  71    , breakLoc    :: !SrcSpan
  72    , breakTick   :: {-# UNPACK #-} !Int
  73    , onBreakCmd  :: String
  74    }
  75
  76 instance Eq BreakLocation where
  77   loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
  78                  breakTick loc1   == breakTick loc2
  79
  80 prettyLocations :: [(Int, BreakLocation)] -> SDoc
  81 prettyLocations []   = text "No active breakpoints."
  82 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
  83
  84 instance Outputable BreakLocation where
  85    ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
  86                 if null (onBreakCmd loc)
  87                    then empty
  88                    else doubleQuotes (text (onBreakCmd loc))
  89
  90 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
  91 recordBreak brkLoc = do
  92    st <- getGHCiState
  93    let oldActiveBreaks = breaks st
  94    -- don't store the same break point twice
  95    case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
  96      (nm:_) -> return (True, nm)
  97      [] -> do
  98       let oldCounter = break_ctr st
  99           newCounter = oldCounter + 1
 100       setGHCiState $ st { break_ctr = newCounter,
 101                           breaks = (oldCounter, brkLoc) : oldActiveBreaks
 102                         }
 103       return (False, oldCounter)
 104
 105 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 106
 107 startGHCi :: GHCi a -> GHCiState -> IO a
 108 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 109
 110 instance Monad GHCi where
 111   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 112   return a  = GHCi $ \s -> return a
 113
 114 instance Functor GHCi where
 115     fmap f m = m >>= return . f
 116
 117 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 118 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 119    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 120
 121 getGHCiState   = GHCi $ \r -> readIORef r
 122 setGHCiState s = GHCi $ \r -> writeIORef r s
 123
 124 -- for convenience...
 125 getSession = getGHCiState >>= return . session
 126 getPrelude = getGHCiState >>= return . prelude
 127
 128 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
 129 no_saved_sess = error "no saved_ses"
 130 saveSession = getSession >>= io . writeIORef saved_sess
 131 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
 132 restoreSession = readIORef saved_sess
 133
 134 getDynFlags = do
 135   s <- getSession
 136   io (GHC.getSessionDynFlags s)
 137 setDynFlags dflags = do
 138   s <- getSession
 139   io (GHC.setSessionDynFlags s dflags)
 140
 141 isOptionSet :: GHCiOption -> GHCi Bool
 142 isOptionSet opt
 143  = do st <- getGHCiState
 144       return (opt `elem` options st)
 145
 146 setOption :: GHCiOption -> GHCi ()
 147 setOption opt
 148  = do st <- getGHCiState
 149       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 150
 151 unsetOption :: GHCiOption -> GHCi ()
 152 unsetOption opt
 153  = do st <- getGHCiState
 154       setGHCiState (st{ options = filter (/= opt) (options st) })
 155
 156 io :: IO a -> GHCi a
 157 io m = GHCi { unGHCi = \s -> m >>= return }
 158
 159 printForUser :: SDoc -> GHCi ()
 160 printForUser doc = do
 161   session <- getSession
 162   unqual <- io (GHC.getPrintUnqual session)
 163   io $ Outputable.printForUser stdout unqual doc
 164
 165 -- --------------------------------------------------------------------------
 166 -- timing & statistics
 167
 168 timeIt :: GHCi a -> GHCi a
 169 timeIt action
 170   = do b <- isOptionSet ShowTiming
 171        if not b
 172           then action
 173           else do allocs1 <- io $ getAllocations
 174                   time1   <- io $ getCPUTime
 175                   a <- action
 176                   allocs2 <- io $ getAllocations
 177                   time2   <- io $ getCPUTime
 178                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 179                                   (time2 - time1)
 180                   return a
 181
 182 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 183         -- defined in ghc/rts/Stats.c
 184
 185 printTimes :: Integer -> Integer -> IO ()
 186 printTimes allocs psecs
 187    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 188             secs_str = showFFloat (Just 2) secs
 189         putStrLn (showSDoc (
 190                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 191                          text (show allocs) <+> text "bytes")))
 192
 193 -----------------------------------------------------------------------------
 194 -- reverting CAFs
 195
 196 revertCAFs :: IO ()
 197 revertCAFs = do
 198   rts_revertCAFs
 199   turnOffBuffering
 200         -- Have to turn off buffering again, because we just
 201         -- reverted stdout, stderr & stdin to their defaults.
 202
 203 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 204         -- Make it "safe", just in case
 205
 206 -----------------------------------------------------------------------------
 207 -- To flush buffers for the *interpreted* computation we need
 208 -- to refer to *its* stdout/stderr handles
 209
 210 GLOBAL_VAR(stdin_ptr,  error "no stdin_ptr",  Ptr ())
 211 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
 212 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
 213
 214 -- After various attempts, I believe this is the least bad way to do
 215 -- what we want.  We know look up the address of the static stdin,
 216 -- stdout, and stderr closures in the loaded base package, and each
 217 -- time we need to refer to them we cast the pointer to a Handle.
 218 -- This avoids any problems with the CAF having been reverted, because
 219 -- we'll always get the current value.
 220 --
 221 -- The previous attempt that didn't work was to compile an expression
 222 -- like "hSetBuffering stdout NoBuffering" into an expression of type
 223 -- IO () and run this expression each time we needed it, but the
 224 -- problem is that evaluating the expression might cache the contents
 225 -- of the Handle rather than referring to it from its static address
 226 -- each time.  There's no safe workaround for this.
 227
 228 initInterpBuffering :: GHC.Session -> IO ()
 229 initInterpBuffering session
 230  = do -- make sure these are linked
 231       mb_hval1 <- GHC.compileExpr session "System.IO.stdout"
 232       mb_hval2 <- GHC.compileExpr session "System.IO.stderr"
 233       mb_hval3 <- GHC.compileExpr session "System.IO.stdin"
 234       when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $
 235         panic "interactiveUI:setBuffering"
 236
 237         -- ToDo: we should really look up these names properly, but
 238         -- it's a fiddle and not all the bits are exposed via the GHC
 239         -- interface.
 240       mb_stdin_ptr  <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
 241       mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
 242       mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
 243
 244       let f ref (Just ptr) = writeIORef ref ptr
 245           f ref Nothing    = panic "interactiveUI:setBuffering2"
 246       zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
 247                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
 248       return ()
 249
 250 flushInterpBuffers :: GHCi ()
 251 flushInterpBuffers
 252  = io $ do getHandle stdout_ptr >>= hFlush
 253            getHandle stderr_ptr >>= hFlush
 254
 255 turnOffBuffering :: IO ()
 256 turnOffBuffering
 257  = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
 258       mapM_ (\h -> hSetBuffering h NoBuffering) hdls
 259
 260 getHandle :: IORef (Ptr ()) -> IO Handle
 261 getHandle ref = do
 262   (Ptr addr) <- readIORef ref
 263   case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)