Drop assumption that passed bytes are pinned

Apply a fix that in case of unpinned bytes passed in hPutBuffer
we first create a pinned ByteArray and copy bytes there

Author: qnikst

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
@@ -239,13 +240,21 @@ hPutBuffer :: (Buffer u) => Handle -> u -> IO ()
 hPutBuffer handle u =
   buffer
     u
-    ( \bytes -> do
-        withForeignPtr (pinnedByteArrayToForeignPtr bytes) $ \ptr -> do
-          hPutBuf handle ptr len
+    ( \bytes off -> do
+        (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) => Fail e a -> Either e a
 runDecode f = runFailLast f

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)