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