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