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