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