diff --git a/GHCi/BinaryArray.hs b/GHCi/BinaryArray.hs new file mode 100644 --- /dev/null +++ b/GHCi/BinaryArray.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-} +-- | Efficient serialisation for GHCi Instruction arrays +-- +-- Author: Ben Gamari +-- +module GHCi.BinaryArray(putArray, getArray) where + +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/CreateBCO.hs b/GHCi/CreateBCO.hs --- a/GHCi/CreateBCO.hs +++ b/GHCi/CreateBCO.hs @@ -25,7 +25,7 @@ import GHC.Arr ( Array(..) ) import GHC.Exts import GHC.IO --- import Debug.Trace +import Control.Exception (throwIO, ErrorCall(..)) createBCOs :: [ResolvedBCO] -> IO [HValueRef] createBCOs bcos = do @@ -36,6 +36,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 +62,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 +77,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/InfoTable.hsc b/GHCi/InfoTable.hsc --- a/GHCi/InfoTable.hsc +++ b/GHCi/InfoTable.hsc @@ -1,5 +1,8 @@ {-# 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/. @@ -17,23 +20,20 @@ import Data.Maybe (fromJust) #endif import Foreign -import Foreign.C -import GHC.Ptr -import GHC.Exts -import System.IO.Unsafe +import Foreign.C -- needed for 2nd stage +import GHC.Ptr -- needed for 2nd stage +import GHC.Exts -- needed for 2nd stage +import System.IO.Unsafe -- needed for 2nd stage 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 +#error Unknown SIZEOF_VOID_P #endif type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) diff --git a/GHCi/Message.hs b/GHCi/Message.hs --- a/GHCi/Message.hs +++ b/GHCi/Message.hs @@ -48,11 +48,7 @@ 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 @@ -244,6 +240,7 @@ AddDependentFile :: FilePath -> THMessage (THResult ()) AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ()) + AddCorePlugin :: String -> THMessage (THResult ()) AddTopDecls :: [TH.Dec] -> THMessage (THResult ()) AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ()) IsExtEnabled :: Extension -> THMessage (THResult Bool) @@ -282,7 +279,8 @@ 15 -> THMsg <$> EndRecover <$> get 16 -> return (THMsg RunTHDone) 17 -> THMsg <$> AddModFinalizer <$> get - _ -> THMsg <$> (AddForeignFile <$> get <*> get) + 18 -> THMsg <$> (AddForeignFile <$> get <*> get) + _ -> THMsg <$> AddCorePlugin <$> get putTHMessage :: THMessage a -> Put putTHMessage m = case m of @@ -305,6 +303,7 @@ RunTHDone -> putWord8 16 AddModFinalizer a -> putWord8 17 >> put a AddForeignFile lang a -> putWord8 18 >> put lang >> put a + AddCorePlugin a -> putWord8 19 >> put a data EvalOpts = EvalOpts @@ -384,17 +383,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 diff --git a/GHCi/ObjLink.hs b/GHCi/ObjLink.hs --- a/GHCi/ObjLink.hs +++ b/GHCi/ObjLink.hs @@ -180,14 +180,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 @@ -30,14 +30,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,64 @@ {-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving, - BangPatterns #-} + BangPatterns, CPP #-} module GHCi.ResolvedBCO ( ResolvedBCO(..) , ResolvedBCOPtr(..) + , isLittleEndian ) where 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 @@ -344,9 +344,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 @@ -5,7 +5,7 @@ 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/TH.hs b/GHCi/TH.hs --- a/GHCi/TH.hs +++ b/GHCi/TH.hs @@ -97,6 +97,7 @@ 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) @@ -160,6 +161,9 @@ 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) @@ -190,12 +194,12 @@ 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) qAddTopDecls decls = ghcCmd (AddTopDecls decls) qAddForeignFile str lang = ghcCmd (AddForeignFile str lang) 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 diff --git a/GHCi/TH/Binary.hs b/GHCi/TH/Binary.hs --- a/GHCi/TH/Binary.hs +++ b/GHCi/TH/Binary.hs @@ -44,7 +44,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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,15 +1,3 @@ -## 8.2.2 Nov 2017 - - * 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,5 +1,5 @@ name: ghci -version: 8.2.2 +version: 8.4.1 license: BSD3 license-file: LICENSE category: GHC @@ -54,6 +54,7 @@ exposed-modules: GHCi.BreakArray + GHCi.BinaryArray GHCi.Message GHCi.ResolvedBCO GHCi.RemoteTypes @@ -65,15 +66,15 @@ Build-Depends: array == 0.5.*, - base >= 4.8 && < 4.11, + base >= 4.8 && < 4.12, binary == 0.8.*, bytestring == 0.10.*, containers == 0.5.*, deepseq == 1.4.*, filepath == 1.4.*, - ghc-boot == 8.2.2, - ghc-boot-th == 8.2.2, - template-haskell == 2.12.*, + ghc-boot == 8.4.1, + ghc-boot-th == 8.4.1, + template-haskell == 2.13.*, transformers == 0.5.* if !os(windows)