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