diff --git a/GHCi/BreakArray.hs b/GHCi/BreakArray.hs --- a/GHCi/BreakArray.hs +++ b/GHCi/BreakArray.hs @@ -19,14 +19,17 @@ module GHCi.BreakArray ( BreakArray +#ifdef GHCI (BA) -- constructor is exported only for ByteCodeGen , newBreakArray , getBreak , setBreakOn , setBreakOff , showBreakArray +#endif ) where +#ifdef GHCI import Control.Monad import Data.Word import GHC.Word @@ -112,3 +115,6 @@ readBreakArray :: BreakArray -> Int -> IO Word8 readBreakArray (BA array) (I# i) = readBA# array i +#else +data BreakArray +#endif diff --git a/GHCi/CreateBCO.hs b/GHCi/CreateBCO.hs --- a/GHCi/CreateBCO.hs +++ b/GHCi/CreateBCO.hs @@ -10,6 +10,7 @@ -- (c) The University of Glasgow 2002-2006 -- +-- | Create real byte-code objects from 'ResolvedBCO's. module GHCi.CreateBCO (createBCOs) where import GHCi.ResolvedBCO diff --git a/GHCi/InfoTable.hsc b/GHCi/InfoTable.hsc --- a/GHCi/InfoTable.hsc +++ b/GHCi/InfoTable.hsc @@ -6,9 +6,11 @@ -- We use the RTS data structures directly via hsc2hs. -- module GHCi.InfoTable - ( mkConInfoTable - , peekItbl, StgInfoTable(..) + ( peekItbl, StgInfoTable(..) , conInfoPtr +#ifdef GHCI + , mkConInfoTable +#endif ) where #if !defined(TABLES_NEXT_TO_CODE) @@ -20,6 +22,66 @@ import GHC.Exts import System.IO.Unsafe +type ItblCodes = Either [Word8] [Word32] + +-- Get definitions for the structs, constants & config etc. +#include "Rts.h" + +-- Ultra-minimalist version specially for constructors +#if SIZEOF_VOID_P == 8 +type HalfWord = Word32 +#elif SIZEOF_VOID_P == 4 +type HalfWord = Word16 +#else +#error Uknown SIZEOF_VOID_P +#endif + +type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) + +data StgInfoTable = StgInfoTable { + entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode + ptrs :: HalfWord, + nptrs :: HalfWord, + tipe :: HalfWord, + srtlen :: HalfWord, + code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode + } + +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable +peekItbl a0 = do +#if defined(TABLES_NEXT_TO_CODE) + let entry' = Nothing +#else + entry' <- Just <$> (#peek StgInfoTable, entry) a0 +#endif + ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0 + nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0 + tipe' <- (#peek StgInfoTable, type) a0 + srtlen' <- (#peek StgInfoTable, srt_bitmap) a0 + return StgInfoTable + { entry = entry' + , ptrs = ptrs' + , nptrs = nptrs' + , tipe = tipe' + , srtlen = srtlen' + , code = Nothing + } + +-- | Convert a pointer to an StgConInfo into an info pointer that can be +-- used in the header of a closure. +conInfoPtr :: Ptr () -> Ptr () +conInfoPtr ptr + | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable) + | otherwise = ptr + +ghciTablesNextToCode :: Bool +#ifdef TABLES_NEXT_TO_CODE +ghciTablesNextToCode = True +#else +ghciTablesNextToCode = False +#endif + +#ifdef GHCI /* To end */ mkConInfoTable :: Int -- ptr words -> Int -- non-ptr words @@ -52,8 +114,6 @@ -- ----------------------------------------------------------------------------- -- Building machine code fragments for a constructor's entry code -type ItblCodes = Either [Word8] [Word32] - funPtrToInt :: FunPtr a -> Int funPtrToInt (FunPtr a) = I## (addr2Int## a) @@ -280,9 +340,6 @@ -- ----------------------------------------------------------------------------- -- read & write intfo tables --- Get definitions for the structs, constants & config etc. -#include "Rts.h" - -- entry point for direct returns for created constr itbls foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr @@ -302,31 +359,12 @@ , stg_interp_constr6_entry , stg_interp_constr7_entry ] --- Ultra-minimalist version specially for constructors -#if SIZEOF_VOID_P == 8 -type HalfWord = Word32 -#elif SIZEOF_VOID_P == 4 -type HalfWord = Word16 -#else -#error Uknown SIZEOF_VOID_P -#endif - data StgConInfoTable = StgConInfoTable { conDesc :: Ptr Word8, infoTable :: StgInfoTable } -type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) -data StgInfoTable = StgInfoTable { - entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode - ptrs :: HalfWord, - nptrs :: HalfWord, - tipe :: HalfWord, - srtlen :: HalfWord, - code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode - } - pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable -> IO () @@ -364,26 +402,6 @@ Just (Right xs) -> pokeArray code_offset xs #endif -peekItbl :: Ptr StgInfoTable -> IO StgInfoTable -peekItbl a0 = do -#if defined(TABLES_NEXT_TO_CODE) - let entry' = Nothing -#else - entry' <- Just <$> (#peek StgInfoTable, entry) a0 -#endif - ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0 - nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0 - tipe' <- (#peek StgInfoTable, type) a0 - srtlen' <- (#peek StgInfoTable, srt_bitmap) a0 - return StgInfoTable - { entry = entry' - , ptrs = ptrs' - , nptrs = nptrs' - , tipe = tipe' - , srtlen = srtlen' - , code = Nothing - } - newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ()) newExecConItbl obj con_desc = alloca $ \pcode -> do @@ -408,13 +426,6 @@ foreign import ccall unsafe "flushExec" _flushExec :: CUInt -> Ptr a -> IO () --- | Convert a pointer to an StgConInfo into an info pointer that can be --- used in the header of a closure. -conInfoPtr :: Ptr () -> Ptr () -conInfoPtr ptr - | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable) - | otherwise = ptr - -- ----------------------------------------------------------------------------- -- Constants and config @@ -443,10 +454,4 @@ cONSTR :: Int -- Defined in ClosureTypes.h cONSTR = (#const CONSTR) - -ghciTablesNextToCode :: Bool -#ifdef TABLES_NEXT_TO_CODE -ghciTablesNextToCode = True -#else -ghciTablesNextToCode = False -#endif +#endif /* GHCI */ diff --git a/GHCi/Message.hs b/GHCi/Message.hs --- a/GHCi/Message.hs +++ b/GHCi/Message.hs @@ -1,16 +1,26 @@ -{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, - GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-} +{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables, + GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, + CPP #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} +-- | +-- Remote GHCi message types and serialization. +-- +-- For details on Remote GHCi, see Note [Remote GHCi] in +-- compiler/ghci/GHCi.hs. +-- module GHCi.Message ( Message(..), Msg(..) + , THMessage(..), THMsg(..) + , QResult(..) , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..) , SerializableException(..) + , toSerializableException, fromSerializableException , THResult(..), THResultType(..) , ResumeContext(..) , QState(..) - , getMessage, putMessage - , Pipe(..), remoteCall, readPipe, writePipe + , getMessage, putMessage, getTHMessage, putTHMessage + , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe ) where import GHCi.RemoteTypes @@ -20,6 +30,8 @@ import GHCi.BreakArray import GHC.LanguageExtensions +import GHC.ForeignSrcLang +import GHC.Fingerprint import Control.Concurrent import Control.Exception import Data.Binary @@ -29,10 +41,18 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Dynamic +#if MIN_VERSION_base(4,10,0) +-- Previously this was re-exported by Data.Dynamic +import Data.Typeable (TypeRep) +#endif import Data.IORef import Data.Map (Map) import GHC.Generics +#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS +#else +import GHC.Stack as GHC.Stack.CCS +#endif import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import System.Exit @@ -42,7 +62,8 @@ -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server --- | A @Message a@ is a message that returns a value of type @a@ +-- | A @Message a@ is a message that returns a value of type @a@. +-- These are requests sent from GHC to the server. data Message a where -- | Exit the iserv process Shutdown :: Message () @@ -65,11 +86,17 @@ -- Interpreter ------------------------------------------- -- | Create a set of BCO objects, and return HValueRefs to them + -- Note: Each ByteString contains a Binary-encoded [ResolvedBCO], not + -- a ResolvedBCO. The list is to allow us to serialise the ResolvedBCOs + -- in parallel. See @createBCOs@ in compiler/ghci/GHCi.hsc. CreateBCOs :: [LB.ByteString] -> Message [HValueRef] -- | Release 'HValueRef's FreeHValueRefs :: [HValueRef] -> Message () + -- | Add entries to the Static Pointer Table + AddSptEntry :: Fingerprint -> HValueRef -> Message () + -- | Malloc some data and return a 'RemotePtr' to it MallocData :: ByteString -> Message (RemotePtr ()) MallocStrings :: [ByteString] -> Message [RemotePtr ()] @@ -158,6 +185,8 @@ -> Message (Maybe HValueRef) -- Template Haskell ------------------------------------------- + -- For more details on how TH works with Remote GHCi, see + -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. -- | Start a new TH module, return a state token that should be StartTH :: Message (RemoteRef (IORef QState)) @@ -174,45 +203,110 @@ -> HValueRef {- e.g. TH.Q TH.Exp -} -> THResultType -> Maybe TH.Loc - -> Message ByteString {- e.g. TH.Exp -} - - -- Template Haskell Quasi monad operations - NewName :: String -> Message (THResult TH.Name) - Report :: Bool -> String -> Message (THResult ()) - LookupName :: Bool -> String -> Message (THResult (Maybe TH.Name)) - Reify :: TH.Name -> Message (THResult TH.Info) - ReifyFixity :: TH.Name -> Message (THResult (Maybe TH.Fixity)) - ReifyInstances :: TH.Name -> [TH.Type] -> Message (THResult [TH.Dec]) - ReifyRoles :: TH.Name -> Message (THResult [TH.Role]) - ReifyAnnotations :: TH.AnnLookup -> TypeRep -> Message (THResult [ByteString]) - ReifyModule :: TH.Module -> Message (THResult TH.ModuleInfo) - ReifyConStrictness :: TH.Name -> Message (THResult [TH.DecidedStrictness]) + -> Message (QResult ByteString) -- | Run the given mod finalizers. RunModFinalizers :: RemoteRef (IORef QState) -> [RemoteRef (TH.Q ())] - -> Message (THResult ()) + -> Message (QResult ()) - AddDependentFile :: FilePath -> Message (THResult ()) - AddModFinalizer :: RemoteRef (TH.Q ()) -> Message (THResult ()) - AddTopDecls :: [TH.Dec] -> Message (THResult ()) - IsExtEnabled :: Extension -> Message (THResult Bool) - ExtsEnabled :: Message (THResult [Extension]) +deriving instance Show (Message a) - StartRecover :: Message () - EndRecover :: Bool -> Message () - -- Template Haskell return values +-- | Template Haskell return values +data QResult a + = QDone a + -- ^ RunTH finished successfully; return value follows + | QException String + -- ^ RunTH threw an exception + | QFail String + -- ^ RunTH called 'fail' + deriving (Generic, Show) - -- | RunTH finished successfully; return value follows - QDone :: Message () - -- | RunTH threw an exception - QException :: String -> Message () - -- | RunTH called 'fail' - QFail :: String -> Message () +instance Binary a => Binary (QResult a) -deriving instance Show (Message a) +-- | Messages sent back to GHC from GHCi.TH, to implement the methods +-- of 'Quasi'. For an overview of how TH works with Remote GHCi, see +-- Note [Remote Template Haskell] in GHCi.TH. +data THMessage a where + NewName :: String -> THMessage (THResult TH.Name) + Report :: Bool -> String -> THMessage (THResult ()) + LookupName :: Bool -> String -> THMessage (THResult (Maybe TH.Name)) + Reify :: TH.Name -> THMessage (THResult TH.Info) + ReifyFixity :: TH.Name -> THMessage (THResult (Maybe TH.Fixity)) + ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec]) + ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role]) + ReifyAnnotations :: TH.AnnLookup -> TypeRep + -> THMessage (THResult [ByteString]) + ReifyModule :: TH.Module -> THMessage (THResult TH.ModuleInfo) + ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness]) + + AddDependentFile :: FilePath -> THMessage (THResult ()) + AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ()) + AddTopDecls :: [TH.Dec] -> THMessage (THResult ()) + AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ()) + IsExtEnabled :: Extension -> THMessage (THResult Bool) + ExtsEnabled :: THMessage (THResult [Extension]) + + StartRecover :: THMessage () + EndRecover :: Bool -> THMessage () + + -- | Indicates that this RunTH is finished, and the next message + -- will be the result of RunTH (a QResult). + RunTHDone :: THMessage () + +deriving instance Show (THMessage a) + +data THMsg = forall a . (Binary a, Show a) => THMsg (THMessage a) + +getTHMessage :: Get THMsg +getTHMessage = do + b <- getWord8 + case b of + 0 -> THMsg <$> NewName <$> get + 1 -> THMsg <$> (Report <$> get <*> get) + 2 -> THMsg <$> (LookupName <$> get <*> get) + 3 -> THMsg <$> Reify <$> get + 4 -> THMsg <$> ReifyFixity <$> get + 5 -> THMsg <$> (ReifyInstances <$> get <*> get) + 6 -> THMsg <$> ReifyRoles <$> get + 7 -> THMsg <$> (ReifyAnnotations <$> get <*> get) + 8 -> THMsg <$> ReifyModule <$> get + 9 -> THMsg <$> ReifyConStrictness <$> get + 10 -> THMsg <$> AddDependentFile <$> get + 11 -> THMsg <$> AddTopDecls <$> get + 12 -> THMsg <$> (IsExtEnabled <$> get) + 13 -> THMsg <$> return ExtsEnabled + 14 -> THMsg <$> return StartRecover + 15 -> THMsg <$> EndRecover <$> get + 16 -> return (THMsg RunTHDone) + 17 -> THMsg <$> AddModFinalizer <$> get + _ -> THMsg <$> (AddForeignFile <$> get <*> get) + +putTHMessage :: THMessage a -> Put +putTHMessage m = case m of + NewName a -> putWord8 0 >> put a + Report a b -> putWord8 1 >> put a >> put b + LookupName a b -> putWord8 2 >> put a >> put b + Reify a -> putWord8 3 >> put a + ReifyFixity a -> putWord8 4 >> put a + ReifyInstances a b -> putWord8 5 >> put a >> put b + ReifyRoles a -> putWord8 6 >> put a + ReifyAnnotations a b -> putWord8 7 >> put a >> put b + ReifyModule a -> putWord8 8 >> put a + ReifyConStrictness a -> putWord8 9 >> put a + AddDependentFile a -> putWord8 10 >> put a + AddTopDecls a -> putWord8 11 >> put a + IsExtEnabled a -> putWord8 12 >> put a + ExtsEnabled -> putWord8 13 + StartRecover -> putWord8 14 + EndRecover a -> putWord8 15 >> put a + RunTHDone -> putWord8 16 + AddModFinalizer a -> putWord8 17 >> put a + AddForeignFile lang a -> putWord8 18 >> put lang >> put a + + data EvalOpts = EvalOpts { useSandboxThread :: Bool , singleStep :: Bool @@ -279,7 +373,28 @@ | EOtherException String deriving (Generic, Show) -instance Binary ExitCode +toSerializableException :: SomeException -> SerializableException +toSerializableException ex + | Just UserInterrupt <- fromException ex = EUserInterrupt + | Just (ec::ExitCode) <- fromException ex = (EExitCode ec) + | otherwise = EOtherException (show (ex :: SomeException)) + +fromSerializableException :: SerializableException -> SomeException +fromSerializableException EUserInterrupt = toException UserInterrupt +fromSerializableException (EExitCode c) = toException c +fromSerializableException (EOtherException str) = toException (ErrorCall str) + +-- NB: Replace this with a derived instance once we depend on GHC 8.0 +-- as the minimum +instance Binary ExitCode where + put ExitSuccess = putWord8 0 + put (ExitFailure ec) = putWord8 1 >> put ec + get = do + w <- getWord8 + case w of + 0 -> pure ExitSuccess + _ -> ExitFailure <$> get + instance Binary SerializableException data THResult a @@ -294,6 +409,9 @@ instance Binary THResultType +-- | The server-side Template Haskell state. This is created by the +-- StartTH message. A new one is created per module that GHC +-- typechecks. data QState = QState { qsMap :: Map TypeRep Dynamic -- ^ persistent data between splices in a module @@ -342,29 +460,9 @@ 29 -> Msg <$> (BreakpointStatus <$> get <*> get) 30 -> Msg <$> (GetBreakpointVar <$> get <*> get) 31 -> Msg <$> return StartTH - -- 32 is missing - 33 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) - 34 -> Msg <$> NewName <$> get - 35 -> Msg <$> (Report <$> get <*> get) - 36 -> Msg <$> (LookupName <$> get <*> get) - 37 -> Msg <$> Reify <$> get - 38 -> Msg <$> ReifyFixity <$> get - 39 -> Msg <$> (ReifyInstances <$> get <*> get) - 40 -> Msg <$> ReifyRoles <$> get - 41 -> Msg <$> (ReifyAnnotations <$> get <*> get) - 42 -> Msg <$> ReifyModule <$> get - 43 -> Msg <$> ReifyConStrictness <$> get - 44 -> Msg <$> AddDependentFile <$> get - 45 -> Msg <$> AddTopDecls <$> get - 46 -> Msg <$> (IsExtEnabled <$> get) - 47 -> Msg <$> return ExtsEnabled - 48 -> Msg <$> return StartRecover - 49 -> Msg <$> EndRecover <$> get - 50 -> Msg <$> return QDone - 51 -> Msg <$> QException <$> get - 52 -> Msg <$> (RunModFinalizers <$> get <*> get) - 53 -> Msg <$> (AddModFinalizer <$> get) - _ -> Msg <$> QFail <$> get + 32 -> Msg <$> (RunModFinalizers <$> get <*> get) + 33 -> Msg <$> (AddSptEntry <$> get <*> get) + _ -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) putMessage :: Message a -> Put putMessage m = case m of @@ -400,28 +498,9 @@ BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix GetBreakpointVar a b -> putWord8 30 >> put a >> put b StartTH -> putWord8 31 - RunTH st q loc ty -> putWord8 33 >> put st >> put q >> put loc >> put ty - NewName a -> putWord8 34 >> put a - Report a b -> putWord8 35 >> put a >> put b - LookupName a b -> putWord8 36 >> put a >> put b - Reify a -> putWord8 37 >> put a - ReifyFixity a -> putWord8 38 >> put a - ReifyInstances a b -> putWord8 39 >> put a >> put b - ReifyRoles a -> putWord8 40 >> put a - ReifyAnnotations a b -> putWord8 41 >> put a >> put b - ReifyModule a -> putWord8 42 >> put a - ReifyConStrictness a -> putWord8 43 >> put a - AddDependentFile a -> putWord8 44 >> put a - AddTopDecls a -> putWord8 45 >> put a - IsExtEnabled a -> putWord8 46 >> put a - ExtsEnabled -> putWord8 47 - StartRecover -> putWord8 48 - EndRecover a -> putWord8 49 >> put a - QDone -> putWord8 50 - QException a -> putWord8 51 >> put a - RunModFinalizers a b -> putWord8 52 >> put a >> put b - AddModFinalizer a -> putWord8 53 >> put a - QFail a -> putWord8 54 >> put a + RunModFinalizers a b -> putWord8 32 >> put a >> put b + AddSptEntry a b -> putWord8 33 >> put a >> put b + RunTH st q loc ty -> putWord8 34 >> put st >> put q >> put loc >> put ty -- ----------------------------------------------------------------------------- -- Reading/writing messages @@ -435,6 +514,11 @@ remoteCall :: Binary a => Pipe -> Message a -> IO a remoteCall pipe msg = do writePipe pipe (putMessage msg) + readPipe pipe get + +remoteTHCall :: Binary a => Pipe -> THMessage a -> IO a +remoteTHCall pipe msg = do + writePipe pipe (putTHMessage msg) readPipe pipe get writePipe :: Pipe -> Put -> IO () diff --git a/GHCi/ObjLink.hs b/GHCi/ObjLink.hs --- a/GHCi/ObjLink.hs +++ b/GHCi/ObjLink.hs @@ -11,11 +11,12 @@ -- | Primarily, this module consists of an interface to the C-land -- dynamic linker. module GHCi.ObjLink - ( initObjLinker + ( initObjLinker, ShouldRetainCAFs(..) , loadDLL , loadArchive , loadObj , unloadObj + , purgeObj , lookupSymbol , lookupClosure , resolveObjs @@ -25,6 +26,7 @@ ) where import GHCi.RemoteTypes +import Control.Exception (throwIO, ErrorCall(..)) import Control.Monad ( when ) import Foreign.C import Foreign.Marshal.Alloc ( free ) @@ -33,10 +35,31 @@ import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath ) import System.FilePath ( dropExtension, normalise ) + + + -- --------------------------------------------------------------------------- -- RTS Linker Interface -- --------------------------------------------------------------------------- +data ShouldRetainCAFs + = RetainCAFs + -- ^ Retain CAFs unconditionally in linked Haskell code. + -- Note that this prevents any code from being unloaded. + -- It should not be necessary unless you are GHCi or + -- hs-plugins, which needs to be able call any function + -- in the compiled code. + | DontRetainCAFs + -- ^ Do not retain CAFs. Everything reachable from foreign + -- exports will be retained, due to the StablePtrs + -- created by the module initialisation code. unloadObj + -- frees these StablePtrs, which will allow the CAFs to + -- be GC'd and the code to be removed. + +initObjLinker :: ShouldRetainCAFs -> IO () +initObjLinker RetainCAFs = c_initLinker_ 1 +initObjLinker _ = c_initLinker_ 0 + lookupSymbol :: String -> IO (Maybe (Ptr a)) lookupSymbol str_in = do let str = prefixUnderscore str_in @@ -88,20 +111,32 @@ loadArchive str = do withFilePath str $ \c_str -> do r <- c_loadArchive c_str - when (r == 0) (error ("loadArchive " ++ show str ++ ": failed")) + when (r == 0) (throwIO (ErrorCall ("loadArchive " ++ show str ++ ": failed"))) loadObj :: String -> IO () loadObj str = do withFilePath str $ \c_str -> do r <- c_loadObj c_str - when (r == 0) (error ("loadObj " ++ show str ++ ": failed")) + when (r == 0) (throwIO (ErrorCall ("loadObj " ++ show str ++ ": failed"))) +-- | @unloadObj@ drops the given dynamic library from the symbol table +-- as well as enables the library to be removed from memory during +-- a future major GC. unloadObj :: String -> IO () unloadObj str = withFilePath str $ \c_str -> do r <- c_unloadObj c_str - when (r == 0) (error ("unloadObj " ++ show str ++ ": failed")) + when (r == 0) (throwIO (ErrorCall ("unloadObj " ++ show str ++ ": failed"))) +-- | @purgeObj@ drops the symbols for the dynamic library from the symbol +-- table. Unlike 'unloadObj', the library will not be dropped memory during +-- a future major GC. +purgeObj :: String -> IO () +purgeObj str = + withFilePath str $ \c_str -> do + r <- c_purgeObj c_str + when (r == 0) (throwIO (ErrorCall ("purgeObj " ++ show str ++ ": failed"))) + addLibrarySearchPath :: String -> IO (Ptr ()) addLibrarySearchPath str = withFilePath str c_addLibrarySearchPath @@ -128,10 +163,11 @@ -- --------------------------------------------------------------------------- foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString -foreign import ccall unsafe "initLinker" initObjLinker :: IO () +foreign import ccall unsafe "initLinker_" c_initLinker_ :: CInt -> IO () foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int foreign import ccall unsafe "loadObj" c_loadObj :: CFilePath -> IO Int +foreign import ccall unsafe "purgeObj" c_purgeObj :: CFilePath -> IO Int foreign import ccall unsafe "unloadObj" c_unloadObj :: CFilePath -> IO Int foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int foreign import ccall unsafe "addLibrarySearchPath" c_addLibrarySearchPath :: CFilePath -> IO (Ptr ()) diff --git a/GHCi/RemoteTypes.hs b/GHCi/RemoteTypes.hs --- a/GHCi/RemoteTypes.hs +++ b/GHCi/RemoteTypes.hs @@ -1,4 +1,12 @@ {-# LANGUAGE CPP, StandaloneDeriving, GeneralizedNewtypeDeriving #-} + +-- | +-- Types for referring to remote objects in Remote GHCi. For more +-- details, see Note [External GHCi pointers] in compiler/ghci/GHCi.hs +-- +-- For details on Remote GHCi, see Note [Remote GHCi] in +-- compiler/ghci/GHCi.hs. +-- module GHCi.RemoteTypes ( RemotePtr(..), toRemotePtr, fromRemotePtr, castRemotePtr , HValue(..) diff --git a/GHCi/Run.hs b/GHCi/Run.hs --- a/GHCi/Run.hs +++ b/GHCi/Run.hs @@ -3,11 +3,13 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | --- Execute GHCi messages +-- Execute GHCi messages. -- +-- For details on Remote GHCi, see Note [Remote GHCi] in +-- compiler/ghci/GHCi.hs. +-- module GHCi.Run ( run, redirectInterrupts - , toSerializableException, fromSerializableException ) where import GHCi.CreateBCO @@ -18,6 +20,7 @@ import GHCi.RemoteTypes import GHCi.TH import GHCi.BreakArray +import GHCi.StaticPtrTable import Control.Concurrent import Control.DeepSeq @@ -33,7 +36,6 @@ import Foreign.C import GHC.Conc.Sync import GHC.IO hiding ( bracket ) -import System.Exit import System.Mem.Weak ( deRefWeak ) import Unsafe.Coerce @@ -42,7 +44,7 @@ run :: Message a -> IO a run m = case m of - InitLinker -> initObjLinker + InitLinker -> initObjLinker RetainCAFs LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str LookupClosure str -> lookupClosure str LoadDLL str -> loadDLL str @@ -55,6 +57,7 @@ FindSystemLibrary str -> findSystemLibrary str CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos) FreeHValueRefs rs -> mapM_ freeRemoteRef rs + AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr EvalStmt opts r -> evalStmt opts r ResumeStmt opts r -> resumeStmt opts r AbandonStmt r -> abandonStmt r @@ -219,17 +222,6 @@ case e of Left ex -> return (EvalException (toSerializableException ex)) Right a -> return (EvalSuccess a) - -toSerializableException :: SomeException -> SerializableException -toSerializableException ex - | Just UserInterrupt <- fromException ex = EUserInterrupt - | Just (ec::ExitCode) <- fromException ex = (EExitCode ec) - | otherwise = EOtherException (show (ex :: SomeException)) - -fromSerializableException :: SerializableException -> SomeException -fromSerializableException EUserInterrupt = toException UserInterrupt -fromSerializableException (EExitCode c) = toException c -fromSerializableException (EOtherException str) = toException (ErrorCall str) -- This function sets up the interpreter for catching breakpoints, and -- resets everything when the computation has stopped running. This diff --git a/GHCi/StaticPtrTable.hs b/GHCi/StaticPtrTable.hs new file mode 100644 --- /dev/null +++ b/GHCi/StaticPtrTable.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module GHCi.StaticPtrTable ( sptAddEntry ) where + +import Data.Word +import Foreign +import GHC.Fingerprint +import GHCi.RemoteTypes + +-- | Used by GHCi to add an SPT entry for a set of interactive bindings. +sptAddEntry :: Fingerprint -> HValue -> IO () +sptAddEntry (Fingerprint a b) (HValue x) = do + -- We own the memory holding the key (fingerprint) which gets inserted into + -- the static pointer table and can't free it until the SPT entry is removed + -- (which is currently never). + fpr_ptr <- newArray [a,b] + sptr <- newStablePtr x + ent_ptr <- malloc + poke ent_ptr (castStablePtrToPtr sptr) + spt_insert_stableptr fpr_ptr ent_ptr + +foreign import ccall "hs_spt_insert_stableptr" + spt_insert_stableptr :: Ptr Word64 -> Ptr (Ptr ()) -> IO () diff --git a/GHCi/TH.hs b/GHCi/TH.hs --- a/GHCi/TH.hs +++ b/GHCi/TH.hs @@ -12,6 +12,85 @@ , GHCiQException(..) ) where +{- Note [Remote Template Haskell] + +Here is an overview of how TH works with -fexternal-interpreter. + +Initialisation +~~~~~~~~~~~~~~ + +GHC sends a StartTH message to the server (see TcSplice.getTHState): + + StartTH :: Message (RemoteRef (IORef QState)) + +The server creates an initial QState object, makes an IORef to it, and +returns a RemoteRef to this to GHC. (see GHCi.TH.startTH below). + +This happens once per module, the first time we need to run a TH +splice. The reference that GHC gets back is kept in +tcg_th_remote_state in the TcGblEnv, and passed to each RunTH call +that follows. + + +For each splice +~~~~~~~~~~~~~~~ + +1. GHC compiles a splice to byte code, and sends it to the server: in + a CreateBCOs message: + + CreateBCOs :: [LB.ByteString] -> Message [HValueRef] + +2. The server creates the real byte-code objects in its heap, and + returns HValueRefs to GHC. HValueRef is the same as RemoteRef + HValue. + +3. GHC sends a RunTH message to the server: + + RunTH + :: RemoteRef (IORef QState) + -- The state returned by StartTH in step1 + -> HValueRef + -- The HValueRef we got in step 4, points to the code for the splice + -> THResultType + -- Tells us what kind of splice this is (decl, expr, type, etc.) + -> Maybe TH.Loc + -- Source location + -> Message (QResult ByteString) + -- Eventually it will return a QResult back to GHC. The + -- ByteString here is the (encoded) result of the splice. + +4. The server runs the splice code. + +5. Each time the splice code calls a method of the Quasi class, such + as qReify, a message is sent from the server to GHC. These + messages are defined by the THMessage type. GHC responds with the + result of the request, e.g. in the case of qReify it would be the + TH.Info for the requested entity. + +6. When the splice has been fully evaluated, the server sends + RunTHDone back to GHC. This tells GHC that the server has finished + sending THMessages and will send the QResult next. + +8. The server then sends a QResult back to GHC, which is notionally + the response to the original RunTH message. The QResult indicates + whether the splice succeeded, failed, or threw an exception. + + +After typechecking +~~~~~~~~~~~~~~~~~~ + +GHC sends a FinishTH message to the server (see TcSplice.finishTH). +The server runs any finalizers that were added by addModuleFinalizer. + + +Other Notes on TH / Remote GHCi + + * Note [Remote GHCi] in compiler/ghci/GHCi.hs + * Note [External GHCi pointers] in compiler/ghci/GHCi.hs + * Note [TH recover with -fexternal-interpreter] in + compiler/typecheck/TcSplice.hs +-} + import GHCi.Message import GHCi.RemoteTypes import GHC.Serialized @@ -34,13 +113,16 @@ import qualified Language.Haskell.TH.Syntax as TH import Unsafe.Coerce +-- | Create a new instance of 'QState' initQState :: Pipe -> QState initQState p = QState M.empty Nothing p +-- | The monad in which we run TH computations on the server newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) } +-- | The exception thrown by "fail" in the GHCiQ monad data GHCiQException = GHCiQException QState String - deriving (Show, Typeable) + deriving Show instance Exception GHCiQException @@ -59,7 +141,6 @@ do (m', s') <- runGHCiQ m s (a, s'') <- runGHCiQ (f m') s' return (a, s'') - fail = Fail.fail instance Fail.MonadFail GHCiQ where @@ -71,9 +152,10 @@ noLoc :: TH.Loc noLoc = TH.Loc "" "" "" (0,0) (0,0) -ghcCmd :: Binary a => Message (THResult a) -> GHCiQ a +-- | Send a 'THMessage' to GHC and return the result. +ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a ghcCmd m = GHCiQ $ \s -> do - r <- remoteCall (qsPipe s) m + r <- remoteTHCall (qsPipe s) m case r of THException str -> throwIO (GHCiQException s str) THComplete res -> return (res, s) @@ -84,12 +166,12 @@ -- See Note [TH recover with -fexternal-interpreter] in TcSplice qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> (do - remoteCall (qsPipe s) StartRecover + remoteTHCall (qsPipe s) StartRecover (r, s') <- a s - remoteCall (qsPipe s) (EndRecover False) + remoteTHCall (qsPipe s) (EndRecover False) return (r,s')) `catch` - \GHCiQException{} -> remoteCall (qsPipe s) (EndRecover True) >> h s + \GHCiQException{} -> remoteTHCall (qsPipe s) (EndRecover True) >> h s qLookupName isType occ = ghcCmd (LookupName isType occ) qReify name = ghcCmd (Reify name) qReifyFixity name = ghcCmd (ReifyFixity name) @@ -111,6 +193,7 @@ qRunIO m = GHCiQ $ \s -> fmap (,s) m qAddDependentFile file = ghcCmd (AddDependentFile file) qAddTopDecls decls = ghcCmd (AddTopDecls decls) + qAddForeignFile str lang = ghcCmd (AddForeignFile str lang) qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>= ghcCmd . AddModFinalizer qGetQ = GHCiQ $ \s -> @@ -122,6 +205,8 @@ qIsExtEnabled x = ghcCmd (IsExtEnabled x) qExtsEnabled = ghcCmd ExtsEnabled +-- | The implementation of the 'StartTH' message: create +-- a new IORef QState, and return a RemoteRef to it. startTH :: IO (RemoteRef (IORef QState)) startTH = do r <- newIORef (initQState (error "startTH: no pipe")) @@ -140,11 +225,20 @@ _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe } return () +-- | The implementation of the 'RunTH' message runTH - :: Pipe -> RemoteRef (IORef QState) -> HValueRef + :: Pipe + -> RemoteRef (IORef QState) + -- ^ The TH state, created by 'startTH' + -> HValueRef + -- ^ The splice to run -> THResultType + -- ^ What kind of splice it is -> Maybe TH.Loc + -- ^ The source location -> IO ByteString + -- ^ Returns an (encoded) result that depends on the THResultType + runTH pipe rstate rhv ty mb_loc = do hv <- localRef rhv case ty of @@ -158,6 +252,7 @@ AnnotationWrapper thing -> return $! LB.toStrict (runPut (put (toSerialized serializeWithData thing))) +-- | Run a Q computation. runTHQ :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a -> IO ByteString diff --git a/GHCi/TH/Binary.hs b/GHCi/TH/Binary.hs --- a/GHCi/TH/Binary.hs +++ b/GHCi/TH/Binary.hs @@ -1,14 +1,21 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} + -- This module is full of orphans, unfortunately module GHCi.TH.Binary () where import Data.Binary import qualified Data.ByteString as B -import Data.Typeable import GHC.Serialized import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH - +#if !MIN_VERSION_base(4,10,0) +import Data.Typeable +#endif -- Put these in a separate module because they take ages to compile instance Binary TH.Loc @@ -30,6 +37,8 @@ instance Binary TH.Exp instance Binary TH.Dec instance Binary TH.Overlap +instance Binary TH.DerivClause +instance Binary TH.DerivStrategy instance Binary TH.Guard instance Binary TH.Body instance Binary TH.Match @@ -59,9 +68,17 @@ instance Binary TH.InjectivityAnn instance Binary TH.FamilyResultSig instance Binary TH.TypeFamilyHead +instance Binary TH.PatSynDir +instance Binary TH.PatSynArgs -- We need Binary TypeRep for serializing annotations +instance Binary Serialized where + put (Serialized tyrep wds) = put tyrep >> put (B.pack wds) + get = Serialized <$> get <*> (B.unpack <$> get) + +-- Typeable and related instances live in binary since GHC 8.2 +#if !MIN_VERSION_base(4,10,0) instance Binary TyCon where put tc = put (tyConPackage tc) >> put (tyConModule tc) >> put (tyConName tc) get = mkTyCon3 <$> get <*> get <*> get @@ -71,7 +88,4 @@ get = do (ty_con, child_type_reps) <- get return (mkTyConApp ty_con child_type_reps) - -instance Binary Serialized where - put (Serialized tyrep wds) = put tyrep >> put (B.pack wds) - get = Serialized <$> get <*> (B.unpack <$> get) +#endif diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,8 +1,18 @@ +## 8.2.1 *Jul 2017* + + * Bundled with GHC 8.2.1 + + * Add support for StaticPointers in GHCi (#12356) + + * Move Typeable Binary instances to binary package + ## 8.0.2 *Jan 2017* * Bundled with GHC 8.0.2 * Tag pointers in interpreted constructors (#12523) + + * Add `NFData` instances ## 8.0.1 *Feb 2016* diff --git a/ghci.cabal b/ghci.cabal --- a/ghci.cabal +++ b/ghci.cabal @@ -1,8 +1,5 @@ --- WARNING: ghci.cabal is automatically generated from ghci.cabal.in by --- ../../configure. Make sure you are editing ghci.cabal.in, not ghci.cabal. - name: ghci -version: 8.0.2 +version: 8.2.1 license: BSD3 license-file: LICENSE category: GHC @@ -17,6 +14,11 @@ build-type: Simple extra-source-files: changelog.md +Flag ghci + Description: Build GHCi support. + Default: False + Manual: True + source-repository head type: git location: http://git.haskell.org/ghc.git @@ -41,31 +43,37 @@ TupleSections UnboxedTuples + if flag(ghci) + CPP-Options: -DGHCI + exposed-modules: + GHCi.Run + GHCi.CreateBCO + GHCi.ObjLink + GHCi.Signals + GHCi.TH + exposed-modules: GHCi.BreakArray GHCi.Message GHCi.ResolvedBCO GHCi.RemoteTypes - GHCi.ObjLink - GHCi.CreateBCO GHCi.FFI GHCi.InfoTable - GHCi.Run - GHCi.Signals - GHCi.TH + GHCi.StaticPtrTable GHCi.TH.Binary SizedSeq Build-Depends: array == 0.5.*, - base == 4.9.*, + base >= 4.8 && < 4.11, binary == 0.8.*, bytestring == 0.10.*, containers == 0.5.*, deepseq == 1.4.*, filepath == 1.4.*, - ghc-boot == 8.0.2, - template-haskell == 2.11.*, + ghc-boot == 8.2.1, + ghc-boot-th == 8.2.1, + template-haskell == 2.12.*, transformers == 0.5.* if !os(windows)