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