diff --git a/GHCi/BinaryArray.hs b/GHCi/BinaryArray.hs new file mode 100644 --- /dev/null +++ b/GHCi/BinaryArray.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-} +-- | Efficient serialisation for GHCi Instruction arrays +-- +-- Author: Ben Gamari +-- +module GHCi.BinaryArray(putArray, getArray) where + +import Prelude +import Foreign.Ptr +import Data.Binary +import Data.Binary.Put (putBuilder) +import qualified Data.Binary.Get.Internal as Binary +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Builder.Internal as BB +import qualified Data.Array.Base as A +import qualified Data.Array.IO.Internals as A +import qualified Data.Array.Unboxed as A +import GHC.Exts +import GHC.IO + +-- | An efficient serialiser of 'A.UArray'. +putArray :: Binary i => A.UArray i a -> Put +putArray (A.UArray l u _ arr#) = do + put l + put u + putBuilder $ byteArrayBuilder arr# + +byteArrayBuilder :: ByteArray# -> BB.Builder +byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#)) + where + go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a + go !inStart !inEnd k (BB.BufferRange outStart outEnd) + -- There is enough room in this output buffer to write all remaining array + -- contents + | inRemaining <= outRemaining = do + copyByteArrayToAddr arr# inStart outStart inRemaining + k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd) + -- There is only enough space for a fraction of the remaining contents + | otherwise = do + copyByteArrayToAddr arr# inStart outStart outRemaining + let !inStart' = inStart + outRemaining + return $! BB.bufferFull 1 outEnd (go inStart' inEnd k) + where + inRemaining = inEnd - inStart + outRemaining = outEnd `minusPtr` outStart + + copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO () + copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) = + IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of + s' -> (# s', () #) + +-- | An efficient deserialiser of 'A.UArray'. +getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a) +getArray = do + l <- get + u <- get + arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <- + return $ unsafeDupablePerformIO $ A.newArray_ (l,u) + let go 0 _ = return () + go !remaining !off = do + Binary.readNWith n $ \ptr -> + copyAddrToByteArray ptr arr# off n + go (remaining - n) (off + n) + where n = min chunkSize remaining + go (I# (sizeofMutableByteArray# arr#)) 0 + return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr + where + chunkSize = 10*1024 + + copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld + -> Int -> Int -> IO () + copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) = + IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of + s' -> (# s', () #) + +-- this is inexplicably not exported in currently released array versions +unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e) +unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr) diff --git a/GHCi/BreakArray.hs b/GHCi/BreakArray.hs --- a/GHCi/BreakArray.hs +++ b/GHCi/BreakArray.hs @@ -19,17 +19,15 @@ module GHCi.BreakArray ( BreakArray -#ifdef GHCI (BA) -- constructor is exported only for ByteCodeGen , newBreakArray , getBreak , setBreakOn , setBreakOff , showBreakArray -#endif ) where -#ifdef GHCI +import Prelude -- See note [Why do we import Prelude here?] import Control.Monad import Data.Word import GHC.Word @@ -115,6 +113,3 @@ 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 @@ -13,6 +13,7 @@ -- | Create real byte-code objects from 'ResolvedBCO's. module GHCi.CreateBCO (createBCOs) where +import Prelude -- See note [Why do we import Prelude here?] import GHCi.ResolvedBCO import GHCi.RemoteTypes import GHCi.BreakArray @@ -25,7 +26,7 @@ import GHC.Arr ( Array(..) ) import GHC.Exts import GHC.IO --- import Debug.Trace +import Control.Exception ( ErrorCall(..) ) createBCOs :: [ResolvedBCO] -> IO [HValueRef] createBCOs bcos = do @@ -36,6 +37,12 @@ mapM mkRemoteRef hvals createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue +createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian + = throwIO (ErrorCall $ + unlines [ "The endianness of the ResolvedBCO does not match" + , "the systems endianness. Using ghc and iserv in a" + , "mixed endianness setup is not supported!" + ]) createBCO arr bco = do BCO bco# <- linkBCO' arr bco -- Why do we need mkApUpd0 here? Otherwise top-level @@ -56,6 +63,9 @@ return (HValue final_bco) } +toWordArray :: UArray Int Word64 -> UArray Int Word +toWordArray = amap fromIntegral + linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO linkBCO' arr ResolvedBCO{..} = do let @@ -68,8 +78,8 @@ barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b insns_barr = barr resolvedBCOInstrs - bitmap_barr = barr resolvedBCOBitmap - literals_barr = barr resolvedBCOLits + bitmap_barr = barr (toWordArray resolvedBCOBitmap) + literals_barr = barr (toWordArray resolvedBCOLits) PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs IO $ \s -> diff --git a/GHCi/FFI.hsc b/GHCi/FFI.hsc --- a/GHCi/FFI.hsc +++ b/GHCi/FFI.hsc @@ -17,6 +17,7 @@ , freeForeignCallInfo ) where +import Prelude -- See note [Why do we import Prelude here?] import Control.Exception import Data.Binary import GHC.Generics diff --git a/GHCi/InfoTable.hsc b/GHCi/InfoTable.hsc --- a/GHCi/InfoTable.hsc +++ b/GHCi/InfoTable.hsc @@ -1,93 +1,43 @@ {-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-} +-- Get definitions for the structs, constants & config etc. +#include "Rts.h" + -- | -- Run-time info table support. This module provides support for -- creating and reading info tables /in the running program/. -- We use the RTS data structures directly via hsc2hs. -- module GHCi.InfoTable - ( peekItbl, StgInfoTable(..) - , conInfoPtr -#ifdef GHCI - , mkConInfoTable -#endif + ( + mkConInfoTable ) where -#if !defined(TABLES_NEXT_TO_CODE) -import Data.Maybe (fromJust) -#endif +import Prelude -- See note [Why do we import Prelude here?] import Foreign import Foreign.C import GHC.Ptr 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 +import GHC.Exts.Heap +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS ghciTablesNextToCode :: Bool -#ifdef TABLES_NEXT_TO_CODE +#if defined(TABLES_NEXT_TO_CODE) ghciTablesNextToCode = True #else ghciTablesNextToCode = False #endif -#ifdef GHCI /* To end */ +-- NOTE: Must return a pointer acceptable for use in the header of a closure. +-- If tables_next_to_code is enabled, then it must point the the 'code' field. +-- Otherwise, it should point to the start of the StgInfoTable. mkConInfoTable :: Int -- ptr words -> Int -- non-ptr words -> Int -- constr tag -> Int -- pointer tag - -> [Word8] -- con desc + -> ByteString -- con desc -> IO (Ptr StgInfoTable) -- resulting info table is allocated with allocateExec(), and -- should be freed with freeExec(). @@ -103,7 +53,7 @@ else Just entry_addr, ptrs = fromIntegral ptr_words, nptrs = fromIntegral nonptr_words, - tipe = fromIntegral cONSTR, + tipe = CONSTR, srtlen = fromIntegral tag, code = if ghciTablesNextToCode then Just code' @@ -126,6 +76,7 @@ | ArchARM64 | ArchPPC64 | ArchPPC64LE + | ArchS390X | ArchUnknown deriving Show @@ -149,6 +100,8 @@ ArchPPC64 #elif defined(powerpc64le_HOST_ARCH) ArchPPC64LE +#elif defined(s390x_HOST_ARCH) + ArchS390X #else # if defined(TABLES_NEXT_TO_CODE) # error Unimplemented architecture @@ -318,6 +271,20 @@ 0x618C0000 .|. lo16 w32, 0x7D8903A6, 0x4E800420 ] + ArchS390X -> + -- Let 0xAABBCCDDEEFFGGHH be the address to jump to. + -- The following code loads the address into scratch + -- register r1 and jumps to it. + -- + -- 0: C0 1E AA BB CC DD llihf %r1,0xAABBCCDD + -- 6: C0 19 EE FF GG HH iilf %r1,0xEEFFGGHH + -- 12: 07 F1 br %r1 + + let w64 = fromIntegral (funPtrToInt a) :: Word64 + in Left [ 0xC0, 0x1E, byte7 w64, byte6 w64, byte5 w64, byte4 w64, + 0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64, + 0x07, 0xF1 ] + -- This code must not be called. You either need to -- add your architecture as a distinct case or -- use non-TABLES_NEXT_TO_CODE mode @@ -368,12 +335,17 @@ pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable -> IO () -pokeConItbl wr_ptr ex_ptr itbl = do - let _con_desc = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB) +pokeConItbl wr_ptr _ex_ptr itbl = do #if defined(TABLES_NEXT_TO_CODE) - (#poke StgConInfoTable, con_desc) wr_ptr _con_desc + -- Write the offset to the con_desc from the end of the standard InfoTable + -- at the first byte. + let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB) + (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset #else - (#poke StgConInfoTable, con_desc) wr_ptr (conDesc itbl) + -- Write the con_desc address after the end of the info table. + -- Use itblSize because CPP will not pick up PROFILING when calculating + -- the offset. + pokeByteOff wr_ptr itblSize (conDesc itbl) #endif pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl) @@ -385,28 +357,14 @@ Left xs -> sizeOf (head xs) * length xs Right xs -> sizeOf (head xs) * length xs -pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () -pokeItbl a0 itbl = do -#if !defined(TABLES_NEXT_TO_CODE) - (#poke StgInfoTable, entry) a0 (fromJust (entry itbl)) -#endif - (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl) - (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl) - (#poke StgInfoTable, type) a0 (tipe itbl) - (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl) -#if defined(TABLES_NEXT_TO_CODE) - let code_offset = (a0 `plusPtr` (#offset StgInfoTable, code)) - case code itbl of - Nothing -> return () - Just (Left xs) -> pokeArray code_offset xs - Just (Right xs) -> pokeArray code_offset xs -#endif - -newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ()) +-- Note: Must return proper pointer for use in a closure +newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ()) newExecConItbl obj con_desc = alloca $ \pcode -> do - let lcon_desc = length con_desc + 1{- null terminator -} - sz = fromIntegral ((#size StgConInfoTable) + sizeOfEntryCode) + let lcon_desc = BS.length con_desc + 1{- null terminator -} + -- SCARY + -- This size represents the number of bytes in an StgConInfoTable. + sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode) -- Note: we need to allocate the conDesc string next to the info -- table, because on a 64-bit platform we reference this string -- with a 32-bit offset relative to the info table, so if we @@ -416,9 +374,16 @@ let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz , infoTable = obj } pokeConItbl wr_ptr ex_ptr cinfo - pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc + BS.useAsCStringLen con_desc $ \(src, len) -> + copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len + let null_off = fromIntegral sz + fromIntegral (BS.length con_desc) + poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8) _flushExec sz ex_ptr -- Cache flush (if needed) +#if defined(TABLES_NEXT_TO_CODE) + return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB)) +#else return (castPtrToFunPtr ex_ptr) +#endif foreign import ccall unsafe "allocateExec" _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a) @@ -432,26 +397,5 @@ wORD_SIZE :: Int wORD_SIZE = (#const SIZEOF_HSINT) -fixedInfoTableSizeB :: Int -fixedInfoTableSizeB = 2 * wORD_SIZE - -profInfoTableSizeB :: Int -profInfoTableSizeB = (#size StgProfInfo) - -stdInfoTableSizeB :: Int -stdInfoTableSizeB - = (if ghciTablesNextToCode then 0 else wORD_SIZE) - + (if rtsIsProfiled then profInfoTableSizeB else 0) - + fixedInfoTableSizeB - conInfoTableSizeB :: Int -conInfoTableSizeB = stdInfoTableSizeB + wORD_SIZE - -foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt - -rtsIsProfiled :: Bool -rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 - -cONSTR :: Int -- Defined in ClosureTypes.h -cONSTR = (#const CONSTR) -#endif /* GHCI */ +conInfoTableSizeB = wORD_SIZE + itblSize diff --git a/GHCi/Message.hs b/GHCi/Message.hs --- a/GHCi/Message.hs +++ b/GHCi/Message.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables, - GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, - CPP #-} + GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -- | @@ -23,13 +22,14 @@ , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe ) where +import Prelude -- See note [Why do we import Prelude here?] import GHCi.RemoteTypes -import GHCi.InfoTable (StgInfoTable) import GHCi.FFI -import GHCi.TH.Binary () +import GHCi.TH.Binary () -- For Binary instances import GHCi.BreakArray import GHC.LanguageExtensions +import GHC.Exts.Heap import GHC.ForeignSrcLang import GHC.Fingerprint import Control.Concurrent @@ -41,18 +41,12 @@ 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 Foreign 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 @@ -67,6 +61,7 @@ data Message a where -- | Exit the iserv process Shutdown :: Message () + RtsRevertCAFs :: Message () -- RTS Linker ------------------------------------------- @@ -113,7 +108,7 @@ -> Int -- non-ptr words -> Int -- constr tag -> Int -- pointer tag - -> [Word8] -- constructor desccription + -> ByteString -- constructor desccription -> Message (RemotePtr StgInfoTable) -- | Evaluate a statement @@ -210,6 +205,18 @@ -> [RemoteRef (TH.Q ())] -> Message (QResult ()) + -- | Remote interface to GHC.Exts.Heap.getClosureData. This is used by + -- the GHCi debugger to inspect values in the heap for :print and + -- type reconstruction. + GetClosure + :: HValueRef + -> Message (GenClosure HValueRef) + + -- | Evaluate something. This is used to support :force in GHCi. + Seq + :: HValueRef + -> Message (EvalResult ()) + deriving instance Show (Message a) @@ -235,6 +242,7 @@ LookupName :: Bool -> String -> THMessage (THResult (Maybe TH.Name)) Reify :: TH.Name -> THMessage (THResult TH.Info) ReifyFixity :: TH.Name -> THMessage (THResult (Maybe TH.Fixity)) + ReifyType :: TH.Name -> THMessage (THResult TH.Type) ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec]) ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role]) ReifyAnnotations :: TH.AnnLookup -> TypeRep @@ -243,14 +251,17 @@ ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness]) AddDependentFile :: FilePath -> THMessage (THResult ()) + AddTempFile :: String -> THMessage (THResult FilePath) AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ()) + AddCorePlugin :: String -> THMessage (THResult ()) AddTopDecls :: [TH.Dec] -> THMessage (THResult ()) - AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ()) + AddForeignFilePath :: ForeignSrcLang -> FilePath -> THMessage (THResult ()) IsExtEnabled :: Extension -> THMessage (THResult Bool) ExtsEnabled :: THMessage (THResult [Extension]) StartRecover :: THMessage () EndRecover :: Bool -> THMessage () + FailIfErrs :: THMessage (THResult ()) -- | Indicates that this RunTH is finished, and the next message -- will be the result of RunTH (a QResult). @@ -275,14 +286,19 @@ 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) + 11 -> THMsg <$> AddTempFile <$> get + 12 -> THMsg <$> AddTopDecls <$> get + 13 -> THMsg <$> (IsExtEnabled <$> get) + 14 -> THMsg <$> return ExtsEnabled + 15 -> THMsg <$> return StartRecover + 16 -> THMsg <$> EndRecover <$> get + 17 -> THMsg <$> return FailIfErrs + 18 -> return (THMsg RunTHDone) + 19 -> THMsg <$> AddModFinalizer <$> get + 20 -> THMsg <$> (AddForeignFilePath <$> get <*> get) + 21 -> THMsg <$> AddCorePlugin <$> get + 22 -> THMsg <$> ReifyType <$> get + n -> error ("getTHMessage: unknown message " ++ show n) putTHMessage :: THMessage a -> Put putTHMessage m = case m of @@ -297,14 +313,18 @@ 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 + AddTempFile a -> putWord8 11 >> put a + AddTopDecls a -> putWord8 12 >> put a + IsExtEnabled a -> putWord8 13 >> put a + ExtsEnabled -> putWord8 14 + StartRecover -> putWord8 15 + EndRecover a -> putWord8 16 >> put a + FailIfErrs -> putWord8 17 + RunTHDone -> putWord8 18 + AddModFinalizer a -> putWord8 19 >> put a + AddForeignFilePath lang a -> putWord8 20 >> put lang >> put a + AddCorePlugin a -> putWord8 21 >> put a + ReifyType a -> putWord8 22 >> put a data EvalOpts = EvalOpts @@ -384,17 +404,7 @@ 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 ExitCode instance Binary SerializableException data THResult a @@ -422,6 +432,22 @@ } instance Show QState where show _ = "" +-- Orphan instances of Binary for Ptr / FunPtr by conversion to Word64. +-- This is to support Binary StgInfoTable which includes these. +instance Binary (Ptr a) where + put p = put (fromIntegral (ptrToWordPtr p) :: Word64) + get = (wordPtrToPtr . fromIntegral) <$> (get :: Get Word64) + +instance Binary (FunPtr a) where + put = put . castFunPtrToPtr + get = castPtrToFunPtr <$> get + +-- Binary instances to support the GetClosure message +instance Binary StgInfoTable +instance Binary ClosureType +instance Binary PrimType +instance Binary a => Binary (GenClosure a) + data Msg = forall a . (Binary a, Show a) => Msg (Message a) getMessage :: Get Msg @@ -462,7 +488,11 @@ 31 -> Msg <$> return StartTH 32 -> Msg <$> (RunModFinalizers <$> get <*> get) 33 -> Msg <$> (AddSptEntry <$> get <*> get) - _ -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) + 34 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) + 35 -> Msg <$> (GetClosure <$> get) + 36 -> Msg <$> (Seq <$> get) + 37 -> Msg <$> return RtsRevertCAFs + _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put putMessage m = case m of @@ -501,6 +531,9 @@ 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 + GetClosure a -> putWord8 35 >> put a + Seq a -> putWord8 36 >> put a + RtsRevertCAFs -> putWord8 37 -- ----------------------------------------------------------------------------- -- Reading/writing messages diff --git a/GHCi/ObjLink.hs b/GHCi/ObjLink.hs --- a/GHCi/ObjLink.hs +++ b/GHCi/ObjLink.hs @@ -25,6 +25,7 @@ , findSystemLibrary ) where +import Prelude -- See note [Why do we import Prelude here?] import GHCi.RemoteTypes import Control.Exception (throwIO, ErrorCall(..)) import Control.Monad ( when ) @@ -180,14 +181,14 @@ #include "ghcautoconf.h" cLeadingUnderscore :: Bool -#ifdef LEADING_UNDERSCORE +#if defined(LEADING_UNDERSCORE) cLeadingUnderscore = True #else cLeadingUnderscore = False #endif isWindowsHost :: Bool -#if mingw32_HOST_OS +#if defined(mingw32_HOST_OS) isWindowsHost = True #else isWindowsHost = False diff --git a/GHCi/RemoteTypes.hs b/GHCi/RemoteTypes.hs --- a/GHCi/RemoteTypes.hs +++ b/GHCi/RemoteTypes.hs @@ -17,6 +17,7 @@ , unsafeForeignRefToRemoteRef, finalizeForeignRef ) where +import Prelude -- See note [Why do we import Prelude here?] import Control.DeepSeq import Data.Word import Foreign hiding (newForeignPtr) @@ -30,14 +31,12 @@ -- RemotePtr -- Static pointers only; don't use this for heap-resident pointers. --- Instead use HValueRef. - -#include "MachDeps.h" -#if SIZEOF_HSINT == 4 -newtype RemotePtr a = RemotePtr Word32 -#elif SIZEOF_HSINT == 8 +-- Instead use HValueRef. We will fix the remote pointer to be 64 bits. This +-- should cover 64 and 32bit systems, and permits the exchange of remote ptrs +-- between machines of different word size. For exmaple, when connecting to +-- an iserv instance on a different architecture with different word size via +-- -fexternal-interpreter. newtype RemotePtr a = RemotePtr Word64 -#endif toRemotePtr :: Ptr a -> RemotePtr a toRemotePtr p = RemotePtr (fromIntegral (ptrToWordPtr p)) diff --git a/GHCi/ResolvedBCO.hs b/GHCi/ResolvedBCO.hs --- a/GHCi/ResolvedBCO.hs +++ b/GHCi/ResolvedBCO.hs @@ -1,78 +1,65 @@ {-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving, - BangPatterns #-} + BangPatterns, CPP #-} module GHCi.ResolvedBCO ( ResolvedBCO(..) , ResolvedBCOPtr(..) + , isLittleEndian ) where +import Prelude -- See note [Why do we import Prelude here?] import SizedSeq import GHCi.RemoteTypes import GHCi.BreakArray -import Control.Monad.ST import Data.Array.Unboxed -import Data.Array.Base import Data.Binary import GHC.Generics +import GHCi.BinaryArray + +#include "MachDeps.h" + +isLittleEndian :: Bool +#if defined(WORDS_BIGENDIAN) +isLittleEndian = True +#else +isLittleEndian = False +#endif + -- ----------------------------------------------------------------------------- -- ResolvedBCO --- A A ResolvedBCO is one in which all the Name references have been --- resolved to actual addresses or RemoteHValues. +-- | A 'ResolvedBCO' is one in which all the 'Name' references have been +-- resolved to actual addresses or 'RemoteHValues'. -- -- Note, all arrays are zero-indexed (we assume this when -- serializing/deserializing) data ResolvedBCO = ResolvedBCO { + resolvedBCOIsLE :: Bool, resolvedBCOArity :: {-# UNPACK #-} !Int, - resolvedBCOInstrs :: UArray Int Word, -- insns - resolvedBCOBitmap :: UArray Int Word, -- bitmap - resolvedBCOLits :: UArray Int Word, -- non-ptrs + resolvedBCOInstrs :: UArray Int Word16, -- insns + resolvedBCOBitmap :: UArray Int Word64, -- bitmap + resolvedBCOLits :: UArray Int Word64, -- non-ptrs resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ptrs } deriving (Generic, Show) +-- | The Binary instance for ResolvedBCOs. +-- +-- Note, that we do encode the endianness, however there is no support for mixed +-- endianness setups. This is primarily to ensure that ghc and iserv share the +-- same endianness. instance Binary ResolvedBCO where put ResolvedBCO{..} = do + put resolvedBCOIsLE put resolvedBCOArity putArray resolvedBCOInstrs putArray resolvedBCOBitmap putArray resolvedBCOLits put resolvedBCOPtrs - get = ResolvedBCO <$> get <*> getArray <*> getArray <*> getArray <*> get - --- Specialized versions of the binary get/put for UArray Int Word. --- This saves a bit of time and allocation over using the default --- get/put, because we get specialisd code and also avoid serializing --- the bounds. -putArray :: UArray Int Word -> Put -putArray a@(UArray _ _ n _) = do - put n - mapM_ put (elems a) - -getArray :: Get (UArray Int Word) -getArray = do - n <- get - xs <- gets n [] - return $! mkArray n xs - where - gets 0 xs = return xs - gets n xs = do - x <- get - gets (n-1) (x:xs) - - mkArray :: Int -> [Word] -> UArray Int Word - mkArray n0 xs0 = runST $ do - !marr <- newArray (0,n0-1) 0 - let go 0 _ = return () - go _ [] = error "mkArray" - go n (x:xs) = do - let n' = n-1 - unsafeWrite marr n' x - go n' xs - go n0 xs0 - unsafeFreezeSTUArray marr + get = ResolvedBCO + <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get data ResolvedBCOPtr = ResolvedBCORef {-# UNPACK #-} !Int diff --git a/GHCi/Run.hs b/GHCi/Run.hs --- a/GHCi/Run.hs +++ b/GHCi/Run.hs @@ -12,6 +12,7 @@ ( run, redirectInterrupts ) where +import Prelude -- See note [Why do we import Prelude here?] import GHCi.CreateBCO import GHCi.InfoTable import GHCi.FFI @@ -31,8 +32,9 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Unsafe as B import GHC.Exts +import GHC.Exts.Heap import GHC.Stack -import Foreign +import Foreign hiding (void) import Foreign.C import GHC.Conc.Sync import GHC.IO hiding ( bracket ) @@ -42,9 +44,13 @@ -- ----------------------------------------------------------------------------- -- Implement messages +foreign import ccall "revertCAFs" rts_revertCAFs :: IO () + -- Make it "safe", just in case + run :: Message a -> IO a run m = case m of InitLinker -> initObjLinker RetainCAFs + RtsRevertCAFs -> rts_revertCAFs LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str LookupClosure str -> lookupClosure str LoadDLL str -> loadDLL str @@ -86,6 +92,10 @@ MkConInfoTable ptrs nptrs tag ptrtag desc -> toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc StartTH -> startTH + GetClosure ref -> do + clos <- getClosureData =<< localRef ref + mapM (\(Box x) -> mkRemoteRef (HValue x)) clos + Seq ref -> tryEval (void $ evaluate =<< localRef ref) _other -> error "GHCi.Run.run" evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef]) @@ -298,7 +308,12 @@ resetStepFlag :: IO () resetStepFlag = poke stepFlag 0 -type BreakpointCallback = Int# -> Int# -> Bool -> HValue -> IO () +type BreakpointCallback + = Int# -- the breakpoint index + -> Int# -- the module uniq + -> Bool -- exception? + -> HValue -- the AP_STACK, or exception + -> IO () foreign import ccall "&rts_breakpoint_io_action" breakPointIOAction :: Ptr (StablePtr BreakpointCallback) @@ -344,9 +359,7 @@ getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue) getIdValFromApStack apStack (I# stackDepth) = do - case getApStackVal# apStack (stackDepth +# 1#) of - -- The +1 is magic! I don't know where it comes - -- from, but this makes things line up. --SDM + case getApStackVal# apStack stackDepth of (# ok, result #) -> case ok of 0# -> return Nothing -- AP_STACK not found diff --git a/GHCi/Signals.hs b/GHCi/Signals.hs --- a/GHCi/Signals.hs +++ b/GHCi/Signals.hs @@ -1,11 +1,12 @@ {-# LANGUAGE CPP #-} module GHCi.Signals (installSignalHandlers) where +import Prelude -- See note [Why do we import Prelude here?] import Control.Concurrent import Control.Exception import System.Mem.Weak ( deRefWeak ) -#ifndef mingw32_HOST_OS +#if !defined(mingw32_HOST_OS) import System.Posix.Signals #endif diff --git a/GHCi/StaticPtrTable.hs b/GHCi/StaticPtrTable.hs --- a/GHCi/StaticPtrTable.hs +++ b/GHCi/StaticPtrTable.hs @@ -3,6 +3,7 @@ module GHCi.StaticPtrTable ( sptAddEntry ) where +import Prelude -- See note [Why do we import Prelude here?] import Data.Word import Foreign import GHC.Fingerprint diff --git a/GHCi/TH.hs b/GHCi/TH.hs --- a/GHCi/TH.hs +++ b/GHCi/TH.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric, - TupleSections, RecordWildCards, InstanceSigs #-} + TupleSections, RecordWildCards, InstanceSigs, CPP #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | @@ -91,12 +91,14 @@ compiler/typecheck/TcSplice.hs -} +import Prelude -- See note [Why do we import Prelude here?] import GHCi.Message import GHCi.RemoteTypes import GHC.Serialized import Control.Exception import qualified Control.Monad.Fail as Fail +import Control.Monad.IO.Class (MonadIO (..)) import Data.Binary import Data.Binary.Put import Data.ByteString (ByteString) @@ -104,6 +106,7 @@ import qualified Data.ByteString.Lazy as LB import Data.Data import Data.Dynamic +import Data.Either import Data.IORef import Data.Map (Map) import qualified Data.Map as M @@ -141,7 +144,9 @@ do (m', s') <- runGHCiQ m s (a, s'') <- runGHCiQ (f m') s' return (a, s'') +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif instance Fail.MonadFail GHCiQ where fail err = GHCiQ $ \s -> throwIO (GHCiQException s err) @@ -160,21 +165,25 @@ THException str -> throwIO (GHCiQException s str) THComplete res -> return (res, s) +instance MonadIO GHCiQ where + liftIO m = GHCiQ $ \s -> fmap (,s) m + instance TH.Quasi GHCiQ where qNewName str = ghcCmd (NewName str) qReport isError msg = ghcCmd (Report isError msg) -- See Note [TH recover with -fexternal-interpreter] in TcSplice - qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> (do + qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do remoteTHCall (qsPipe s) StartRecover - (r, s') <- a s - remoteTHCall (qsPipe s) (EndRecover False) - return (r,s')) - `catch` - \GHCiQException{} -> remoteTHCall (qsPipe s) (EndRecover True) >> h s + e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s + remoteTHCall (qsPipe s) (EndRecover (isLeft e)) + case e of + Left GHCiQException{} -> h s + Right r -> return r qLookupName isType occ = ghcCmd (LookupName isType occ) qReify name = ghcCmd (Reify name) qReifyFixity name = ghcCmd (ReifyFixity name) + qReifyType name = ghcCmd (ReifyType name) qReifyInstances name tys = ghcCmd (ReifyInstances name tys) qReifyRoles name = ghcCmd (ReifyRoles name) @@ -190,12 +199,13 @@ qReifyModule m = ghcCmd (ReifyModule m) qReifyConStrictness name = ghcCmd (ReifyConStrictness name) qLocation = fromMaybe noLoc . qsLocation <$> getState - qRunIO m = GHCiQ $ \s -> fmap (,s) m qAddDependentFile file = ghcCmd (AddDependentFile file) + qAddTempFile suffix = ghcCmd (AddTempFile suffix) qAddTopDecls decls = ghcCmd (AddTopDecls decls) - qAddForeignFile str lang = ghcCmd (AddForeignFile str lang) + qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp) qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>= ghcCmd . AddModFinalizer + qAddCorePlugin str = ghcCmd (AddCorePlugin str) qGetQ = GHCiQ $ \s -> let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m @@ -256,7 +266,7 @@ runTHQ :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a -> IO ByteString -runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do +runTHQ pipe rstate mb_loc ghciq = do qstateref <- localRef rstate qstate <- readIORef qstateref let st = qstate { qsLocation = mb_loc, qsPipe = pipe } diff --git a/GHCi/TH/Binary.hs b/GHCi/TH/Binary.hs --- a/GHCi/TH/Binary.hs +++ b/GHCi/TH/Binary.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,14 +7,13 @@ -- This module is full of orphans, unfortunately module GHCi.TH.Binary () where +import Prelude -- See note [Why do we import Prelude here?] import Data.Binary import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B 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 @@ -44,7 +42,6 @@ instance Binary TH.Match instance Binary TH.Fixity instance Binary TH.TySynEqn -instance Binary TH.FamFlavour instance Binary TH.FunDep instance Binary TH.AnnTarget instance Binary TH.RuleBndr @@ -77,15 +74,9 @@ 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 - -instance Binary TypeRep where - put type_rep = put (splitTyConApp type_rep) - get = do - (ty_con, child_type_reps) <- get - return (mkTyConApp ty_con child_type_reps) -#endif +instance Binary TH.Bytes where + put (TH.Bytes ptr off sz) = put bs + where bs = B.PS ptr (fromIntegral off) (fromIntegral sz) + get = do + B.PS ptr off sz <- get + return (TH.Bytes ptr (fromIntegral off) (fromIntegral sz)) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/SizedSeq.hs b/SizedSeq.hs --- a/SizedSeq.hs +++ b/SizedSeq.hs @@ -8,6 +8,7 @@ , sizeSS ) where +import Prelude -- See note [Why do we import Prelude here?] import Control.DeepSeq import Data.Binary import Data.List diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -2,14 +2,6 @@ * Bundled with GHC 8.2.2 -## 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.1 *Feb 2016* * Bundled with GHC 8.0.1 diff --git a/ghci.cabal b/ghci.cabal --- a/ghci.cabal +++ b/ghci.cabal @@ -1,16 +1,17 @@ +cabal-version: >=1.10 name: ghci -version: 8.2.2 +version: 8.10.2 + license: BSD3 license-file: LICENSE category: GHC maintainer: ghc-devs@haskell.org -bug-reports: https://ghc.haskell.org/trac/ghc/newticket +bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new synopsis: The library supporting GHC's interactive interpreter description: This library offers interfaces which mediate interactions between the @ghci@ interactive shell and @iserv@, GHC's out-of-process interpreter backend. -cabal-version: >=1.10 build-type: Simple extra-source-files: changelog.md @@ -21,11 +22,12 @@ source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/ghci library default-language: Haskell2010 + default-extensions: NoImplicitPrelude other-extensions: BangPatterns CPP @@ -44,7 +46,7 @@ UnboxedTuples if flag(ghci) - CPP-Options: -DGHCI + CPP-Options: -DHAVE_INTERNAL_INTERPRETER exposed-modules: GHCi.Run GHCi.CreateBCO @@ -52,8 +54,11 @@ GHCi.Signals GHCi.TH + include-dirs: + exposed-modules: GHCi.BreakArray + GHCi.BinaryArray GHCi.Message GHCi.ResolvedBCO GHCi.RemoteTypes @@ -65,15 +70,16 @@ Build-Depends: array == 0.5.*, - base >= 4.8 && < 4.11, + base >= 4.8 && < 4.15, binary == 0.8.*, bytestring == 0.10.*, - containers == 0.5.*, + containers >= 0.5 && < 0.7, deepseq == 1.4.*, filepath == 1.4.*, - ghc-boot == 8.2.2, - ghc-boot-th == 8.2.2, - template-haskell == 2.12.*, + ghc-boot == 8.10.2, + ghc-boot-th == 8.10.2, + ghc-heap == 8.10.2, + template-haskell == 2.16.*, transformers == 0.5.* if !os(windows)