Commit 7ae4a28f authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari
Browse files

[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
parent 60ec8f74
......@@ -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.
......
......@@ -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
......
......@@ -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
}
......
{-# 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)
......@@ -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 ->
......
......@@ -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))
......
{-# 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
......
......@@ -57,6 +57,7 @@ library
exposed-modules:
GHCi.BreakArray
GHCi.BinaryArray
GHCi.Message
GHCi.ResolvedBCO
GHCi.RemoteTypes
......
{-# 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)
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment