compiler/ghci/GhciMonad.hs

   1 {-# OPTIONS -fno-cse #-}
   2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
   3
   4 -----------------------------------------------------------------------------
   5 --
   6 -- Monadery code used in InteractiveUI
   7 --
   8 -- (c) The GHC Team 2005-2006
   9 --
  10 -----------------------------------------------------------------------------
  11
  12 module GhciMonad where
  13
  14 #include "HsVersions.h"
  15
  16 import qualified GHC
  17 import Outputable       hiding (printForUser, printForUserPartWay)
  18 import qualified Outputable
  19 import Panic            hiding (showException)
  20 import Util
  21 import DynFlags
  22 import HscTypes
  23 import SrcLoc
  24 import Module
  25 import ObjLink
  26 import Linker
  27 import StaticFlags
  28 import MonadUtils       ( MonadIO, liftIO )
  29
  30 import Exception
  31 import Data.Maybe
  32 import Numeric
  33 import Data.Array
  34 import Data.Char
  35 import Data.Int         ( Int64 )
  36 import Data.IORef
  37 import Data.List
  38 import System.CPUTime
  39 import System.Directory
  40 import System.Environment
  41 import System.IO
  42 import Control.Monad as Monad
  43 import GHC.Exts
  44
  45 -----------------------------------------------------------------------------
  46 -- GHCi monad
  47
  48 type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String])
  49
  50 data GHCiState = GHCiState
  51      {
  52         progname       :: String,
  53         args           :: [String],
  54         prompt         :: String,
  55         editor         :: String,
  56         stop           :: String,
  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         -- ":" at the GHCi prompt repeats the last command, so we
  66         -- remember is here:
  67         last_command   :: Maybe Command,
  68         cmdqueue       :: [String],
  69         remembered_ctx :: [(CtxtCmd, [String], [String])],
  70              -- we remember the :module commands between :loads, so that
  71              -- on a :reload we can replay them.  See bugs #2049,
  72              -- \#1873, #1360. Previously we tried to remember modules that
  73              -- were supposed to be in the context but currently had errors,
  74              -- but this was complicated.  Just replaying the :module commands
  75              -- seems to be the right thing.
  76         virtual_path   :: FilePath,
  77         ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
  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 -> Ghc a }
 131
 132 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
 133 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
 134
 135 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
 136 reifyGHCi f = GHCi f'
 137   where
 138     -- f' :: IORef GHCiState -> Ghc a
 139     f' gs = reifyGhc (f'' gs)
 140     -- f'' :: IORef GHCiState -> Session -> IO a
 141     f'' gs s = f (s, gs)
 142
 143 startGHCi :: GHCi a -> GHCiState -> Ghc a
 144 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
 145
 146 instance Monad GHCi where
 147   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 148   return a  = GHCi $ \_ -> return a
 149
 150 instance Functor GHCi where
 151     fmap f m = m >>= return . f
 152
 153 ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
 154 ghciHandleGhcException = handleGhcException
 155
 156 getGHCiState :: GHCi GHCiState
 157 getGHCiState   = GHCi $ \r -> liftIO $ readIORef r
 158 setGHCiState :: GHCiState -> GHCi ()
 159 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
 160
 161 liftGhc :: Ghc a -> GHCi a
 162 liftGhc m = GHCi $ \_ -> m
 163
 164 instance MonadIO GHCi where
 165   liftIO m = liftGhc $ liftIO m
 166
 167 instance GhcMonad GHCi where
 168   setSession s' = liftGhc $ setSession s'
 169   getSession    = liftGhc $ getSession
 170
 171 instance ExceptionMonad GHCi where
 172   gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
 173   gbracket acq rel ib =
 174       GHCi $ \r -> gbracket (unGHCi acq r)
 175                             (\x -> unGHCi (rel x) r)
 176                             (\x -> unGHCi (ib x) r)
 177   gfinally th cu =
 178       GHCi $ \r -> gfinally (unGHCi th r) (unGHCi cu r)
 179
 180 instance WarnLogMonad GHCi where
 181   setWarnings warns = liftGhc $ setWarnings warns
 182   getWarnings = liftGhc $ getWarnings
 183
 184 -- for convenience...
 185 getPrelude :: GHCi Module
 186 getPrelude = getGHCiState >>= return . prelude
 187
 188 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
 189
 190 no_saved_sess :: Session
 191 no_saved_sess = error "no saved_ses"
 192
 193 saveSession :: GHCi ()
 194 saveSession =
 195     liftGhc $ do
 196       reifyGhc $ \s ->
 197         writeIORef saved_sess s
 198
 199 splatSavedSession :: GHCi ()
 200 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
 201
 202 -- restoreSession :: IO Session
 203 -- restoreSession = readIORef saved_sess
 204
 205 withRestoredSession :: Ghc a -> IO a
 206 withRestoredSession ghc = do
 207     s <- readIORef saved_sess
 208     reflectGhc ghc s
 209
 210 getDynFlags :: GHCi DynFlags
 211 getDynFlags = do
 212   GHC.getSessionDynFlags
 213
 214 setDynFlags :: DynFlags -> GHCi [PackageId]
 215 setDynFlags dflags = do
 216   GHC.setSessionDynFlags dflags
 217
 218 isOptionSet :: GHCiOption -> GHCi Bool
 219 isOptionSet opt
 220  = do st <- getGHCiState
 221       return (opt `elem` options st)
 222
 223 setOption :: GHCiOption -> GHCi ()
 224 setOption opt
 225  = do st <- getGHCiState
 226       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 227
 228 unsetOption :: GHCiOption -> GHCi ()
 229 unsetOption opt
 230  = do st <- getGHCiState
 231       setGHCiState (st{ options = filter (/= opt) (options st) })
 232
 233 io :: IO a -> GHCi a
 234 io = liftIO
 235
 236 printForUser :: SDoc -> GHCi ()
 237 printForUser doc = do
 238   unqual <- GHC.getPrintUnqual
 239   io $ Outputable.printForUser stdout unqual doc
 240
 241 printForUserPartWay :: SDoc -> GHCi ()
 242 printForUserPartWay doc = do
 243   unqual <- GHC.getPrintUnqual
 244   io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
 245
 246 withVirtualPath :: GHCi a -> GHCi a
 247 withVirtualPath m = do
 248   ghci_wd <- io getCurrentDirectory                -- Store the cwd of GHCi
 249   st  <- getGHCiState
 250   io$ setCurrentDirectory (virtual_path st)
 251   result <- m                                  -- Evaluate in the virtual wd..
 252   vwd <- io getCurrentDirectory
 253   setGHCiState (st{ virtual_path = vwd})       -- Update the virtual path
 254   io$ setCurrentDirectory ghci_wd                  -- ..and restore GHCi wd
 255   return result
 256
 257 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
 258 runStmt expr step = withVirtualPath$ do
 259   st <- getGHCiState
 260   reifyGHCi $ \x ->
 261     withProgName (progname st) $
 262     withArgs (args st) $
 263       reflectGHCi x $ do
 264         GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
 265                                         return GHC.RunFailed) $ do
 266           GHC.runStmt expr step
 267
 268 resume :: GHC.SingleStep -> GHCi GHC.RunResult
 269 resume step = withVirtualPath$ do
 270   GHC.resume step
 271
 272
 273 -- --------------------------------------------------------------------------
 274 -- timing & statistics
 275
 276 timeIt :: GHCi a -> GHCi a
 277 timeIt action
 278   = do b <- isOptionSet ShowTiming
 279        if not b
 280           then action
 281           else do allocs1 <- io $ getAllocations
 282                   time1   <- io $ getCPUTime
 283                   a <- action
 284                   allocs2 <- io $ getAllocations
 285                   time2   <- io $ getCPUTime
 286                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 287                                   (time2 - time1)
 288                   return a
 289
 290 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 291         -- defined in ghc/rts/Stats.c
 292
 293 printTimes :: Integer -> Integer -> IO ()
 294 printTimes allocs psecs
 295    = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
 296             secs_str = showFFloat (Just 2) secs
 297         putStrLn (showSDoc (
 298                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 299                          text (show allocs) <+> text "bytes")))
 300
 301 -----------------------------------------------------------------------------
 302 -- reverting CAFs
 303
 304 revertCAFs :: GHCi ()
 305 revertCAFs = do
 306   io $ rts_revertCAFs
 307   s <- getGHCiState
 308   when (not (ghc_e s)) $ io turnOffBuffering
 309         -- Have to turn off buffering again, because we just
 310         -- reverted stdout, stderr & stdin to their defaults.
 311
 312 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 313         -- Make it "safe", just in case
 314
 315 -----------------------------------------------------------------------------
 316 -- To flush buffers for the *interpreted* computation we need
 317 -- to refer to *its* stdout/stderr handles
 318
 319 GLOBAL_VAR(stdin_ptr,  error "no stdin_ptr",  Ptr ())
 320 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
 321 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
 322
 323 -- After various attempts, I believe this is the least bad way to do
 324 -- what we want.  We know look up the address of the static stdin,
 325 -- stdout, and stderr closures in the loaded base package, and each
 326 -- time we need to refer to them we cast the pointer to a Handle.
 327 -- This avoids any problems with the CAF having been reverted, because
 328 -- we'll always get the current value.
 329 --
 330 -- The previous attempt that didn't work was to compile an expression
 331 -- like "hSetBuffering stdout NoBuffering" into an expression of type
 332 -- IO () and run this expression each time we needed it, but the
 333 -- problem is that evaluating the expression might cache the contents
 334 -- of the Handle rather than referring to it from its static address
 335 -- each time.  There's no safe workaround for this.
 336
 337 initInterpBuffering :: Ghc ()
 338 initInterpBuffering = do -- make sure these are linked
 339     dflags <- GHC.getSessionDynFlags
 340     liftIO $ do
 341       initDynLinker dflags
 342
 343         -- ToDo: we should really look up these names properly, but
 344         -- it's a fiddle and not all the bits are exposed via the GHC
 345         -- interface.
 346       mb_stdin_ptr  <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
 347       mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
 348       mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
 349
 350       let f ref (Just ptr) = writeIORef ref ptr
 351           f _   Nothing    = panic "interactiveUI:setBuffering2"
 352       zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
 353                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
 354       return ()
 355
 356 flushInterpBuffers :: GHCi ()
 357 flushInterpBuffers
 358  = io $ do getHandle stdout_ptr >>= hFlush
 359            getHandle stderr_ptr >>= hFlush
 360
 361 turnOffBuffering :: IO ()
 362 turnOffBuffering
 363  = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
 364       mapM_ (\h -> hSetBuffering h NoBuffering) hdls
 365
 366 getHandle :: IORef (Ptr ()) -> IO Handle
 367 getHandle ref = do
 368   (Ptr addr) <- readIORef ref
 369   case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)