compiler/ghci/GhciMonad.hs

   1 module GhciMonad where
   2
   3 #include "HsVersions.h"
   4
   5 import qualified GHC
   6 import {-#SOURCE#-} Debugger
   7 import Breakpoints
   8 import Outputable
   9 import Panic hiding (showException)
  10 import Util
  11
  12 import Numeric
  13 import Control.Exception as Exception
  14 import Data.Char
  15 import Data.Dynamic
  16 import Data.Int         ( Int64 )
  17 import Data.IORef
  18 import Data.List
  19 import Data.Typeable
  20 import System.CPUTime
  21 import System.IO
  22 import Control.Monad as Monad
  23 import GHC.Exts
  24
  25 -----------------------------------------------------------------------------
  26 -- GHCi monad
  27
  28 data GHCiState = GHCiState
  29      {
  30         progname       :: String,
  31         args           :: [String],
  32         prompt         :: String,
  33         editor         :: String,
  34         session        :: GHC.Session,
  35         options        :: [GHCiOption],
  36         prelude        :: GHC.Module,
  37         bkptTable      :: IORef (BkptTable GHC.Module),
  38         topLevel       :: Bool
  39      }
  40
  41 data GHCiOption
  42         = ShowTiming            -- show time/allocs after evaluation
  43         | ShowType              -- show the type of expressions
  44         | RevertCAFs            -- revert CAFs after every evaluation
  45         deriving Eq
  46
  47 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
  48
  49 startGHCi :: GHCi a -> GHCiState -> IO a
  50 startGHCi g state = do ref <- newIORef state; unGHCi g ref
  51
  52 instance Monad GHCi where
  53   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
  54   return a  = GHCi $ \s -> return a
  55
  56 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
  57 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
  58    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
  59
  60 getGHCiState   = GHCi $ \r -> readIORef r
  61 setGHCiState s = GHCi $ \r -> writeIORef r s
  62
  63 -- for convenience...
  64 getSession = getGHCiState >>= return . session
  65 getPrelude = getGHCiState >>= return . prelude
  66
  67 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
  68 no_saved_sess = error "no saved_ses"
  69 saveSession = getSession >>= io . writeIORef saved_sess
  70 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
  71 restoreSession = readIORef saved_sess
  72
  73 getDynFlags = do
  74   s <- getSession
  75   io (GHC.getSessionDynFlags s)
  76 setDynFlags dflags = do
  77   s <- getSession
  78   io (GHC.setSessionDynFlags s dflags)
  79
  80 isOptionSet :: GHCiOption -> GHCi Bool
  81 isOptionSet opt
  82  = do st <- getGHCiState
  83       return (opt `elem` options st)
  84
  85 setOption :: GHCiOption -> GHCi ()
  86 setOption opt
  87  = do st <- getGHCiState
  88       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
  89
  90 unsetOption :: GHCiOption -> GHCi ()
  91 unsetOption opt
  92  = do st <- getGHCiState
  93       setGHCiState (st{ options = filter (/= opt) (options st) })
  94
  95 io :: IO a -> GHCi a
  96 io m = GHCi { unGHCi = \s -> m >>= return }
  97
  98 isTopLevel :: GHCi Bool
  99 isTopLevel = getGHCiState >>= return . topLevel
 100
 101 getBkptTable :: GHCi (BkptTable GHC.Module)
 102 getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
 103                   io$ readIORef table_ref
 104
 105 setBkptTable :: BkptTable GHC.Module -> GHCi ()
 106 setBkptTable new_table = do
 107     table_ref <- getGHCiState >>= return . bkptTable
 108     io$ writeIORef table_ref new_table
 109
 110 modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
 111 modifyBkptTable f = do
 112     bt <- getBkptTable
 113     new_bt <- io . evaluate$ f bt
 114     setBkptTable new_bt
 115
 116 showForUser :: SDoc -> GHCi String
 117 showForUser doc = do
 118   session <- getSession
 119   unqual <- io (GHC.getPrintUnqual session)
 120   return $! showSDocForUser unqual doc
 121
 122 -- --------------------------------------------------------------------------
 123 -- Inferior Sessions Exceptions (used by the debugger)
 124
 125 data InfSessionException =
 126              StopChildSession -- A child session requests to be stopped
 127            | ChildSessionStopped String  -- A child session has stopped
 128   deriving Typeable
 129
 130
 131 -- --------------------------------------------------------------------------
 132 -- timing & statistics
 133
 134 timeIt :: GHCi a -> GHCi a
 135 timeIt action
 136   = do b <- isOptionSet ShowTiming
 137        if not b
 138           then action
 139           else do allocs1 <- io $ getAllocations
 140                   time1   <- io $ getCPUTime
 141                   a <- action
 142                   allocs2 <- io $ getAllocations
 143                   time2   <- io $ getCPUTime
 144                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 145                                   (time2 - time1)
 146                   return a
 147
 148 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 149         -- defined in ghc/rts/Stats.c
 150
 151 printTimes :: Integer -> Integer -> IO ()
 152 printTimes allocs psecs
 153    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 154             secs_str = showFFloat (Just 2) secs
 155         putStrLn (showSDoc (
 156                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 157                          text (show allocs) <+> text "bytes")))
 158
 159 -----------------------------------------------------------------------------
 160 -- reverting CAFs
 161
 162 revertCAFs :: IO ()
 163 revertCAFs = do
 164   rts_revertCAFs
 165   turnOffBuffering
 166         -- Have to turn off buffering again, because we just
 167         -- reverted stdout, stderr & stdin to their defaults.
 168
 169 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 170         -- Make it "safe", just in case
 171
 172 -----------------------------------------------------------------------------
 173 -- To flush buffers for the *interpreted* computation we need
 174 -- to refer to *its* stdout/stderr handles
 175
 176 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 177 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 178
 179 command_sequence :: [String] -> String
 180 command_sequence = unwords . intersperse "Prelude.>>"
 181
 182 no_buffer :: String -> String
 183 no_buffer h = unwords ["System.IO.hSetBuffering",
 184                        "System.IO." ++ h,
 185                        "System.IO.NoBuffering"]
 186
 187 no_buf_cmd :: String
 188 no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
 189
 190 flush_buffer :: String -> String
 191 flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
 192
 193 flush_cmd :: String
 194 flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
 195
 196 initInterpBuffering :: GHC.Session -> IO ()
 197 initInterpBuffering session
 198  = do maybe_hval <- GHC.compileExpr session no_buf_cmd
 199
 200       case maybe_hval of
 201         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 202         other     -> panic "interactiveUI:setBuffering"
 203
 204       maybe_hval <- GHC.compileExpr session flush_cmd
 205       case maybe_hval of
 206         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 207         _         -> panic "interactiveUI:flush"
 208
 209       return ()
 210
 211
 212 flushInterpBuffers :: GHCi ()
 213 flushInterpBuffers
 214  = io $ do Monad.join (readIORef flush_interp)
 215            return ()
 216
 217 turnOffBuffering :: IO ()
 218 turnOffBuffering
 219  = do Monad.join (readIORef turn_off_buffering)
 220       return ()