From 7ae4a28f6a09a0540aab59f5a03fdbcd46a99f17 Mon Sep 17 00:00:00 2001
From: Ben Gamari <bgamari.foss@gmail.com>
Date: Tue, 11 Jul 2017 20:50:38 -0400
Subject: [PATCH] [iserv] Fixing the word size for RemotePtr and toWordArray
When we load non absolute pathed .so's this usually implies that we
expect the system to have them in place already, and hence we should not
need to ship them. Without the absolute path to the library, we are
also unable to open and send said library. Thus we'll do library
shipping only for libraries with absolute paths.
When dealing with a host and target of different word size (say host
hast 64bit, target has 32bit), we need to fix the RemotePtr size and the
toWordArray function, as they are part of the iserv ResolvedBCO binary
protocol. This needs to be word size independent. The choice for
RemotePtr to 64bit was made to ensure we can store 64bit pointers when
targeting 64bit. The choice for 32bit word arrays was made wrt.
encoding/decoding on the potentially slower device.
The efficient serialization code has been graciously provided by
@bgamari.
Reviewers: bgamari, simonmar, austin, hvr
Reviewed By: bgamari
Subscribers: Ericson2314, rwbarton, thomie, ryantrinkle
Differential Revision: https://phabricator.haskell.org/D3443
---
compiler/ghci/ByteCodeAsm.hs | 2 +-
compiler/ghci/ByteCodeLink.hs | 18 +----
compiler/ghci/ByteCodeTypes.hs | 2 +-
libraries/ghci/GHCi/BinaryArray.hs | 77 +++++++++++++++++++
libraries/ghci/GHCi/CreateBCO.hs | 15 +++-
libraries/ghci/GHCi/RemoteTypes.hs | 12 ++-
libraries/ghci/GHCi/ResolvedBCO.hs | 68 +++++++---------
libraries/ghci/ghci.cabal.in | 1 +
.../tests/ghci/should_run/BinaryArray.hs | 29 +++++++
testsuite/tests/ghci/should_run/all.T | 1 +
10 files changed, 158 insertions(+), 67 deletions(-)
create mode 100644 libraries/ghci/GHCi/BinaryArray.hs
create mode 100644 testsuite/tests/ghci/should_run/BinaryArray.hs
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index 9eb730ff1a00..a7395221ce95 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 40f7341d3241..e865590f2b97 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 ec962c886bf2..1318a47ef400 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 000000000000..9529744b3337
--- /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 f42c975cd722..aae4b686face 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 3b4dee75c5ea..12ae529b1604 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 aa63d36c9ce2..37836a4e620d 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 d15da5a0f568..da25507b0826 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 000000000000..828588c74805
--- /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 3dc05ce31c4e..fe3368519365 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
--
GitLab