diff --git a/zero-copy/LICENSE b/zero-copy/LICENSE new file mode 100644 index 000000000..dcda04eb6 --- /dev/null +++ b/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. diff --git a/zero-copy/app/Generated.hs b/zero-copy/app/Generated.hs new file mode 100644 index 000000000..b310e49db --- /dev/null +++ b/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 diff --git a/zero-copy/app/Main.hs b/zero-copy/app/Main.hs new file mode 100644 index 000000000..ff01fe722 --- /dev/null +++ b/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 diff --git a/zero-copy/app/ZeroCopy.hs b/zero-copy/app/ZeroCopy.hs new file mode 100644 index 000000000..d9c328317 --- /dev/null +++ b/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) + diff --git a/zero-copy/cabal.project b/zero-copy/cabal.project new file mode 100644 index 000000000..9f29ae839 --- /dev/null +++ b/zero-copy/cabal.project @@ -0,0 +1 @@ +packages: ., ../clang, ../hs-bindgen, ../hs-bindgen-runtime, ../c-expr diff --git a/zero-copy/cbits/cbits.c b/zero-copy/cbits/cbits.c new file mode 100644 index 000000000..7955a8983 --- /dev/null +++ b/zero-copy/cbits/cbits.c @@ -0,0 +1,11 @@ +#include + +#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); +} \ No newline at end of file diff --git a/zero-copy/cbits/cbits.h b/zero-copy/cbits/cbits.h new file mode 100644 index 000000000..5da529476 --- /dev/null +++ b/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]; +}; \ No newline at end of file diff --git a/zero-copy/generate.sh b/zero-copy/generate.sh new file mode 100755 index 000000000..e380d282d --- /dev/null +++ b/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 diff --git a/zero-copy/zero-copy.cabal b/zero-copy/zero-copy.cabal new file mode 100644 index 000000000..e757408b9 --- /dev/null +++ b/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: edsko@well-typed.com +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