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 -- User code exception handling
 123
 124 -- This hierarchy of exceptions is used to signal interruption of a child session
 125 data BkptException = StopChildSession -- A child debugging session requests to be stopped
 126                    | ChildSessionStopped String
 127   deriving Typeable
 128
 129 -- This is the exception handler for exceptions generated by the
 130 -- user's code and exceptions coming from children sessions;
 131 -- it normally just prints out the exception.  The
 132 -- handler must be recursive, in case showing the exception causes
 133 -- more exceptions to be raised.
 134 --
 135 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
 136 -- raising another exception.  We therefore don't put the recursive
 137 -- handler arond the flushing operation, so if stderr is closed
 138 -- GHCi will just die gracefully rather than going into an infinite loop.
 139 handler :: Exception -> GHCi Bool
 140 handler (DynException dyn)
 141   | Just StopChildSession <- fromDynamic dyn
 142  -- propagate to the parent session
 143   = ASSERTM (liftM not isTopLevel) >> throwDyn StopChildSession
 144
 145   | Just (ChildSessionStopped msg) <- fromDynamic dyn
 146  -- Revert CAFs and display some message
 147   = ASSERTM (isTopLevel) >>
 148     io (revertCAFs >> putStrLn msg) >>
 149     return False
 150
 151 handler exception = do
 152   flushInterpBuffers
 153   io installSignalHandlers
 154   ghciHandle handler (showException exception >> return False)
 155
 156 showException (DynException dyn) =
 157   case fromDynamic dyn of
 158     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 159     Just Interrupted      -> io (putStrLn "Interrupted.")
 160     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 161     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 162     Just other_ghc_ex     -> io (print other_ghc_ex)
 163
 164 showException other_exception
 165   = io (putStrLn ("*** Exception: " ++ show other_exception))
 166
 167 -----------------------------------------------------------------------------
 168 -- recursive exception handlers
 169
 170 -- Don't forget to unblock async exceptions in the handler, or if we're
 171 -- in an exception loop (eg. let a = error a in a) the ^C exception
 172 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 173
 174 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 175 ghciHandle h (GHCi m) = GHCi $ \s ->
 176    Exception.catch (m s)
 177         (\e -> unGHCi (ghciUnblock (h e)) s)
 178
 179 ghciUnblock :: GHCi a -> GHCi a
 180 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 181
 182 -----------------------------------------------------------------------------
 183 -- timing & statistics
 184
 185 timeIt :: GHCi a -> GHCi a
 186 timeIt action
 187   = do b <- isOptionSet ShowTiming
 188        if not b
 189           then action
 190           else do allocs1 <- io $ getAllocations
 191                   time1   <- io $ getCPUTime
 192                   a <- action
 193                   allocs2 <- io $ getAllocations
 194                   time2   <- io $ getCPUTime
 195                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 196                                   (time2 - time1)
 197                   return a
 198
 199 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 200         -- defined in ghc/rts/Stats.c
 201
 202 printTimes :: Integer -> Integer -> IO ()
 203 printTimes allocs psecs
 204    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 205             secs_str = showFFloat (Just 2) secs
 206         putStrLn (showSDoc (
 207                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 208                          text (show allocs) <+> text "bytes")))
 209
 210 -----------------------------------------------------------------------------
 211 -- reverting CAFs
 212
 213 revertCAFs :: IO ()
 214 revertCAFs = do
 215   rts_revertCAFs
 216   turnOffBuffering
 217         -- Have to turn off buffering again, because we just
 218         -- reverted stdout, stderr & stdin to their defaults.
 219
 220 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 221         -- Make it "safe", just in case
 222
 223 -----------------------------------------------------------------------------
 224 -- To flush buffers for the *interpreted* computation we need
 225 -- to refer to *its* stdout/stderr handles
 226
 227 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 228 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 229
 230 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
 231              " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
 232 flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush System.IO.stderr"
 233
 234 initInterpBuffering :: Session -> IO ()
 235 initInterpBuffering session
 236  = do maybe_hval <- GHC.compileExpr session no_buf_cmd
 237
 238       case maybe_hval of
 239         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 240         other     -> panic "interactiveUI:setBuffering"
 241
 242       maybe_hval <- GHC.compileExpr session flush_cmd
 243       case maybe_hval of
 244         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 245         _         -> panic "interactiveUI:flush"
 246
 247       return ()
 248
 249
 250 flushInterpBuffers :: GHCi ()
 251 flushInterpBuffers
 252  = io $ do Monad.join (readIORef flush_interp)
 253            return ()
 254
 255 turnOffBuffering :: IO ()
 256 turnOffBuffering
 257  = do Monad.join (readIORef turn_off_buffering)
 258       return ()