compiler/ghci/GhciMonad.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Monadery code used in InteractiveUI
   4 --
   5 -- (c) The GHC Team 2005-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 {-# OPTIONS_GHC -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
  14 -- for details
  15
  16 module GhciMonad where
  17
  18 #include "HsVersions.h"
  19
  20 import qualified GHC
  21 import Outputable       hiding (printForUser)
  22 import qualified Outputable
  23 import Panic            hiding (showException)
  24 import Util
  25 import DynFlags
  26 import HscTypes
  27 import SrcLoc
  28 import Module
  29 import ObjLink
  30
  31 import Data.Maybe
  32 import Numeric
  33 import Control.Exception as Exception
  34 import Data.Array
  35 import Data.Char
  36 import Data.Int         ( Int64 )
  37 import Data.IORef
  38 import Data.List
  39 import Data.Typeable
  40 import System.CPUTime
  41 import System.IO
  42 import Control.Monad as Monad
  43 import GHC.Exts
  44
  45 -----------------------------------------------------------------------------
  46 -- GHCi monad
  47
  48 data GHCiState = GHCiState
  49      {
  50         progname       :: String,
  51         args           :: [String],
  52         prompt         :: String,
  53         editor         :: String,
  54         stop           :: String,
  55         session        :: GHC.Session,
  56         options        :: [GHCiOption],
  57         prelude        :: GHC.Module,
  58         break_ctr      :: !Int,
  59         breaks         :: ![(Int, BreakLocation)],
  60         tickarrays     :: ModuleEnv TickArray,
  61                 -- tickarrays caches the TickArray for loaded modules,
  62                 -- so that we don't rebuild it each time the user sets
  63                 -- a breakpoint.
  64         cmdqueue       :: [String]
  65      }
  66
  67 type TickArray = Array Int [(BreakIndex,SrcSpan)]
  68
  69 data GHCiOption
  70         = ShowTiming            -- show time/allocs after evaluation
  71         | ShowType              -- show the type of expressions
  72         | RevertCAFs            -- revert CAFs after every evaluation
  73         deriving Eq
  74
  75 data BreakLocation
  76    = BreakLocation
  77    { breakModule :: !GHC.Module
  78    , breakLoc    :: !SrcSpan
  79    , breakTick   :: {-# UNPACK #-} !Int
  80    , onBreakCmd  :: String
  81    }
  82
  83 instance Eq BreakLocation where
  84   loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
  85                  breakTick loc1   == breakTick loc2
  86
  87 prettyLocations :: [(Int, BreakLocation)] -> SDoc
  88 prettyLocations []   = text "No active breakpoints."
  89 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
  90
  91 instance Outputable BreakLocation where
  92    ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
  93                 if null (onBreakCmd loc)
  94                    then empty
  95                    else doubleQuotes (text (onBreakCmd loc))
  96
  97 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
  98 recordBreak brkLoc = do
  99    st <- getGHCiState
 100    let oldActiveBreaks = breaks st
 101    -- don't store the same break point twice
 102    case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
 103      (nm:_) -> return (True, nm)
 104      [] -> do
 105       let oldCounter = break_ctr st
 106           newCounter = oldCounter + 1
 107       setGHCiState $ st { break_ctr = newCounter,
 108                           breaks = (oldCounter, brkLoc) : oldActiveBreaks
 109                         }
 110       return (False, oldCounter)
 111
 112 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 113
 114 startGHCi :: GHCi a -> GHCiState -> IO a
 115 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 116
 117 instance Monad GHCi where
 118   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 119   return a  = GHCi $ \s -> return a
 120
 121 instance Functor GHCi where
 122     fmap f m = m >>= return . f
 123
 124 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 125 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 126    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 127
 128 getGHCiState   = GHCi $ \r -> readIORef r
 129 setGHCiState s = GHCi $ \r -> writeIORef r s
 130
 131 -- for convenience...
 132 getSession = getGHCiState >>= return . session
 133 getPrelude = getGHCiState >>= return . prelude
 134
 135 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
 136 no_saved_sess = error "no saved_ses"
 137 saveSession = getSession >>= io . writeIORef saved_sess
 138 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
 139 restoreSession = readIORef saved_sess
 140
 141 getDynFlags = do
 142   s <- getSession
 143   io (GHC.getSessionDynFlags s)
 144 setDynFlags dflags = do
 145   s <- getSession
 146   io (GHC.setSessionDynFlags s dflags)
 147
 148 isOptionSet :: GHCiOption -> GHCi Bool
 149 isOptionSet opt
 150  = do st <- getGHCiState
 151       return (opt `elem` options st)
 152
 153 setOption :: GHCiOption -> GHCi ()
 154 setOption opt
 155  = do st <- getGHCiState
 156       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 157
 158 unsetOption :: GHCiOption -> GHCi ()
 159 unsetOption opt
 160  = do st <- getGHCiState
 161       setGHCiState (st{ options = filter (/= opt) (options st) })
 162
 163 io :: IO a -> GHCi a
 164 io m = GHCi { unGHCi = \s -> m >>= return }
 165
 166 printForUser :: SDoc -> GHCi ()
 167 printForUser doc = do
 168   session <- getSession
 169   unqual <- io (GHC.getPrintUnqual session)
 170   io $ Outputable.printForUser stdout unqual doc
 171
 172 -- --------------------------------------------------------------------------
 173 -- timing & statistics
 174
 175 timeIt :: GHCi a -> GHCi a
 176 timeIt action
 177   = do b <- isOptionSet ShowTiming
 178        if not b
 179           then action
 180           else do allocs1 <- io $ getAllocations
 181                   time1   <- io $ getCPUTime
 182                   a <- action
 183                   allocs2 <- io $ getAllocations
 184                   time2   <- io $ getCPUTime
 185                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 186                                   (time2 - time1)
 187                   return a
 188
 189 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 190         -- defined in ghc/rts/Stats.c
 191
 192 printTimes :: Integer -> Integer -> IO ()
 193 printTimes allocs psecs
 194    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 195             secs_str = showFFloat (Just 2) secs
 196         putStrLn (showSDoc (
 197                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 198                          text (show allocs) <+> text "bytes")))
 199
 200 -----------------------------------------------------------------------------
 201 -- reverting CAFs
 202
 203 revertCAFs :: IO ()
 204 revertCAFs = do
 205   rts_revertCAFs
 206   turnOffBuffering
 207         -- Have to turn off buffering again, because we just
 208         -- reverted stdout, stderr & stdin to their defaults.
 209
 210 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 211         -- Make it "safe", just in case
 212
 213 -----------------------------------------------------------------------------
 214 -- To flush buffers for the *interpreted* computation we need
 215 -- to refer to *its* stdout/stderr handles
 216
 217 GLOBAL_VAR(stdin_ptr,  error "no stdin_ptr",  Ptr ())
 218 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
 219 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
 220
 221 -- After various attempts, I believe this is the least bad way to do
 222 -- what we want.  We know look up the address of the static stdin,
 223 -- stdout, and stderr closures in the loaded base package, and each
 224 -- time we need to refer to them we cast the pointer to a Handle.
 225 -- This avoids any problems with the CAF having been reverted, because
 226 -- we'll always get the current value.
 227 --
 228 -- The previous attempt that didn't work was to compile an expression
 229 -- like "hSetBuffering stdout NoBuffering" into an expression of type
 230 -- IO () and run this expression each time we needed it, but the
 231 -- problem is that evaluating the expression might cache the contents
 232 -- of the Handle rather than referring to it from its static address
 233 -- each time.  There's no safe workaround for this.
 234
 235 initInterpBuffering :: GHC.Session -> IO ()
 236 initInterpBuffering session
 237  = do -- make sure these are linked
 238       mb_hval1 <- GHC.compileExpr session "System.IO.stdout"
 239       mb_hval2 <- GHC.compileExpr session "System.IO.stderr"
 240       mb_hval3 <- GHC.compileExpr session "System.IO.stdin"
 241       when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $
 242         panic "interactiveUI:setBuffering"
 243
 244         -- ToDo: we should really look up these names properly, but
 245         -- it's a fiddle and not all the bits are exposed via the GHC
 246         -- interface.
 247       mb_stdin_ptr  <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
 248       mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
 249       mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
 250
 251       let f ref (Just ptr) = writeIORef ref ptr
 252           f ref Nothing    = panic "interactiveUI:setBuffering2"
 253       zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
 254                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
 255       return ()
 256
 257 flushInterpBuffers :: GHCi ()
 258 flushInterpBuffers
 259  = io $ do getHandle stdout_ptr >>= hFlush
 260            getHandle stderr_ptr >>= hFlush
 261
 262 turnOffBuffering :: IO ()
 263 turnOffBuffering
 264  = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
 265       mapM_ (\h -> hSetBuffering h NoBuffering) hdls
 266
 267 getHandle :: IORef (Ptr ()) -> IO Handle
 268 getHandle ref = do
 269   (Ptr addr) <- readIORef ref
 270   case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)