Cheng Shao pushed to branch wip/wasm-iserv-fast-binary at Glasgow Haskell Compiler / GHC

Commits:

2 changed files:

Changes:

  • libraries/ghci/GHCi/ResolvedBCO.hs
    ... ... @@ -9,12 +9,24 @@ module GHCi.ResolvedBCO
    9 9 
       , mkBCOByteArray
    10 10 
       ) where
    11 11
    12 
    +#include "MachDeps.h"
    13 
    +
    12 14 
     import Prelude -- See note [Why do we import Prelude here?]
    13 15 
     import GHC.Data.SizedSeq
    14 16 
     import GHCi.RemoteTypes
    15 17 
     import GHCi.BreakArray
    16 18
    17 
    -import Data.Binary
    19 
    +#if SIZEOF_HSWORD == 4
    20 
    +import Control.Monad
    21 
    +import Data.Array.Base (foldrArray, listArray)
    22 
    +import Data.ByteString.Builder.Extra
    23 
    +#endif
    24 
    +
    25 
    +import Data.Binary (Binary(..))
    26 
    +import Data.Binary.Get
    27 
    +import Data.Binary.Put
    28 
    +import Data.ByteString.Short (ShortByteString(..))
    29 
    +import Data.Word
    18 30 
     import GHC.Generics
    19 31
    20 32 
     import Foreign.Storable
    ... ... @@ -58,15 +70,23 @@ data BCOByteArray a
    58 70 
             getBCOByteArray :: !ByteArray#
    59 71 
       }
    60 72
    73 
    +#if SIZEOF_HSWORD == 4
    61 74 
     fromBCOByteArray :: forall a . Storable a => BCOByteArray a -> UArray Int a
    62 75 
     fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba#
    63 76 
       where
    64 77 
         len# = sizeofByteArray# ba#
    65 78 
         n = (I# len#) `div` sizeOf (undefined :: a)
    79 
    +#endif
    66 80
    67 81 
     mkBCOByteArray :: UArray Int a -> BCOByteArray a
    68 82 
     mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr
    69 83
    84 
    +putFixedWidthBCOByteArray :: BCOByteArray a -> Put
    85 
    +putFixedWidthBCOByteArray (BCOByteArray ba#) = put $ SBS ba#
    86 
    +
    87 
    +getFixedWidthBCOByteArray :: Get (BCOByteArray a)
    88 
    +getFixedWidthBCOByteArray = (\(SBS ba#) -> BCOByteArray ba#) <$> get
    89 
    +
    70 90 
     instance Show (BCOByteArray Word16) where
    71 91 
       showsPrec _ _ = showString "BCOByteArray Word16"
    72 92
    ... ... @@ -89,10 +109,40 @@ instance Binary ResolvedBCO where
    89 109 
       get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get
    90 110
    91 111 
     -- See Note [BCOByteArray serialization]
    92 
    -instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where
    93 
    -  put = put . fromBCOByteArray
    94 
    -  get = mkBCOByteArray <$> get
    95 
    -
    112 
    +instance Binary (BCOByteArray Word16) where
    113 
    +  put = putFixedWidthBCOByteArray
    114 
    +  get = getFixedWidthBCOByteArray
    115 
    +
    116 
    +-- Word size depends on host, which is tricky when host/target word
    117 
    +-- sizes differ. We always serialize `BCOByteArray Word` as
    118 
    +-- `BCOByteArray Word64`.
    119 
    +instance Binary (BCOByteArray Word) where
    120 
    +#if SIZEOF_HSWORD == 8
    121 
    +  -- 64-bit fast path. `BCOByteArray` is directly serialized via the
    122 
    +  -- `Binary ShortByteString` instance, which serializes the `Int`
    123 
    +  -- bytelength first (via `Int64` transparently), then copies the
    124 
    +  -- buffer.
    125 
    +  put = putFixedWidthBCOByteArray
    126 
    +
    127 
    +  get = getFixedWidthBCOByteArray
    128 
    +#else
    129 
    +  -- 32-bit slow path. Pretend it's a `BCOByteArray Word64` and handle
    130 
    +  -- the bytelength & buffer elements directly.
    131 
    +  put ba32@(BCOByteArray ba32#) =
    132 
    +    put len64 *>
    133 
    +    putBuilder
    134 
    +      (foldrArray (\w32 acc -> word64Host (fromIntegral w32) <> acc) mempty arr32)
    135 
    +    where
    136 
    +      len32# = sizeofByteArray# ba32#
    137 
    +      len64 = I# len32# * 2
    138 
    +      arr32 = fromBCOByteArray ba32
    139 
    +
    140 
    +  get = do
    141 
    +    len64 <- get
    142 
    +    let len = len64 `div` 8
    143 
    +    w32s <- replicateM len (fromIntegral <$> getWord64host)
    144 
    +    pure $ mkBCOByteArray $ listArray (0, len - 1) w32s
    145 
    +#endif
    96 146
    97 147 
     data ResolvedBCOPtr
    98 148 
       = ResolvedBCORef {-# UNPACK #-} !Int
    ... ... @@ -124,12 +174,17 @@ instance Binary ResolvedBCOPtr
    124 174 
     -- The root issue here is the usage of platform sized integer types in
    125 175 
     -- BCO (and any messages we pass between ghc/iserv really), we should
    126 176 
     -- do what we already do for RemotePtr: always use Word64 instead of
    127 
    --- Word. But that takes much more work, and there's an easier
    128 
    --- mitigation: keep BCOByteArray as ByteArray#, but serialize it as
    129 
    --- UArray, given the Binary instances are independent of platform word
    130 
    --- size and endianness, so each Word/Int is always serialized as
    131 
    --- 64-bit big-endian Word64/Int64, and the entire UArray is serialized
    132 
    --- as a list (length+elements).
    177 
    +-- Word.
    178 
    +--
    179 
    +-- When we serialize `BCOByteArray Word16`, element is fixed width on
    180 
    +-- 32/64-bit host, so we can directly serialize the buffer per se. For
    181 
    +-- `BCOByteArray Word`, we must always serialize it as `BCOByteArray
    182 
    +-- Word64`, and hence it has fast-path/slow-path decided at
    183 
    +-- compile-time, see comments of `instance Binary (BCOByteArray Word)`
    184 
    +-- for explanation. These are the only two `Binary` instances we ever
    185 
    +-- use, so to avoid unnecessary complexity, we're fine with flexible
    186 
    +-- instances here, instead of generalizing to any element type that
    187 
    +-- may be fixed-width or not.
    133 188 
     --
    134 189 
     -- Since we erase the metadata in UArray, we need to find a way to
    135 190 
     -- calculate the item count by dividing the ByteArray# length with

  • testsuite/tests/ghci/should_run/BinaryArray.hs
    ... ... @@ -24,7 +24,7 @@ roundtripTest arr =
    24 24 
              Left _           -> putStrLn "deserialization failed"
    25 25
    26 26 
     -- See Note [BCOByteArray serialization]
    27 
    -roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a, Binary a, Storable a)
    27 
    +roundtripTestByteArray :: forall a . (IArray UArray a, Eq a, Binary (BCOByteArray a))
    28 28 
                   => UArray Int a -> IO ()
    29 29 
     roundtripTestByteArray (UArray _ _ _ arr#) =
    30 30 
         let val  = BCOByteArray arr# :: BCOByteArray a
    ... ... @@ -44,10 +44,5 @@ main = do
    44 44 
         roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32)
    45 45 
         roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64)
    46 46 
         roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char)
    47 
    -    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Int)
    48 47 
         roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word)
    49 
    -    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word8)
    50 48 
         roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16)
    51 
    -    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word32)
    52 
    -    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word64)
    53 
    -    roundtripTestByteArray (AU.listArray (1,500) ['a'..] :: UArray Int Char)

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help