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