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 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 115 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 116    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 117
 118 getGHCiState   = GHCi $ \r -> readIORef r
 119 setGHCiState s = GHCi $ \r -> writeIORef r s
 120
 121 -- for convenience...
 122 getSession = getGHCiState >>= return . session
 123 getPrelude = getGHCiState >>= return . prelude
 124
 125 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
 126 no_saved_sess = error "no saved_ses"
 127 saveSession = getSession >>= io . writeIORef saved_sess
 128 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
 129 restoreSession = readIORef saved_sess
 130
 131 getDynFlags = do
 132   s <- getSession
 133   io (GHC.getSessionDynFlags s)
 134 setDynFlags dflags = do
 135   s <- getSession
 136   io (GHC.setSessionDynFlags s dflags)
 137
 138 isOptionSet :: GHCiOption -> GHCi Bool
 139 isOptionSet opt
 140  = do st <- getGHCiState
 141       return (opt `elem` options st)
 142
 143 setOption :: GHCiOption -> GHCi ()
 144 setOption opt
 145  = do st <- getGHCiState
 146       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 147
 148 unsetOption :: GHCiOption -> GHCi ()
 149 unsetOption opt
 150  = do st <- getGHCiState
 151       setGHCiState (st{ options = filter (/= opt) (options st) })
 152
 153 io :: IO a -> GHCi a
 154 io m = GHCi { unGHCi = \s -> m >>= return }
 155
 156 printForUser :: SDoc -> GHCi ()
 157 printForUser doc = do
 158   session <- getSession
 159   unqual <- io (GHC.getPrintUnqual session)
 160   io $ Outputable.printForUser stdout unqual doc
 161
 162 -- --------------------------------------------------------------------------
 163 -- timing & statistics
 164
 165 timeIt :: GHCi a -> GHCi a
 166 timeIt action
 167   = do b <- isOptionSet ShowTiming
 168        if not b
 169           then action
 170           else do allocs1 <- io $ getAllocations
 171                   time1   <- io $ getCPUTime
 172                   a <- action
 173                   allocs2 <- io $ getAllocations
 174                   time2   <- io $ getCPUTime
 175                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 176                                   (time2 - time1)
 177                   return a
 178
 179 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 180         -- defined in ghc/rts/Stats.c
 181
 182 printTimes :: Integer -> Integer -> IO ()
 183 printTimes allocs psecs
 184    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 185             secs_str = showFFloat (Just 2) secs
 186         putStrLn (showSDoc (
 187                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 188                          text (show allocs) <+> text "bytes")))
 189
 190 -----------------------------------------------------------------------------
 191 -- reverting CAFs
 192
 193 revertCAFs :: IO ()
 194 revertCAFs = do
 195   rts_revertCAFs
 196   turnOffBuffering
 197         -- Have to turn off buffering again, because we just
 198         -- reverted stdout, stderr & stdin to their defaults.
 199
 200 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 201         -- Make it "safe", just in case
 202
 203 -----------------------------------------------------------------------------
 204 -- To flush buffers for the *interpreted* computation we need
 205 -- to refer to *its* stdout/stderr handles
 206
 207 GLOBAL_VAR(stdin_ptr,  error "no stdin_ptr",  Ptr ())
 208 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
 209 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
 210
 211 -- After various attempts, I believe this is the least bad way to do
 212 -- what we want.  We know look up the address of the static stdin,
 213 -- stdout, and stderr closures in the loaded base package, and each
 214 -- time we need to refer to them we cast the pointer to a Handle.
 215 -- This avoids any problems with the CAF having been reverted, because
 216 -- we'll always get the current value.
 217 --
 218 -- The previous attempt that didn't work was to compile an expression
 219 -- like "hSetBuffering stdout NoBuffering" into an expression of type
 220 -- IO () and run this expression each time we needed it, but the
 221 -- problem is that evaluating the expression might cache the contents
 222 -- of the Handle rather than referring to it from its static address
 223 -- each time.  There's no safe workaround for this.
 224
 225 initInterpBuffering :: GHC.Session -> IO ()
 226 initInterpBuffering session
 227  = do -- make sure these are linked
 228       mb_hval1 <- GHC.compileExpr session "System.IO.stdout"
 229       mb_hval2 <- GHC.compileExpr session "System.IO.stderr"
 230       mb_hval3 <- GHC.compileExpr session "System.IO.stdin"
 231       when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $
 232         panic "interactiveUI:setBuffering"
 233
 234         -- ToDo: we should really look up these names properly, but
 235         -- it's a fiddle and not all the bits are exposed via the GHC
 236         -- interface.
 237       mb_stdin_ptr  <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
 238       mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
 239       mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
 240
 241       let f ref (Just ptr) = writeIORef ref ptr
 242           f ref Nothing    = panic "interactiveUI:setBuffering2"
 243       zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
 244                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
 245       return ()
 246
 247 flushInterpBuffers :: GHCi ()
 248 flushInterpBuffers
 249  = io $ do getHandle stdout_ptr >>= hFlush
 250            getHandle stderr_ptr >>= hFlush
 251
 252 turnOffBuffering :: IO ()
 253 turnOffBuffering
 254  = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
 255       mapM_ (\h -> hSetBuffering h NoBuffering) hdls
 256
 257 getHandle :: IORef (Ptr ()) -> IO Handle
 258 getHandle ref = do
 259   (Ptr addr) <- readIORef ref
 260   case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)