Skip to content
Snippets Groups Projects
Commit 698a315e authored by Cheng Shao's avatar Cheng Shao
Browse files

ghci: mitigate host/target word size mismatch in BCOByteArray serialization

This patch mitigates a severe host/target word size mismatch issue in
BCOByteArray serialization logic introduced since !12142, see added
note for detailed explanation.

(cherry picked from commit 90891962)
(cherry picked from commit 86059632)
(cherry picked from commit 30d12c46)
parent 94eebec6
No related branches found
No related tags found
No related merge requests found
{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving, {-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,
BangPatterns, CPP, MagicHash, FlexibleInstances, FlexibleContexts, BangPatterns, CPP, MagicHash, FlexibleInstances, FlexibleContexts,
TypeApplications, ScopedTypeVariables, UnboxedTuples #-} TypeApplications, ScopedTypeVariables, UnboxedTuples, UndecidableInstances #-}
module GHCi.ResolvedBCO module GHCi.ResolvedBCO
( ResolvedBCO(..) ( ResolvedBCO(..)
, ResolvedBCOPtr(..) , ResolvedBCOPtr(..)
...@@ -15,18 +15,12 @@ import GHCi.RemoteTypes ...@@ -15,18 +15,12 @@ import GHCi.RemoteTypes
import GHCi.BreakArray import GHCi.BreakArray
import Data.Binary import Data.Binary
import Data.Binary.Put (putBuilder)
import GHC.Generics import GHC.Generics
import Foreign.Ptr import Foreign.Storable
import Data.Array.Byte
import qualified Data.Binary.Get.Internal as Binary
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Builder.Internal as BB
import GHC.Exts import GHC.Exts
import Data.Array.Base (UArray(..)) import Data.Array.Base (IArray, UArray(..))
import GHC.IO
#include "MachDeps.h" #include "MachDeps.h"
...@@ -63,6 +57,12 @@ data BCOByteArray a ...@@ -63,6 +57,12 @@ data BCOByteArray a
getBCOByteArray :: !ByteArray# getBCOByteArray :: !ByteArray#
} }
fromBCOByteArray :: forall a . Storable a => BCOByteArray a -> UArray Int a
fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba#
where
len# = sizeofByteArray# ba#
n = (I# len#) `div` sizeOf (undefined :: a)
mkBCOByteArray :: UArray Int a -> BCOByteArray a mkBCOByteArray :: UArray Int a -> BCOByteArray a
mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr
...@@ -87,9 +87,10 @@ instance Binary ResolvedBCO where ...@@ -87,9 +87,10 @@ instance Binary ResolvedBCO where
put resolvedBCOPtrs put resolvedBCOPtrs
get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get
instance Binary (BCOByteArray a) where -- See Note [BCOByteArray serialization]
put = putBCOByteArray instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where
get = decodeBCOByteArray put = put . fromBCOByteArray
get = mkBCOByteArray <$> get
data ResolvedBCOPtr data ResolvedBCOPtr
...@@ -107,64 +108,29 @@ data ResolvedBCOPtr ...@@ -107,64 +108,29 @@ data ResolvedBCOPtr
instance Binary ResolvedBCOPtr instance Binary ResolvedBCOPtr
-- -------------------------------------------------------- -- Note [BCOByteArray serialization]
-- Serialisers for 'BCOByteArray' -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- -------------------------------------------------------- --
-- !12142 changed some BCO blob types from UArray to
putBCOByteArray :: BCOByteArray a -> Put -- BCOByteArray(ByteArray#) to save a little space. Unfortunately, a
putBCOByteArray (BCOByteArray bar) = do -- nasty serialization bug has surfaced since then. It happens when we
put (I# (sizeofByteArray# bar)) -- need to pass BCOByteArray between host/target with mismatching word
putBuilder $ byteArrayBuilder bar -- sizes. When 32-bit iserv receives a `BCOByteArray Word` from 64-bit
-- host GHC, it would parse the buffer assuming each Word=Word32, even
decodeBCOByteArray :: Get (BCOByteArray a) -- if host GHC assumes each Word=Word64, and of course it's horribly
decodeBCOByteArray = do -- wrong!
n <- get --
getByteArray n -- The root issue here is the usage of platform sized integer types in
-- BCO (and any messages we pass between ghc/iserv really), we should
byteArrayBuilder :: ByteArray# -> BB.Builder -- do what we already do for RemotePtr: always use Word64 instead of
byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#)) -- Word. But that takes much more work, and there's an easier
where -- mitigation: keep BCOByteArray as ByteArray#, but serialize it as
go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a -- UArray, given the Binary instances are independent of platform word
go !inStart !inEnd k (BB.BufferRange outStart outEnd) -- size and endianness, so each Word/Int is always serialized as
-- There is enough room in this output buffer to write all remaining array -- 64-bit big-endian Word64/Int64, and the entire UArray is serialized
-- contents -- as a list (length+elements).
| inRemaining <= outRemaining = do --
copyByteArrayToAddr arr# inStart outStart inRemaining -- Since we erase the metadata in UArray, we need to find a way to
k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd) -- calculate the item count by dividing the ByteArray# length with
-- There is only enough space for a fraction of the remaining contents -- element size. The element size comes from Storable's sizeOf method,
| otherwise = do -- thus the addition of Storable constraint.
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', () #)
getByteArray :: Int -> Get (BCOByteArray a)
getByteArray nbytes@(I# nbytes#) = do
let !(MutableByteArray arr#) = unsafeDupablePerformIO $
IO $ \s -> case newByteArray# nbytes# s of
(# s', mbar #) -> (# s', MutableByteArray mbar #)
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 nbytes 0
return $! unsafeDupablePerformIO $
IO $ \s -> case unsafeFreezeByteArray# arr# s of
(# s', bar #) -> (# s', BCOByteArray bar #)
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', () #)
{-# LANGUAGE FlexibleContexts, MagicHash, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts, MagicHash, ScopedTypeVariables #-}
import Data.Binary.Get import Data.Binary.Get
import Data.Binary.Put import Data.Binary.Put
import Data.Binary (get, put) import Data.Binary (Binary, get, put)
import Data.Array.Byte import Data.Array.Byte
import Data.Array.Unboxed as AU import Data.Array.Unboxed as AU
import Data.Array.IO (IOUArray) import Data.Array.IO (IOUArray)
import Data.Array.MArray (MArray) import Data.Array.MArray (MArray)
import Data.Array as A import Data.Array as A
import Data.Array.Base as A import Data.Array.Base as A
import Foreign.Storable
import GHCi.BinaryArray import GHCi.BinaryArray
import GHCi.ResolvedBCO import GHCi.ResolvedBCO
import GHC.Word import GHC.Word
...@@ -22,7 +23,8 @@ roundtripTest arr = ...@@ -22,7 +23,8 @@ roundtripTest arr =
| otherwise -> putStrLn "failed to round-trip" | otherwise -> putStrLn "failed to round-trip"
Left _ -> putStrLn "deserialization failed" Left _ -> putStrLn "deserialization failed"
roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a) -- See Note [BCOByteArray serialization]
roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a, Binary a, Storable a)
=> UArray Int a -> IO () => UArray Int a -> IO ()
roundtripTestByteArray (UArray _ _ _ arr#) = roundtripTestByteArray (UArray _ _ _ arr#) =
let val = BCOByteArray arr# :: BCOByteArray a let val = BCOByteArray arr# :: BCOByteArray a
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment