diff options
| -rw-r--r-- | compiler/ghci/ByteCodeAsm.hs | 2 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeLink.hs | 18 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeTypes.hs | 2 | ||||
| -rw-r--r-- | libraries/ghci/GHCi/BinaryArray.hs | 77 | ||||
| -rw-r--r-- | libraries/ghci/GHCi/CreateBCO.hs | 15 | ||||
| -rw-r--r-- | libraries/ghci/GHCi/RemoteTypes.hs | 12 | ||||
| -rw-r--r-- | libraries/ghci/GHCi/ResolvedBCO.hs | 68 | ||||
| -rw-r--r-- | libraries/ghci/ghci.cabal.in | 1 | ||||
| -rw-r--r-- | testsuite/tests/ghci/should_run/BinaryArray.hs | 29 | ||||
| -rw-r--r-- | testsuite/tests/ghci/should_run/all.T | 1 |
10 files changed, 158 insertions, 67 deletions
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs index 9eb730ff1a..a7395221ce 100644 --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -194,7 +194,7 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d return ul_bco -mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word +mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64 -- Here the return type must be an array of Words, not StgWords, -- because the underlying ByteArray# will end up as a component -- of a BCO object. diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs index 40f7341d32..e865590f2b 100644 --- a/compiler/ghci/ByteCodeLink.hs +++ b/compiler/ghci/ByteCodeLink.hs @@ -28,7 +28,6 @@ import SizedSeq import GHCi import ByteCodeTypes import HscTypes -import DynFlags import Name import NameEnv import PrimOp @@ -40,8 +39,6 @@ import Util -- Standard libraries import Data.Array.Unboxed -import Data.Array.Base -import Data.Word import Foreign.Ptr import GHC.IO ( IO(..) ) import GHC.Exts @@ -69,21 +66,14 @@ linkBCO -> IO ResolvedBCO linkBCO hsc_env ie ce bco_ix breakarray (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do - lits <- mapM (lookupLiteral hsc_env ie) (ssElts lits0) + -- fromIntegral Word -> Word64 should be a no op if Word is Word64 + -- otherwise it will result in a cast to longlong on 32bit systems. + lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0) ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0) - let dflags = hsc_dflags hsc_env - return (ResolvedBCO arity (toWordArray dflags insns) bitmap + return (ResolvedBCO isLittleEndian arity insns bitmap (listArray (0, fromIntegral (sizeSS lits0)-1) lits) (addListToSS emptySS ptrs)) --- Turn the insns array from a Word16 array into a Word array. The --- latter is much faster to serialize/deserialize. Assumes the input --- array is zero-indexed. -toWordArray :: DynFlags -> UArray Int Word16 -> UArray Int Word -toWordArray dflags (UArray _ _ n arr) = UArray 0 (n'-1) n' arr - where n' = (n + w16s_per_word - 1) `quot` w16s_per_word - w16s_per_word = wORD_SIZE dflags `quot` 2 - lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word lookupLiteral _ _ (BCONPtrWord lit) = return lit lookupLiteral hsc_env _ (BCONPtrLbl sym) = do diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs index ec962c886b..1318a47ef4 100644 --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs @@ -80,7 +80,7 @@ data UnlinkedBCO unlinkedBCOName :: !Name, unlinkedBCOArity :: {-# UNPACK #-} !Int, unlinkedBCOInstrs :: !(UArray Int Word16), -- insns - unlinkedBCOBitmap :: !(UArray Int Word), -- bitmap + unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs } diff --git a/libraries/ghci/GHCi/BinaryArray.hs b/libraries/ghci/GHCi/BinaryArray.hs new file mode 100644 index 0000000000..9529744b33 --- /dev/null +++ b/libraries/ghci/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/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs index f42c975cd7..aae4b686fa 100644 --- a/libraries/ghci/GHCi/CreateBCO.hs +++ b/libraries/ghci/GHCi/CreateBCO.hs @@ -25,7 +25,7 @@ import Foreign hiding (newArray) 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 @@ createBCOs bcos = do mapM mkRemoteRef hvals createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue +createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian + = throwIO (ErrorCall $ + unlines [ "The endianess of the ResolvedBCO does not match" + , "the systems endianess. Using ghc and iserv in a" + , "mixed endianess 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 @@ createBCO arr bco 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 @@ linkBCO' arr ResolvedBCO{..} = do 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/libraries/ghci/GHCi/RemoteTypes.hs b/libraries/ghci/GHCi/RemoteTypes.hs index 3b4dee75c5..12ae529b16 100644 --- a/libraries/ghci/GHCi/RemoteTypes.hs +++ b/libraries/ghci/GHCi/RemoteTypes.hs @@ -30,14 +30,12 @@ import GHC.ForeignPtr -- 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/libraries/ghci/GHCi/ResolvedBCO.hs b/libraries/ghci/GHCi/ResolvedBCO.hs index aa63d36c9c..37836a4e62 100644 --- a/libraries/ghci/GHCi/ResolvedBCO.hs +++ b/libraries/ghci/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 endianess, however there is no support for mixed +-- endianess setups. This is primarily to ensure that ghc and iserv share the +-- same endianess. 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/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in index d15da5a0f5..da25507b08 100644 --- a/libraries/ghci/ghci.cabal.in +++ b/libraries/ghci/ghci.cabal.in @@ -57,6 +57,7 @@ library exposed-modules: GHCi.BreakArray + GHCi.BinaryArray GHCi.Message GHCi.ResolvedBCO GHCi.RemoteTypes diff --git a/testsuite/tests/ghci/should_run/BinaryArray.hs b/testsuite/tests/ghci/should_run/BinaryArray.hs new file mode 100644 index 0000000000..828588c748 --- /dev/null +++ b/testsuite/tests/ghci/should_run/BinaryArray.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE FlexibleContexts #-} +import Data.Binary.Get +import Data.Binary.Put +import Data.Array.Unboxed as AU +import Data.Array.IO (IOUArray) +import Data.Array.MArray (MArray) +import Data.Array as A +import GHCi.BinaryArray +import GHC.Word + +roundtripTest :: (IArray UArray a, MArray IOUArray a IO, Eq a) + => UArray Int a -> IO () +roundtripTest arr = + let ser = Data.Binary.Put.runPut $ putArray arr + in case Data.Binary.Get.runGetOrFail getArray ser of + Right (_, _, arr') + | arr == arr' -> return () + | otherwise -> putStrLn "failed to round-trip" + Left _ -> putStrLn "deserialization failed" + +main :: IO () +main = do + roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Int) + roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word) + roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word8) + roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word16) + roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32) + roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64) + roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char) diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T index 3dc05ce31c..fe33685193 100644 --- a/testsuite/tests/ghci/should_run/all.T +++ b/testsuite/tests/ghci/should_run/all.T @@ -27,3 +27,4 @@ test('T11825', just_ghci, ghci_script, ['T11825.script']) test('T12128', just_ghci, ghci_script, ['T12128.script']) test('T12456', just_ghci, ghci_script, ['T12456.script']) test('T12549', just_ghci, ghci_script, ['T12549.script']) +test('BinaryArray', normal, compile_and_run, [''])
\ No newline at end of file |