Skip to content

Commit cf646eb

Browse files
edskoedsko
committed
Simple zero copy demo
1 parent cb65238 commit cf646eb

File tree

9 files changed

+359
-0
lines changed

9 files changed

+359
-0
lines changed

‎zero-copy/LICENSE‎

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

‎zero-copy/app/Generated.hs‎

Lines changed: 79 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,79 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
3+
-- | Code generated by @hs-bindgen@ and then cleaned up for better presentation
4+
module Generated where
5+
6+
import Data.Array.Byte (ByteArray)
7+
import Foreign
8+
import Foreign.C
9+
10+
import HsBindgen.Runtime.ByteArray qualified as ByteArray
11+
import HsBindgen.Runtime.CAPI as CAPI
12+
import HsBindgen.Runtime.ConstantArray (ConstantArray)
13+
import HsBindgen.Runtime.SizedByteArray (SizedByteArray(..))
14+
15+
$(CAPI.addCSource "#include \"cbits.h\"\nvoid Generated_show_rect (struct rect *arg1) { show_rect(arg1); }\n")
16+
17+
{-------------------------------------------------------------------------------
18+
Structs
19+
-------------------------------------------------------------------------------}
20+
21+
data Point = Point {
22+
x :: CInt
23+
, y :: CInt
24+
}
25+
deriving stock (Show, Eq)
26+
27+
data Rect = Rect {
28+
topleft :: Point
29+
, bottomright :: Point
30+
}
31+
deriving stock (Show, Eq)
32+
33+
instance Storable Point where
34+
sizeOf _ = 8
35+
alignment _ = 4
36+
37+
peek ptr =
38+
pure Point
39+
<*> peekByteOff ptr 0
40+
<*> peekByteOff ptr 4
41+
42+
poke ptr Point{x, y} = do
43+
pokeByteOff ptr 0 x
44+
pokeByteOff ptr 4 y
45+
46+
instance Storable Rect where
47+
sizeOf _ = 16
48+
alignment _ = 4
49+
50+
peek ptr =
51+
pure Rect
52+
<*> peekByteOff ptr (0 :: Int)
53+
<*> peekByteOff ptr (8 :: Int)
54+
55+
poke ptr Rect{topleft, bottomright} = do
56+
pokeByteOff ptr (0 :: Int) topleft
57+
pokeByteOff ptr (8 :: Int) bottomright
58+
59+
foreign import ccall safe "Generated_show_rect"
60+
show_rect :: Ptr Rect -> IO ()
61+
62+
{-------------------------------------------------------------------------------
63+
Union
64+
-------------------------------------------------------------------------------}
65+
66+
newtype Point_vs_array = Point_vs_array ByteArray
67+
deriving Storable via SizedByteArray 8 4
68+
69+
get_point_vs_array_as_point :: Point_vs_array -> Point
70+
get_point_vs_array_as_point = ByteArray.getUnionPayload
71+
72+
set_point_vs_array_as_point :: Point -> Point_vs_array
73+
set_point_vs_array_as_point = ByteArray.setUnionPayload
74+
75+
get_point_vs_array_as_array :: Point_vs_array -> ConstantArray 2 CInt
76+
get_point_vs_array_as_array = ByteArray.getUnionPayload
77+
78+
set_point_vs_array_as_array :: ConstantArray 2 CInt -> Point_vs_array
79+
set_point_vs_array_as_array = ByteArray.setUnionPayload

‎zero-copy/app/Main.hs‎

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
{-# LANGUAGE OverloadedRecordDot #-}
2+
3+
module Main where
4+
5+
import Foreign
6+
7+
import HsBindgen.Runtime.ConstantArray qualified as CA
8+
9+
import Generated qualified as G
10+
import ZeroCopy qualified as Z
11+
12+
main :: IO ()
13+
main = do
14+
with (G.Rect (G.Point 1 2) (G.Point 3 4)) $ G.show_rect
15+
16+
with (Z.Rect (Z.Point 1 2) (Z.Point 3 4)) $ \ptr -> do
17+
poke ptr.bottomright.x 99
18+
Z.show_rect ptr
19+
20+
with (Z.set_point_vs_array_as_array $ CA.fromList [55, 66]) $ \ptr -> do
21+
y <- peek ptr.as_point.y
22+
print y

‎zero-copy/app/ZeroCopy.hs‎

Lines changed: 148 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,148 @@
1+
{-# LANGUAGE CApiFFI #-}
2+
{-# LANGUAGE DuplicateRecordFields #-}
3+
{-# LANGUAGE NoFieldSelectors #-}
4+
{-# LANGUAGE OverloadedRecordDot #-}
5+
6+
module ZeroCopy where
7+
8+
import Data.Array.Byte (ByteArray)
9+
import Data.Kind
10+
import Data.Proxy
11+
import Foreign
12+
import Foreign.C
13+
import GHC.Exts
14+
import GHC.Records qualified as GHC
15+
16+
import HsBindgen.Runtime.ByteArray qualified as ByteArray
17+
import HsBindgen.Runtime.ConstantArray (ConstantArray)
18+
import HsBindgen.Runtime.SizedByteArray (SizedByteArray(..))
19+
20+
{-------------------------------------------------------------------------------
21+
Infrastructure (this would live in hs-bindgen-runtime)
22+
-------------------------------------------------------------------------------}
23+
24+
class Storable (FieldType a field)
25+
=> HasCField (a :: Type) (field :: Symbol) where
26+
type FieldType a field :: Type
27+
ptrToField :: Proxy field -> Ptr a -> Ptr (FieldType a field)
28+
29+
pokeField ::
30+
HasCField a field
31+
=> Proxy field -> Ptr a -> FieldType a field -> IO ()
32+
pokeField field ptr val = poke (ptrToField field ptr) val
33+
34+
peekField ::
35+
HasCField a field
36+
=> Proxy field -> Ptr a -> IO (FieldType a field)
37+
peekField field ptr = peek (ptrToField field ptr)
38+
39+
{-------------------------------------------------------------------------------
40+
Example (this would be generated code)
41+
-------------------------------------------------------------------------------}
42+
43+
data Point = Point {
44+
x :: CInt
45+
, y :: CInt
46+
}
47+
deriving stock (Show, Eq)
48+
49+
data Rect = Rect {
50+
topleft :: Point
51+
, bottomright :: Point
52+
}
53+
deriving stock (Show, Eq)
54+
55+
instance HasCField Point "x" where
56+
type FieldType Point "x" = CInt
57+
ptrToField _ ptr = ptr `plusPtr` 0
58+
59+
instance HasCField Point "y" where
60+
type FieldType Point "y" = CInt
61+
ptrToField _ ptr = ptr `plusPtr` 4
62+
63+
instance HasCField Rect "topleft" where
64+
type FieldType Rect "topleft" = Point
65+
ptrToField _ ptr = ptr `plusPtr` 0
66+
67+
instance HasCField Rect "bottomright" where
68+
type FieldType Rect "bottomright" = Point
69+
ptrToField _ ptr = ptr `plusPtr` 8
70+
71+
{-------------------------------------------------------------------------------
72+
Storable instance
73+
-------------------------------------------------------------------------------}
74+
75+
instance Storable Point where
76+
sizeOf _ = 8
77+
alignment _ = 4
78+
79+
peek ptr =
80+
pure Point
81+
<*> peekField (Proxy @"x") ptr
82+
<*> peekField (Proxy @"y") ptr
83+
84+
poke ptr Point{x, y} = do
85+
pokeField (Proxy @"x") ptr x
86+
pokeField (Proxy @"y") ptr y
87+
88+
instance Storable Rect where
89+
sizeOf _ = 16
90+
alignment _ = 4
91+
92+
peek ptr =
93+
pure Rect
94+
<*> peekField (Proxy @"topleft") ptr
95+
<*> peekField (Proxy @"bottomright") ptr
96+
97+
poke ptr Rect{topleft, bottomright} = do
98+
pokeField (Proxy @"topleft") ptr topleft
99+
pokeField (Proxy @"bottomright") ptr bottomright
100+
101+
{-------------------------------------------------------------------------------
102+
(Optional) integration with 'HasField'
103+
-------------------------------------------------------------------------------}
104+
105+
instance (HasCField Point field, ty ~ FieldType Point field)
106+
=> GHC.HasField field (Ptr Point) (Ptr ty) where
107+
getField = ptrToField (Proxy @field)
108+
109+
instance (HasCField Rect field, ty ~ FieldType Rect field)
110+
=> GHC.HasField field (Ptr Rect) (Ptr ty) where
111+
getField = ptrToField (Proxy @field)
112+
113+
{-------------------------------------------------------------------------------
114+
Function imports are unchanged (omitting CAPI for simplicity)
115+
-------------------------------------------------------------------------------}
116+
117+
foreign import capi safe "cbits.h show_rect"
118+
show_rect :: Ptr Rect -> IO ()
119+
120+
{-------------------------------------------------------------------------------
121+
Unions
122+
-------------------------------------------------------------------------------}
123+
124+
newtype Point_vs_array = Point_vs_array ByteArray
125+
deriving Storable via SizedByteArray 8 4
126+
127+
instance HasCField Point_vs_array "as_point" where
128+
type FieldType Point_vs_array "as_point" = Point
129+
ptrToField _ = castPtr
130+
131+
instance HasCField Point_vs_array "as_array" where
132+
type FieldType Point_vs_array "as_array" = ConstantArray 2 CInt
133+
ptrToField _ = castPtr
134+
135+
instance (HasCField Point_vs_array field, ty ~ FieldType Point_vs_array field)
136+
=> GHC.HasField field (Ptr Point_vs_array) (Ptr ty) where
137+
getField = ptrToField (Proxy @field)
138+
139+
set_point_vs_array_as_point :: Point -> Point_vs_array
140+
set_point_vs_array_as_array :: ConstantArray 2 CInt -> Point_vs_array
141+
get_point_vs_array_as_point :: Point_vs_array -> Point
142+
get_point_vs_array_as_array :: Point_vs_array -> ConstantArray 2 CInt
143+
144+
get_point_vs_array_as_point = ByteArray.getUnionPayload
145+
set_point_vs_array_as_point = ByteArray.setUnionPayload
146+
get_point_vs_array_as_array = ByteArray.getUnionPayload
147+
set_point_vs_array_as_array = ByteArray.setUnionPayload
148+

‎zero-copy/cabal.project‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
packages: ., ../clang, ../hs-bindgen, ../hs-bindgen-runtime, ../c-expr

‎zero-copy/cbits/cbits.c‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
#include <stdio.h>
2+
3+
#include "cbits.h"
4+
5+
void show_rect(struct rect* r) {
6+
printf("{{%d, %d}, {%d, %d}}\n",
7+
r->topleft.x,
8+
r->topleft.y,
9+
r->bottomright.x,
10+
r->bottomright.y);
11+
}

‎zero-copy/cbits/cbits.h‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
#pragma once
2+
3+
struct point {
4+
int x;
5+
int y;
6+
};
7+
8+
struct rect {
9+
struct point topleft;
10+
struct point bottomright;
11+
};
12+
13+
void show_rect(struct rect* r);
14+
15+
union point_vs_array {
16+
struct point as_point;
17+
int as_array[2];
18+
};

‎zero-copy/generate.sh‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
#!/bin/bash
2+
3+
cabal run -- hs-bindgen-cli preprocess \
4+
-I cbits \
5+
-o app/Generated.hs \
6+
--module Generated \
7+
cbits.h

‎zero-copy/zero-copy.cabal‎

Lines changed: 44 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
cabal-version: 3.0
2+
name: zero-copy
3+
version: 0.1.0
4+
license: BSD-3-Clause
5+
license-file: LICENSE
6+
author: Edsko de Vries
7+
maintainer: [email protected]
8+
build-type: Simple
9+
10+
common lang
11+
default-language: GHC2021
12+
build-depends: base ^>=4.17.2.1
13+
14+
ghc-options:
15+
-Wall
16+
-Wredundant-constraints
17+
-Wprepositive-qualified-module
18+
19+
default-extensions:
20+
DataKinds
21+
DerivingStrategies
22+
DerivingVia
23+
TypeFamilies
24+
UndecidableInstances
25+
26+
executable zero-copy
27+
import: lang
28+
main-is: Main.hs
29+
hs-source-dirs: app
30+
31+
other-modules:
32+
Generated
33+
ZeroCopy
34+
35+
build-depends:
36+
hs-bindgen-runtime
37+
38+
build-tool-depends:
39+
hs-bindgen:hs-bindgen-cli
40+
41+
-- C
42+
c-sources: cbits/cbits.c
43+
include-dirs: cbits
44+
cc-options: -Wall

0 commit comments

Comments
 (0)