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      }
  37
  38 data GHCiOption
  39         = ShowTiming            -- show time/allocs after evaluation
  40         | ShowType              -- show the type of expressions
  41         | RevertCAFs            -- revert CAFs after every evaluation
  42         deriving Eq
  43
  44 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
  45
  46 startGHCi :: GHCi a -> GHCiState -> IO a
  47 startGHCi g state = do ref <- newIORef state; unGHCi g ref
  48
  49 instance Monad GHCi where
  50   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
  51   return a  = GHCi $ \s -> return a
  52
  53 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
  54 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
  55    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
  56
  57 getGHCiState   = GHCi $ \r -> readIORef r
  58 setGHCiState s = GHCi $ \r -> writeIORef r s
  59
  60 -- for convenience...
  61 getSession = getGHCiState >>= return . session
  62 getPrelude = getGHCiState >>= return . prelude
  63
  64 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
  65 no_saved_sess = error "no saved_ses"
  66 saveSession = getSession >>= io . writeIORef saved_sess
  67 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
  68 restoreSession = readIORef saved_sess
  69
  70 getDynFlags = do
  71   s <- getSession
  72   io (GHC.getSessionDynFlags s)
  73 setDynFlags dflags = do
  74   s <- getSession
  75   io (GHC.setSessionDynFlags s dflags)
  76
  77 isOptionSet :: GHCiOption -> GHCi Bool
  78 isOptionSet opt
  79  = do st <- getGHCiState
  80       return (opt `elem` options st)
  81
  82 setOption :: GHCiOption -> GHCi ()
  83 setOption opt
  84  = do st <- getGHCiState
  85       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
  86
  87 unsetOption :: GHCiOption -> GHCi ()
  88 unsetOption opt
  89  = do st <- getGHCiState
  90       setGHCiState (st{ options = filter (/= opt) (options st) })
  91
  92 io :: IO a -> GHCi a
  93 io m = GHCi { unGHCi = \s -> m >>= return }
  94
  95 showForUser :: SDoc -> GHCi String
  96 showForUser doc = do
  97   session <- getSession
  98   unqual <- io (GHC.getPrintUnqual session)
  99   return $! showSDocForUser unqual doc
 100
 101 -----------------------------------------------------------------------------
 102 -- User code exception handling
 103
 104 -- This is the exception handler for exceptions generated by the
 105 -- user's code and exceptions coming from children sessions;
 106 -- it normally just prints out the exception.  The
 107 -- handler must be recursive, in case showing the exception causes
 108 -- more exceptions to be raised.
 109 --
 110 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
 111 -- raising another exception.  We therefore don't put the recursive
 112 -- handler arond the flushing operation, so if stderr is closed
 113 -- GHCi will just die gracefully rather than going into an infinite loop.
 114 handler exception = do
 115   flushInterpBuffers
 116   io installSignalHandlers
 117   ghciHandle handler (showException exception >> return False)
 118
 119 showException (DynException dyn) =
 120   case fromDynamic dyn of
 121     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 122     Just Interrupted      -> io (putStrLn "Interrupted.")
 123     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 124     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 125     Just other_ghc_ex     -> io (print other_ghc_ex)
 126
 127 showException other_exception
 128   = io (putStrLn ("*** Exception: " ++ show other_exception))
 129
 130 -----------------------------------------------------------------------------
 131 -- recursive exception handlers
 132
 133 -- Don't forget to unblock async exceptions in the handler, or if we're
 134 -- in an exception loop (eg. let a = error a in a) the ^C exception
 135 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 136
 137 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 138 ghciHandle h (GHCi m) = GHCi $ \s ->
 139    Exception.catch (m s)
 140         (\e -> unGHCi (ghciUnblock (h e)) s)
 141
 142 ghciUnblock :: GHCi a -> GHCi a
 143 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 144
 145 -----------------------------------------------------------------------------
 146 -- timing & statistics
 147
 148 timeIt :: GHCi a -> GHCi a
 149 timeIt action
 150   = do b <- isOptionSet ShowTiming
 151        if not b
 152           then action
 153           else do allocs1 <- io $ getAllocations
 154                   time1   <- io $ getCPUTime
 155                   a <- action
 156                   allocs2 <- io $ getAllocations
 157                   time2   <- io $ getCPUTime
 158                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 159                                   (time2 - time1)
 160                   return a
 161
 162 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 163         -- defined in ghc/rts/Stats.c
 164
 165 printTimes :: Integer -> Integer -> IO ()
 166 printTimes allocs psecs
 167    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 168             secs_str = showFFloat (Just 2) secs
 169         putStrLn (showSDoc (
 170                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 171                          text (show allocs) <+> text "bytes")))
 172
 173 -----------------------------------------------------------------------------
 174 -- reverting CAFs
 175
 176 revertCAFs :: IO ()
 177 revertCAFs = do
 178   rts_revertCAFs
 179   turnOffBuffering
 180         -- Have to turn off buffering again, because we just
 181         -- reverted stdout, stderr & stdin to their defaults.
 182
 183 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 184         -- Make it "safe", just in case
 185
 186 -----------------------------------------------------------------------------
 187 -- To flush buffers for the *interpreted* computation we need
 188 -- to refer to *its* stdout/stderr handles
 189
 190 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 191 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 192
 193 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
 194              " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
 195 flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush System.IO.stderr"
 196
 197 initInterpBuffering :: Session -> IO ()
 198 initInterpBuffering session
 199  = do maybe_hval <- GHC.compileExpr session no_buf_cmd
 200
 201       case maybe_hval of
 202         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 203         other     -> panic "interactiveUI:setBuffering"
 204
 205       maybe_hval <- GHC.compileExpr session flush_cmd
 206       case maybe_hval of
 207         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 208         _         -> panic "interactiveUI:flush"
 209
 210       return ()
 211
 212
 213 flushInterpBuffers :: GHCi ()
 214 flushInterpBuffers
 215  = io $ do Monad.join (readIORef flush_interp)
 216            return ()
 217
 218 turnOffBuffering :: IO ()
 219 turnOffBuffering
 220  = do Monad.join (readIORef turn_off_buffering)
 221       return ()