compiler/ghci/GhciMonad.hs

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