Simple zero copy demo

zero-copy/LICENSE

@@ -0,0 +1,29 @@
+Copyright (c) 2024-2025, Well-Typed LLP and Anduril Industries Inc. 
+
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the copyright holder nor the names of its
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

zero-copy/app/Generated.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | Code generated by @hs-bindgen@ and then cleaned up for better presentation
+module Generated where
+
+import Data.Array.Byte (ByteArray)
+import Foreign
+import Foreign.C
+
+import HsBindgen.Runtime.ByteArray qualified as ByteArray
+import HsBindgen.Runtime.CAPI as CAPI
+import HsBindgen.Runtime.ConstantArray (ConstantArray)
+import HsBindgen.Runtime.SizedByteArray (SizedByteArray(..))
+
+$(CAPI.addCSource "#include \"cbits.h\"\nvoid Generated_show_rect (struct rect *arg1) { show_rect(arg1); }\n")
+
+{-------------------------------------------------------------------------------
+  Structs
+-------------------------------------------------------------------------------}
+
+data Point = Point {
+      x :: CInt
+    , y :: CInt
+    }
+  deriving stock (Show, Eq)
+
+data Rect = Rect {
+      topleft     :: Point
+    , bottomright :: Point
+    }
+  deriving stock (Show, Eq)
+
+instance Storable Point where
+  sizeOf    _ = 8
+  alignment _ = 4
+
+  peek ptr =
+          pure Point
+      <*> peekByteOff ptr 0
+      <*> peekByteOff ptr 4
+
+  poke ptr Point{x, y} = do
+      pokeByteOff ptr 0 x
+      pokeByteOff ptr 4 y
+
+instance Storable Rect where
+  sizeOf    _ = 16
+  alignment _ = 4
+
+  peek ptr =
+          pure Rect
+      <*> peekByteOff ptr (0 :: Int)
+      <*> peekByteOff ptr (8 :: Int)
+
+  poke ptr Rect{topleft, bottomright} = do
+      pokeByteOff ptr (0 :: Int) topleft
+      pokeByteOff ptr (8 :: Int) bottomright
+
+foreign import ccall safe "Generated_show_rect"
+  show_rect :: Ptr Rect -> IO ()
+
+{-------------------------------------------------------------------------------
+  Union
+-------------------------------------------------------------------------------}
+
+newtype PointVsArray = PointVsArray ByteArray
+  deriving Storable via SizedByteArray 8 4
+
+get_pointVsArray_asPoint :: PointVsArray -> Point
+get_pointVsArray_asPoint = ByteArray.getUnionPayload
+
+set_pointVsArray_asPoint :: Point -> PointVsArray
+set_pointVsArray_asPoint = ByteArray.setUnionPayload
+
+get_pointVsArray_asArray :: PointVsArray -> ConstantArray 2 CInt
+get_pointVsArray_asArray = ByteArray.getUnionPayload
+
+set_pointVsArray_asArray :: ConstantArray 2 CInt -> PointVsArray
+set_pointVsArray_asArray = ByteArray.setUnionPayload

zero-copy/app/Main.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Main where
+
+import Foreign
+
+import HsBindgen.Runtime.ConstantArray qualified as CA
+
+import Generated qualified as G
+import ZeroCopy  qualified as Z
+
+main :: IO ()
+main = do
+    with (G.Rect (G.Point 1 2) (G.Point 3 4)) $ G.show_rect
+
+    with (Z.Rect (Z.Point 1 2) (Z.Point 3 4)) $ \ptr -> do
+      poke ptr.bottomright.x 99
+      Z.show_rect ptr
+
+    with (Z.set_pointVsArray_asArray $ CA.fromList [55, 66]) $ \ptr -> do
+      y <- peek ptr.asPoint.y
+      print y

zero-copy/app/ZeroCopy.hs

@@ -0,0 +1,148 @@
+{-# LANGUAGE CApiFFI               #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NoFieldSelectors      #-}
+{-# LANGUAGE OverloadedRecordDot   #-}
+
+module ZeroCopy where
+
+import Data.Array.Byte (ByteArray)
+import Data.Kind
+import Data.Proxy
+import Foreign
+import Foreign.C
+import GHC.Exts
+import GHC.Records qualified as GHC
+
+import HsBindgen.Runtime.ByteArray qualified as ByteArray
+import HsBindgen.Runtime.ConstantArray (ConstantArray)
+import HsBindgen.Runtime.SizedByteArray (SizedByteArray(..))
+
+{-------------------------------------------------------------------------------
+  Infrastructure (this would live in hs-bindgen-runtime)
+-------------------------------------------------------------------------------}
+
+class Storable (FieldType a field)
+   => HasCField (a :: Type) (field :: Symbol) where
+  type FieldType a field :: Type
+  ptrToField :: Proxy field -> Ptr a -> Ptr (FieldType a field)
+
+pokeField ::
+     HasCField a field
+  => Proxy field -> Ptr a -> FieldType a field -> IO ()
+pokeField field ptr val = poke (ptrToField field ptr) val
+
+peekField ::
+     HasCField a field
+  => Proxy field -> Ptr a -> IO (FieldType a field)
+peekField field ptr = peek (ptrToField field ptr)
+
+{-------------------------------------------------------------------------------
+  Example (this would be generated code)
+-------------------------------------------------------------------------------}
+
+data Point = Point {
+      x :: CInt
+    , y :: CInt
+    }
+  deriving stock (Show, Eq)
+
+data Rect = Rect {
+      topleft     :: Point
+    , bottomright :: Point
+    }
+  deriving stock (Show, Eq)
+
+instance HasCField Point "x" where
+  type FieldType Point "x" = CInt
+  ptrToField _ ptr = ptr `plusPtr` 0
+
+instance HasCField Point "y" where
+  type FieldType Point "y" = CInt
+  ptrToField _ ptr = ptr `plusPtr` 4
+
+instance HasCField Rect "topleft" where
+  type FieldType Rect "topleft" = Point
+  ptrToField _ ptr = ptr `plusPtr` 0
+
+instance HasCField Rect "bottomright" where
+  type FieldType Rect "bottomright" = Point
+  ptrToField _ ptr = ptr `plusPtr` 8
+
+{-------------------------------------------------------------------------------
+  Storable instance
+-------------------------------------------------------------------------------}
+
+instance Storable Point where
+  sizeOf    _ = 8
+  alignment _ = 4
+
+  peek ptr =
+          pure Point
+      <*> peekField (Proxy @"x") ptr
+      <*> peekField (Proxy @"y") ptr
+
+  poke ptr Point{x, y} = do
+      pokeField (Proxy @"x") ptr x
+      pokeField (Proxy @"y") ptr y
+
+instance Storable Rect where
+  sizeOf    _ = 16
+  alignment _ = 4
+
+  peek ptr =
+          pure Rect
+      <*> peekField (Proxy @"topleft")     ptr
+      <*> peekField (Proxy @"bottomright") ptr
+
+  poke ptr Rect{topleft, bottomright} = do
+      pokeField (Proxy @"topleft")     ptr topleft
+      pokeField (Proxy @"bottomright") ptr bottomright
+
+{-------------------------------------------------------------------------------
+  (Optional) integration with 'HasField'
+-------------------------------------------------------------------------------}
+
+instance (HasCField Point field, ty ~ FieldType Point field)
+      => GHC.HasField field (Ptr Point) (Ptr ty) where
+  getField = ptrToField (Proxy @field)
+
+instance (HasCField Rect field, ty ~ FieldType Rect field)
+      => GHC.HasField field (Ptr Rect) (Ptr ty) where
+  getField = ptrToField (Proxy @field)
+
+{-------------------------------------------------------------------------------
+  Function imports are unchanged (omitting CAPI for simplicity)
+-------------------------------------------------------------------------------}
+
+foreign import capi safe "cbits.h show_rect"
+  show_rect :: Ptr Rect -> IO ()
+
+{-------------------------------------------------------------------------------
+  Unions
+-------------------------------------------------------------------------------}
+
+newtype PointVsArray = PointVsArray ByteArray
+  deriving Storable via SizedByteArray 8 4
+
+get_pointVsArray_asArray :: PointVsArray -> ConstantArray 2 CInt
+get_pointVsArray_asPoint :: PointVsArray -> Point
+set_pointVsArray_asArray :: ConstantArray 2 CInt -> PointVsArray
+set_pointVsArray_asPoint :: Point                -> PointVsArray
+
+get_pointVsArray_asArray = ByteArray.getUnionPayload
+get_pointVsArray_asPoint = ByteArray.getUnionPayload
+set_pointVsArray_asArray = ByteArray.setUnionPayload
+set_pointVsArray_asPoint = ByteArray.setUnionPayload
+
+instance HasCField PointVsArray "asPoint" where
+  type FieldType PointVsArray "asPoint" = Point
+  ptrToField _ = castPtr
+
+instance HasCField PointVsArray "asArray" where
+  type FieldType PointVsArray "asArray" = ConstantArray 2 CInt
+  ptrToField _ = castPtr
+
+instance (HasCField PointVsArray field, ty ~ FieldType PointVsArray field)
+      => GHC.HasField field (Ptr PointVsArray) (Ptr ty) where
+  getField = ptrToField (Proxy @field)
+

zero-copy/cabal.project

@@ -0,0 +1 @@
+packages: ., ../clang, ../hs-bindgen, ../hs-bindgen-runtime, ../c-expr

zero-copy/cbits/cbits.c

@@ -0,0 +1,11 @@
+#include <stdio.h>
+
+#include "cbits.h"
+
+void show_rect(struct rect* r) {
+    printf("{{%d, %d}, {%d, %d}}\n",
+      r->topleft.x,
+      r->topleft.y,
+      r->bottomright.x,
+      r->bottomright.y);
+}

zero-copy/cbits/cbits.h

@@ -0,0 +1,18 @@
+#pragma once
+
+struct point {
+    int x;
+    int y;
+};
+
+struct rect {
+    struct point topleft;
+    struct point bottomright;
+};
+
+void show_rect(struct rect* r);
+
+union pointVsArray {
+    struct point asPoint;
+    int asArray[2];
+};

zero-copy/generate.sh

@@ -0,0 +1,7 @@
+#!/bin/bash
+
+cabal run -- hs-bindgen-cli preprocess \
+  -I cbits \
+  -o app/Generated.hs \
+  --module Generated \
+  cbits.h

zero-copy/zero-copy.cabal

@@ -0,0 +1,44 @@
+cabal-version:      3.0
+name:               zero-copy
+version:            0.1.0
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Edsko de Vries
+maintainer:         [email protected]
+build-type:         Simple
+
+common lang
+  default-language: GHC2021
+  build-depends:    base ^>=4.17.2.1
+
+  ghc-options:
+      -Wall
+      -Wredundant-constraints
+      -Wprepositive-qualified-module
+
+  default-extensions:
+      DataKinds
+      DerivingStrategies
+      DerivingVia
+      TypeFamilies
+      UndecidableInstances
+
+executable zero-copy
+  import:         lang
+  main-is:        Main.hs
+  hs-source-dirs: app
+
+  other-modules:
+      Generated
+      ZeroCopy
+
+  build-depends:
+      hs-bindgen-runtime
+
+  build-tool-depends:
+      hs-bindgen:hs-bindgen-cli
+
+  -- C
+  c-sources:    cbits/cbits.c
+  include-dirs: cbits
+  cc-options:   -Wall