compiler/ghci/GhciMonad.hs

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