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