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         session        :: GHC.Session,
  47         options        :: [GHCiOption],
  48         prelude        :: GHC.Module,
  49         resume         :: [(SrcSpan, ThreadId, GHC.ResumeHandle)],
  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 popResume :: GHCi (Maybe (SrcSpan, ThreadId, GHC.ResumeHandle))
 184 popResume = do
 185    st <- getGHCiState
 186    case (resume st) of
 187       []     -> return Nothing
 188       (x:xs) -> do setGHCiState $ st { resume = xs } ; return (Just x)
 189
 190 pushResume :: SrcSpan -> ThreadId -> GHC.ResumeHandle -> GHCi ()
 191 pushResume span threadId resumeAction = do
 192    st <- getGHCiState
 193    let oldResume = resume st
 194    setGHCiState $ st { resume = (span, threadId, resumeAction) : oldResume }
 195
 196 discardResumeContext :: GHCi ()
 197 discardResumeContext = do
 198    st <- getGHCiState
 199    setGHCiState st { resume = [] }
 200
 201 printForUser :: SDoc -> GHCi ()
 202 printForUser doc = do
 203   session <- getSession
 204   unqual <- io (GHC.getPrintUnqual session)
 205   io $ Outputable.printForUser stdout unqual doc
 206
 207 -- --------------------------------------------------------------------------
 208 -- timing & statistics
 209
 210 timeIt :: GHCi a -> GHCi a
 211 timeIt action
 212   = do b <- isOptionSet ShowTiming
 213        if not b
 214           then action
 215           else do allocs1 <- io $ getAllocations
 216                   time1   <- io $ getCPUTime
 217                   a <- action
 218                   allocs2 <- io $ getAllocations
 219                   time2   <- io $ getCPUTime
 220                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 221                                   (time2 - time1)
 222                   return a
 223
 224 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 225         -- defined in ghc/rts/Stats.c
 226
 227 printTimes :: Integer -> Integer -> IO ()
 228 printTimes allocs psecs
 229    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 230             secs_str = showFFloat (Just 2) secs
 231         putStrLn (showSDoc (
 232                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 233                          text (show allocs) <+> text "bytes")))
 234
 235 -----------------------------------------------------------------------------
 236 -- reverting CAFs
 237
 238 revertCAFs :: IO ()
 239 revertCAFs = do
 240   rts_revertCAFs
 241   turnOffBuffering
 242         -- Have to turn off buffering again, because we just
 243         -- reverted stdout, stderr & stdin to their defaults.
 244
 245 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 246         -- Make it "safe", just in case
 247
 248 -----------------------------------------------------------------------------
 249 -- To flush buffers for the *interpreted* computation we need
 250 -- to refer to *its* stdout/stderr handles
 251
 252 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 253 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 254
 255 command_sequence :: [String] -> String
 256 command_sequence = unwords . intersperse "Prelude.>>"
 257
 258 no_buffer :: String -> String
 259 no_buffer h = unwords ["System.IO.hSetBuffering",
 260                        "System.IO." ++ h,
 261                        "System.IO.NoBuffering"]
 262
 263 no_buf_cmd :: String
 264 no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
 265
 266 flush_buffer :: String -> String
 267 flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
 268
 269 flush_cmd :: String
 270 flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
 271
 272 initInterpBuffering :: GHC.Session -> IO ()
 273 initInterpBuffering session
 274  = do -- we don't want to be fooled by any modules lying around in the current
 275       -- directory when we compile these code fragments, so set the import
 276       -- path to be empty while we compile them.
 277       dflags <- GHC.getSessionDynFlags session
 278       GHC.setSessionDynFlags session dflags{importPaths=[]}
 279
 280       maybe_hval <- GHC.compileExpr session no_buf_cmd
 281
 282       case maybe_hval of
 283         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 284         other     -> panic "interactiveUI:setBuffering"
 285
 286       maybe_hval <- GHC.compileExpr session flush_cmd
 287       case maybe_hval of
 288         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 289         _         -> panic "interactiveUI:flush"
 290
 291       GHC.setSessionDynFlags session dflags
 292       GHC.workingDirectoryChanged session
 293       return ()
 294
 295
 296 flushInterpBuffers :: GHCi ()
 297 flushInterpBuffers
 298  = io $ do Monad.join (readIORef flush_interp)
 299            return ()
 300
 301 turnOffBuffering :: IO ()
 302 turnOffBuffering
 303  = do Monad.join (readIORef turn_off_buffering)
 304       return ()