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