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