[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

10 files changed, 158 insertions, 67 deletions

diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index 9eb730f..a739522 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 40f7341..e865590 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 ec962c8..1318a47 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 0000000..9529744
--- /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 f42c975..aae4b68 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 3b4dee7..12ae529 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 aa63d36..37836a4 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 d15da5a..da25507 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 0000000..828588c
--- /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 3dc05ce..fe33685 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