Cheng Shao pushed to branch wip/ghci-smallarray-cleanup at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • libraries/ghci/GHCi/BinaryArray.hs deleted
    1 
    -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}
    2 
    --- | Efficient serialisation for GHCi Instruction arrays
    3 
    ---
    4 
    --- Author: Ben Gamari
    5 
    ---
    6 
    -module GHCi.BinaryArray(putArray, getArray) where
    7 
    -
    8 
    -import Prelude
    9 
    -import Foreign.Ptr
    10 
    -import Data.Binary
    11 
    -import Data.Binary.Put (putBuilder)
    12 
    -import qualified Data.Binary.Get.Internal as Binary
    13 
    -import qualified Data.ByteString.Builder as BB
    14 
    -import qualified Data.ByteString.Builder.Internal as BB
    15 
    -import qualified Data.Array.Base as A
    16 
    -import qualified Data.Array.IO.Internals as A
    17 
    -import qualified Data.Array.Unboxed as A
    18 
    -import GHC.Exts
    19 
    -import GHC.IO
    20 
    -
    21 
    --- | An efficient serialiser of 'A.UArray'.
    22 
    -putArray :: Binary i => A.UArray i a -> Put
    23 
    -putArray (A.UArray l u _ arr#) = do
    24 
    -    put l
    25 
    -    put u
    26 
    -    putBuilder $ byteArrayBuilder arr#
    27 
    -
    28 
    -byteArrayBuilder :: ByteArray# -> BB.Builder
    29 
    -byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))
    30 
    -  where
    31 
    -    go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a
    32 
    -    go !inStart !inEnd k (BB.BufferRange outStart outEnd)
    33 
    -      -- There is enough room in this output buffer to write all remaining array
    34 
    -      -- contents
    35 
    -      | inRemaining <= outRemaining = do
    36 
    -          copyByteArrayToAddr arr# inStart outStart inRemaining
    37 
    -          k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)
    38 
    -      -- There is only enough space for a fraction of the remaining contents
    39 
    -      | otherwise = do
    40 
    -          copyByteArrayToAddr arr# inStart outStart outRemaining
    41 
    -          let !inStart' = inStart + outRemaining
    42 
    -          return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)
    43 
    -      where
    44 
    -        inRemaining  = inEnd - inStart
    45 
    -        outRemaining = outEnd `minusPtr` outStart
    46 
    -
    47 
    -    copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()
    48 
    -    copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =
    49 
    -        IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of
    50 
    -                     s' -> (# s', () #)
    51 
    -
    52 
    --- | An efficient deserialiser of 'A.UArray'.
    53 
    -getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)
    54 
    -getArray = do
    55 
    -    l <- get
    56 
    -    u <- get
    57 
    -    arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <-
    58 
    -        return $ unsafeDupablePerformIO $ A.newArray_ (l,u)
    59 
    -    let go 0 _ = return ()
    60 
    -        go !remaining !off = do
    61 
    -            Binary.readNWith n $ \ptr ->
    62 
    -              copyAddrToByteArray ptr arr# off n
    63 
    -            go (remaining - n) (off + n)
    64 
    -          where n = min chunkSize remaining
    65 
    -    sz <- return $ unsafeDupablePerformIO $ IO $ \s -> case getSizeofMutableByteArray# arr# s of
    66 
    -            (# s2, n #) -> (# s2, I# n #)
    67 
    -    go sz 0
    68 
    -    return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr
    69 
    -  where
    70 
    -    chunkSize = 10*1024
    71 
    -
    72 
    -    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld
    73 
    -                        -> Int -> Int -> IO ()
    74 
    -    copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =
    75 
    -        IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of
    76 
    -                     s' -> (# s', () #)
    77 
    -
    78 
    --- this is inexplicably not exported in currently released array versions
    79 
    -unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)
    80 
    -unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr)

  • libraries/ghci/ghci.cabal.in
    ... ... @@ -74,7 +74,6 @@ library
    74 74
    75 75 
         exposed-modules:
    76 76 
             GHCi.BreakArray
    77 
    -        GHCi.BinaryArray
    78 77 
             GHCi.Message
    79 78 
             GHCi.ResolvedBCO
    80 79 
             GHCi.RemoteTypes

  • testsuite/tests/ghci/should_run/BinaryArray.hs
    ... ... @@ -4,25 +4,10 @@ import Data.Binary.Put
    4 4 
     import Data.Binary (Binary, get, put)
    5 5 
     import Data.Array.Byte
    6 6 
     import Data.Array.Unboxed as AU
    7 
    -import Data.Array.IO (IOUArray)
    8 
    -import Data.Array.MArray (MArray)
    9 
    -import Data.Array as A
    10 7 
     import Data.Array.Base as A
    11 
    -import Foreign.Storable
    12 
    -import GHCi.BinaryArray
    13 8 
     import GHCi.ResolvedBCO
    14 9 
     import GHC.Word
    15 10
    16 
    -roundtripTest :: (IArray UArray a, MArray IOUArray a IO, Eq a)
    17 
    -              => UArray Int a -> IO ()
    18 
    -roundtripTest arr =
    19 
    -    let ser  = Data.Binary.Put.runPut $ putArray arr
    20 
    -    in case Data.Binary.Get.runGetOrFail getArray ser of
    21 
    -         Right (_, _, arr')
    22 
    -           | arr == arr'  -> return ()
    23 
    -           | otherwise    -> putStrLn "failed to round-trip"
    24 
    -         Left _           -> putStrLn "deserialization failed"
    25 
    -
    26 11 
     -- See Note [BCOByteArray serialization]
    27 12 
     roundtripTestByteArray :: forall a . (IArray UArray a, Eq a, Binary (BCOByteArray a))
    28 13 
                   => UArray Int a -> IO ()
    ... ... @@ -37,12 +22,5 @@ roundtripTestByteArray (UArray _ _ _ arr#) =
    37 22
    38 23 
     main :: IO ()
    39 24 
     main = do
    40 
    -    roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Int)
    41 
    -    roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word)
    42 
    -    roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word8)
    43 
    -    roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word16)
    44 
    -    roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32)
    45 
    -    roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64)
    46 
    -    roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char)
    47 25 
         roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word)
    48 26 
         roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16)

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