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