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