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
  23 import Numeric
  24 import Control.Concurrent
  25 import Control.Exception as Exception
  26 import Data.Array
  27 import Data.Char
  28 import Data.Int         ( Int64 )
  29 import Data.IORef
  30 import Data.List
  31 import Data.Typeable
  32 import System.CPUTime
  33 import System.IO
  34 import Control.Monad as Monad
  35 import GHC.Exts
  36
  37 -----------------------------------------------------------------------------
  38 -- GHCi monad
  39
  40 data GHCiState = GHCiState
  41      {
  42         progname       :: String,
  43         args           :: [String],
  44         prompt         :: String,
  45         editor         :: String,
  46         stop           :: String,
  47         session        :: GHC.Session,
  48         options        :: [GHCiOption],
  49         prelude        :: GHC.Module,
  50         breaks         :: !ActiveBreakPoints,
  51         tickarrays     :: ModuleEnv TickArray
  52                 -- tickarrays caches the TickArray for loaded modules,
  53                 -- so that we don't rebuild it each time the user sets
  54                 -- a breakpoint.
  55      }
  56
  57 type TickArray = Array Int [(BreakIndex,SrcSpan)]
  58
  59 data GHCiOption
  60         = ShowTiming            -- show time/allocs after evaluation
  61         | ShowType              -- show the type of expressions
  62         | RevertCAFs            -- revert CAFs after every evaluation
  63         deriving Eq
  64
  65 data ActiveBreakPoints
  66    = ActiveBreakPoints
  67    { breakCounter   :: !Int
  68    , breakLocations :: ![(Int, BreakLocation)]  -- break location uniquely numbered
  69    }
  70
  71 instance Outputable ActiveBreakPoints where
  72    ppr activeBrks = prettyLocations $ breakLocations activeBrks
  73
  74 emptyActiveBreakPoints :: ActiveBreakPoints
  75 emptyActiveBreakPoints
  76    = ActiveBreakPoints { breakCounter = 0, breakLocations = [] }
  77
  78 data BreakLocation
  79    = BreakLocation
  80    { breakModule :: !GHC.Module
  81    , breakLoc    :: !SrcSpan
  82    , breakTick   :: {-# UNPACK #-} !Int
  83    }
  84    deriving Eq
  85
  86 prettyLocations :: [(Int, BreakLocation)] -> SDoc
  87 prettyLocations []   = text "No active breakpoints."
  88 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
  89
  90 instance Outputable BreakLocation where
  91    ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
  92
  93 getActiveBreakPoints :: GHCi ActiveBreakPoints
  94 getActiveBreakPoints = liftM breaks getGHCiState
  95
  96 -- don't reset the counter back to zero?
  97 discardActiveBreakPoints :: GHCi ()
  98 discardActiveBreakPoints = do
  99    st <- getGHCiState
 100    let oldActiveBreaks = breaks st
 101        newActiveBreaks = oldActiveBreaks { breakLocations = [] }
 102    setGHCiState $ st { breaks = newActiveBreaks }
 103
 104 deleteBreak :: Int -> GHCi ()
 105 deleteBreak identity = do
 106    st <- getGHCiState
 107    let oldActiveBreaks = breaks st
 108        oldLocations    = breakLocations oldActiveBreaks
 109        newLocations    = filter (\loc -> fst loc /= identity) oldLocations
 110        newActiveBreaks = oldActiveBreaks { breakLocations = newLocations }
 111    setGHCiState $ st { breaks = newActiveBreaks }
 112
 113 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
 114 recordBreak brkLoc = do
 115    st <- getGHCiState
 116    let oldActiveBreaks = breaks st
 117    let oldLocations    = breakLocations oldActiveBreaks
 118    -- don't store the same break point twice
 119    case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
 120      (nm:_) -> return (True, nm)
 121      [] -> do
 122       let oldCounter = breakCounter oldActiveBreaks
 123           newCounter = oldCounter + 1
 124           newActiveBreaks =
 125              oldActiveBreaks
 126              { breakCounter   = newCounter
 127              , breakLocations = (oldCounter, brkLoc) : oldLocations
 128              }
 129       setGHCiState $ st { breaks = newActiveBreaks }
 130       return (False, oldCounter)
 131
 132 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 133
 134 startGHCi :: GHCi a -> GHCiState -> IO a
 135 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 136
 137 instance Monad GHCi where
 138   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 139   return a  = GHCi $ \s -> return a
 140
 141 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 142 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 143    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 144
 145 getGHCiState   = GHCi $ \r -> readIORef r
 146 setGHCiState s = GHCi $ \r -> writeIORef r s
 147
 148 -- for convenience...
 149 getSession = getGHCiState >>= return . session
 150 getPrelude = getGHCiState >>= return . prelude
 151
 152 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
 153 no_saved_sess = error "no saved_ses"
 154 saveSession = getSession >>= io . writeIORef saved_sess
 155 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
 156 restoreSession = readIORef saved_sess
 157
 158 getDynFlags = do
 159   s <- getSession
 160   io (GHC.getSessionDynFlags s)
 161 setDynFlags dflags = do
 162   s <- getSession
 163   io (GHC.setSessionDynFlags s dflags)
 164
 165 isOptionSet :: GHCiOption -> GHCi Bool
 166 isOptionSet opt
 167  = do st <- getGHCiState
 168       return (opt `elem` options st)
 169
 170 setOption :: GHCiOption -> GHCi ()
 171 setOption opt
 172  = do st <- getGHCiState
 173       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 174
 175 unsetOption :: GHCiOption -> GHCi ()
 176 unsetOption opt
 177  = do st <- getGHCiState
 178       setGHCiState (st{ options = filter (/= opt) (options st) })
 179
 180 io :: IO a -> GHCi a
 181 io m = GHCi { unGHCi = \s -> m >>= return }
 182
 183 printForUser :: SDoc -> GHCi ()
 184 printForUser doc = do
 185   session <- getSession
 186   unqual <- io (GHC.getPrintUnqual session)
 187   io $ Outputable.printForUser stdout unqual doc
 188
 189 -- --------------------------------------------------------------------------
 190 -- timing & statistics
 191
 192 timeIt :: GHCi a -> GHCi a
 193 timeIt action
 194   = do b <- isOptionSet ShowTiming
 195        if not b
 196           then action
 197           else do allocs1 <- io $ getAllocations
 198                   time1   <- io $ getCPUTime
 199                   a <- action
 200                   allocs2 <- io $ getAllocations
 201                   time2   <- io $ getCPUTime
 202                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 203                                   (time2 - time1)
 204                   return a
 205
 206 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 207         -- defined in ghc/rts/Stats.c
 208
 209 printTimes :: Integer -> Integer -> IO ()
 210 printTimes allocs psecs
 211    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 212             secs_str = showFFloat (Just 2) secs
 213         putStrLn (showSDoc (
 214                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 215                          text (show allocs) <+> text "bytes")))
 216
 217 -----------------------------------------------------------------------------
 218 -- reverting CAFs
 219
 220 revertCAFs :: IO ()
 221 revertCAFs = do
 222   rts_revertCAFs
 223   turnOffBuffering
 224         -- Have to turn off buffering again, because we just
 225         -- reverted stdout, stderr & stdin to their defaults.
 226
 227 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 228         -- Make it "safe", just in case
 229
 230 -----------------------------------------------------------------------------
 231 -- To flush buffers for the *interpreted* computation we need
 232 -- to refer to *its* stdout/stderr handles
 233
 234 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 235 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 236
 237 command_sequence :: [String] -> String
 238 command_sequence = unwords . intersperse "Prelude.>>"
 239
 240 no_buffer :: String -> String
 241 no_buffer h = unwords ["System.IO.hSetBuffering",
 242                        "System.IO." ++ h,
 243                        "System.IO.NoBuffering"]
 244
 245 no_buf_cmd :: String
 246 no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
 247
 248 flush_buffer :: String -> String
 249 flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
 250
 251 flush_cmd :: String
 252 flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
 253
 254 initInterpBuffering :: GHC.Session -> IO ()
 255 initInterpBuffering session
 256  = do -- we don't want to be fooled by any modules lying around in the current
 257       -- directory when we compile these code fragments, so set the import
 258       -- path to be empty while we compile them.
 259       dflags <- GHC.getSessionDynFlags session
 260       GHC.setSessionDynFlags session dflags{importPaths=[]}
 261
 262       maybe_hval <- GHC.compileExpr session no_buf_cmd
 263
 264       case maybe_hval of
 265         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 266         other     -> panic "interactiveUI:setBuffering"
 267
 268       maybe_hval <- GHC.compileExpr session flush_cmd
 269       case maybe_hval of
 270         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 271         _         -> panic "interactiveUI:flush"
 272
 273       GHC.setSessionDynFlags session dflags
 274       GHC.workingDirectoryChanged session
 275       return ()
 276
 277
 278 flushInterpBuffers :: GHCi ()
 279 flushInterpBuffers
 280  = io $ do Monad.join (readIORef flush_interp)
 281            return ()
 282
 283 turnOffBuffering :: IO ()
 284 turnOffBuffering
 285  = do Monad.join (readIORef turn_off_buffering)
 286       return ()