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