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