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            | StopParentSession -- A child session requests to be stopped
 128                                -- AND that the parent session quits after that
 129            | ChildSessionStopped String  -- A child session has stopped
 130   deriving Typeable
 131
 132
 133 -- --------------------------------------------------------------------------
 134 -- timing & statistics
 135
 136 timeIt :: GHCi a -> GHCi a
 137 timeIt action
 138   = do b <- isOptionSet ShowTiming
 139        if not b
 140           then action
 141           else do allocs1 <- io $ getAllocations
 142                   time1   <- io $ getCPUTime
 143                   a <- action
 144                   allocs2 <- io $ getAllocations
 145                   time2   <- io $ getCPUTime
 146                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 147                                   (time2 - time1)
 148                   return a
 149
 150 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 151         -- defined in ghc/rts/Stats.c
 152
 153 printTimes :: Integer -> Integer -> IO ()
 154 printTimes allocs psecs
 155    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 156             secs_str = showFFloat (Just 2) secs
 157         putStrLn (showSDoc (
 158                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 159                          text (show allocs) <+> text "bytes")))
 160
 161 -----------------------------------------------------------------------------
 162 -- reverting CAFs
 163
 164 revertCAFs :: IO ()
 165 revertCAFs = do
 166   rts_revertCAFs
 167   turnOffBuffering
 168         -- Have to turn off buffering again, because we just
 169         -- reverted stdout, stderr & stdin to their defaults.
 170
 171 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 172         -- Make it "safe", just in case
 173
 174 -----------------------------------------------------------------------------
 175 -- To flush buffers for the *interpreted* computation we need
 176 -- to refer to *its* stdout/stderr handles
 177
 178 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 179 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 180
 181 command_sequence :: [String] -> String
 182 command_sequence = unwords . intersperse "Prelude.>>"
 183
 184 no_buffer :: String -> String
 185 no_buffer h = unwords ["System.IO.hSetBuffering",
 186                        "System.IO." ++ h,
 187                        "System.IO.NoBuffering"]
 188
 189 no_buf_cmd :: String
 190 no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
 191
 192 flush_buffer :: String -> String
 193 flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
 194
 195 flush_cmd :: String
 196 flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
 197
 198 initInterpBuffering :: GHC.Session -> IO ()
 199 initInterpBuffering session
 200  = do maybe_hval <- GHC.compileExpr session no_buf_cmd
 201
 202       case maybe_hval of
 203         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 204         other     -> panic "interactiveUI:setBuffering"
 205
 206       maybe_hval <- GHC.compileExpr session flush_cmd
 207       case maybe_hval of
 208         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 209         _         -> panic "interactiveUI:flush"
 210
 211       return ()
 212
 213
 214 flushInterpBuffers :: GHCi ()
 215 flushInterpBuffers
 216  = io $ do Monad.join (readIORef flush_interp)
 217            return ()
 218
 219 turnOffBuffering :: IO ()
 220 turnOffBuffering
 221  = do Monad.join (readIORef turn_off_buffering)
 222       return ()