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