diff --git a/mempack-scls/mempack-1.0/Data/MemPack/Extra.hs b/mempack-scls/mempack-1.0/Data/MemPack/Extra.hs index 9feaa2d..44b8ad2 100644 --- a/mempack-scls/mempack-1.0/Data/MemPack/Extra.hs +++ b/mempack-scls/mempack-1.0/Data/MemPack/Extra.hs @@ -38,6 +38,7 @@ import Data.ByteString.Lazy qualified as BSL import Data.MemPack import Data.MemPack.Buffer import Data.MemPack.Error +import Data.Primitive.ByteArray import Data.Primitive.Ptr import Data.String (IsString) import Data.Text qualified as T @@ -240,12 +241,19 @@ hPutBuffer handle u = buffer u ( \bytes -> do - withForeignPtr (pinnedByteArrayToForeignPtr bytes) $ \ptr -> do + pinnedBytes <- pinIfNeeded (ByteArray bytes) + withForeignPtr (byteArrayAsForeignPtr pinnedBytes) $ \ptr -> do hPutBuf handle ptr len ) - (\addr -> hPutBuf handle (Ptr addr) len) -- Write Ptr# + (\addr -> hPutBuf handle (Ptr addr) len) where len = bufferByteCount u + pinIfNeeded bytes + | isByteArrayPinned bytes = return bytes + | otherwise = do + dest <- newPinnedByteArray len + copyByteArray dest 0 bytes 0 len + unsafeFreezeByteArray dest runDecode :: (IsString e) => Fail e a -> Either e a runDecode f = runFailLast f diff --git a/mempack-scls/mempack-2.0/Data/MemPack/Extra.hs b/mempack-scls/mempack-2.0/Data/MemPack/Extra.hs index a51ae60..0d295b7 100644 --- a/mempack-scls/mempack-2.0/Data/MemPack/Extra.hs +++ b/mempack-scls/mempack-2.0/Data/MemPack/Extra.hs @@ -39,6 +39,7 @@ import Data.ByteString.Lazy qualified as BSL import Data.MemPack import Data.MemPack.Buffer import Data.MemPack.Error +import Data.Primitive.ByteArray import Data.Primitive.Ptr import Data.Text qualified as T import Data.Typeable @@ -245,12 +246,20 @@ hPutBuffer handle u = buffer u ( \bytes off -> do - withForeignPtr (pinnedByteArrayToForeignPtr bytes) $ \ptr -> do - hPutBuf handle (ptr `plusPtr` (I# off)) (len - (I# off)) + (pinnedBytes, offset) <- pinIfNeeded (ByteArray bytes) (I# off) + withForeignPtr (byteArrayAsForeignPtr pinnedBytes) $ \ptr -> do + hPutBuf handle (ptr `plusPtr` offset) (len - offset) ) - (\addr -> hPutBuf handle (Ptr addr) len) -- Write Ptr# + (\addr -> hPutBuf handle (Ptr addr) len) where len = bufferByteCount u + pinIfNeeded bytes off + | isByteArrayPinned bytes = return (bytes, off) + | otherwise = do + let l = len - off + dest <- newPinnedByteArray l + copyByteArray dest 0 bytes off l + (,0) <$> unsafeFreezeByteArray dest runDecode :: (IsString e) => (forall s. FailT e (ST s) a) -> Either e a runDecode f = runST (runFailLastT f)