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         remembered_ctx :: Maybe ([Module],[Module])
  67                 -- modules we want to add to the context, but can't
  68                 -- because they currently have errors.  Set by :reload.
  69      }
  70
  71 type TickArray = Array Int [(BreakIndex,SrcSpan)]
  72
  73 data GHCiOption
  74         = ShowTiming            -- show time/allocs after evaluation
  75         | ShowType              -- show the type of expressions
  76         | RevertCAFs            -- revert CAFs after every evaluation
  77         deriving Eq
  78
  79 data BreakLocation
  80    = BreakLocation
  81    { breakModule :: !GHC.Module
  82    , breakLoc    :: !SrcSpan
  83    , breakTick   :: {-# UNPACK #-} !Int
  84    , onBreakCmd  :: String
  85    }
  86
  87 instance Eq BreakLocation where
  88   loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
  89                  breakTick loc1   == breakTick loc2
  90
  91 prettyLocations :: [(Int, BreakLocation)] -> SDoc
  92 prettyLocations []   = text "No active breakpoints."
  93 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
  94
  95 instance Outputable BreakLocation where
  96    ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
  97                 if null (onBreakCmd loc)
  98                    then empty
  99                    else doubleQuotes (text (onBreakCmd loc))
 100
 101 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
 102 recordBreak brkLoc = do
 103    st <- getGHCiState
 104    let oldActiveBreaks = breaks st
 105    -- don't store the same break point twice
 106    case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
 107      (nm:_) -> return (True, nm)
 108      [] -> do
 109       let oldCounter = break_ctr st
 110           newCounter = oldCounter + 1
 111       setGHCiState $ st { break_ctr = newCounter,
 112                           breaks = (oldCounter, brkLoc) : oldActiveBreaks
 113                         }
 114       return (False, oldCounter)
 115
 116 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 117
 118 startGHCi :: GHCi a -> GHCiState -> IO a
 119 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 120
 121 instance Monad GHCi where
 122   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 123   return a  = GHCi $ \s -> return a
 124
 125 instance Functor GHCi where
 126     fmap f m = m >>= return . f
 127
 128 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 129 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 130    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 131
 132 getGHCiState   = GHCi $ \r -> readIORef r
 133 setGHCiState s = GHCi $ \r -> writeIORef r s
 134
 135 -- for convenience...
 136 getSession = getGHCiState >>= return . session
 137 getPrelude = getGHCiState >>= return . prelude
 138
 139 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
 140 no_saved_sess = error "no saved_ses"
 141 saveSession = getSession >>= io . writeIORef saved_sess
 142 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
 143 restoreSession = readIORef saved_sess
 144
 145 getDynFlags = do
 146   s <- getSession
 147   io (GHC.getSessionDynFlags s)
 148 setDynFlags dflags = do
 149   s <- getSession
 150   io (GHC.setSessionDynFlags s dflags)
 151
 152 isOptionSet :: GHCiOption -> GHCi Bool
 153 isOptionSet opt
 154  = do st <- getGHCiState
 155       return (opt `elem` options st)
 156
 157 setOption :: GHCiOption -> GHCi ()
 158 setOption opt
 159  = do st <- getGHCiState
 160       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 161
 162 unsetOption :: GHCiOption -> GHCi ()
 163 unsetOption opt
 164  = do st <- getGHCiState
 165       setGHCiState (st{ options = filter (/= opt) (options st) })
 166
 167 io :: IO a -> GHCi a
 168 io m = GHCi { unGHCi = \s -> m >>= return }
 169
 170 printForUser :: SDoc -> GHCi ()
 171 printForUser doc = do
 172   session <- getSession
 173   unqual <- io (GHC.getPrintUnqual session)
 174   io $ Outputable.printForUser stdout unqual doc
 175
 176 printForUserPartWay :: SDoc -> GHCi ()
 177 printForUserPartWay doc = do
 178   session <- getSession
 179   unqual <- io (GHC.getPrintUnqual session)
 180   io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
 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(stdin_ptr,  error "no stdin_ptr",  Ptr ())
 228 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
 229 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
 230
 231 -- After various attempts, I believe this is the least bad way to do
 232 -- what we want.  We know look up the address of the static stdin,
 233 -- stdout, and stderr closures in the loaded base package, and each
 234 -- time we need to refer to them we cast the pointer to a Handle.
 235 -- This avoids any problems with the CAF having been reverted, because
 236 -- we'll always get the current value.
 237 --
 238 -- The previous attempt that didn't work was to compile an expression
 239 -- like "hSetBuffering stdout NoBuffering" into an expression of type
 240 -- IO () and run this expression each time we needed it, but the
 241 -- problem is that evaluating the expression might cache the contents
 242 -- of the Handle rather than referring to it from its static address
 243 -- each time.  There's no safe workaround for this.
 244
 245 initInterpBuffering :: GHC.Session -> IO ()
 246 initInterpBuffering session
 247  = do -- make sure these are linked
 248       mb_hval1 <- GHC.compileExpr session "System.IO.stdout"
 249       mb_hval2 <- GHC.compileExpr session "System.IO.stderr"
 250       mb_hval3 <- GHC.compileExpr session "System.IO.stdin"
 251       when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $
 252         panic "interactiveUI:setBuffering"
 253
 254         -- ToDo: we should really look up these names properly, but
 255         -- it's a fiddle and not all the bits are exposed via the GHC
 256         -- interface.
 257       mb_stdin_ptr  <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
 258       mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
 259       mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
 260
 261       let f ref (Just ptr) = writeIORef ref ptr
 262           f ref Nothing    = panic "interactiveUI:setBuffering2"
 263       zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
 264                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
 265       return ()
 266
 267 flushInterpBuffers :: GHCi ()
 268 flushInterpBuffers
 269  = io $ do getHandle stdout_ptr >>= hFlush
 270            getHandle stderr_ptr >>= hFlush
 271
 272 turnOffBuffering :: IO ()
 273 turnOffBuffering
 274  = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
 275       mapM_ (\h -> hSetBuffering h NoBuffering) hdls
 276
 277 getHandle :: IORef (Ptr ()) -> IO Handle
 278 getHandle ref = do
 279   (Ptr addr) <- readIORef ref
 280   case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)