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   gblock (GHCi m)   = GHCi $ \r -> gblock (m r)
 174   gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
 175
 176 instance WarnLogMonad GHCi where
 177   setWarnings warns = liftGhc $ setWarnings warns
 178   getWarnings = liftGhc $ getWarnings
 179
 180 -- for convenience...
 181 getPrelude :: GHCi Module
 182 getPrelude = getGHCiState >>= return . prelude
 183
 184 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
 185
 186 no_saved_sess :: Session
 187 no_saved_sess = error "no saved_ses"
 188
 189 saveSession :: GHCi ()
 190 saveSession =
 191     liftGhc $ do
 192       reifyGhc $ \s ->
 193         writeIORef saved_sess s
 194
 195 splatSavedSession :: GHCi ()
 196 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
 197
 198 -- restoreSession :: IO Session
 199 -- restoreSession = readIORef saved_sess
 200
 201 withRestoredSession :: Ghc a -> IO a
 202 withRestoredSession ghc = do
 203     s <- readIORef saved_sess
 204     reflectGhc ghc s
 205
 206 getDynFlags :: GHCi DynFlags
 207 getDynFlags = do
 208   GHC.getSessionDynFlags
 209
 210 setDynFlags :: DynFlags -> GHCi [PackageId]
 211 setDynFlags dflags = do
 212   GHC.setSessionDynFlags dflags
 213
 214 isOptionSet :: GHCiOption -> GHCi Bool
 215 isOptionSet opt
 216  = do st <- getGHCiState
 217       return (opt `elem` options st)
 218
 219 setOption :: GHCiOption -> GHCi ()
 220 setOption opt
 221  = do st <- getGHCiState
 222       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 223
 224 unsetOption :: GHCiOption -> GHCi ()
 225 unsetOption opt
 226  = do st <- getGHCiState
 227       setGHCiState (st{ options = filter (/= opt) (options st) })
 228
 229 io :: IO a -> GHCi a
 230 io = liftIO
 231
 232 printForUser :: SDoc -> GHCi ()
 233 printForUser doc = do
 234   unqual <- GHC.getPrintUnqual
 235   io $ Outputable.printForUser stdout unqual doc
 236
 237 printForUserPartWay :: SDoc -> GHCi ()
 238 printForUserPartWay doc = do
 239   unqual <- GHC.getPrintUnqual
 240   io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
 241
 242 withVirtualPath :: GHCi a -> GHCi a
 243 withVirtualPath m = do
 244   ghci_wd <- io getCurrentDirectory                -- Store the cwd of GHCi
 245   st  <- getGHCiState
 246   io$ setCurrentDirectory (virtual_path st)
 247   result <- m                                  -- Evaluate in the virtual wd..
 248   vwd <- io getCurrentDirectory
 249   setGHCiState (st{ virtual_path = vwd})       -- Update the virtual path
 250   io$ setCurrentDirectory ghci_wd                  -- ..and restore GHCi wd
 251   return result
 252
 253 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
 254 runStmt expr step = withVirtualPath$ do
 255   st <- getGHCiState
 256   reifyGHCi $ \x ->
 257     withProgName (progname st) $
 258     withArgs (args st) $
 259       reflectGHCi x $ do
 260         GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
 261                                         return GHC.RunFailed) $ do
 262           GHC.runStmt expr step
 263
 264 resume :: GHC.SingleStep -> GHCi GHC.RunResult
 265 resume step = withVirtualPath$ do
 266   GHC.resume step
 267
 268
 269 -- --------------------------------------------------------------------------
 270 -- timing & statistics
 271
 272 timeIt :: GHCi a -> GHCi a
 273 timeIt action
 274   = do b <- isOptionSet ShowTiming
 275        if not b
 276           then action
 277           else do allocs1 <- io $ getAllocations
 278                   time1   <- io $ getCPUTime
 279                   a <- action
 280                   allocs2 <- io $ getAllocations
 281                   time2   <- io $ getCPUTime
 282                   io $ printTimes (fromIntegral (allocs2 - allocs1))
 283                                   (time2 - time1)
 284                   return a
 285
 286 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
 287         -- defined in ghc/rts/Stats.c
 288
 289 printTimes :: Integer -> Integer -> IO ()
 290 printTimes allocs psecs
 291    = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
 292             secs_str = showFFloat (Just 2) secs
 293         putStrLn (showSDoc (
 294                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 295                          text (show allocs) <+> text "bytes")))
 296
 297 -----------------------------------------------------------------------------
 298 -- reverting CAFs
 299
 300 revertCAFs :: GHCi ()
 301 revertCAFs = do
 302   io $ rts_revertCAFs
 303   s <- getGHCiState
 304   when (not (ghc_e s)) $ io turnOffBuffering
 305         -- Have to turn off buffering again, because we just
 306         -- reverted stdout, stderr & stdin to their defaults.
 307
 308 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 309         -- Make it "safe", just in case
 310
 311 -----------------------------------------------------------------------------
 312 -- To flush buffers for the *interpreted* computation we need
 313 -- to refer to *its* stdout/stderr handles
 314
 315 GLOBAL_VAR(stdin_ptr,  error "no stdin_ptr",  Ptr ())
 316 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
 317 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
 318
 319 -- After various attempts, I believe this is the least bad way to do
 320 -- what we want.  We know look up the address of the static stdin,
 321 -- stdout, and stderr closures in the loaded base package, and each
 322 -- time we need to refer to them we cast the pointer to a Handle.
 323 -- This avoids any problems with the CAF having been reverted, because
 324 -- we'll always get the current value.
 325 --
 326 -- The previous attempt that didn't work was to compile an expression
 327 -- like "hSetBuffering stdout NoBuffering" into an expression of type
 328 -- IO () and run this expression each time we needed it, but the
 329 -- problem is that evaluating the expression might cache the contents
 330 -- of the Handle rather than referring to it from its static address
 331 -- each time.  There's no safe workaround for this.
 332
 333 initInterpBuffering :: Ghc ()
 334 initInterpBuffering = do -- make sure these are linked
 335     dflags <- GHC.getSessionDynFlags
 336     liftIO $ do
 337       initDynLinker dflags
 338
 339         -- ToDo: we should really look up these names properly, but
 340         -- it's a fiddle and not all the bits are exposed via the GHC
 341         -- interface.
 342       mb_stdin_ptr  <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
 343       mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
 344       mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
 345
 346       let f ref (Just ptr) = writeIORef ref ptr
 347           f _   Nothing    = panic "interactiveUI:setBuffering2"
 348       zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
 349                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
 350       return ()
 351
 352 flushInterpBuffers :: GHCi ()
 353 flushInterpBuffers
 354  = io $ do getHandle stdout_ptr >>= hFlush
 355            getHandle stderr_ptr >>= hFlush
 356
 357 turnOffBuffering :: IO ()
 358 turnOffBuffering
 359  = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
 360       mapM_ (\h -> hSetBuffering h NoBuffering) hdls
 361
 362 getHandle :: IORef (Ptr ()) -> IO Handle
 363 getHandle ref = do
 364   (Ptr addr) <- readIORef ref
 365   case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)