module GHCi
(
evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
, resumeStmt
, abandonStmt
, evalIO
, evalString
, evalStringToIOString
, mallocData
, mkCostCentre
, costCentreStackInfo
, newBreakArray
, enableBreakpoint
, breakpointStatus
, initObjLinker
, lookupSymbol
, lookupClosure
, loadDLL
, loadArchive
, loadObj
, unloadObj
, addLibrarySearchPath
, removeLibrarySearchPath
, resolveObjs
, findSystemLibrary
, iservCmd, Message(..), withIServ, stopIServ
, iservCall, readIServ, writeIServ
, purgeLookupSymbolCache
, freeHValueRefs
, mkFinalizedHValue
, wormhole, wormholeRef
, mkEvalOpts
, fromEvalResult
) where
import GHCi.Message
import GHCi.Run
import GHCi.RemoteTypes
import GHCi.BreakArray (BreakArray)
import HscTypes
import UniqFM
import Panic
import DynFlags
#ifndef mingw32_HOST_OS
import ErrUtils
import Outputable
#endif
import Exception
import BasicTypes
import FastString
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.Binary
import Data.ByteString (ByteString)
import Data.IORef
import Foreign
import Foreign.C
import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Exit
#ifndef mingw32_HOST_OS
import Data.Maybe
import System.Posix as Posix
#endif
import System.Process
iservCmd :: Binary a => HscEnv -> Message a -> IO a
iservCmd hsc_env@HscEnv{..} msg
| gopt Opt_ExternalInterpreter hsc_dflags =
withIServ hsc_env $ \iserv ->
uninterruptibleMask_ $ do
iservCall iserv msg
| otherwise =
run msg
withIServ
:: (MonadIO m, ExceptionMonad m)
=> HscEnv -> (IServ -> m a) -> m a
withIServ HscEnv{..} action =
gmask $ \restore -> do
m <- liftIO $ takeMVar hsc_iserv
iserv <- maybe (liftIO $ startIServ hsc_dflags) return m
`gonException` (liftIO $ putMVar hsc_iserv Nothing)
let iserv' = iserv{ iservPendingFrees = [] }
a <- (do
liftIO $ when (not (null (iservPendingFrees iserv))) $
iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))
restore $ action iserv)
`gonException` (liftIO $ putMVar hsc_iserv (Just iserv'))
liftIO $ putMVar hsc_iserv (Just iserv')
return a
evalStmt
:: HscEnv -> Bool -> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt hsc_env step foreign_expr = do
let dflags = hsc_dflags hsc_env
status <- withExpr foreign_expr $ \expr ->
iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr)
handleEvalStatus hsc_env status
where
withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr (EvalThis fhv) cont =
withForeignRef fhv $ \hvref -> cont (EvalThis hvref)
withExpr (EvalApp fl fr) cont =
withExpr fl $ \fl' ->
withExpr fr $ \fr' ->
cont (EvalApp fl' fr')
resumeStmt
:: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
resumeStmt hsc_env step resume_ctxt = do
let dflags = hsc_dflags hsc_env
status <- withForeignRef resume_ctxt $ \rhv ->
iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)
handleEvalStatus hsc_env status
abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt hsc_env resume_ctxt = do
withForeignRef resume_ctxt $ \rhv ->
iservCmd hsc_env (AbandonStmt rhv)
handleEvalStatus
:: HscEnv -> EvalStatus [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
handleEvalStatus hsc_env status =
case status of
EvalBreak a b c d e f -> return (EvalBreak a b c d e f)
EvalComplete alloc res ->
EvalComplete alloc <$> addFinalizer res
where
addFinalizer (EvalException e) = return (EvalException e)
addFinalizer (EvalSuccess rs) = do
EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs
evalIO :: HscEnv -> ForeignHValue -> IO ()
evalIO hsc_env fhv = do
liftIO $ withForeignRef fhv $ \fhv ->
iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult
evalString :: HscEnv -> ForeignHValue -> IO String
evalString hsc_env fhv = do
liftIO $ withForeignRef fhv $ \fhv ->
iservCmd hsc_env (EvalString fhv) >>= fromEvalResult
evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String
evalStringToIOString hsc_env fhv str = do
liftIO $ withForeignRef fhv $ \fhv ->
iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult
mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())
mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)
mkCostCentre
:: HscEnv -> RemotePtr CChar -> String -> String -> IO (RemotePtr CostCentre)
mkCostCentre hsc_env c_module name src =
iservCmd hsc_env (MkCostCentre c_module name src)
costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
costCentreStackInfo hsc_env ccs =
iservCmd hsc_env (CostCentreStackInfo ccs)
newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)
newBreakArray hsc_env size = do
breakArray <- iservCmd hsc_env (NewBreakArray size)
mkFinalizedHValue hsc_env breakArray
enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()
enableBreakpoint hsc_env ref ix b = do
withForeignRef ref $ \breakarray ->
iservCmd hsc_env (EnableBreakpoint breakarray ix b)
breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
breakpointStatus hsc_env ref ix = do
withForeignRef ref $ \breakarray ->
iservCmd hsc_env (BreakpointStatus breakarray ix)
initObjLinker :: HscEnv -> IO ()
initObjLinker hsc_env = iservCmd hsc_env InitLinker
lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol hsc_env@HscEnv{..} str
| gopt Opt_ExternalInterpreter hsc_dflags =
withIServ hsc_env $ \iserv@IServ{..} -> do
cache <- readIORef iservLookupSymbolCache
case lookupUFM cache str of
Just p -> return (Just p)
Nothing -> do
m <- uninterruptibleMask_ $
iservCall iserv (LookupSymbol (unpackFS str))
case m of
Nothing -> return Nothing
Just r -> do
let p = fromRemotePtr r
writeIORef iservLookupSymbolCache $! addToUFM cache str p
return (Just p)
| otherwise =
fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
lookupClosure hsc_env str =
iservCmd hsc_env (LookupClosure str)
purgeLookupSymbolCache :: HscEnv -> IO ()
purgeLookupSymbolCache hsc_env@HscEnv{..} =
when (gopt Opt_ExternalInterpreter hsc_dflags) $
withIServ hsc_env $ \IServ{..} ->
writeIORef iservLookupSymbolCache emptyUFM
loadDLL :: HscEnv -> String -> IO (Maybe String)
loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str)
loadArchive :: HscEnv -> String -> IO ()
loadArchive hsc_env str = iservCmd hsc_env (LoadArchive str)
loadObj :: HscEnv -> String -> IO ()
loadObj hsc_env str = iservCmd hsc_env (LoadObj str)
unloadObj :: HscEnv -> String -> IO ()
unloadObj hsc_env str = iservCmd hsc_env (UnloadObj str)
addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())
addLibrarySearchPath hsc_env str =
fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)
removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
removeLibrarySearchPath hsc_env p =
iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))
resolveObjs :: HscEnv -> IO SuccessFlag
resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs
findSystemLibrary :: HscEnv -> String -> IO (Maybe String)
findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)
iservCall :: Binary a => IServ -> Message a -> IO a
iservCall iserv@IServ{..} msg =
remoteCall iservPipe msg
`catch` \(e :: SomeException) -> handleIServFailure iserv e
readIServ :: IServ -> Get a -> IO a
readIServ iserv@IServ{..} get =
readPipe iservPipe get
`catch` \(e :: SomeException) -> handleIServFailure iserv e
writeIServ :: IServ -> Put -> IO ()
writeIServ iserv@IServ{..} put =
writePipe iservPipe put
`catch` \(e :: SomeException) -> handleIServFailure iserv e
handleIServFailure :: IServ -> SomeException -> IO a
handleIServFailure IServ{..} e = do
ex <- getProcessExitCode iservProcess
case ex of
Just (ExitFailure n) ->
throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
_ -> do
terminateProcess iservProcess
_ <- waitForProcess iservProcess
throw e
startIServ :: DynFlags -> IO IServ
#ifdef mingw32_HOST_OS
startIServ _ = panic "startIServ"
#else
startIServ dflags = do
let flavour
| WayProf `elem` ways dflags = "-prof"
| WayDyn `elem` ways dflags = "-dyn"
| otherwise = ""
prog = pgm_i dflags ++ flavour
opts = getOpts dflags opt_i
debugTraceMsg dflags 3 $ text "Starting " <> text prog
(rfd1, wfd1) <- Posix.createPipe
(rfd2, wfd2) <- Posix.createPipe
setFdOption rfd1 CloseOnExec True
setFdOption wfd2 CloseOnExec True
let args = show wfd1 : show rfd2 : opts
(_, _, _, ph) <- createProcess (proc prog args)
closeFd wfd1
closeFd rfd2
rh <- fdToHandle rfd1
wh <- fdToHandle wfd2
lo_ref <- newIORef Nothing
cache_ref <- newIORef emptyUFM
return $ IServ
{ iservPipe = Pipe { pipeRead = rh
, pipeWrite = wh
, pipeLeftovers = lo_ref }
, iservProcess = ph
, iservLookupSymbolCache = cache_ref
, iservPendingFrees = []
}
#endif
stopIServ :: HscEnv -> IO ()
#ifdef mingw32_HOST_OS
stopIServ _ = return ()
#else
stopIServ HscEnv{..} =
gmask $ \_restore -> do
m <- takeMVar hsc_iserv
maybe (return ()) stop m
putMVar hsc_iserv Nothing
where
stop iserv = do
ex <- getProcessExitCode (iservProcess iserv)
if isJust ex
then return ()
else iservCall iserv Shutdown
#endif
mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free
where
!external = gopt Opt_ExternalInterpreter hsc_dflags
hvref = toHValueRef rref
free :: IO ()
free
| not external = freeRemoteRef hvref
| otherwise =
modifyMVar_ hsc_iserv $ \mb_iserv ->
case mb_iserv of
Nothing -> return Nothing
Just iserv@IServ{..} ->
return (Just iserv{iservPendingFrees = hvref : iservPendingFrees})
freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
freeHValueRefs _ [] = return ()
freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
wormhole :: DynFlags -> ForeignRef a -> IO a
wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)
wormholeRef :: DynFlags -> RemoteRef a -> IO a
wormholeRef dflags r
| gopt Opt_ExternalInterpreter dflags
= throwIO (InstallationError
"this operation requires -fno-external-interpreter")
| otherwise
= localRef r
mkEvalOpts :: DynFlags -> Bool -> EvalOpts
mkEvalOpts dflags step =
EvalOpts
{ useSandboxThread = gopt Opt_GhciSandbox dflags
, singleStep = step
, breakOnException = gopt Opt_BreakOnException dflags
, breakOnError = gopt Opt_BreakOnError dflags }
fromEvalResult :: EvalResult a -> IO a
fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
fromEvalResult (EvalSuccess a) = return a