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