diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,20 @@ +# Changelog for `heph-aligned-storable` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - 2026-02-02 + +### Added + +- Initial release. Generic derivation of `AlignedStorable` for GPU memory layouts. +- Provided instances for `Std140`, `Std430`, and `Scalar` layout rules. +- Added support for SPIR-V primitives, vectors, and matrices. +- Included `AlignedArray` for opt-in `memcpy` of fixed-size arrays. +- Added marshaling helpers (`withPacked`, `allocaPacked`) with guaranteed zero-initialized padding. +- Tested via property-based tests, unit tests verified against GLSL compiler output, and inspection tests. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2025 Jeremy Nuttall + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. 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. + +3. 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,103 @@ +# heph-aligned-storable + +Generically derive `Storable` instances for GPU memory layouts (`std140`, `std430`, `scalar`). + +[![CI](https://github.com/jtnuttall/heph/actions/workflows/haskell.yml/badge.svg)](https://github.com/jtnuttall/heph/actions/workflows/haskell.yml) + + + +## Quick Start + +**IMPORTANT**: Be sure to use `layout(row_major)` if you are using `linear` with this library. + +GLSL: + +```glsl +layout(std140, row_major, binding = 0) uniform myuniforms { + mat4 modelViewProjection; + vec3 cameraPosition; + float time; +}; +``` + +Haskell: + +```haskell +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +import Foreign.GPU.Storable.Aligned +import Foreign.GPU.Marshal.Aligned +import GHC.Generics (Generic) +import Linear (M44, V3, V4(..)) + +data Uniforms = Uniforms + { modelViewProjection :: M44 Float + , cameraPosition :: V3 Float + , time :: Float + } deriving (Generic, Show, Eq) + +instance AlignedStorable Std140 Uniforms + +main :: IO () +main = do + let uniforms = Uniforms + { modelViewProjection = V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1) + , cameraPosition = V3 0 0 5 + , time = 0 + } + withPacked @Std140 uniforms $ \ptr -> do + -- ptr is ready for vkCmdPushConstants, memcpy to mapped buffer, etc. + pure () +``` + +## Features + +- Correct, spec-compliant padding for `Std140`, `Std430`, and `Scalar` layouts +- Single `memcpy` for arrays via `AlignedArray` +- Type-level layout witnesses prevent mismatched layouts at compile time +- Zero runtime overhead—generic machinery fully eliminated by GHC + +## The Contract + +**`alignedPoke` writes member data only. Padding bytes are untouched.** + +Use the helpers in `Foreign.GPU.Marshal.Aligned` (`withPacked`, `allocaPacked`, etc.) for guaranteed zero-initialized padding. If you allocate memory yourself, use `calloc` or zero the buffer before poking. + +## Arrays + +By default, arrays are poked element-by-element. For a single `memcpy`, wrap in `AlignedArray`: + +```haskell +data MyStruct (layout :: MemoryLayout) = MyStruct + { meta :: Float + , pixels :: AlignedArray layout 64 (V4 Float) -- memcpy'd as a block + } deriving Generic + +instance AlignedStorable Std140 (MyStruct Std140) +``` + +## Gotchas + +### Matrix naming conventions + +`linear` uses `Mnm` for n rows × m columns. GLSL uses `matNxM` for N columns of M-vectors. + +- `M32 Float` (3 rows, 2 cols) → `mat2x3` +- `M24 Double` (2 rows, 4 cols) → `dmat4x2` + +### `row_major` + +GLSL's `layout(row_major)` affects memory layout, not matrix semantics. Matrices are still column-major for arithmetic. This library implements the memory layout correctly. You don't need to transpose before upload. + +### `vec3` and `mat3` are cursed + +Driver handling of the round-up rules for these types has historically been inconsistent. Consider padding to `vec4`/`mat4` and pretending the 3-element variants don't exist. + +## Why not `derive-storable`? + +`derive-storable` produces FFI-compatible layouts (C struct ABI), not GPU layouts. GPU alignment rules differ: + +- `std140` rounds struct alignment to 16 bytes +- `scalar` layout requires 4-byte booleans, not 1-byte diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/heph-aligned-storable.cabal b/heph-aligned-storable.cabal new file mode 100644 --- /dev/null +++ b/heph-aligned-storable.cabal @@ -0,0 +1,82 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.39.1. +-- +-- see: https://github.com/sol/hpack + +name: heph-aligned-storable +version: 0.1.0.0 +synopsis: Generically derive Storable instances suitable for CPU-GPU transfer +description: Please see the README on GitHub at +category: Graphics +homepage: https://github.com/jtnuttall/heph/tree/main/heph-aligned-storable#readme +bug-reports: https://github.com/jtnuttall/heph/issues +author: Jeremy Nuttall +maintainer: jeremy@jeremy-nuttall.com +copyright: 2025 Jeremy Nuttall +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +tested-with: + GHC == 9.8.4 || == 9.6.5 || == 8.10.7 || == 8.10.4 +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/jtnuttall/heph + +library + exposed-modules: + Foreign.GPU.Marshal.Aligned + Foreign.GPU.Storable.Aligned + other-modules: + Paths_heph_aligned_storable + autogen-modules: + Paths_heph_aligned_storable + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , half >=0.3 && <0.5 + , hashable >=1.3 && <1.6 + , linear >=1.20 && <1.24 + , unliftio ==0.2.* + , vector >=0.12.3.0 && <0.14 + , vector-sized >=1.4 && <1.7 + default-language: Haskell2010 + +test-suite heph-aligned-storable-test + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + Foreign.GPU.Marshal.AlignedSpec + Foreign.GPU.Storable.AlignedInspectionSpec + Foreign.GPU.Storable.AlignedSpec + Paths_heph_aligned_storable + autogen-modules: + Paths_heph_aligned_storable + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring >=0.10 && <0.13 + , half >=0.3 && <0.5 + , hashable >=1.3 && <1.6 + , hedgehog >=1.0.4 && <1.6 + , heph-aligned-storable + , lifted-base ==0.2.* + , linear >=1.20 && <1.24 + , monad-control ==1.0.* + , tasty >=1.4.1 && <1.6 + , tasty-discover >=4.2.1 && <6 + , tasty-hedgehog >=1.1 && <1.5 + , tasty-hunit ==0.10.* + , tasty-inspection-testing >=0.1 && <0.3 + , unliftio ==0.2.* + , vector >=0.12.3.0 && <0.14 + , vector-sized >=1.4 && <1.7 + default-language: Haskell2010 diff --git a/src/Foreign/GPU/Marshal/Aligned.hs b/src/Foreign/GPU/Marshal/Aligned.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/GPU/Marshal/Aligned.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- | +-- Description : Zero-initialized allocation for GPU-aligned types +-- Copyright : (c) Jeremy Nuttall, 2025 +-- License : BSD-3-Clause +-- Maintainer : jeremy@jeremy-nuttall.com +-- Stability : experimental +-- +-- Allocation helpers with guaranteed zero-initialized padding. +-- Use these instead of 'alloca' or 'malloc' to avoid garbage in padding bytes. +module Foreign.GPU.Marshal.Aligned ( + -- * Utilities for 'Packed' values + PackedPtr, + withPacked, + allocaPacked, + + -- * Utilities for 'Strided' values + StridedPtr, + withStrided, + allocaStrided, + + -- * Utilities for runtime length arrays + alignedCopyVector, +) where + +import qualified Data.Vector.Storable as SV +import UnliftIO (MonadIO, MonadUnliftIO, liftIO) +import UnliftIO.Foreign + +import Foreign.GPU.Storable.Aligned + +-- | Convenience type for 'Packed' 'AlignedPtr' +type PackedPtr layout a = AlignedPtr layout (Packed layout a) + +-- | Temporarily allocates a zero-initialized block of memory and pokes a +-- 'Packed' value into it, providing a pointer to the result. +-- The storage is freed automatically. The pointer is only valid within the continuation. +withPacked + :: forall layout a m b + . (MonadUnliftIO m, AlignedStorable layout a) + => a + -> (PackedPtr layout a -> m b) + -> m b +withPacked a f = withZeroed (Packed a) (f . AlignedPtr) +{-# INLINEABLE withPacked #-} + +-- | Allocates temporary, zero-initialized storage for a 'Packed' value on the stack. +-- The pointer is only valid within the continuation. +allocaPacked + :: forall layout a b m + . (MonadUnliftIO m, AlignedStorable layout a) + => (PackedPtr layout a -> m b) + -> m b +allocaPacked f = allocaZeroed (f . AlignedPtr) +{-# INLINEABLE allocaPacked #-} + +-- | Convenience type for 'Strided' 'AlignedPtr' +type StridedPtr layout a = AlignedPtr layout (Strided layout a) + +-- | Temporarily allocates a zero-initialized block of memory and pokes a +-- 'Strided' value into it, providing a pointer to the result. +-- The storage is freed automatically. The pointer is only valid within the continuation. +withStrided + :: (MonadUnliftIO m, AlignedStorable layout a) => a -> (StridedPtr layout a -> m b) -> m b +withStrided a f = withZeroed (Strided a) (f . AlignedPtr) +{-# INLINEABLE withStrided #-} + +-- | Allocates temporary, zero-initialized storage for a 'Strided' value on the stack. +-- The pointer is only valid within the continuation. +allocaStrided :: (MonadUnliftIO m, AlignedStorable layout a) => (StridedPtr layout a -> m b) -> m b +allocaStrided f = allocaZeroed (f . AlignedPtr) +{-# INLINEABLE allocaStrided #-} + +-- | Performs a straight 'copyBytes' on the underlying pointer of 'SV.Vector' +alignedCopyVector + :: forall layout a m + . (MonadIO m, AlignedStorable layout a) + => AlignedPtr layout a + -> SV.Vector (Strided layout a) + -> m () +alignedCopyVector (AlignedPtr dest) v = liftIO $ SV.unsafeWith v \src -> + copyBytes + dest + (castPtr src) + (sizeOf @(Strided layout a) undefined * SV.length v) +{-# INLINE alignedCopyVector #-} + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +zeroPtr :: forall a m. (MonadIO m, Storable a) => Ptr a -> m () +zeroPtr ptr = fillBytes ptr 0 (sizeOf @a undefined) +{-# INLINE zeroPtr #-} + +allocaZeroed :: (MonadUnliftIO m, Storable a) => (Ptr a -> m b) -> m b +allocaZeroed f = alloca \ptr -> zeroPtr ptr >> f ptr +{-# INLINE allocaZeroed #-} + +withZeroed :: (MonadUnliftIO m, Storable a) => a -> (Ptr a -> m b) -> m b +withZeroed a f = allocaZeroed \ptr -> do + liftIO $ poke ptr a + f ptr +{-# INLINE withZeroed #-} diff --git a/src/Foreign/GPU/Storable/Aligned.hs b/src/Foreign/GPU/Storable/Aligned.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/GPU/Storable/Aligned.hs @@ -0,0 +1,1216 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Description : Generically derive Storable instances for GPU memory layouts +-- Copyright : (c) Jeremy Nuttall, 2025 +-- License : BSD-3-Clause +-- Maintainer : jeremy@jeremy-nuttall.com +-- Stability : experimental +-- +-- Derive @Storable@ instances that respect GPU memory layout rules (@std140@, +-- @std430@, @scalar@). Works with any product type that has a 'Generic' instance. +-- +-- @ +-- data Uniforms = Uniforms +-- { viewProj :: M44 Float +-- , cameraPos :: V3 Float +-- } deriving Generic +-- +-- instance AlignedStorable Std140 Uniforms +-- @ +-- +-- Then use "Foreign.GPU.Marshal.Aligned" to get properly-padded pointers: +-- +-- @ +-- withPacked \@Std140 uniforms $ \\ptr -> uploadToGPU ptr +-- @ +-- +-- __NB:__ @vec3@ and @mat3@ types have historically had driver bugs +-- around alignment. Prefer @vec4@/@mat4@ when possible. +module Foreign.GPU.Storable.Aligned ( + -- * The AlignedStorable class + AlignedStorable (..), + + -- * Memory layout + MemoryLayout (..), + SMemoryLayout (..), + KnownMemoryLayout (..), + memoryLayoutVal, + + -- * Storable Wrappers + Strided (..), + StridedVector, + Packed (..), + AlignedArray (..), + mkAlignedArray, + withAlignedArray, + AlignedPtr (..), + + -- * Memory layout rules + MemoryLayoutRules (..), + + -- * Generics + GAlignedStorable (..), +) +where + +import Control.Monad +import Data.Bifunctor (first) +import Data.Bits +import Data.Coerce +import Data.Foldable (traverse_) +import Data.Hashable (Hashable) +import Data.Int +import Data.Kind +import Data.Maybe (fromJust) +import Data.Proxy +import Data.Typeable (Typeable) +import qualified Data.Vector.Generic as GV +import qualified Data.Vector.Generic.Sized as SGV +import qualified Data.Vector.Storable as SV +import qualified Data.Vector.Storable.Mutable as SMV +import qualified Data.Vector.Storable.Sized as SSV +import Data.Word +import Foreign (Ptr, castPtr, copyBytes, plusPtr) +import Foreign.Storable +import GHC.Generics +import GHC.TypeLits +import Linear (M22, M23, M24, M32, M33, M34, M42, M43, M44, V2 (..), V3 (..), V4 (..)) +import Numeric.Half (Half) + +-------------------------------------------------------------------------------- +-- Layout Rules +-------------------------------------------------------------------------------- + +-- | A type-level tag representing a memory layout standard. +data MemoryLayout + = -- | `std140` is a standardized memory layout for SPIR-V interface blocks. + -- It has strict padding and alignment rules, ensuring layout consistency across platforms. + -- + -- For details, refer to 7.6.2.2 "Standard Uniform Block Layout" of the + -- [OpenGL 4.6 Specification](https://registry.khronos.org/OpenGL/specs/gl/glspec46.core.pdf). + Std140 + | -- | `std430` is a standardized memory layout, typically used for Shader Storage Buffer + -- Objects (SSBOs). It has more relaxed alignment rules for arrays and structs + -- than `std140`, which can result in more compact memory usage. + -- + -- For details, please refer to the section 7.6.2.2 "Standard Uniform Block Layout" of the + -- [OpenGL 4.6 Specification](https://registry.khronos.org/OpenGL/specs/gl/glspec46.core.pdf). + Std430 + | -- | `scalar` block layout is a memory layout with the most relaxed alignment rules, + -- closely matching the alignment of scalar and vector types in C. + -- + -- For details, please refer to the + -- [extension specification](https://github.com/KhronosGroup/GLSL/blob/main/extensions/ext/GL_EXT_scalar_block_layout.txt) + Scalar + deriving (Show, Generic, Typeable, Enum, Bounded, Eq, Ord) + +instance Hashable MemoryLayout + +-- | Singled 'MemoryLayout', primarily useful for authors of higher-level libraries +-- (e.g., shader eDSLs, descriptor set builders). +data SMemoryLayout (layout :: MemoryLayout) where + SStd140 :: SMemoryLayout Std140 + SStd430 :: SMemoryLayout Std430 + SScalar :: SMemoryLayout Scalar + +-- | This class gives the 'SMemoryLayout' associated with a 'MemoryLayout'. +-- +-- A very rough sketch of this use case: +-- +-- > emitLayoutQualifier :: forall layout. KnownMemoryLayout layout => String +-- > emitLayoutQualifier = case memoryLayoutVal (Proxy @layout) of +-- > Std140 -> "layout(std140)" +-- > Std430 -> "layout(std430)" +-- > Scalar -> "layout(scalar)" +class KnownMemoryLayout (layout :: MemoryLayout) where + memoryLayoutSing :: SMemoryLayout layout + +instance KnownMemoryLayout Std140 where + memoryLayoutSing = SStd140 + {-# INLINE memoryLayoutSing #-} + +instance KnownMemoryLayout Std430 where + memoryLayoutSing = SStd430 + {-# INLINE memoryLayoutSing #-} + +instance KnownMemoryLayout Scalar where + memoryLayoutSing = SScalar + {-# INLINE memoryLayoutSing #-} + +memoryLayoutVal :: forall layout. (KnownMemoryLayout layout) => Proxy layout -> MemoryLayout +memoryLayoutVal _ = case memoryLayoutSing @layout of + SStd140 -> Std140 + SStd430 -> Std430 + SScalar -> Scalar +{-# INLINE memoryLayoutVal #-} + +-- | Defines the precise calculation rules for a given 'MemoryLayout'. +-- +-- These rules correspond to the memory layout requirements found in the OpenGL +-- and Vulkan specifications. +class MemoryLayoutRules (layout :: MemoryLayout) where + -- | The alignment rule for top-level structs, matrix rows, and array members. + alignBlock :: Proxy layout -> Int -> Int + + -- | The final size rule for a top-level struct. + roundStructSize :: Proxy layout -> Int -> Int -> Int + + -- | The stride rule for an element within an array. + layoutStride :: Proxy layout -> Int -> Int -> Int + +std140Align :: Int +std140Align = 16 + +instance MemoryLayoutRules Std140 where + alignBlock _ = roundUpTo std140Align + {-# INLINE alignBlock #-} + roundStructSize _ = flip roundUpTo + {-# INLINE roundStructSize #-} + layoutStride _ size align = roundUpTo std140Align (roundUpTo align size) + {-# INLINE layoutStride #-} + +instance MemoryLayoutRules Std430 where + alignBlock _ = id + {-# INLINE alignBlock #-} + roundStructSize _ = flip roundUpTo + {-# INLINE roundStructSize #-} + layoutStride _ = flip roundUpTo + {-# INLINE layoutStride #-} + +instance MemoryLayoutRules Scalar where + alignBlock _ = id + {-# INLINE alignBlock #-} + roundStructSize _ size _ = size + {-# INLINE roundStructSize #-} + layoutStride _ = flip roundUpTo + {-# INLINE layoutStride #-} + +-------------------------------------------------------------------------------- +-- Layout-aware Storable +-------------------------------------------------------------------------------- + +-- | Wrapper whose 'sizeOf' includes stride padding, for use in arrays. +-- @SV.Vector (Strided Std140 MyType)@ can be 'copyBytes'd to the GPU in one shot. +newtype Strided (layout :: MemoryLayout) a = Strided {unStrided :: a} + deriving (Generic, Typeable, Show, Eq, Ord) + +-- | Wrapper without stride padding. Use for single values (push constants, lone UBOs). +newtype Packed (layout :: MemoryLayout) a = Packed {unPacked :: a} + deriving (Generic, Typeable, Show, Eq, Ord) + +-- | A convenience type for Data.Vector.Storable.Vector (Strided layout a) +type StridedVector (layout :: MemoryLayout) a = SV.Vector (Strided layout a) + +-- | Opt-in 'copyBytes' for fixed-size arrays. Parameterize your struct by layout: +-- +-- @ +-- data MyStruct layout = MyStruct { pixels :: AlignedArray layout 64 (V4 Float) } +-- @ +newtype AlignedArray (layout :: MemoryLayout) (n :: Nat) a = AlignedArray + {unAlignedArray :: SSV.Vector n (Strided layout a)} + deriving (Generic, Typeable, Show, Eq, Ord) + +-- | Construct an 'AlignedArray' from a sized vector. +mkAlignedArray + :: (AlignedStorable layout a, Storable a) => SSV.Vector n a -> AlignedArray layout n a +mkAlignedArray = AlignedArray . SSV.map Strided +{-# INLINE CONLIKE mkAlignedArray #-} + +-- | Helper function to unwrap an 'AlignedArray' and manipulate its contents. +-- Don't do unsafe pointer tricks in the closure. +withAlignedArray + :: AlignedArray layout n a + -> (SSV.Vector n (Strided layout a) -> SSV.Vector n (Strided layout a)) + -> AlignedArray layout n a +withAlignedArray (AlignedArray v) f = AlignedArray (f v) +{-# INLINE withAlignedArray #-} + +-- | A 'Ptr' that is tagged with its 'MemoryLayout'. +newtype AlignedPtr (layout :: MemoryLayout) a = AlignedPtr {unAlignedPtr :: Ptr a} + deriving (Generic, Typeable, Show) + +type role AlignedPtr nominal nominal + +-- | A class for types that have calculable layouts according to GPU requirements. +-- +-- __NB__: `alignedPoke` only writes member data. Only poke into zeroed buffers +-- unless you really enjoy parsing through garbage in RenderDoc. +class (MemoryLayoutRules layout) => AlignedStorable (layout :: MemoryLayout) a where + -- | The size of the type 'a' after its contents are laid out, but *before* + -- any final padding is applied to the container struct itself. This is + -- the offset after the last member. + packedAlignedSizeOf :: Proxy layout -> Proxy a -> Int + default packedAlignedSizeOf + :: (GAlignedStorable layout (Rep a)) + => Proxy layout + -> Proxy a + -> Int + packedAlignedSizeOf l _ = fst (galignedSize l (Proxy @(Rep a)) 0) + {-# INLINE packedAlignedSizeOf #-} + + -- | The size of the type 'a' including final padding/rounding according to the + -- layout rules for a struct. For `Std140`, this means the size is rounded + -- up to a multiple of 16. + alignedSizeOf :: Proxy layout -> Proxy a -> Int + default alignedSizeOf + :: (GAlignedStorable layout (Rep a)) + => Proxy layout + -> Proxy a + -> Int + alignedSizeOf l _ = + let (!s, !a) = galignedSize l (Proxy @(Rep a)) 0 + !structAlign = alignBlock l a + in roundStructSize l s structAlign + {-# INLINE alignedSizeOf #-} + + -- | The base alignment requirement for the type 'a'. + alignedAlignment :: Proxy layout -> Proxy a -> Int + default alignedAlignment + :: (GAlignedStorable layout (Rep a)) + => Proxy layout + -> Proxy a + -> Int + alignedAlignment l _ = + let (_, !a) = galignedSize l (Proxy @(Rep a)) 0 + in alignBlock l a + {-# INLINE alignedAlignment #-} + + -- | Read a value from the given pointer, respecting the layout rules. + alignedPeek :: AlignedPtr layout a -> IO a + default alignedPeek + :: (Generic a, GAlignedStorable layout (Rep a)) + => AlignedPtr layout a + -> IO a + alignedPeek (AlignedPtr ptr) = to . fst <$> galignedPeek @layout (AlignedPtr (castPtr ptr)) 0 + {-# INLINE alignedPeek #-} + + -- | Write a value to the given pointer, respecting the layout rules. + alignedPoke :: AlignedPtr layout a -> a -> IO () + default alignedPoke + :: (Generic a, GAlignedStorable layout (Rep a)) + => AlignedPtr layout a + -> a + -> IO () + alignedPoke (AlignedPtr ptr) val = void $ galignedPoke @layout (AlignedPtr (castPtr ptr)) (from val) 0 + {-# INLINE alignedPoke #-} + +-- | @sizeOf @(Strided layout a)@ calculates the full stride of the type, +-- including final padding, making it suitable for array allocations. +-- +-- Use zeroed buffers when using this newtype. +instance (MemoryLayoutRules layout, AlignedStorable layout a) => Storable (Strided layout a) where + sizeOf _ = + layoutStride + (Proxy @layout) + (alignedSizeOf (Proxy @layout) (Proxy @a)) + (alignedAlignment (Proxy @layout) (Proxy @a)) + {-# INLINE sizeOf #-} + alignment _ = alignedAlignment (Proxy @layout) (Proxy @a) + {-# INLINE alignment #-} + peek ptr = Strided <$> alignedPeek @layout (AlignedPtr (castPtr ptr)) + {-# INLINE peek #-} + poke ptr a = alignedPoke @layout (AlignedPtr (castPtr ptr)) (coerce a :: a) + {-# INLINE poke #-} + +instance (AlignedStorable layout a) => Storable (Packed layout a) where + sizeOf _ = alignedSizeOf (Proxy @layout) (Proxy @a) + {-# INLINE sizeOf #-} + alignment _ = alignedAlignment (Proxy @layout) (Proxy @a) + {-# INLINE alignment #-} + peek ptr = Packed <$> alignedPeek @layout (AlignedPtr (castPtr ptr)) + {-# INLINE peek #-} + poke ptr a = alignedPoke @layout (AlignedPtr (castPtr ptr)) (coerce a :: a) + {-# INLINE poke #-} + +-------------------------------------------------------------------------------- +-- Generic deriving +-------------------------------------------------------------------------------- + +-- | Generically derive 'AlignedStorable'. +-- +-- > data MyType = MyType { field1 :: Float, field2 :: V3 Float } +-- > deriving (Generic) +-- > +-- > instance AlignedStorable Std140 MyType +class GAlignedStorable (layout :: MemoryLayout) (rep :: Type -> Type) where + galignedSize :: Proxy layout -> Proxy rep -> Int -> (Int, Int) + galignedPoke :: AlignedPtr layout a -> rep a -> Int -> IO Int + galignedPeek :: AlignedPtr layout a -> Int -> IO (rep a, Int) + +instance + ( TypeError + (Text "Cannot derive AlignedStorable for empty data types as there is no shader equivalent.") + ) + => GAlignedStorable layout V1 + where + galignedSize = error "unreachable: empty data type" + galignedPoke = error "unreachable: empty data type" + galignedPeek = error "unreachable: empty data type" + +instance + ( TypeError + (Text "Cannot derive AlignedStorable for nullary constructors as there is no shader equivalent.") + ) + => GAlignedStorable layout U1 + where + galignedSize = error "unreachable: nullary constructor" + galignedPoke = error "unreachable: nullary constructor" + galignedPeek = error "unreachable: nullary constructor" + +instance + ( TypeError + ( Text + "Cannot derive AlignedStorable for sum types as there is no unambiguous shader equivalent." + ) + ) + => GAlignedStorable layout (a :+: b) + where + galignedSize = error "unreachable: sum type" + galignedPoke = error "unreachable: sum type" + galignedPeek = error "unreachable: sum type" + +instance (AlignedStorable layout c) => GAlignedStorable layout (K1 i c) where + galignedSize l _ off = + let !a = alignedAlignment l (Proxy @c) + !s = alignedSizeOf l (Proxy @c) + !off' = roundUpTo a off + in (off' + s, a) + {-# INLINE galignedSize #-} + galignedPoke (AlignedPtr ptr) (K1 !v) !off = do + let !a = alignedAlignment (Proxy @layout) (Proxy @c) + !s = alignedSizeOf (Proxy @layout) (Proxy @c) + !off' = roundUpTo a off + alignedPoke @layout (AlignedPtr (ptr `plusPtr` off')) v + pure (off' + s) + {-# INLINE galignedPoke #-} + galignedPeek (AlignedPtr ptr) !off = do + let !a = alignedAlignment (Proxy @layout) (Proxy @c) + !s = alignedSizeOf (Proxy @layout) (Proxy @c) + !off' = roundUpTo a off + !v <- alignedPeek @layout (AlignedPtr (ptr `plusPtr` off')) + pure (K1 v, off' + s) + {-# INLINE galignedPeek #-} + +instance (GAlignedStorable layout a, GAlignedStorable layout b) => GAlignedStorable layout (a :*: b) where + galignedSize l _ off = + let (!nextOffA, !alignA) = galignedSize l (Proxy @a) off + (!nextOffB, !alignB) = galignedSize l (Proxy @b) nextOffA + in (nextOffB, max alignA alignB) + {-# INLINE galignedSize #-} + galignedPoke ptr (valA :*: valB) !off = do + !nextOffA <- galignedPoke ptr valA off + galignedPoke ptr valB nextOffA + {-# INLINE galignedPoke #-} + galignedPeek ptr off = do + (!valA, !nextOffA) <- galignedPeek ptr off + (!valB, !nextOffB) <- galignedPeek ptr nextOffA + pure (valA :*: valB, nextOffB) + {-# INLINE galignedPeek #-} + +instance (GAlignedStorable layout f) => GAlignedStorable layout (M1 i c f) where + galignedSize l _ = galignedSize l (Proxy @f) + {-# INLINE galignedSize #-} + galignedPoke ptr = galignedPoke ptr . unM1 + {-# INLINE galignedPoke #-} + galignedPeek ptr off = first M1 <$> galignedPeek ptr off + {-# INLINE galignedPeek #-} + +-------------------------------------------------------------------------------- +-- Sized arrays +-------------------------------------------------------------------------------- + +instance + {-# OVERLAPPABLE #-} + (KnownNat n, AlignedStorable layout a, GV.Vector v a) + => AlignedStorable layout (SGV.Vector v n a) + where + packedAlignedSizeOf _ _ = packedAlignedSizeOfArray (Proxy @layout) (Proxy @n) (Proxy @a) + {-# INLINE packedAlignedSizeOf #-} + alignedSizeOf = packedAlignedSizeOf + {-# INLINE alignedSizeOf #-} + alignedAlignment l _ = arrayAlignedAlignment l (Proxy @a) + {-# INLINE alignedAlignment #-} + alignedPeek = garrayAlignedPeek + {-# INLINE alignedPeek #-} + alignedPoke = garrayAlignedPoke + {-# INLINE alignedPoke #-} + +instance (KnownNat n, AlignedStorable Scalar a, GV.Vector v a) => AlignedStorable Scalar (SGV.Vector v n a) where + packedAlignedSizeOf _ _ = scalarPackedAlignedSizeOfArray (Proxy @n) (Proxy @a) + {-# INLINE packedAlignedSizeOf #-} + alignedSizeOf = packedAlignedSizeOf + {-# INLINE alignedSizeOf #-} + alignedAlignment l _ = arrayAlignedAlignment l (Proxy @a) + {-# INLINE alignedAlignment #-} + alignedPeek = garrayAlignedPeek + {-# INLINE alignedPeek #-} + alignedPoke = garrayAlignedPoke + {-# INLINE alignedPoke #-} + +instance + {-# OVERLAPPABLE #-} + (KnownNat n, AlignedStorable layout a) + => AlignedStorable layout (AlignedArray layout n a) + where + packedAlignedSizeOf _ _ = packedAlignedSizeOfArray (Proxy @layout) (Proxy @n) (Proxy @a) + {-# INLINE packedAlignedSizeOf #-} + alignedSizeOf = packedAlignedSizeOf + {-# INLINE alignedSizeOf #-} + alignedAlignment l _ = arrayAlignedAlignment l (Proxy @a) + {-# INLINE alignedAlignment #-} + alignedPeek (AlignedPtr src) = do + let s = fromIntegral $ natVal (Proxy @n) + v <- SMV.new s + SMV.unsafeWith v \dest -> + copyBytes (castPtr dest) src (alignedSizeOf (Proxy @layout) (Proxy @(AlignedArray layout n a))) + AlignedArray . fromJust . SSV.toSized @n <$> SV.unsafeFreeze v + {-# INLINE alignedPeek #-} + alignedPoke (AlignedPtr dest) (AlignedArray v) = SV.unsafeWith (SSV.fromSized v) \src -> + copyBytes dest (castPtr src) (alignedSizeOf (Proxy @layout) (Proxy @(AlignedArray layout n a))) + {-# INLINE alignedPoke #-} + +instance + (KnownNat n, AlignedStorable Scalar a) + => AlignedStorable Scalar (AlignedArray Scalar n a) + where + packedAlignedSizeOf _ _ = scalarPackedAlignedSizeOfArray (Proxy @n) (Proxy @a) + {-# INLINE packedAlignedSizeOf #-} + alignedSizeOf = packedAlignedSizeOf + {-# INLINE alignedSizeOf #-} + alignedAlignment l _ = arrayAlignedAlignment l (Proxy @a) + {-# INLINE alignedAlignment #-} + alignedPeek (AlignedPtr src) = do + let s = fromIntegral $ natVal (Proxy @n) + v <- SMV.new s + SMV.unsafeWith v \dest -> + copyBytes (castPtr dest) src (alignedSizeOf (Proxy @Scalar) (Proxy @(AlignedArray Scalar n a))) + AlignedArray . fromJust . SSV.toSized @n <$> SV.unsafeFreeze v + {-# INLINE alignedPeek #-} + alignedPoke (AlignedPtr dest) (AlignedArray v) = SV.unsafeWith (SSV.fromSized v) \src -> + copyBytes dest (castPtr src) (alignedSizeOf (Proxy @Scalar) (Proxy @(AlignedArray Scalar n a))) + {-# INLINE alignedPoke #-} + +packedAlignedSizeOfArray + :: forall layout n a + . (KnownNat n, AlignedStorable layout a) + => Proxy layout + -> Proxy n + -> Proxy a + -> Int +packedAlignedSizeOfArray _ _ _ = fromIntegral (natVal (Proxy @n)) * sizeOf @(Strided layout a) undefined +{-# INLINE packedAlignedSizeOfArray #-} + +scalarPackedAlignedSizeOfArray + :: forall n a + . (KnownNat n, AlignedStorable Scalar a) + => Proxy n + -> Proxy a + -> Int +scalarPackedAlignedSizeOfArray _ _ = + let n = fromIntegral $ natVal (Proxy @n) + stride = sizeOf @(Strided Scalar a) undefined + lastElementSize = packedAlignedSizeOf (Proxy @Scalar) (Proxy @a) + in if n > 0 + then ((n - 1) * stride) + lastElementSize + else 0 +{-# INLINE scalarPackedAlignedSizeOfArray #-} + +arrayAlignedAlignment + :: forall layout a. (AlignedStorable layout a) => Proxy layout -> Proxy a -> Int +arrayAlignedAlignment l a = alignBlock l $ alignedAlignment l a +{-# INLINE arrayAlignedAlignment #-} + +garrayAlignedPeek + :: forall layout n a v + . (KnownNat n, GV.Vector v a, AlignedStorable layout a) + => AlignedPtr layout (SGV.Vector v n a) + -> IO (SGV.Vector v n a) +garrayAlignedPeek (AlignedPtr ptr) = + let !stride = sizeOf @(Strided layout a) undefined + in SGV.generateM \i -> + alignedPeek @layout (AlignedPtr (ptr `plusPtr` (fromIntegral i * stride))) +{-# INLINE garrayAlignedPeek #-} + +garrayAlignedPoke + :: forall layout n a v + . (KnownNat n, GV.Vector v a, AlignedStorable layout a) + => AlignedPtr layout (SGV.Vector v n a) + -> SGV.Vector v n a + -> IO () +garrayAlignedPoke (AlignedPtr ptr) = + let !stride = sizeOf @(Strided layout a) undefined + in fusedimapMSized_ \i -> alignedPoke @layout (AlignedPtr (ptr `plusPtr` (i * stride))) +{-# INLINE garrayAlignedPoke #-} + +-------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- + +-- | Bit-twiddling hack. Assumes multiple is a power of 2. +-- The assumption holds for all standard GPU layouts. +-- +-- __NB__: As of writing, GHC's optimizer fails when optimizing GAlignedStorable +-- if this function branches. +roundUpTo :: (Bits a, Num a) => a -> a -> a +roundUpTo multiple val = (val + multiple - 1) .&. complement (multiple - 1) +{-# INLINE roundUpTo #-} + +-- | Exploits the knowledge of the array length to create a straight, bounded loop over the +-- underlying vector. +fusedimapMSized_ + :: forall n v a f + . (Monad f, KnownNat n, GV.Vector v a) + => (Int -> a -> f ()) + -> SGV.Vector v n a + -> f () +fusedimapMSized_ f v = + traverse_ + (\i -> f i (SGV.unsafeIndex v i)) + [0 .. fromIntegral (natVal (Proxy @n)) - 1] +{-# INLINE fusedimapMSized_ #-} + +-------------------------------------------------------------------------------- +-- Internal helpers used across macros +-------------------------------------------------------------------------------- + +defaultAlignedPeek :: (Storable a) => AlignedPtr layout a -> IO a +defaultAlignedPeek (AlignedPtr ptr) = peek ptr +{-# INLINE defaultAlignedPeek #-} + +defaultAlignedPoke :: (Storable a) => AlignedPtr layout a -> a -> IO () +defaultAlignedPoke (AlignedPtr ptr) = poke ptr +{-# INLINE defaultAlignedPoke #-} + +packedAlignedSizeOfMat + :: forall layout a f g + . (AlignedStorable layout (g a)) + => Proxy layout + -> Proxy (f (g a)) + -> Int +packedAlignedSizeOfMat l _ = + let rowSize = packedAlignedSizeOf l (Proxy @(g a)) + rowAlign = alignedAlignment l (Proxy @(g a)) + in layoutStride (Proxy @layout) rowSize rowAlign +{-# INLINE packedAlignedSizeOfMat #-} + +-- | Unsafe, for internal use only +castAlignedPtr :: forall layout a b. AlignedPtr layout a -> AlignedPtr layout b +castAlignedPtr (AlignedPtr ptr) = AlignedPtr (castPtr ptr) + +-- | Unsafe, for internal use only +alignedPeekByteOff + :: forall layout a. (AlignedStorable layout a) => AlignedPtr layout a -> Int -> IO a +alignedPeekByteOff (AlignedPtr ptr) off = alignedPeek (AlignedPtr @layout (ptr `plusPtr` off)) +{-# INLINE alignedPeekByteOff #-} + +-- | Unsafe, for internal use only +alignedPokeByteOff + :: forall layout a. (AlignedStorable layout a) => AlignedPtr layout a -> Int -> a -> IO () +alignedPokeByteOff (AlignedPtr ptr) off = alignedPoke (AlignedPtr @layout (ptr `plusPtr` off)) +{-# INLINE alignedPokeByteOff #-} + +alignedPeekV2 + :: forall layout a + . (AlignedStorable layout a, Storable a) + => AlignedPtr layout (V2 a) + -> IO (V2 a) +alignedPeekV2 (AlignedPtr ptr) = + let !stride = alignedAlignment (Proxy @layout) (Proxy @a) + in V2 <$> peekByteOff ptr 0 <*> peekByteOff ptr stride +{-# INLINE alignedPeekV2 #-} + +alignedPokeV2 + :: forall layout a + . (AlignedStorable layout a, Storable a) + => AlignedPtr layout (V2 a) + -> V2 a + -> IO () +alignedPokeV2 (AlignedPtr ptr) (V2 x y) = do + let !stride = alignedAlignment (Proxy @layout) (Proxy @a) + pokeByteOff ptr 0 x + pokeByteOff ptr stride y +{-# INLINE alignedPokeV2 #-} + +alignedPeekM2 + :: forall layout a v + . (AlignedStorable layout (v a)) + => AlignedPtr layout (V2 (v a)) + -> IO (V2 (v a)) +alignedPeekM2 aptr = + let ptr = castAlignedPtr aptr + !rowSize = packedAlignedSizeOf (Proxy @layout) (Proxy @(v a)) + !rowAlign = alignedAlignment (Proxy @layout) (Proxy @(v a)) + !stride = layoutStride (Proxy @layout) rowSize rowAlign + in V2 + <$> alignedPeekByteOff ptr 0 + <*> alignedPeekByteOff ptr stride +{-# INLINE alignedPeekM2 #-} + +alignedPokeM2 + :: forall layout a v + . (AlignedStorable layout (v a)) + => AlignedPtr layout (V2 (v a)) + -> V2 (v a) + -> IO () +alignedPokeM2 aptr (V2 x y) = do + let ptr = castAlignedPtr aptr + !rowSize = packedAlignedSizeOf (Proxy @layout) (Proxy @(v a)) + !rowAlign = alignedAlignment (Proxy @layout) (Proxy @(v a)) + !stride = layoutStride (Proxy @layout) rowSize rowAlign + alignedPokeByteOff ptr 0 x + alignedPokeByteOff ptr stride y +{-# INLINE alignedPokeM2 #-} + +alignedPeekV3 + :: forall layout a. (AlignedStorable layout a, Storable a) => AlignedPtr layout (V3 a) -> IO (V3 a) +alignedPeekV3 (AlignedPtr ptr) = + let a = alignedAlignment (Proxy @layout) (Proxy @a) + in V3 <$> peekByteOff ptr 0 <*> peekByteOff ptr a <*> peekByteOff ptr (a * 2) +{-# INLINE alignedPeekV3 #-} + +alignedPokeV3 + :: forall layout a. (AlignedStorable layout a, Storable a) => AlignedPtr layout (V3 a) -> V3 a -> IO () +alignedPokeV3 (AlignedPtr ptr) (V3 x y z) = do + let a = alignedAlignment (Proxy @layout) (Proxy @a) + pokeByteOff ptr 0 x + pokeByteOff ptr a y + pokeByteOff ptr (a * 2) z +{-# INLINE alignedPokeV3 #-} + +alignedPeekM3 + :: forall layout a v + . (AlignedStorable layout (v a)) + => AlignedPtr layout (V3 (v a)) + -> IO (V3 (v a)) +alignedPeekM3 aptr = + let ptr = castAlignedPtr aptr + !rowSize = packedAlignedSizeOf (Proxy @layout) (Proxy @(v a)) + !rowAlign = alignedAlignment (Proxy @layout) (Proxy @(v a)) + !stride = layoutStride (Proxy @layout) rowSize rowAlign + in V3 + <$> alignedPeekByteOff ptr 0 + <*> alignedPeekByteOff ptr stride + <*> alignedPeekByteOff ptr (stride * 2) +{-# INLINE alignedPeekM3 #-} + +alignedPokeM3 + :: forall layout a v + . (AlignedStorable layout (v a)) + => AlignedPtr layout (V3 (v a)) + -> V3 (v a) + -> IO () +alignedPokeM3 aptr (V3 x y z) = do + let ptr = castAlignedPtr aptr + !rowSize = packedAlignedSizeOf (Proxy @layout) (Proxy @(v a)) + !rowAlign = alignedAlignment (Proxy @layout) (Proxy @(v a)) + !stride = layoutStride (Proxy @layout) rowSize rowAlign + alignedPokeByteOff ptr 0 x + alignedPokeByteOff ptr stride y + alignedPokeByteOff ptr (stride * 2) z +{-# INLINE alignedPokeM3 #-} + +alignedPokeV4 + :: forall layout a. (AlignedStorable layout a, Storable a) => AlignedPtr layout (V4 a) -> V4 a -> IO () +alignedPokeV4 (AlignedPtr ptr) (V4 x y z w) = do + let a = alignedAlignment (Proxy @layout) (Proxy @a) + pokeByteOff ptr 0 x + pokeByteOff ptr a y + pokeByteOff ptr (a * 2) z + pokeByteOff ptr (a * 3) w +{-# INLINE alignedPokeV4 #-} + +alignedPeekV4 + :: forall layout a. (AlignedStorable layout a, Storable a) => AlignedPtr layout (V4 a) -> IO (V4 a) +alignedPeekV4 (AlignedPtr ptr) = + let a = alignedAlignment (Proxy @layout) (Proxy @a) + in V4 + <$> peekByteOff ptr 0 + <*> peekByteOff ptr a + <*> peekByteOff ptr (a * 2) + <*> peekByteOff ptr (a * 3) +{-# INLINE alignedPeekV4 #-} + +alignedPeekM4 + :: forall layout a v + . (AlignedStorable layout (v a)) + => AlignedPtr layout (V4 (v a)) + -> IO (V4 (v a)) +alignedPeekM4 aptr = + let ptr = castAlignedPtr aptr + !rowSize = packedAlignedSizeOf (Proxy @layout) (Proxy @(v a)) + !rowAlign = alignedAlignment (Proxy @layout) (Proxy @(v a)) + !stride = layoutStride (Proxy @layout) rowSize rowAlign + in V4 + <$> alignedPeekByteOff ptr 0 + <*> alignedPeekByteOff ptr stride + <*> alignedPeekByteOff ptr (stride * 2) + <*> alignedPeekByteOff ptr (stride * 3) +{-# INLINE alignedPeekM4 #-} + +alignedPokeM4 + :: forall layout a v + . (AlignedStorable layout (v a)) + => AlignedPtr layout (V4 (v a)) + -> V4 (v a) + -> IO () +alignedPokeM4 aptr (V4 x y z w) = do + let ptr = castAlignedPtr aptr + !rowSize = packedAlignedSizeOf (Proxy @layout) (Proxy @(v a)) + !rowAlign = alignedAlignment (Proxy @layout) (Proxy @(v a)) + !stride = layoutStride (Proxy @layout) rowSize rowAlign + alignedPokeByteOff ptr 0 x + alignedPokeByteOff ptr stride y + alignedPokeByteOff ptr (stride * 2) z + alignedPokeByteOff ptr (stride * 3) w +{-# INLINE alignedPokeM4 #-} + +-------------------------------------------------------------------------------- +-- Base instances for primitive shader types +-- +-- CPP is the simple way to stamp out the instances. I'll probably switch to TH +-- at some point. +-------------------------------------------------------------------------------- + +-- schema: (MemoryLayout, Type, size, alignment) +#define FOR_EACH_STD140_PRIMITIVE(X) \ + X (Std140, Bool, 4, 4) \ + X (Std140, Half, 2, 2) \ + X (Std140, Float, 4, 4) \ + X (Std140, Double, 8, 8) \ + X (Std140, Int8, 4, 4) \ + X (Std140, Int16, 4, 4) \ + X (Std140, Int32, 4, 4) \ + X (Std140, Int64, 8, 8) \ + X (Std140, Word8, 4, 4) \ + X (Std140, Word16, 4, 4) \ + X (Std140, Word32, 4, 4) \ + X (Std140, Word64, 8, 8) + +-- schema: (MemoryLayout, Type, size, alignment) +#define FOR_EACH_STD430_PRIMITIVE(X) \ + X (Std430, Bool, 4, 4) \ + X (Std430, Half, 2, 2) \ + X (Std430, Float, 4, 4) \ + X (Std430, Double, 8, 8) \ + X (Std430, Int8, 1, 1) \ + X (Std430, Int16, 2, 2) \ + X (Std430, Int32, 4, 4) \ + X (Std430, Int64, 8, 8) \ + X (Std430, Word8, 1, 1) \ + X (Std430, Word16, 2, 2) \ + X (Std430, Word32, 4, 4) \ + X (Std430, Word64, 8, 8) + +-- schema: (MemoryLayout, Type, size, alignment) +#define FOR_EACH_SCALAR_PRIMITIVE(X) \ + X (Scalar, Bool, 4, 4) \ + X (Scalar, Half, 2, 2) \ + X (Scalar, Float, 4, 4) \ + X (Scalar, Double, 8, 8) \ + X (Scalar, Int8, 1, 1) \ + X (Scalar, Int16, 2, 2) \ + X (Scalar, Int32, 4, 4) \ + X (Scalar, Int64, 8, 8) \ + X (Scalar, Word8, 1, 1) \ + X (Scalar, Word16, 2, 2) \ + X (Scalar, Word32, 4, 4) \ + X (Scalar, Word64, 8, 8) + +-- schema: (Type) +#define FOR_EACH_MATRIX_PRIMITIVE(X) \ + X (Half) \ + X (Float) \ + X (Double) + +#define PRIMITIVE_INSTANCE(LAYOUT, T, S, A) \ +instance AlignedStorable LAYOUT T where { \ + packedAlignedSizeOf _ _ = S; \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf _ _ = S; \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment _ _ = A; \ + {-# INLINE alignedAlignment #-}; \ + alignedPeek = defaultAlignedPeek; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = defaultAlignedPoke; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(LAYOUT, T, S, A) PRIMITIVE_INSTANCE(LAYOUT, T, S, A) +FOR_EACH_STD140_PRIMITIVE (X) +FOR_EACH_STD430_PRIMITIVE (X) +FOR_EACH_SCALAR_PRIMITIVE (X) +#undef X + +-------------------------------------------------------------------------------- +-- Base instances for vectors and matrices +-------------------------------------------------------------------------------- + +#define VEC2_STD_INSTANCE(LAYOUT, T) \ +instance AlignedStorable LAYOUT (V2 T) where { \ + packedAlignedSizeOf _ _ = 2 * alignedSizeOf (Proxy :: Proxy LAYOUT) (Proxy :: Proxy T); \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf _ _ = 2 * alignedSizeOf (Proxy :: Proxy LAYOUT) (Proxy :: Proxy T); \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment _ _ = 2 * alignedAlignment (Proxy :: Proxy LAYOUT) (Proxy :: Proxy T); \ + {-# INLINE alignedAlignment #-}; \ + alignedPeek = alignedPeekV2; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeV2; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(LAYOUT, T, S, A) VEC2_STD_INSTANCE(LAYOUT, T) +FOR_EACH_STD140_PRIMITIVE (X) +FOR_EACH_STD430_PRIMITIVE (X) +#undef X + +#define VEC2_SCALAR_INSTANCE(T) \ +instance AlignedStorable Scalar (V2 T) where { \ + packedAlignedSizeOf _ _ = 2 * alignedSizeOf (Proxy :: Proxy Scalar) (Proxy :: Proxy T); \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf _ _ = 2 * alignedSizeOf (Proxy :: Proxy Scalar) (Proxy :: Proxy T); \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment _ _ = alignedAlignment (Proxy :: Proxy Scalar) (Proxy :: Proxy T); \ + alignedPeek = defaultAlignedPeek; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = defaultAlignedPoke; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(LAYOUT, T, S, A) VEC2_SCALAR_INSTANCE(T) +FOR_EACH_SCALAR_PRIMITIVE (X) +#undef X + +#define MAT2_STD_INSTANCE(LAYOUT, T) \ +instance AlignedStorable LAYOUT (M22 T) where { \ + packedAlignedSizeOf l a = 2 * packedAlignedSizeOfMat l a; \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf = packedAlignedSizeOf; \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment l _ = alignBlock l (alignedAlignment l (Proxy :: Proxy (V2 T))); \ + {-# INLINE alignedAlignment #-}; \ + alignedPeek = alignedPeekM2; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeM2; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(T) MAT2_STD_INSTANCE(Std140, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define X(T) MAT2_STD_INSTANCE(Std430, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +-- For Scalar layout, matrices are trivially the same as nested vectors +#define X(T) VEC2_SCALAR_INSTANCE((V2 T)) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define MAT23_STD_INSTANCE(LAYOUT, T) \ +instance AlignedStorable LAYOUT (M23 T) where { \ + packedAlignedSizeOf l a = 2 * packedAlignedSizeOfMat l a; \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf = packedAlignedSizeOf; \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment l _ = alignBlock l (alignedAlignment l (Proxy :: Proxy (V3 T))); \ + {-# INLINE alignedAlignment #-}; \ + alignedPeek = alignedPeekM2; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeM2; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(T) MAT23_STD_INSTANCE(Std140, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define X(T) MAT23_STD_INSTANCE(Std430, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +-- For Scalar layout, matrices are trivially the same as nested vectors +#define X(T) VEC2_SCALAR_INSTANCE((V3 T)) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define MAT24_STD_INSTANCE(LAYOUT, T) \ +instance AlignedStorable LAYOUT (M24 T) where { \ + packedAlignedSizeOf l a = 2 * packedAlignedSizeOfMat l a; \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf = packedAlignedSizeOf ; \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment l _ = alignBlock l (alignedAlignment l (Proxy :: Proxy (V4 T))); \ + {-# INLINE alignedAlignment #-}; \ + alignedPeek = alignedPeekM2; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeM2; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(T) MAT24_STD_INSTANCE(Std140, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define X(T) MAT24_STD_INSTANCE(Std430, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +-- For Scalar layout, matrices are trivially the same as nested vectors +#define X(T) VEC2_SCALAR_INSTANCE((V4 T)) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define VEC3_STD_INSTANCE(LAYOUT, A) \ +instance AlignedStorable LAYOUT (V3 A) where { \ + packedAlignedSizeOf l _ = 3 * alignedSizeOf l (Proxy :: Proxy A); \ + {-# INLINE packedAlignedSizeOf #-} ; \ + alignedSizeOf l _ = 3 * alignedSizeOf l (Proxy :: Proxy A); \ + alignedAlignment l _ = 4 * alignedAlignment l (Proxy :: Proxy A); \ + {-# INLINE alignedAlignment #-} ; \ + alignedPeek = alignedPeekV3; \ + {-# INLINE alignedPeek #-} ; \ + alignedPoke = alignedPokeV3; \ + {-# INLINE alignedPoke #-} ; \ + }; \ + +#define X(LAYOUT, T, S, A) VEC3_STD_INSTANCE(LAYOUT, T) +FOR_EACH_STD140_PRIMITIVE (X) +FOR_EACH_STD430_PRIMITIVE (X) +#undef X + +#define VEC3_SCALAR_INSTANCE(A) \ +instance AlignedStorable Scalar (V3 A) where { \ + packedAlignedSizeOf _ _ = 3 * alignedSizeOf (Proxy :: Proxy Scalar) (Proxy :: Proxy A); \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf _ _ = 3 * alignedSizeOf (Proxy :: Proxy Scalar) (Proxy :: Proxy A); \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment _ _ = alignedAlignment (Proxy :: Proxy Scalar) (Proxy :: Proxy A); \ + {-# INLINE alignedAlignment #-}; \ + alignedPeek = defaultAlignedPeek; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = defaultAlignedPoke; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(LAYOUT, T, S, A) VEC3_SCALAR_INSTANCE(T) +FOR_EACH_SCALAR_PRIMITIVE (X) +#undef X + +#define MAT3_STD_INSTANCE(LAYOUT, A) \ +instance AlignedStorable LAYOUT (M33 A) where { \ + packedAlignedSizeOf l a = 3 * packedAlignedSizeOfMat l a; \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf = packedAlignedSizeOf; \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment l _ = alignBlock l (alignedAlignment l (Proxy :: Proxy (V3 A))); \ + {-# INLINE alignedAlignment #-} ; \ + alignedPeek = alignedPeekM3; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeM3; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(T) MAT3_STD_INSTANCE(Std140, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define X(T) MAT3_STD_INSTANCE(Std430, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +-- For Scalar layout, matrices are trivially the same as nested vectors +#define X(T) VEC3_SCALAR_INSTANCE((V3 T)) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define MAT32_STD_INSTANCE(LAYOUT, A) \ +instance AlignedStorable LAYOUT (M32 A) where { \ + packedAlignedSizeOf l a = 3 * packedAlignedSizeOfMat l a ; \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf = packedAlignedSizeOf; \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment l _ = alignBlock l (alignedAlignment l (Proxy :: Proxy (V2 A))); \ + {-# INLINE alignedAlignment #-} ; \ + alignedPeek = alignedPeekM3; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeM3; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(T) MAT32_STD_INSTANCE(Std140, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define X(T) MAT32_STD_INSTANCE(Std430, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +-- For Scalar layout, matrices are trivially the same as nested vectors +#define X(T) VEC3_SCALAR_INSTANCE((V2 T)) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define MAT34_STD_INSTANCE(LAYOUT, A) \ +instance AlignedStorable LAYOUT (M34 A) where { \ + packedAlignedSizeOf l a = 3 * packedAlignedSizeOfMat l a; \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf = packedAlignedSizeOf ; \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment l _ = alignBlock l (alignedAlignment l (Proxy :: Proxy (V4 A))); \ + {-# INLINE alignedAlignment #-} ; \ + alignedPeek = alignedPeekM3; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeM3; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(T) MAT34_STD_INSTANCE(Std140, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define X(T) MAT34_STD_INSTANCE(Std430, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +-- For Scalar layout, matrices are trivially the same as nested vectors +#define X(T) VEC3_SCALAR_INSTANCE((V4 T)) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define VEC4_STD_INSTANCE(LAYOUT, A) \ +instance AlignedStorable LAYOUT (V4 A) where { \ + packedAlignedSizeOf l _ = 4 * alignedSizeOf l (Proxy :: Proxy A); \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf l _ = 4 * alignedSizeOf l (Proxy :: Proxy A); \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment l _ = 4 * alignedAlignment l (Proxy :: Proxy A); \ + {-# INLINE alignedAlignment #-} ; \ + alignedPeek = alignedPeekV4; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeV4; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(LAYOUT, T, S, A) VEC4_STD_INSTANCE(LAYOUT, T) +FOR_EACH_STD140_PRIMITIVE (X) +FOR_EACH_STD430_PRIMITIVE (X) +#undef X + +#define VEC4_SCALAR_INSTANCE(A) \ +instance AlignedStorable Scalar (V4 A) where { \ + packedAlignedSizeOf _ _ = 4 * alignedSizeOf (Proxy :: Proxy Scalar) (Proxy :: Proxy A); \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf _ _ = 4 * alignedSizeOf (Proxy :: Proxy Scalar) (Proxy :: Proxy A); \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment _ _ = alignedAlignment (Proxy :: Proxy Scalar) (Proxy :: Proxy A); \ + {-# INLINE alignedAlignment #-}; \ + alignedPeek = defaultAlignedPeek; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = defaultAlignedPoke; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(LAYOUT, T, S, A) VEC4_SCALAR_INSTANCE(T) +FOR_EACH_SCALAR_PRIMITIVE (X) +#undef X + +#define MAT4_STD_INSTANCE(LAYOUT, A) \ +instance AlignedStorable LAYOUT (M44 A) where { \ + packedAlignedSizeOf l a = 4 * packedAlignedSizeOfMat l a; \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf = packedAlignedSizeOf; \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment l _ = alignBlock l (alignedAlignment l (Proxy :: Proxy (V4 A))); \ + {-# INLINE alignedAlignment #-}; \ + alignedPeek = alignedPeekM4; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeM4; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(T) MAT4_STD_INSTANCE(Std140, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define X(T) MAT4_STD_INSTANCE(Std430, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +-- For Scalar layout, matrices are trivially the same as nested vectors +#define X(T) VEC4_SCALAR_INSTANCE((V4 T)) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define MAT42_STD_INSTANCE(LAYOUT, A) \ +instance AlignedStorable LAYOUT (M42 A) where { \ + packedAlignedSizeOf l a = 4 * packedAlignedSizeOfMat l a; \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf = packedAlignedSizeOf; \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment l _ = alignBlock l (alignedAlignment l (Proxy :: Proxy (V2 A))); \ + {-# INLINE alignedAlignment #-}; \ + alignedPeek = alignedPeekM4; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeM4; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(T) MAT42_STD_INSTANCE(Std140, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define X(T) MAT42_STD_INSTANCE(Std430, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +-- For Scalar layout, matrices are trivially the same as nested vectors +#define X(T) VEC4_SCALAR_INSTANCE((V2 T)) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define MAT43_STD_INSTANCE(LAYOUT, A) \ +instance AlignedStorable LAYOUT (M43 A) where { \ + packedAlignedSizeOf l a = 4 * packedAlignedSizeOfMat l a; \ + {-# INLINE packedAlignedSizeOf #-}; \ + alignedSizeOf = packedAlignedSizeOf; \ + {-# INLINE alignedSizeOf #-}; \ + alignedAlignment l _ = alignBlock l (alignedAlignment l (Proxy :: Proxy (V3 A))); \ + {-# INLINE alignedAlignment #-}; \ + alignedPeek = alignedPeekM4; \ + {-# INLINE alignedPeek #-}; \ + alignedPoke = alignedPokeM4; \ + {-# INLINE alignedPoke #-}; \ + }; + +#define X(T) MAT43_STD_INSTANCE(Std140, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +#define X(T) MAT43_STD_INSTANCE(Std430, T) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X + +-- For Scalar layout, matrices are trivially the same as nested vectors +#define X(T) VEC4_SCALAR_INSTANCE((V3 T)) +FOR_EACH_MATRIX_PRIMITIVE (X) +#undef X diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 --- /dev/null +++ b/test/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} diff --git a/test/Foreign/GPU/Marshal/AlignedSpec.hs b/test/Foreign/GPU/Marshal/AlignedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/GPU/Marshal/AlignedSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Foreign.GPU.Marshal.AlignedSpec where + +import Control.Exception.Lifted (bracket) +import Control.Monad.IO.Class +import Data.Coerce +import Data.Foldable +import Data.Traversable +import qualified Data.Vector.Storable as SV +import qualified Data.Vector.Storable.Sized as SSV +import Foreign +import GHC.Generics +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Linear (V4 (..)) + +import Foreign.GPU.Marshal.Aligned +import Foreign.GPU.Storable.Aligned +import Foreign.GPU.Storable.AlignedSpec + +getBytes :: Int -> Ptr a -> IO [Word8] +getBytes n = peekArray @Word8 n . castPtr + +genSV :: (Storable a) => Gen a -> Gen (SV.Vector a) +genSV gen = SV.fromList <$> Gen.list (Range.linear 1 1000) gen + +hprop_dynamic_vector_copy_byte_identity :: Property +hprop_dynamic_vector_copy_byte_identity = property do + vec <- forAll $ genSV (Strided @Std140 <$> genSimple) + let totalBytes = SV.length vec * sizeOf (SV.head vec) + sutBytes <- liftIO $ SV.unsafeWith vec (getBytes totalBytes . castPtr) + oracleBytes <- liftIO $ bracket (mallocBytes totalBytes) free \ptr -> do + alignedCopyVector (AlignedPtr ptr) vec + getBytes totalBytes ptr + sutBytes === oracleBytes + +hprop_dynamic_vector_copy :: Property +hprop_dynamic_vector_copy = property do + values <- forAll $ Gen.list (Range.linear 1 100) genSimple + let n = length values + vec = SV.fromList $ map (Strided @Std140) values + stride = sizeOf (SV.head vec) + totalBytes = n * stride + + oracleResult <- liftIO $ bracket (mallocBytes totalBytes) free \ptr -> do + alignedCopyVector (AlignedPtr (castPtr ptr)) vec + for [0 .. n - 1] \i -> + coerce <$> peekByteOff @SimpleStd140 ptr (i * stride) + + packedResult <- liftIO $ bracket (mallocBytes totalBytes) free \ptr -> do + alignedCopyVector (AlignedPtr (castPtr ptr)) vec + for [0 .. n - 1] \i -> + coerce <$> peekByteOff @(Packed Std140 Simple) ptr (i * stride) + + oracleResult === values + packedResult === values + +-- | A struct containing a fixed-size array, designed to be optimized +-- by AlignedArray. +data StructWithArray (layout :: MemoryLayout) = StructWithArray + { fieldA :: Float + , fieldB :: AlignedArray layout 4 (V4 Float) + } + deriving (Generic) + +deriving instance + (MemoryLayoutRules layout, AlignedStorable layout (V4 Float)) => Show (StructWithArray layout) + +deriving instance + (MemoryLayoutRules layout, AlignedStorable layout (V4 Float)) => Eq (StructWithArray layout) + +instance AlignedStorable Std140 (StructWithArray Std140) + +hprop_dynamic_vector_with_aligned_array_copy :: Property +hprop_dynamic_vector_with_aligned_array_copy = property do + values <- + forAll $ + Gen.list + (Range.linear 1 100) + (StructWithArray <$> genFloat <*> (mkAlignedArray @Std140 <$> SSV.replicateM (genV genFloat))) + + let vec = SV.fromList $ map (Strided @Std140) values + structStride = sizeOf (SV.head vec) + totalBytes = length values * structStride + + bracket (liftIO $ mallocBytes totalBytes) (liftIO . free) \ptr -> do + alignedCopyVector (AlignedPtr (castPtr ptr)) vec + for_ (zip [0 ..] values) \(i, StructWithArray expectedFieldA expectedFieldB) -> do + let structBaseOffset = i * structStride + fieldAOffset = structBaseOffset + actualFieldA <- liftIO $ peekByteOff @Float ptr fieldAOffset + actualFieldA === expectedFieldA + + let fieldBBaseOffset = structBaseOffset + 16 + vec4Stride = 16 + expectedVecs = unAlignedArray expectedFieldB + + for_ [0 .. 3] \j -> do + let fieldBElementOffset = fieldBBaseOffset + (fromIntegral j * vec4Stride) + actualVec4 <- liftIO $ peekByteOff @(V4 Float) ptr fieldBElementOffset + let expectedVec4 = SSV.index expectedVecs j + actualVec4 === coerce expectedVec4 diff --git a/test/Foreign/GPU/Storable/AlignedInspectionSpec.hs b/test/Foreign/GPU/Storable/AlignedInspectionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/GPU/Storable/AlignedInspectionSpec.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} + +module Foreign.GPU.Storable.AlignedInspectionSpec where + +import Data.Proxy +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.Inspection + +import Foreign.GPU.Storable.Aligned +import Foreign.GPU.Storable.AlignedSpec + +-- | Any type that pokes an array incurs allocations, even if it uses `copyBytes` internally. +-- I suspect llvm will unroll the loop if it is used, but I can't prove this by inspecting core. +data Stress + = Stress + Insanity + Insanity + Insanity + Insanity + Insanity + Insanity + Insanity + Insanity + Insanity + Insanity + Insanity + Insanity + Insanity + deriving (Generic) + +instance AlignedStorable Std140 Stress +instance AlignedStorable Std430 Stress +instance AlignedStorable Scalar Stress + +packedAlignedSizeOf140Stress :: Proxy Std140 -> Proxy Stress -> Int +packedAlignedSizeOf140Stress = packedAlignedSizeOf +packedAlignedSizeOf430Stress :: Proxy Std430 -> Proxy Stress -> Int +packedAlignedSizeOf430Stress = packedAlignedSizeOf +packedAlignedSizeOfScalarStress :: Proxy Scalar -> Proxy Stress -> Int +packedAlignedSizeOfScalarStress = packedAlignedSizeOf + +alignedAlignment140Stress :: Proxy Std140 -> Proxy Stress -> Int +alignedAlignment140Stress = alignedAlignment +alignedAlignment430Stress :: Proxy Std430 -> Proxy Stress -> Int +alignedAlignment430Stress = alignedAlignment +alignedAlignmentScalarStress :: Proxy Scalar -> Proxy Stress -> Int +alignedAlignmentScalarStress = alignedAlignment + +alignedSizeOf140Stress :: Proxy Std140 -> Proxy Stress -> Int +alignedSizeOf140Stress = alignedSizeOf +alignedSizeOf430Stress :: Proxy Std430 -> Proxy Stress -> Int +alignedSizeOf430Stress = alignedSizeOf +alignedSizeOfScalarStress :: Proxy Scalar -> Proxy Stress -> Int +alignedSizeOfScalarStress = alignedSizeOf + +alignedPoke140Stress :: AlignedPtr Std140 Stress -> Stress -> IO () +alignedPoke140Stress = alignedPoke +alignedPoke430Stress :: AlignedPtr Std430 Stress -> Stress -> IO () +alignedPoke430Stress = alignedPoke +alignedPokeScalarStress :: AlignedPtr Scalar Stress -> Stress -> IO () +alignedPokeScalarStress = alignedPoke + +alignedPeek140Stress :: AlignedPtr Std140 Stress -> IO Stress +alignedPeek140Stress = alignedPeek +alignedPeek430Stress :: AlignedPtr Std430 Stress -> IO Stress +alignedPeek430Stress = alignedPeek +alignedPeekScalarStress :: AlignedPtr Scalar Stress -> IO Stress +alignedPeekScalarStress = alignedPeek + +packedAlignedSizeOf140Nested :: Proxy Std140 -> Proxy Nested -> Int +packedAlignedSizeOf140Nested = packedAlignedSizeOf +packedAlignedSizeOf430Nested :: Proxy Std430 -> Proxy Nested -> Int +packedAlignedSizeOf430Nested = packedAlignedSizeOf +packedAlignedSizeOfScalarNested :: Proxy Scalar -> Proxy Nested -> Int +packedAlignedSizeOfScalarNested = packedAlignedSizeOf + +alignedSizeOf140Nested :: Proxy Std140 -> Proxy Nested -> Int +alignedSizeOf140Nested = alignedSizeOf +alignedSizeOf430Nested :: Proxy Std430 -> Proxy Nested -> Int +alignedSizeOf430Nested = alignedSizeOf +alignedSizeOfScalarNested :: Proxy Scalar -> Proxy Nested -> Int +alignedSizeOfScalarNested = alignedSizeOf + +alignedAlignment140Nested :: Proxy Std140 -> Proxy Nested -> Int +alignedAlignment140Nested = alignedAlignment +alignedAlignment430Nested :: Proxy Std430 -> Proxy Nested -> Int +alignedAlignment430Nested = alignedAlignment +alignedAlignmentScalarNested :: Proxy Scalar -> Proxy Nested -> Int +alignedAlignmentScalarNested = alignedAlignment + +alignedPoke140Nested :: AlignedPtr Std140 Nested -> Nested -> IO () +alignedPoke140Nested = alignedPoke +alignedPoke430Nested :: AlignedPtr Std430 Nested -> Nested -> IO () +alignedPoke430Nested = alignedPoke +alignedPokeScalarNested :: AlignedPtr Scalar Nested -> Nested -> IO () +alignedPokeScalarNested = alignedPoke + +alignedPeek140Nested :: AlignedPtr Std140 Nested -> IO Nested +alignedPeek140Nested = alignedPeek +alignedPeek430Nested :: AlignedPtr Std430 Nested -> IO Nested +alignedPeek430Nested = alignedPeek +alignedPeekScalarNested :: AlignedPtr Scalar Nested -> IO Nested +alignedPeekScalarNested = alignedPeek + +test_inspection :: [TestTree] +test_inspection = + [ testGroup + "Stress" + [ testGroup + "std140" + [ $(inspectTest $ hasNoGenerics 'packedAlignedSizeOf140Stress) + , $(inspectTest $ hasNoTypeClasses 'packedAlignedSizeOf140Stress) + , $( inspectTest $ + 'packedAlignedSizeOf140Stress + `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedSizeOf140Stress) + , $(inspectTest $ hasNoTypeClasses 'alignedSizeOf140Stress) + , $( inspectTest $ + 'alignedSizeOf140Stress + `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedAlignment140Stress) + , $(inspectTest $ hasNoTypeClasses 'alignedAlignment140Stress) + , $( inspectTest $ + 'alignedAlignment140Stress + `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPoke140Stress) + , $(inspectTest $ hasNoTypeClasses 'alignedPoke140Stress) + , $( inspectTest $ + 'alignedPoke140Stress + `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPeek140Stress) + , $(inspectTest $ hasNoTypeClasses 'alignedPeek140Stress) + , $( inspectTest $ + 'alignedPeek140Stress + `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + ] + , testGroup + "std430" + [ $(inspectTest $ hasNoGenerics 'packedAlignedSizeOf430Stress) + , $(inspectTest $ hasNoTypeClasses 'packedAlignedSizeOf430Stress) + , $( inspectTest $ + 'packedAlignedSizeOf140Stress + `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedSizeOf430Stress) + , $(inspectTest $ hasNoTypeClasses 'alignedSizeOf430Stress) + , $( inspectTest $ + 'alignedSizeOf430Stress + `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedAlignment430Stress) + , $(inspectTest $ hasNoTypeClasses 'alignedAlignment430Stress) + , $( inspectTest $ + 'alignedAlignment430Stress + `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPoke430Stress) + , $(inspectTest $ hasNoTypeClasses 'alignedPoke430Stress) + , $( inspectTest $ + 'alignedPoke430Stress + `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPeek430Stress) + , $(inspectTest $ hasNoTypeClasses 'alignedPeek430Stress) + , $( inspectTest $ + 'alignedPeek430Stress + `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + ] + , testGroup + "scalar" + [ $(inspectTest $ hasNoGenerics 'packedAlignedSizeOfScalarStress) + , $(inspectTest $ hasNoTypeClasses 'packedAlignedSizeOfScalarStress) + , $( inspectTest $ + 'packedAlignedSizeOfScalarStress `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedSizeOfScalarStress) + , $(inspectTest $ hasNoTypeClasses 'alignedSizeOfScalarStress) + , $( inspectTest $ + 'alignedSizeOfScalarStress `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedAlignmentScalarStress) + , $(inspectTest $ hasNoTypeClasses 'alignedAlignmentScalarStress) + , $( inspectTest $ + 'alignedAlignmentScalarStress `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPokeScalarStress) + , $(inspectTest $ hasNoTypeClasses 'alignedPokeScalarStress) + , $( inspectTest $ + 'alignedPokeScalarStress `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPeekScalarStress) + , $(inspectTest $ hasNoTypeClasses 'alignedPeekScalarStress) + , $( inspectTest $ + 'alignedPeekScalarStress `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + ] + ] + , testGroup + "Nested" + [ testGroup + "std140" + [ $(inspectTest $ hasNoGenerics 'packedAlignedSizeOf140Nested) + , $(inspectTest $ mkObligation 'packedAlignedSizeOf140Nested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'packedAlignedSizeOf140Nested) + , $( inspectTest $ + 'packedAlignedSizeOf140Nested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedSizeOf140Nested) + , $(inspectTest $ mkObligation 'alignedSizeOf140Nested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedSizeOf140Nested) + , $( inspectTest $ + 'alignedSizeOf140Nested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedAlignment140Nested) + , $(inspectTest $ mkObligation 'alignedAlignment140Nested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedAlignment140Nested) + , $( inspectTest $ + 'alignedAlignment140Nested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPoke140Nested) + , $(inspectTest $ mkObligation 'alignedPoke140Nested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedPoke140Nested) + , $( inspectTest $ 'alignedPoke140Nested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPeek140Nested) + , $(inspectTest $ mkObligation 'alignedPeek140Nested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedPeek140Nested) + , $( inspectTest $ 'alignedPeek140Nested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + ] + , testGroup + "std430" + [ $(inspectTest $ hasNoGenerics 'packedAlignedSizeOf430Nested) + , $(inspectTest $ mkObligation 'packedAlignedSizeOf430Nested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'packedAlignedSizeOf430Nested) + , $( inspectTest $ + 'packedAlignedSizeOf430Nested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedSizeOf430Nested) + , $(inspectTest $ mkObligation 'alignedSizeOf430Nested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedSizeOf430Nested) + , $( inspectTest $ + 'alignedSizeOf430Nested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedAlignment430Nested) + , $(inspectTest $ mkObligation 'alignedAlignment430Nested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedAlignment430Nested) + , $( inspectTest $ + 'alignedAlignment430Nested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPoke430Nested) + , $(inspectTest $ mkObligation 'alignedPoke430Nested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedPoke430Nested) + , $( inspectTest $ 'alignedPoke430Nested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPeek430Nested) + , $(inspectTest $ mkObligation 'alignedPeek430Nested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedPeek430Nested) + , $( inspectTest $ 'alignedPeek430Nested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + ] + , testGroup + "scalar" + [ $(inspectTest $ hasNoGenerics 'packedAlignedSizeOfScalarNested) + , $(inspectTest $ mkObligation 'packedAlignedSizeOfScalarNested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'packedAlignedSizeOfScalarNested) + , $( inspectTest $ + 'packedAlignedSizeOfScalarNested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedSizeOfScalarNested) + , $(inspectTest $ mkObligation 'alignedSizeOfScalarNested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedSizeOfScalarNested) + , $( inspectTest $ + 'alignedSizeOfScalarNested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedAlignmentScalarNested) + , $(inspectTest $ mkObligation 'alignedAlignmentScalarNested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedAlignmentScalarNested) + , $( inspectTest $ + 'alignedAlignmentScalarNested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPokeScalarNested) + , $(inspectTest $ mkObligation 'alignedPokeScalarNested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedPokeScalarNested) + , $( inspectTest $ + 'alignedPokeScalarNested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + , $(inspectTest $ hasNoGenerics 'alignedPeekScalarNested) + , $(inspectTest $ mkObligation 'alignedPeekScalarNested NoAllocation) + , $(inspectTest $ hasNoTypeClasses 'alignedPeekScalarNested) + , $( inspectTest $ + 'alignedPeekScalarNested `doesNotUseAnyOf` ['galignedSize, 'galignedPoke, 'galignedPeek] + ) + ] + ] + ] diff --git a/test/Foreign/GPU/Storable/AlignedSpec.hs b/test/Foreign/GPU/Storable/AlignedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/GPU/Storable/AlignedSpec.hs @@ -0,0 +1,2448 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Alignments verified by running glslang against AlignedSpec.glsl and manually +-- inspecting the SPIR-V. +-- +-- You can use https://godbolt.org/z/njnvM8q4o to check for yourself. +module Foreign.GPU.Storable.AlignedSpec where + +import Control.Exception.Lifted (bracket) +import Control.Monad (replicateM) +import Control.Monad.IO.Class +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Coerce +import Data.Foldable (traverse_) +import Data.Int +import Data.Proxy +import Data.Typeable (Typeable, showsTypeRep, typeRep) +import qualified Data.Vector.Generic as GV +import qualified Data.Vector.Generic.Sized as SGV +import qualified Data.Vector.Sized as SV +import qualified Data.Vector.Storable.Sized as SSV +import Data.Word +import Foreign +import GHC.Generics +import GHC.TypeLits +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Linear hiding (outer) +import Numeric (showHex) +import Numeric.Half +import Test.Tasty.HUnit + +import Foreign.GPU.Storable.Aligned + +-------------------------------------------------------------------------------- +-- Test harness +-------------------------------------------------------------------------------- + +newtype Canary = Canary {unCanary :: Word64} + deriving newtype (Storable, Num, Eq) + +instance Show Canary where + showsPrec _ (Canary n) = showHex n + +genCanary :: Gen Canary +genCanary = + Gen.element + [ 0xDEADBEEFDEADBEEF + , 0xCAFEBABECAFEBABE + , 0xABADBABEABADBABE + , 0xCDCDCDCDCDCDCDCD + , 0x5555555555555555 + , 0xAAAAAAAAAAAAAAAA + , 0x0000000000000000 + , 0xFFFFFFFFFFFFFFFF + , 0x0123456789ABCDEF + , 0xFEDCBA9876543210 + ] + +genCanaries :: Int -> Gen [Canary] +genCanaries sz = replicateM sz genCanary + +-- | +-- Given a SUT and an oracle, checks that they round trip with oneself and one another. +-- +-- We validate four ways: SUT vs. SUT, Oracle vs. Oracle, SUT vs. Oracle, Oracle vs. SUT. +-- At the top of the test, the SUT size and alignment is verified to match the Oracle's. +-- +-- This verifies: +-- 1. The SUT is coherent. +-- 2. The Oracle is coherent. +-- 3. The SUT's 'peek' is the inverse of the Oracle's 'poke'. +-- 4. The Oracle's 'peek' is the inverse of the SUT's 'poke'. +-- +-- This makes it highly probable that we catch subtle unidirectional bugs. +-- +-- For each combination (a, b): +-- 1. Allocate a buffer approximately 3*sizeOf(SUT) - rounded up to the next multiple of sizeof(Canary) +-- 2. Poison the buffer with a repeating bit pattern (0xCD) +-- 3. Fill the edges of the buffer with a canary value. +-- 4. Check that the canaries got written to the right place. +-- 5. Poke `a` into the middle of the buffer +-- 6. Check the canaries -- if we overrun or undrrun the buffer, it's very likely to show here. +-- 7. Peek `b` out of the middle of the buffer +-- 8. Out of an overabundance of caution, check the canaries again +-- 9. Check that the peeked value of `b` is equal to the poked value of `a` +-- 10. Check that the peeked value of `b` is equal to the poked value of `b` +-- +-- This makes it incredibly unlikely (but not impossible) that this module corrupts memory in a way +-- that isn't caught in test. +ptrTripping + :: forall s o m + . ( HasCallStack + , Coercible s o + , MonadBaseControl IO m + , MonadIO m + , Typeable s + , Typeable o + , Eq s + , Eq o + , Show s + , Show o + , Storable s + , Storable o + ) + => s + -> o + -> PropertyT m () +ptrTripping sut oracle = do + let sz = sizeOf sut + cSz = sizeOf @Canary undefined + pSz = roundUpTo cSz sz + tSz = sz + 2 * pSz + lPadOffsets = [0, cSz .. pSz - cSz] + rPadOffsets = [pSz + sz, pSz + sz + cSz .. tSz - cSz] + poison = 0xCD + sz === sizeOf oracle + alignment sut === alignment oracle + + lCanaries <- zip lPadOffsets <$> forAll (genCanaries (length lPadOffsets)) + rCanaries <- zip rPadOffsets <$> forAll (genCanaries (length rPadOffsets)) + + let populateCanaries ptr = liftIO do + traverse_ (uncurry (pokeByteOff ptr)) lCanaries + traverse_ (uncurry (pokeByteOff ptr)) rCanaries + + checkCanary ptr offset canary = do + result <- liftIO $ peekByteOff ptr offset + Canary result === canary + + checkCanaries ptr = do + annotate $ "Left pad: 0-" <> show pSz + traverse_ (uncurry (checkCanary ptr)) lCanaries + annotate $ "Right pad: " <> show (pSz + sz) <> "-" <> show tSz + traverse_ (uncurry (checkCanary ptr)) rCanaries + + checkRoundTrip + :: forall a b + . ( HasCallStack + , Coercible a b + , MonadBaseControl IO m + , MonadIO m + , Typeable a + , Typeable b + , Eq a + , Eq b + , Show a + , Show b + , Storable a + , Storable b + ) + => a + -> b + -> PropertyT m () + checkRoundTrip a b = bracket (liftIO $ mallocBytes @a tSz) (liftIO . free) \ptr -> do + annotate + $ showsTypeRep (typeRep (Proxy @a)) + . showString " x " + . showsTypeRep (typeRep (Proxy @b)) + $ "" + liftIO $ fillBytes ptr poison tSz + populateCanaries ptr + checkCanaries ptr + + liftIO $ pokeByteOff ptr pSz a + checkCanaries ptr + + (result :: b) <- liftIO $ peekByteOff (castPtr @a @b ptr) pSz + checkCanaries ptr + + result === coerce a + result === b + + checkRoundTrip sut sut + checkRoundTrip oracle oracle + checkRoundTrip sut oracle + checkRoundTrip oracle sut + +hprop_base_float_is_storable :: Property +hprop_base_float_is_storable = property do + let x = Strided @Std140 (1.0 :: Float) + let _ = sizeOf x + success + +hprop_base_int16_round_trips :: Property +hprop_base_int16_round_trips = property do + ptrTripping @Int16 @Int16 12 12 + +-------------------------------------------------------------------------------- +-- Simple +-------------------------------------------------------------------------------- + +data Simple = Simple + { simpleA :: Float + , simpleB :: Int32 + } + deriving (Generic, Typeable, Show, Eq) + +genSimple :: Gen Simple +genSimple = Simple <$> genFloat <*> genInt + +instance AlignedStorable Std140 Simple +instance AlignedStorable Std430 Simple +instance AlignedStorable Scalar Simple + +newtype SimpleStd140 = SimpleStd140 Simple + deriving (Generic, Typeable, Show, Eq) + +instance Storable SimpleStd140 where + sizeOf _ = 16 + alignment _ = 16 + peek ptr = SimpleStd140 <$> (Simple <$> peekByteOff ptr 0 <*> peekByteOff ptr 4) + poke ptr (SimpleStd140 Simple{..}) = do + pokeByteOff ptr 0 simpleA + pokeByteOff ptr 4 simpleB + +unit_simple_std140_packed_size :: Assertion +unit_simple_std140_packed_size = + packedAlignedSizeOf @Std140 @Simple Proxy Proxy @?= 8 + +hprop_simple_std140_round_trip :: Property +hprop_simple_std140_round_trip = property do + simple <- forAll genSimple + let sut = Strided @Std140 simple + oracle = SimpleStd140 simple + ptrTripping sut oracle + +newtype SimpleStd430 = SimpleStd430 Simple + deriving (Generic, Typeable, Show, Eq) + +instance Storable SimpleStd430 where + sizeOf _ = 8 + alignment _ = 4 + peek ptr = SimpleStd430 <$> (Simple <$> peekByteOff ptr 0 <*> peekByteOff ptr 4) + poke ptr (SimpleStd430 Simple{..}) = do + pokeByteOff ptr 0 simpleA + pokeByteOff ptr 4 simpleB + +unit_simple_std430_packed_size :: Assertion +unit_simple_std430_packed_size = + packedAlignedSizeOf @Std430 @Simple Proxy Proxy @?= 8 + +hprop_simple_std430_round_trip :: Property +hprop_simple_std430_round_trip = property do + val <- forAll genSimple + let sut = Strided @Std430 val + let oracle = SimpleStd430 val + ptrTripping sut oracle + +newtype SimpleScalar = SimpleScalar Simple + deriving (Generic, Typeable, Show, Eq) + +instance Storable SimpleScalar where + sizeOf _ = 8 + alignment _ = 4 + peek ptr = SimpleScalar <$> (Simple <$> peekByteOff ptr 0 <*> peekByteOff ptr 4) + poke ptr (SimpleScalar Simple{..}) = do + pokeByteOff ptr 0 simpleA + pokeByteOff ptr 4 simpleB + +unit_simple_scalar_packed_size :: Assertion +unit_simple_scalar_packed_size = + packedAlignedSizeOf @Scalar @Simple Proxy Proxy @?= 8 + +hprop_simple_scalar_round_trip :: Property +hprop_simple_scalar_round_trip = property do + val <- forAll genSimple + let sut = Strided @Scalar val + let oracle = SimpleScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- Nonsquare +-------------------------------------------------------------------------------- + +-- | Needs to be documented, but Mnm -> matnxm +data TestNonSquare = TestNonSquare + { matA :: M32 Half + , matB :: M43 Double + } + deriving (Generic, Typeable, Show, Eq) + +genTestNonSquare :: Gen TestNonSquare +genTestNonSquare = TestNonSquare <$> genMat genFloat <*> genMat genFloat + +instance AlignedStorable Std140 TestNonSquare +instance AlignedStorable Std430 TestNonSquare +instance AlignedStorable Scalar TestNonSquare + +newtype TestNonSquareStd140 = TestNonSquareStd140 TestNonSquare + deriving (Generic, Typeable, Show, Eq) + +instance Storable TestNonSquareStd140 where + sizeOf _ = 192 + alignment _ = 32 + peek ptr = + TestNonSquareStd140 + <$> (TestNonSquare <$> peekMat3Oracle Std140 ptr 0 <*> peekMat4Oracle Std140 ptr 64) + poke ptr (TestNonSquareStd140 TestNonSquare{..}) = do + pokeMat3Oracle Std140 ptr 0 matA + pokeMat4Oracle Std140 ptr 64 matB + +hprop_testnonsquare_std140_round_trip :: Property +hprop_testnonsquare_std140_round_trip = property do + value <- forAll genTestNonSquare + let sut = Strided @Std140 value + oracle = TestNonSquareStd140 value + ptrTripping sut oracle + +newtype TestNonSquareStd430 = TestNonSquareStd430 TestNonSquare + deriving (Generic, Typeable, Show, Eq) + +instance Storable TestNonSquareStd430 where + sizeOf _ = 160 + alignment _ = 32 + peek ptr = + TestNonSquareStd430 + <$> (TestNonSquare <$> peekMat3Oracle Std430 ptr 0 <*> peekMat4Oracle Std430 ptr 32) + poke ptr (TestNonSquareStd430 TestNonSquare{..}) = do + pokeMat3Oracle Std430 ptr 0 matA + pokeMat4Oracle Std430 ptr 32 matB + +hprop_testnonsquare_std430_round_trip :: Property +hprop_testnonsquare_std430_round_trip = property do + value <- forAll genTestNonSquare + let sut = Strided @Std430 value + oracle = TestNonSquareStd430 value + ptrTripping sut oracle + +newtype TestNonSquareScalar = TestNonSquareScalar TestNonSquare + deriving (Generic, Typeable, Show, Eq) + +instance Storable TestNonSquareScalar where + sizeOf _ = 112 + alignment _ = 8 + peek ptr = TestNonSquareScalar <$> (TestNonSquare <$> peekByteOff ptr 0 <*> peekByteOff ptr 16) + poke ptr (TestNonSquareScalar TestNonSquare{..}) = do + pokeByteOff ptr 0 matA + pokeByteOff ptr 16 matB + +hprop_testnonsquare_scalar_round_trip :: Property +hprop_testnonsquare_scalar_round_trip = property do + value <- forAll genTestNonSquare + let sut = Strided @Scalar value + oracle = TestNonSquareScalar value + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- D2 +-------------------------------------------------------------------------------- + +data D2 = D2 + { d2A :: Half + , d2B :: V2 Float + , d2C :: Half + , d2D :: M22 Float + , d2E :: Half + } + deriving (Generic, Typeable, Show, Eq) + +genD2 :: Gen D2 +genD2 = D2 <$> genFloat <*> genV genFloat <*> genFloat <*> genMat genFloat <*> genFloat + +instance AlignedStorable Std140 D2 +instance AlignedStorable Std430 D2 +instance AlignedStorable Scalar D2 + +newtype D2Std140 = D2Std140 D2 + deriving (Generic, Typeable, Show, Eq) + +instance Storable D2Std140 where + sizeOf _ = 80 + alignment _ = 16 + peek ptr = + D2Std140 + <$> ( D2 + <$> peekByteOff ptr 0 + <*> peekByteOff ptr 8 + <*> peekByteOff ptr 16 + <*> peekMat2Oracle Std140 ptr 32 + <*> peekByteOff ptr 64 + ) + poke ptr (D2Std140 D2{..}) = do + pokeByteOff ptr 0 d2A + pokeByteOff ptr 8 d2B + pokeByteOff ptr 16 d2C + pokeMat2Oracle Std140 ptr 32 d2D + pokeByteOff ptr 64 d2E + +unit_d2_std140_packed_size :: Assertion +unit_d2_std140_packed_size = + packedAlignedSizeOf @Std140 @D2 Proxy Proxy @?= 66 + +hprop_d2_std140_round_trip :: Property +hprop_d2_std140_round_trip = property do + d2 <- forAll genD2 + let sut = Strided @Std140 d2 + oracle = D2Std140 d2 + ptrTripping sut oracle + +newtype D2Std430 = D2Std430 D2 + deriving (Generic, Typeable, Show, Eq) + +instance Storable D2Std430 where + sizeOf _ = 48 + alignment _ = 8 + peek ptr = + D2Std430 + <$> ( D2 + <$> peekByteOff ptr 0 + <*> peekByteOff ptr 8 + <*> peekByteOff ptr 16 + <*> peekMat2Oracle Std430 ptr 24 + <*> peekByteOff ptr 40 + ) + poke ptr (D2Std430 D2{..}) = do + pokeByteOff ptr 0 d2A + pokeByteOff ptr 8 d2B + pokeByteOff ptr 16 d2C + pokeMat2Oracle Std430 ptr 24 d2D + pokeByteOff ptr 40 d2E + +unit_d2_std430_packed_size :: Assertion +unit_d2_std430_packed_size = + packedAlignedSizeOf @Std430 @D2 Proxy Proxy @?= 42 + +hprop_d2_std430_round_trip :: Property +hprop_d2_std430_round_trip = property do + val <- forAll genD2 + let sut = Strided @Std430 val + oracle = D2Std430 val + ptrTripping sut oracle + +newtype D2Scalar = D2Scalar D2 + deriving (Generic, Typeable, Show, Eq) + +instance Storable D2Scalar where + sizeOf _ = 36 + alignment _ = 4 + peek ptr = + D2Scalar + <$> ( D2 + <$> peekByteOff ptr 0 + <*> peekByteOff ptr 4 + <*> peekByteOff ptr 12 + <*> peekByteOff ptr 16 + <*> peekByteOff ptr 32 + ) + poke ptr (D2Scalar D2{..}) = do + pokeByteOff ptr 0 d2A + pokeByteOff ptr 4 d2B + pokeByteOff ptr 12 d2C + pokeByteOff ptr 16 d2D + pokeByteOff ptr 32 d2E + +unit_d2_scalar_packed_size :: Assertion +unit_d2_scalar_packed_size = + packedAlignedSizeOf @Scalar @D2 Proxy Proxy @?= 34 + +hprop_d2_scalar_round_trip :: Property +hprop_d2_scalar_round_trip = property do + val <- forAll genD2 + let sut = Strided @Scalar val + oracle = D2Scalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- Kitchen sink +-------------------------------------------------------------------------------- + +-- | Every shader primitive, ordered to be pretty close to worst case for padding +-- rules +data KitchenSink = KitchenSink + { ksA :: Half + , ksB :: V3 Double + , ksC :: Float + , ksD :: M33 Float + , ksE :: Int32 + , ksF :: M33 Float + , ksG :: Word8 + , ksH :: M32 Half + , ksI :: Word16 + , ksJ :: M23 Half + , ksK :: Word16 + , ksL :: M43 Float + , ksM :: Int16 + , ksN :: M34 Double + , ksO :: Bool + , ksP :: Int8 + , ksQ :: M44 Half + , ksR :: Int64 + , ksS :: M42 Double + , ksT :: Word64 + , ksU :: M24 Half + , ksV :: Half + } + deriving (Generic, Typeable, Show, Eq) + +genKitchenSink :: Gen KitchenSink +genKitchenSink = + KitchenSink + <$> genFloat + <*> genV genFloat + <*> genFloat + <*> genMat genFloat + <*> genInt + <*> genMat genFloat + <*> genInt + <*> genMat genFloat + <*> genInt + <*> genMat genFloat + <*> genInt + <*> genMat genFloat + <*> genInt + <*> genMat genFloat + <*> Gen.bool + <*> genInt + <*> genMat genFloat + <*> genInt + <*> genMat genFloat + <*> genInt + <*> genMat genFloat + <*> genFloat + +instance AlignedStorable Std140 KitchenSink +instance AlignedStorable Std430 KitchenSink +instance AlignedStorable Scalar KitchenSink + +newtype KitchenSinkStd140 = KitchenSinkStd140 KitchenSink + deriving (Generic, Typeable, Show, Eq) + +instance Storable KitchenSinkStd140 where + sizeOf _ = 704 + alignment _ = 32 + peek ptr = + KitchenSinkStd140 + <$> ( KitchenSink + <$> peekByteOff ptr 0 + <*> peekByteOff ptr 32 + <*> peekByteOff ptr 56 + <*> peekMat3Oracle Std140 ptr 64 + <*> peekByteOff ptr 112 + <*> peekMat3Oracle Std140 ptr 128 + <*> peekByteOff ptr 176 + <*> peekMat3Oracle Std140 ptr 192 + <*> peekByteOff ptr 240 + <*> peekMat2Oracle Std140 ptr 256 + <*> peekByteOff ptr 288 + <*> peekMat4Oracle Std140 ptr 304 + <*> peekByteOff ptr 368 + <*> peekMat3Oracle Std140 ptr 384 + <*> peekByteOff ptr 480 + <*> peekByteOff ptr 484 + <*> peekMat4Oracle Std140 ptr 496 + <*> peekByteOff ptr 560 + <*> peekMat4Oracle Std140 ptr 576 + <*> peekByteOff ptr 640 + <*> peekMat2Oracle Std140 ptr 656 + <*> peekByteOff ptr 688 + ) + poke ptr (KitchenSinkStd140 KitchenSink{..}) = do + pokeByteOff ptr 0 ksA + pokeByteOff ptr 32 ksB + pokeByteOff ptr 56 ksC + pokeMat3Oracle Std140 ptr 64 ksD + pokeByteOff ptr 112 ksE + pokeMat3Oracle Std140 ptr 128 ksF + pokeByteOff ptr 176 ksG + pokeMat3Oracle Std140 ptr 192 ksH + pokeByteOff ptr 240 ksI + pokeMat2Oracle Std140 ptr 256 ksJ + pokeByteOff ptr 288 ksK + pokeMat4Oracle Std140 ptr 304 ksL + pokeByteOff ptr 368 ksM + pokeMat3Oracle Std140 ptr 384 ksN + pokeByteOff ptr 480 ksO + pokeByteOff ptr 484 ksP + pokeMat4Oracle Std140 ptr 496 ksQ + pokeByteOff ptr 560 ksR + pokeMat4Oracle Std140 ptr 576 ksS + pokeByteOff ptr 640 ksT + pokeMat2Oracle Std140 ptr 656 ksU + pokeByteOff ptr 688 ksV + +hprop_kitchensink_std140_round_trip :: Property +hprop_kitchensink_std140_round_trip = property do + val <- forAll genKitchenSink + let sut = Strided @Std140 val + oracle = KitchenSinkStd140 val + ptrTripping sut oracle + +newtype KitchenSinkStd430 = KitchenSinkStd430 KitchenSink + deriving (Generic, Typeable, Show, Eq) + +instance Storable KitchenSinkStd430 where + sizeOf _ = 576 + alignment _ = 32 + peek ptr = + KitchenSinkStd430 + <$> ( KitchenSink + <$> peekByteOff ptr 0 + <*> peekByteOff ptr 32 + <*> peekByteOff ptr 56 + <*> peekMat3Oracle Std430 ptr 64 + <*> peekByteOff ptr 112 + <*> peekMat3Oracle Std430 ptr 128 + <*> peekByteOff ptr 176 + <*> peekMat3Oracle Std430 ptr 180 + <*> peekByteOff ptr 192 + <*> peekMat2Oracle Std430 ptr 200 + <*> peekByteOff ptr 216 + <*> peekMat4Oracle Std430 ptr 224 + <*> peekByteOff ptr 288 + <*> peekMat3Oracle Std430 ptr 320 + <*> peekByteOff ptr 416 + <*> peekByteOff ptr 420 + <*> peekMat4Oracle Std430 ptr 424 + <*> peekByteOff ptr 456 + <*> peekMat4Oracle Std430 ptr 464 + <*> peekByteOff ptr 528 + <*> peekMat2Oracle Std430 ptr 536 + <*> peekByteOff ptr 552 + ) + poke ptr (KitchenSinkStd430 KitchenSink{..}) = do + pokeByteOff ptr 0 ksA + pokeByteOff ptr 32 ksB + pokeByteOff ptr 56 ksC + pokeMat3Oracle Std430 ptr 64 ksD + pokeByteOff ptr 112 ksE + pokeMat3Oracle Std430 ptr 128 ksF + pokeByteOff ptr 176 ksG + pokeMat3Oracle Std430 ptr 180 ksH + pokeByteOff ptr 192 ksI + pokeMat2Oracle Std430 ptr 200 ksJ + pokeByteOff ptr 216 ksK + pokeMat4Oracle Std430 ptr 224 ksL + pokeByteOff ptr 288 ksM + pokeMat3Oracle Std430 ptr 320 ksN + pokeByteOff ptr 416 ksO + pokeByteOff ptr 420 ksP + pokeMat4Oracle Std430 ptr 424 ksQ + pokeByteOff ptr 456 ksR + pokeMat4Oracle Std430 ptr 464 ksS + pokeByteOff ptr 528 ksT + pokeMat2Oracle Std430 ptr 536 ksU + pokeByteOff ptr 552 ksV + +hprop_kitchensink_std430_round_trip :: Property +hprop_kitchensink_std430_round_trip = property do + val <- forAll genKitchenSink + let sut = Strided @Std430 val + oracle = KitchenSinkStd430 val + ptrTripping sut oracle + +-- Oracle for scalar layout +newtype KitchenSinkScalar = KitchenSinkScalar KitchenSink + deriving (Generic, Typeable, Show, Eq) + +instance Storable KitchenSinkScalar where + sizeOf _ = 440 + alignment _ = 8 -- Based on alignment of dvec3 + peek ptr = + KitchenSinkScalar + <$> ( KitchenSink + <$> peekByteOff ptr 0 + <*> peekByteOff ptr 8 + <*> peekByteOff ptr 32 + <*> peekByteOff ptr 36 + <*> peekByteOff ptr 72 + <*> peekByteOff ptr 76 + <*> peekByteOff ptr 112 + <*> peekByteOff ptr 114 + <*> peekByteOff ptr 126 + <*> peekByteOff ptr 128 + <*> peekByteOff ptr 140 + <*> peekByteOff ptr 144 + <*> peekByteOff ptr 192 + <*> peekByteOff ptr 200 + <*> peekByteOff ptr 296 + <*> peekByteOff ptr 300 + <*> peekByteOff ptr 302 + <*> peekByteOff ptr 336 + <*> peekByteOff ptr 344 + <*> peekByteOff ptr 408 + <*> peekByteOff ptr 416 + <*> peekByteOff ptr 432 + ) + poke ptr (KitchenSinkScalar KitchenSink{..}) = do + pokeByteOff ptr 0 ksA + pokeByteOff ptr 8 ksB + pokeByteOff ptr 32 ksC + pokeByteOff ptr 36 ksD + pokeByteOff ptr 72 ksE + pokeByteOff ptr 76 ksF + pokeByteOff ptr 112 ksG + pokeByteOff ptr 114 ksH + pokeByteOff ptr 126 ksI + pokeByteOff ptr 128 ksJ + pokeByteOff ptr 140 ksK + pokeByteOff ptr 144 ksL + pokeByteOff ptr 192 ksM + pokeByteOff ptr 200 ksN + pokeByteOff ptr 296 ksO + pokeByteOff ptr 300 ksP + pokeByteOff ptr 302 ksQ + pokeByteOff ptr 336 ksR + pokeByteOff ptr 344 ksS + pokeByteOff ptr 408 ksT + pokeByteOff ptr 416 ksU + pokeByteOff ptr 432 ksV + +hprop_kitchensink_scalar_round_trip :: Property +hprop_kitchensink_scalar_round_trip = property do + val <- forAll genKitchenSink + let sut = Strided @Scalar val + oracle = KitchenSinkScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- LayoutBug +-------------------------------------------------------------------------------- + +data LayoutBug = LayoutBug + { fieldA :: Float + , fieldB :: Float + , fieldC :: Double + } + deriving (Generic, Typeable, Show, Eq) + +genLayoutBug :: Gen LayoutBug +genLayoutBug = LayoutBug <$> genFloat <*> genFloat <*> genFloat + +instance AlignedStorable Std140 LayoutBug +instance AlignedStorable Std430 LayoutBug +instance AlignedStorable Scalar LayoutBug + +newtype LayoutBugStd140 = LayoutBugStd140 LayoutBug + deriving (Generic, Typeable, Show, Eq) + +instance Storable LayoutBugStd140 where + sizeOf _ = 16 + alignment _ = 16 + peek ptr = LayoutBugStd140 <$> (LayoutBug <$> peekByteOff ptr 0 <*> peekByteOff ptr 4 <*> peekByteOff ptr 8) + poke ptr (LayoutBugStd140 LayoutBug{..}) = do + pokeByteOff ptr 0 fieldA + pokeByteOff ptr 4 fieldB + pokeByteOff ptr 8 fieldC + +unit_layoutbug_std140_packed_size :: Assertion +unit_layoutbug_std140_packed_size = + packedAlignedSizeOf @Std140 @LayoutBug Proxy Proxy @?= 16 + +hprop_layoutbug_std140_round_trip :: Property +hprop_layoutbug_std140_round_trip = property do + val <- forAll genLayoutBug + let sut = Strided @Std140 val + oracle = LayoutBugStd140 val + ptrTripping sut oracle + +newtype LayoutBugStd430 = LayoutBugStd430 LayoutBug + deriving (Generic, Typeable, Show, Eq) + +instance Storable LayoutBugStd430 where + sizeOf _ = 16 + alignment _ = 8 + peek ptr = LayoutBugStd430 <$> (LayoutBug <$> peekByteOff ptr 0 <*> peekByteOff ptr 4 <*> peekByteOff ptr 8) + poke ptr (LayoutBugStd430 LayoutBug{..}) = do + pokeByteOff ptr 0 fieldA + pokeByteOff ptr 4 fieldB + pokeByteOff ptr 8 fieldC + +unit_layoutbug_std430_packed_size :: Assertion +unit_layoutbug_std430_packed_size = + packedAlignedSizeOf @Std430 @LayoutBug Proxy Proxy @?= 16 + +hprop_layoutbug_std430_round_trip :: Property +hprop_layoutbug_std430_round_trip = property do + val <- forAll genLayoutBug + let sut = Strided @Std430 val + let oracle = LayoutBugStd430 val + ptrTripping sut oracle + +newtype LayoutBugScalar = LayoutBugScalar LayoutBug + deriving (Generic, Typeable, Show, Eq) + +instance Storable LayoutBugScalar where + sizeOf _ = 16 + alignment _ = 8 + peek ptr = LayoutBugScalar <$> (LayoutBug <$> peekByteOff ptr 0 <*> peekByteOff ptr 4 <*> peekByteOff ptr 8) + poke ptr (LayoutBugScalar LayoutBug{..}) = do + pokeByteOff ptr 0 fieldA + pokeByteOff ptr 4 fieldB + pokeByteOff ptr 8 fieldC + +unit_layoutbug_scalar_packed_size :: Assertion +unit_layoutbug_scalar_packed_size = + packedAlignedSizeOf @Scalar @LayoutBug Proxy Proxy @?= 16 + +hprop_layoutbug_scalar_round_trip :: Property +hprop_layoutbug_scalar_round_trip = property do + val <- forAll genLayoutBug + let sut = Strided @Scalar val + let oracle = LayoutBugScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- PaddingTest +-------------------------------------------------------------------------------- + +data PaddingTest = PaddingTest + { f :: Float + , v :: V4 Float + } + deriving (Generic, Typeable, Show, Eq) + +genPaddingTest :: Gen PaddingTest +genPaddingTest = PaddingTest <$> genFloat <*> genV genFloat + +instance AlignedStorable Std140 PaddingTest +instance AlignedStorable Std430 PaddingTest +instance AlignedStorable Scalar PaddingTest + +newtype PaddingTestStd140 = PaddingTestStd140 PaddingTest + deriving (Generic, Typeable, Show, Eq) + +instance Storable PaddingTestStd140 where + sizeOf _ = 32 + alignment _ = 16 + peek ptr = PaddingTestStd140 <$> (PaddingTest <$> peekByteOff ptr 0 <*> peekByteOff ptr 16) + poke ptr (PaddingTestStd140 PaddingTest{..}) = do + pokeByteOff ptr 0 f + pokeByteOff ptr 16 v + +unit_paddingtest_std140_packed_size :: Assertion +unit_paddingtest_std140_packed_size = + packedAlignedSizeOf @Std140 @PaddingTest Proxy Proxy @?= 32 + +hprop_paddingtest_std140_round_trip :: Property +hprop_paddingtest_std140_round_trip = property do + val <- forAll genPaddingTest + let sut = Strided @Std140 val + let oracle = PaddingTestStd140 val + ptrTripping sut oracle + +-- Oracle for Std430 layout. +-- Layout is identical to Std140 for this struct, but we define a separate +-- oracle to maintain a 1-to-1 mapping between tests and layouts. +newtype PaddingTestStd430 = PaddingTestStd430 PaddingTest + deriving (Generic, Typeable, Show, Eq) + +instance Storable PaddingTestStd430 where + sizeOf _ = 32 + alignment _ = 16 + peek ptr = PaddingTestStd430 <$> (PaddingTest <$> peekByteOff ptr 0 <*> peekByteOff ptr 16) + poke ptr (PaddingTestStd430 PaddingTest{..}) = do + pokeByteOff ptr 0 f + pokeByteOff ptr 16 v + +unit_paddingtest_std430_packed_size :: Assertion +unit_paddingtest_std430_packed_size = + packedAlignedSizeOf @Std430 @PaddingTest Proxy Proxy @?= 32 + +hprop_paddingtest_std430_round_trip :: Property +hprop_paddingtest_std430_round_trip = property do + val <- forAll genPaddingTest + let sut = Strided @Std430 val + let oracle = PaddingTestStd430 val + ptrTripping sut oracle + +newtype PaddingTestScalar = PaddingTestScalar PaddingTest + deriving (Generic, Typeable, Show, Eq) + +instance Storable PaddingTestScalar where + sizeOf _ = 20 + alignment _ = 4 + peek ptr = PaddingTestScalar <$> (PaddingTest <$> peekByteOff ptr 0 <*> peekByteOff ptr 4) + poke ptr (PaddingTestScalar PaddingTest{..}) = do + pokeByteOff ptr 0 f + pokeByteOff ptr 4 v + +unit_paddingtest_scalar_packed_size :: Assertion +unit_paddingtest_scalar_packed_size = + packedAlignedSizeOf @Scalar @PaddingTest Proxy Proxy @?= 20 + +hprop_paddingtest_scalar_round_trip :: Property +hprop_paddingtest_scalar_round_trip = property do + val <- forAll genPaddingTest + let sut = Strided @Scalar val + let oracle = PaddingTestScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- Std140Test +-------------------------------------------------------------------------------- + +data Std140Test = Std140Test + { v3 :: V3 Float + , f1 :: Float + } + deriving (Generic, Typeable, Show, Eq) + +genStd140Test :: Gen Std140Test +genStd140Test = + Std140Test + <$> (V3 <$> genFloat <*> genFloat <*> genFloat) + <*> genFloat + +instance AlignedStorable Std140 Std140Test +instance AlignedStorable Std430 Std140Test +instance AlignedStorable Scalar Std140Test + +newtype Std140TestStd140 = Std140TestStd140 Std140Test + deriving (Generic, Typeable, Show, Eq) + +instance Storable Std140TestStd140 where + sizeOf _ = 16 + alignment _ = 16 + peek ptr = Std140TestStd140 <$> (Std140Test <$> peekByteOff ptr 0 <*> peekByteOff ptr 12) + poke ptr (Std140TestStd140 Std140Test{..}) = do + pokeByteOff ptr 0 v3 + pokeByteOff ptr 12 f1 + +unit_std140test_std140_packed_size :: Assertion +unit_std140test_std140_packed_size = + packedAlignedSizeOf @Std140 @Std140Test Proxy Proxy @?= 16 + +hprop_std140test_std140_round_trip :: Property +hprop_std140test_std140_round_trip = property do + val <- forAll genStd140Test + let sut = Strided @Std140 val + oracle = Std140TestStd140 val + ptrTripping sut oracle + +-- Oracle for Std430 layout. For this type, it is identical to std140. +newtype Std140TestStd430 = Std140TestStd430 Std140Test + deriving (Generic, Typeable, Show, Eq) + +instance Storable Std140TestStd430 where + sizeOf _ = 16 + alignment _ = 16 + peek ptr = Std140TestStd430 <$> (Std140Test <$> peekByteOff ptr 0 <*> peekByteOff ptr 12) + poke ptr (Std140TestStd430 Std140Test{..}) = do + pokeByteOff ptr 0 v3 + pokeByteOff ptr 12 f1 + +unit_std140test_std430_packed_size :: Assertion +unit_std140test_std430_packed_size = + packedAlignedSizeOf @Std430 @Std140Test Proxy Proxy @?= 16 + +hprop_std140test_std430_round_trip :: Property +hprop_std140test_std430_round_trip = property do + val <- forAll genStd140Test + let sut = Strided @Std430 val + let oracle = Std140TestStd430 val + ptrTripping sut oracle + +newtype Std140TestScalar = Std140TestScalar Std140Test + deriving (Generic, Typeable, Show, Eq) + +instance Storable Std140TestScalar where + sizeOf _ = 16 + alignment _ = 4 + peek ptr = Std140TestScalar <$> (Std140Test <$> peekByteOff ptr 0 <*> peekByteOff ptr 12) + poke ptr (Std140TestScalar Std140Test{..}) = do + pokeByteOff ptr 0 v3 + pokeByteOff ptr 12 f1 + +unit_std140test_scalar_packed_size :: Assertion +unit_std140test_scalar_packed_size = + packedAlignedSizeOf @Scalar @Std140Test Proxy Proxy @?= 16 + +hprop_std140test_scalar_round_trip :: Property +hprop_std140test_scalar_round_trip = property do + val <- forAll genStd140Test + let sut = Strided @Scalar val + let oracle = Std140TestScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- ComplexPadding +-------------------------------------------------------------------------------- + +-- | +-- complexpaddingA : float (size=4, align=4); tSize=4 +-- complexpaddingB : vec3 (size=12, align=16); tSize=16+12=28; align to 16, start at 16 +-- complexpaddingC : mat3 (size=3*16=48, align=16); tSize=32+48=80; align to 16, start at 32 +-- complexpaddingD : float (size=4, align=4); tSize=80+4=4; align to 4, start at 80 +-- complexpaddingE : mat4 (size=4*4=64, align=16); tSize=96+64=160; align to 16, start at 96 +-- complexpaddingF : float (size=4, align=4); tSize=160+4=164; align to 4, start at 160 +-- +-- overall size: alignTo 16 164 +-- = 176 +data ComplexPadding = ComplexPadding + { complexpaddingA :: Float + , complexpaddingB :: V3 Float + , complexpaddingC :: M33 Float + , complexpaddingD :: Float + , complexpaddingE :: M44 Float + , complexpaddingF :: Float + } + deriving (Generic, Typeable, Show, Eq) + +-- >>> alignedSizeOf (Data.Proxy.Proxy @Std430) (Data.Proxy.Proxy @ComplexPadding) +-- 176 + +genComplexPadding :: Gen ComplexPadding +genComplexPadding = + ComplexPadding + <$> genFloat + <*> genV genFloat + <*> genMat genFloat + <*> genFloat + <*> genMat genFloat + <*> genFloat + +instance AlignedStorable Std140 ComplexPadding +instance AlignedStorable Std430 ComplexPadding +instance AlignedStorable Scalar ComplexPadding + +newtype ComplexPaddingStd140 = ComplexPaddingStd140 ComplexPadding + deriving (Generic, Typeable, Show, Eq) + +instance Storable ComplexPaddingStd140 where + sizeOf _ = 176 + alignment _ = 16 + peek ptr = + ComplexPaddingStd140 + <$> ( ComplexPadding + <$> peekByteOff ptr 0 + <*> peekByteOff ptr 16 + <*> peekMat3Oracle Std140 ptr 32 + <*> peekByteOff ptr 80 + <*> peekByteOff ptr 96 + <*> peekByteOff ptr 160 + ) + poke ptr (ComplexPaddingStd140 ComplexPadding{..}) = do + pokeByteOff ptr 0 complexpaddingA + pokeByteOff ptr 16 complexpaddingB + pokeMat3Oracle Std140 ptr 32 complexpaddingC + pokeByteOff ptr 80 complexpaddingD + pokeByteOff ptr 96 complexpaddingE + pokeByteOff ptr 160 complexpaddingF + +unit_complexpadding_std140_packed_size :: Assertion +unit_complexpadding_std140_packed_size = + packedAlignedSizeOf @Std140 @ComplexPadding Proxy Proxy @?= 164 + +hprop_complexpadding_std140_round_trip :: Property +hprop_complexpadding_std140_round_trip = property do + complexpadding <- forAll genComplexPadding + let sut = Strided @Std140 complexpadding + oracle = ComplexPaddingStd140 complexpadding + ptrTripping sut oracle + +newtype ComplexPaddingStd430 = ComplexPaddingStd430 ComplexPadding + deriving (Generic, Typeable, Show, Eq) + +instance Storable ComplexPaddingStd430 where + sizeOf _ = 176 + alignment _ = 16 + peek ptr = + ComplexPaddingStd430 + <$> ( ComplexPadding + <$> peekByteOff ptr 0 + <*> peekByteOff ptr 16 + <*> peekMat3Oracle Std430 ptr 32 + <*> peekByteOff ptr 80 + <*> peekByteOff ptr 96 + <*> peekByteOff ptr 160 + ) + poke ptr (ComplexPaddingStd430 ComplexPadding{..}) = do + pokeByteOff ptr 0 complexpaddingA + pokeByteOff ptr 16 complexpaddingB + pokeMat3Oracle Std430 ptr 32 complexpaddingC + pokeByteOff ptr 80 complexpaddingD + pokeByteOff ptr 96 complexpaddingE + pokeByteOff ptr 160 complexpaddingF + +unit_complexpadding_std430_packed_size :: Assertion +unit_complexpadding_std430_packed_size = + packedAlignedSizeOf @Std430 @ComplexPadding Proxy Proxy @?= 164 + +hprop_complexpadding_std430_round_trip :: Property +hprop_complexpadding_std430_round_trip = property do + val <- forAll genComplexPadding + let sut = Strided @Std430 val + let oracle = ComplexPaddingStd430 val + ptrTripping sut oracle + +newtype ComplexPaddingScalar = ComplexPaddingScalar ComplexPadding + deriving (Generic, Typeable, Show, Eq) + +instance Storable ComplexPaddingScalar where + sizeOf _ = 124 + alignment _ = 4 + peek ptr = + ComplexPaddingScalar + <$> ( ComplexPadding + <$> peekByteOff ptr 0 + <*> peekByteOff ptr 4 + <*> peekByteOff ptr 16 + <*> peekByteOff ptr 52 + <*> peekByteOff ptr 56 + <*> peekByteOff ptr 120 + ) + poke ptr (ComplexPaddingScalar ComplexPadding{..}) = do + pokeByteOff ptr 0 complexpaddingA + pokeByteOff ptr 4 complexpaddingB + pokeByteOff ptr 16 complexpaddingC + pokeByteOff ptr 52 complexpaddingD + pokeByteOff ptr 56 complexpaddingE + pokeByteOff ptr 120 complexpaddingF + +unit_complexpadding_scalar_packed_size :: Assertion +unit_complexpadding_scalar_packed_size = + packedAlignedSizeOf @Scalar @ComplexPadding Proxy Proxy @?= 124 + +hprop_complexpadding_scalar_round_trip :: Property +hprop_complexpadding_scalar_round_trip = property do + val <- forAll genComplexPadding + let sut = Strided @Scalar val + let oracle = ComplexPaddingScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- Vertex +-------------------------------------------------------------------------------- + +data Vertex = Vertex + { position :: V3 Float + , normal :: V3 Float + , uv :: V2 Float + } + deriving (Generic, Typeable, Show, Eq) + +genVertex :: Gen Vertex +genVertex = Vertex <$> genV genFloat <*> genV genFloat <*> genV genFloat + +instance AlignedStorable Std140 Vertex +instance AlignedStorable Std430 Vertex +instance AlignedStorable Scalar Vertex + +newtype VertexStd140 = VertexStd140 Vertex + deriving (Generic, Typeable, Show, Eq) + +instance Storable VertexStd140 where + sizeOf _ = 48 + alignment _ = 16 + peek ptr = VertexStd140 <$> (Vertex <$> peekByteOff ptr 0 <*> peekByteOff ptr 16 <*> peekByteOff ptr 32) + poke ptr (VertexStd140 Vertex{..}) = do + pokeByteOff ptr 0 position + pokeByteOff ptr 16 normal + pokeByteOff ptr 32 uv + +unit_vertex_std140_packed_size :: Assertion +unit_vertex_std140_packed_size = + packedAlignedSizeOf @Std140 @Vertex Proxy Proxy @?= 40 + +hprop_vertex_std140_round_trip :: Property +hprop_vertex_std140_round_trip = property do + val <- forAll genVertex + let sut = Strided @Std140 val + oracle = VertexStd140 val + ptrTripping sut oracle + +newtype VertexStd430 = VertexStd430 Vertex + deriving (Generic, Typeable, Show, Eq) + +instance Storable VertexStd430 where + sizeOf _ = 48 + alignment _ = 16 + peek ptr = VertexStd430 <$> (Vertex <$> peekByteOff ptr 0 <*> peekByteOff ptr 16 <*> peekByteOff ptr 32) + poke ptr (VertexStd430 Vertex{..}) = do + pokeByteOff ptr 0 position + pokeByteOff ptr 16 normal + pokeByteOff ptr 32 uv + +unit_vertex_std430_packed_size :: Assertion +unit_vertex_std430_packed_size = + packedAlignedSizeOf @Std430 @Vertex Proxy Proxy @?= 40 + +hprop_vertex_std430_round_trip :: Property +hprop_vertex_std430_round_trip = property do + val <- forAll genVertex + let sut = Strided @Std430 val + oracle = VertexStd430 val + ptrTripping sut oracle + +newtype VertexScalar = VertexScalar Vertex + deriving (Generic, Typeable, Show, Eq) + +instance Storable VertexScalar where + sizeOf _ = 32 + alignment _ = 4 + peek ptr = VertexScalar <$> (Vertex <$> peekByteOff ptr 0 <*> peekByteOff ptr 12 <*> peekByteOff ptr 24) + poke ptr (VertexScalar Vertex{..}) = do + pokeByteOff ptr 0 position + pokeByteOff ptr 12 normal + pokeByteOff ptr 24 uv + +unit_vertex_scalar_packed_size :: Assertion +unit_vertex_scalar_packed_size = + packedAlignedSizeOf @Scalar @Vertex Proxy Proxy @?= 32 + +hprop_vertex_scalar_round_trip :: Property +hprop_vertex_scalar_round_trip = property do + val <- forAll genVertex + let sut = Strided @Scalar val + oracle = VertexScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- LargePrimitives +-------------------------------------------------------------------------------- + +data LargePrimitives = LargePrimitives + { d :: Double + , l :: Int64 + } + deriving (Generic, Typeable, Show, Eq) + +genLargePrimitives :: Gen LargePrimitives +genLargePrimitives = LargePrimitives <$> genFloat <*> genInt + +instance AlignedStorable Std140 LargePrimitives +instance AlignedStorable Std430 LargePrimitives +instance AlignedStorable Scalar LargePrimitives + +newtype LargePrimitivesStd140 = LargePrimitivesStd140 LargePrimitives + deriving (Generic, Typeable, Show, Eq) + +instance Storable LargePrimitivesStd140 where + sizeOf _ = 16 + alignment _ = 16 + peek ptr = LargePrimitivesStd140 <$> (LargePrimitives <$> peekByteOff ptr 0 <*> peekByteOff ptr 8) + poke ptr (LargePrimitivesStd140 LargePrimitives{..}) = do + pokeByteOff ptr 0 d + pokeByteOff ptr 8 l + +unit_largeprimitives_std140_packed_size :: Assertion +unit_largeprimitives_std140_packed_size = + packedAlignedSizeOf @Std140 @LargePrimitives Proxy Proxy @?= 16 + +hprop_largeprimitives_std140_round_trip :: Property +hprop_largeprimitives_std140_round_trip = property do + val <- forAll genLargePrimitives + let sut = Strided @Std140 val + let oracle = LargePrimitivesStd140 val + ptrTripping sut oracle + +newtype LargePrimitivesStd430 = LargePrimitivesStd430 LargePrimitives + deriving (Generic, Typeable, Show, Eq) + +instance Storable LargePrimitivesStd430 where + sizeOf _ = 16 + alignment _ = 8 + peek ptr = LargePrimitivesStd430 <$> (LargePrimitives <$> peekByteOff ptr 0 <*> peekByteOff ptr 8) + poke ptr (LargePrimitivesStd430 LargePrimitives{..}) = do + pokeByteOff ptr 0 d + pokeByteOff ptr 8 l + +unit_largeprimitives_std430_packed_size :: Assertion +unit_largeprimitives_std430_packed_size = + packedAlignedSizeOf @Std430 @LargePrimitives Proxy Proxy @?= 16 + +hprop_largeprimitives_std430_round_trip :: Property +hprop_largeprimitives_std430_round_trip = property do + val <- forAll genLargePrimitives + let sut = Strided @Std430 val + let oracle = LargePrimitivesStd430 val + ptrTripping sut oracle + +newtype LargePrimitivesScalar = LargePrimitivesScalar LargePrimitives + deriving (Generic, Typeable, Show, Eq) + +instance Storable LargePrimitivesScalar where + sizeOf _ = 16 + alignment _ = 8 + peek ptr = LargePrimitivesScalar <$> (LargePrimitives <$> peekByteOff ptr 0 <*> peekByteOff ptr 8) + poke ptr (LargePrimitivesScalar LargePrimitives{..}) = do + pokeByteOff ptr 0 d + pokeByteOff ptr 8 l + +hprop_largeprimitives_scalar_round_trip :: Property +hprop_largeprimitives_scalar_round_trip = property do + val <- forAll genLargePrimitives + let sut = Strided @Scalar val + let oracle = LargePrimitivesScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- Uniforms +-------------------------------------------------------------------------------- + +data Uniforms = Uniforms + { modelView :: V4 (V4 Float) + , cameraPos :: V4 Float + } + deriving (Generic, Typeable, Show, Eq) + +genUniforms :: Gen Uniforms +genUniforms = Uniforms <$> genMat genFloat <*> genV genFloat + +instance AlignedStorable Std140 Uniforms +instance AlignedStorable Std430 Uniforms +instance AlignedStorable Scalar Uniforms + +newtype UniformsStd140 = UniformsStd140 Uniforms + deriving (Generic, Typeable, Show, Eq) + +instance Storable UniformsStd140 where + sizeOf _ = 80 + alignment _ = 16 + peek ptr = UniformsStd140 <$> (Uniforms <$> peekByteOff ptr 0 <*> peekByteOff ptr 64) + poke ptr (UniformsStd140 Uniforms{..}) = do + pokeByteOff ptr 0 modelView + pokeByteOff ptr 64 cameraPos + +hprop_uniforms_std140_round_trip :: Property +hprop_uniforms_std140_round_trip = property do + val <- forAll genUniforms + let sut = Strided @Std140 val + let oracle = UniformsStd140 val + ptrTripping sut oracle + +newtype UniformsStd430 = UniformsStd430 Uniforms + deriving (Generic, Typeable, Show, Eq) + +instance Storable UniformsStd430 where + sizeOf _ = 80 + alignment _ = 16 + peek ptr = UniformsStd430 <$> (Uniforms <$> peekByteOff ptr 0 <*> peekByteOff ptr 64) + poke ptr (UniformsStd430 Uniforms{..}) = do + pokeByteOff ptr 0 modelView + pokeByteOff ptr 64 cameraPos + +hprop_uniforms_std430_round_trip :: Property +hprop_uniforms_std430_round_trip = property do + val <- forAll genUniforms + let sut = Strided @Std430 val + let oracle = UniformsStd430 val + ptrTripping sut oracle + +newtype UniformsScalar = UniformsScalar Uniforms + deriving (Generic, Typeable, Show, Eq) + +instance Storable UniformsScalar where + sizeOf _ = 80 + alignment _ = 4 + peek ptr = UniformsScalar <$> (Uniforms <$> peekByteOff ptr 0 <*> peekByteOff ptr 64) + poke ptr (UniformsScalar Uniforms{..}) = do + pokeByteOff ptr 0 modelView + pokeByteOff ptr 64 cameraPos + +hprop_uniforms_scalar_round_trip :: Property +hprop_uniforms_scalar_round_trip = property do + val <- forAll genUniforms + let sut = Strided @Scalar val + let oracle = UniformsScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- MixedAlign (explicitly tests the difference between std140 and std430) +-------------------------------------------------------------------------------- + +data MixedAlign = MixedAlign + { a :: Int16 + , b :: Double + , c :: Int32 + } + deriving (Generic, Typeable, Show, Eq) + +genMixedAlign :: Gen MixedAlign +genMixedAlign = MixedAlign <$> genInt <*> genFloat <*> genInt + +instance AlignedStorable Std140 MixedAlign +instance AlignedStorable Std430 MixedAlign +instance AlignedStorable Scalar MixedAlign + +newtype MixedAlignStd140 = MixedAlignStd140 MixedAlign + deriving (Generic, Typeable, Show, Eq) + +instance Storable MixedAlignStd140 where + sizeOf _ = 32 + alignment _ = 16 + peek ptr = + MixedAlignStd140 <$> (MixedAlign <$> peekByteOff ptr 0 <*> peekByteOff ptr 8 <*> peekByteOff ptr 16) + poke ptr (MixedAlignStd140 MixedAlign{..}) = do + pokeByteOff ptr 0 a + pokeByteOff ptr 8 b + pokeByteOff ptr 16 c + +hprop_mixedalign_std140_round_trip :: Property +hprop_mixedalign_std140_round_trip = property do + val <- forAll genMixedAlign + let sut = Strided @Std140 val + let oracle = MixedAlignStd140 val + ptrTripping sut oracle + +newtype MixedAlignStd430 = MixedAlignStd430 MixedAlign + deriving (Generic, Typeable, Show, Eq) + +instance Storable MixedAlignStd430 where + sizeOf _ = 24 + alignment _ = 8 + peek ptr = + MixedAlignStd430 <$> (MixedAlign <$> peekByteOff ptr 0 <*> peekByteOff ptr 8 <*> peekByteOff ptr 16) + poke ptr (MixedAlignStd430 MixedAlign{..}) = do + pokeByteOff ptr 0 a + pokeByteOff ptr 8 b + pokeByteOff ptr 16 c + +hprop_mixedalign_std430_round_trip :: Property +hprop_mixedalign_std430_round_trip = property do + val <- forAll genMixedAlign + let sut = Strided @Std430 val + let oracle = MixedAlignStd430 val + ptrTripping sut oracle + +newtype MixedAlignScalar = MixedAlignScalar MixedAlign + deriving (Generic, Typeable, Show, Eq) + +instance Storable MixedAlignScalar where + sizeOf _ = 24 + alignment _ = 8 + peek ptr = + MixedAlignScalar <$> (MixedAlign <$> peekByteOff ptr 0 <*> peekByteOff ptr 8 <*> peekByteOff ptr 16) + poke ptr (MixedAlignScalar MixedAlign{..}) = do + pokeByteOff ptr 0 a + pokeByteOff ptr 8 b + pokeByteOff ptr 16 c + +hprop_mixedalign_scalar_round_trip :: Property +hprop_mixedalign_scalar_round_trip = property do + val <- forAll genMixedAlign + let sut = Strided @Scalar val + let oracle = MixedAlignScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- FinalPaddingTest +-------------------------------------------------------------------------------- + +data FinalPaddingTest = FinalPaddingTest + { fptA :: V4 Float + , fptB :: Int32 + } + deriving (Generic, Typeable, Show, Eq) + +genFinalPaddingTest :: Gen FinalPaddingTest +genFinalPaddingTest = FinalPaddingTest <$> genV genFloat <*> genInt + +instance AlignedStorable Std140 FinalPaddingTest +instance AlignedStorable Std430 FinalPaddingTest +instance AlignedStorable Scalar FinalPaddingTest + +newtype FinalPaddingTestStd140 = FinalPaddingTestStd140 FinalPaddingTest + deriving (Generic, Typeable, Show, Eq) + +instance Storable FinalPaddingTestStd140 where + sizeOf _ = 32 + alignment _ = 16 + peek ptr = FinalPaddingTestStd140 <$> (FinalPaddingTest <$> peekByteOff ptr 0 <*> peekByteOff ptr 16) + poke ptr (FinalPaddingTestStd140 FinalPaddingTest{..}) = do + pokeByteOff ptr 0 fptA + pokeByteOff ptr 16 fptB + +hprop_finalpaddingtest_std140_round_trip :: Property +hprop_finalpaddingtest_std140_round_trip = property do + val <- forAll genFinalPaddingTest + let sut = Strided @Std140 val + let oracle = FinalPaddingTestStd140 val + ptrTripping sut oracle + +newtype FinalPaddingTestStd430 = FinalPaddingTestStd430 FinalPaddingTest + deriving (Generic, Typeable, Show, Eq) + +instance Storable FinalPaddingTestStd430 where + sizeOf _ = 32 + alignment _ = 16 + peek ptr = FinalPaddingTestStd430 <$> (FinalPaddingTest <$> peekByteOff ptr 0 <*> peekByteOff ptr 16) + poke ptr (FinalPaddingTestStd430 FinalPaddingTest{..}) = do + pokeByteOff ptr 0 fptA + pokeByteOff ptr 16 fptB + +hprop_finalpaddingtest_std430_round_trip :: Property +hprop_finalpaddingtest_std430_round_trip = property do + val <- forAll genFinalPaddingTest + let sut = Strided @Std430 val + let oracle = FinalPaddingTestStd430 val + ptrTripping sut oracle + +newtype FinalPaddingTestScalar = FinalPaddingTestScalar FinalPaddingTest + deriving (Generic, Typeable, Show, Eq) + +instance Storable FinalPaddingTestScalar where + sizeOf _ = 20 + alignment _ = 4 + peek ptr = FinalPaddingTestScalar <$> (FinalPaddingTest <$> peekByteOff ptr 0 <*> peekByteOff ptr 16) + poke ptr (FinalPaddingTestScalar FinalPaddingTest{..}) = do + pokeByteOff ptr 0 fptA + pokeByteOff ptr 16 fptB + +hprop_finalpaddingtest_scalar_round_trip :: Property +hprop_finalpaddingtest_scalar_round_trip = property do + val <- forAll genFinalPaddingTest + let sut = Strided @Scalar val + let oracle = FinalPaddingTestScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- BoolTest +-------------------------------------------------------------------------------- + +data BoolTest = BoolTest + { isEnabled :: Bool + , value :: Float + } + deriving (Generic, Typeable, Show, Eq) + +genBoolTest :: Gen BoolTest +genBoolTest = BoolTest <$> Gen.bool <*> genFloat + +instance AlignedStorable Std140 BoolTest +instance AlignedStorable Std430 BoolTest +instance AlignedStorable Scalar BoolTest + +newtype BoolTestStd140 = BoolTestStd140 BoolTest + deriving (Generic, Typeable, Show, Eq) + +instance Storable BoolTestStd140 where + sizeOf _ = 16 + alignment _ = 16 + peek ptr = BoolTestStd140 <$> (BoolTest <$> peekByteOff ptr 0 <*> peekByteOff ptr 4) + poke ptr (BoolTestStd140 BoolTest{..}) = do + pokeByteOff ptr 0 isEnabled + pokeByteOff ptr 4 value + +hprop_booltest_std140_round_trip :: Property +hprop_booltest_std140_round_trip = property do + val <- forAll genBoolTest + let sut = Strided @Std140 val + oracle = BoolTestStd140 val + ptrTripping sut oracle + +newtype BoolTestStd430 = BoolTestStd430 BoolTest + deriving (Generic, Typeable, Show, Eq) + +instance Storable BoolTestStd430 where + sizeOf _ = 8 + alignment _ = 4 + peek ptr = BoolTestStd430 <$> (BoolTest <$> peekByteOff ptr 0 <*> peekByteOff ptr 4) + poke ptr (BoolTestStd430 BoolTest{..}) = do + pokeByteOff ptr 0 isEnabled + pokeByteOff ptr 4 value + +hprop_booltest_std430_round_trip :: Property +hprop_booltest_std430_round_trip = property do + val <- forAll genBoolTest + let sut = Strided @Std430 val + oracle = BoolTestStd430 val + ptrTripping sut oracle + +newtype BoolTestScalar = BoolTestScalar BoolTest + deriving (Generic, Typeable, Show, Eq) + +instance Storable BoolTestScalar where + sizeOf _ = 8 + alignment _ = 4 + peek ptr = BoolTestScalar <$> (BoolTest <$> peekByteOff ptr 0 <*> peekByteOff ptr 4) + poke ptr (BoolTestScalar BoolTest{..}) = do + pokeByteOff ptr 0 isEnabled + pokeByteOff ptr 4 value + +hprop_booltest_scalar_round_trip :: Property +hprop_booltest_scalar_round_trip = property do + val <- forAll genBoolTest + let sut = Strided @Scalar val + oracle = BoolTestScalar val + ptrTripping sut oracle + +data Nested = Nested + { nestedV3 :: V3 Float + , nestedSimple :: Simple + , nestedMixed :: MixedAlign + , nestedBoolTest :: BoolTest + } + deriving (Generic, Typeable, Show, Eq) + +genNested :: Gen Nested +genNested = + Nested + <$> genV genFloat + <*> genSimple + <*> genMixedAlign + <*> genBoolTest + +instance AlignedStorable Std140 Nested +instance AlignedStorable Std430 Nested +instance AlignedStorable Scalar Nested + +newtype NestedStd140 = NestedStd140 Nested + deriving (Generic, Typeable, Show, Eq) + +instance Storable NestedStd140 where + sizeOf _ = 80 + alignment _ = 16 + peek ptr = + NestedStd140 + <$> ( Nested + <$> peekByteOff ptr 0 + <*> (coerce <$> peekByteOff @(Strided Std140 Simple) ptr 16) + <*> (coerce <$> peekByteOff @(Strided Std140 MixedAlign) ptr 32) + <*> (coerce <$> peekByteOff @(Strided Std140 BoolTest) ptr 64) + ) + poke ptr (NestedStd140 Nested{..}) = do + pokeByteOff ptr 0 nestedV3 + pokeByteOff ptr 16 (Strided @Std140 nestedSimple) + pokeByteOff ptr 32 (Strided @Std140 nestedMixed) + pokeByteOff ptr 64 (Strided @Std140 nestedBoolTest) + +hprop_nested_std140_round_trip :: Property +hprop_nested_std140_round_trip = property do + val <- forAll genNested + let sut = Strided @Std140 val + oracle = NestedStd140 val + ptrTripping sut oracle + +newtype NestedStd430 = NestedStd430 Nested + deriving (Generic, Typeable, Show, Eq) + +instance Storable NestedStd430 where + sizeOf _ = 64 + alignment _ = 16 + peek ptr = + NestedStd430 + <$> ( Nested + <$> peekByteOff ptr 0 + <*> (coerce <$> peekByteOff @(Strided Std430 Simple) ptr 12) + <*> (coerce <$> peekByteOff @(Strided Std430 MixedAlign) ptr 24) + <*> (coerce <$> peekByteOff @(Strided Std430 BoolTest) ptr 48) + ) + poke ptr (NestedStd430 Nested{..}) = do + pokeByteOff ptr 0 nestedV3 + pokeByteOff ptr 12 (Strided @Std430 nestedSimple) + pokeByteOff ptr 24 (Strided @Std430 nestedMixed) + pokeByteOff ptr 48 (Strided @Std430 nestedBoolTest) + +hprop_nested_std430_round_trip :: Property +hprop_nested_std430_round_trip = property do + val <- forAll genNested + let sut = Strided @Std430 val + oracle = NestedStd430 val + ptrTripping sut oracle + +newtype NestedScalar = NestedScalar Nested + deriving (Generic, Typeable, Show, Eq) + +instance Storable NestedScalar where + sizeOf _ = 56 + alignment _ = 8 + peek ptr = + NestedScalar + <$> ( Nested + <$> peekByteOff ptr 0 + <*> (coerce <$> peekByteOff @(Strided Scalar Simple) ptr 12) + <*> (coerce <$> peekByteOff @(Strided Scalar MixedAlign) ptr 24) + <*> (coerce <$> peekByteOff @(Strided Scalar BoolTest) ptr 44) + ) + poke ptr (NestedScalar Nested{..}) = do + pokeByteOff ptr 0 nestedV3 + pokeByteOff ptr 12 (Strided @Scalar nestedSimple) + pokeByteOff ptr 24 (Strided @Scalar nestedMixed) + pokeByteOff ptr 44 (Strided @Scalar nestedBoolTest) + +hprop_nested_scalar_round_trip :: Property +hprop_nested_scalar_round_trip = property do + val <- forAll genNested + let sut = Strided @Scalar val + oracle = NestedScalar val + ptrTripping sut oracle + +newtype NestedNewtype = NestedNewtype Nested + deriving (Generic, Typeable, Show, Eq) + +genNestedNewtype :: Gen NestedNewtype +genNestedNewtype = NestedNewtype <$> genNested + +instance AlignedStorable Std140 NestedNewtype +instance AlignedStorable Std430 NestedNewtype +instance AlignedStorable Scalar NestedNewtype + +newtype NestedNewtypeStd140 = NestedNewtypeStd140 NestedNewtype + deriving (Generic, Typeable, Show, Eq) + +instance Storable NestedNewtypeStd140 where + sizeOf _ = sizeOf @(Strided Std140 Nested) undefined + alignment _ = alignment @(Strided Std140 Nested) undefined + peek ptr = NestedNewtypeStd140 . coerce <$> peek @(Strided Std140 Nested) (castPtr ptr) + poke ptr (NestedNewtypeStd140 nested) = poke @(Strided Std140 Nested) (castPtr ptr) (coerce nested) + +hprop_nested_newtype_std140_round_trip :: Property +hprop_nested_newtype_std140_round_trip = property do + val <- forAll genNestedNewtype + let sut = Strided @Std140 val + oracle = NestedNewtypeStd140 val + ptrTripping sut oracle + +newtype NestedNewtypeStd430 = NestedNewtypeStd430 NestedNewtype + deriving (Generic, Typeable, Show, Eq) + +instance Storable NestedNewtypeStd430 where + sizeOf _ = sizeOf @(Strided Std430 Nested) undefined + alignment _ = alignment @(Strided Std430 Nested) undefined + peek ptr = NestedNewtypeStd430 . coerce <$> peek @(Strided Std430 Nested) (castPtr ptr) + poke ptr (NestedNewtypeStd430 nested) = poke @(Strided Std430 Nested) (castPtr ptr) (coerce nested) + +hprop_nested_newtype_std430_round_trip :: Property +hprop_nested_newtype_std430_round_trip = property do + val <- forAll genNestedNewtype + let sut = Strided @Std430 val + oracle = NestedNewtypeStd430 val + ptrTripping sut oracle + +newtype NestedNewtypeScalar = NestedNewtypeScalar NestedNewtype + deriving (Generic, Typeable, Show, Eq) + +instance Storable NestedNewtypeScalar where + sizeOf _ = sizeOf @(Strided Scalar Nested) undefined + alignment _ = alignment @(Strided Scalar Nested) undefined + peek ptr = + NestedNewtypeScalar . coerce <$> peek @(Strided Scalar Nested) (castPtr ptr) + poke ptr (NestedNewtypeScalar nested) = poke @(Strided Scalar Nested) (castPtr ptr) (coerce nested) + +hprop_nested_newtype_scalar_round_trip :: Property +hprop_nested_newtype_scalar_round_trip = property do + val <- forAll genNestedNewtype + let sut = Strided @Scalar val + oracle = NestedNewtypeScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- DoubleTrouble +-------------------------------------------------------------------------------- + +data DoubleTrouble = DoubleTrouble + { dtD0 :: Double + , dtM0 :: M33 Double + , dtF0 :: Float + , dtV0 :: V3 Double + , dtF1 :: Float + , dtV1 :: V4 Double + , dtF2 :: Float + , dtM1 :: M44 Double + } + deriving (Generic, Typeable, Show, Eq) + +genDoubleTrouble :: Gen DoubleTrouble +genDoubleTrouble = + DoubleTrouble + <$> genFloat + <*> genMat genFloat + <*> genFloat + <*> genV genFloat + <*> genFloat + <*> genV genFloat + <*> genFloat + <*> genMat genFloat + +instance AlignedStorable Std140 DoubleTrouble +instance AlignedStorable Std430 DoubleTrouble +instance AlignedStorable Scalar DoubleTrouble + +newtype DoubleTroubleStd140 = DoubleTroubleStd140 DoubleTrouble + deriving (Generic, Typeable, Show, Eq) + +instance Storable DoubleTroubleStd140 where + sizeOf _ = 384 + alignment _ = 32 + peek ptr = + DoubleTroubleStd140 + <$> ( DoubleTrouble + <$> peekByteOff ptr 0 + <*> peekMat3Oracle Std140 ptr 32 + <*> peekByteOff ptr 128 + <*> peekByteOff ptr 160 + <*> peekByteOff ptr 184 + <*> peekByteOff ptr 192 + <*> peekByteOff ptr 224 + <*> peekByteOff ptr 256 + ) + poke ptr (DoubleTroubleStd140 DoubleTrouble{..}) = do + pokeByteOff ptr 0 dtD0 + pokeMat3Oracle Std140 ptr 32 dtM0 + pokeByteOff ptr 128 dtF0 + pokeByteOff ptr 160 dtV0 + pokeByteOff ptr 184 dtF1 + pokeByteOff ptr 192 dtV1 + pokeByteOff ptr 224 dtF2 + pokeByteOff ptr 256 dtM1 + +hprop_doubletrouble_std140_round_trip :: Property +hprop_doubletrouble_std140_round_trip = property do + val <- forAll genDoubleTrouble + let sut = Strided @Std140 val + oracle = DoubleTroubleStd140 val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- VectorStruct +-------------------------------------------------------------------------------- + +data VectorStruct = VectorStruct + { vsA :: Float + , vsB :: SSV.Vector 2 (V3 Float) + , vsC :: Int32 + } + deriving (Generic, Typeable, Show, Eq) + +genVectorStruct :: Gen VectorStruct +genVectorStruct = + VectorStruct + <$> genFloat + <*> SSV.replicateM (genV genFloat) + <*> genInt + +instance AlignedStorable Std140 VectorStruct +instance AlignedStorable Std430 VectorStruct +instance AlignedStorable Scalar VectorStruct + +newtype VectorStructStd140 = VectorStructStd140 VectorStruct + deriving (Generic, Typeable, Show, Eq) + +instance Storable VectorStructStd140 where + sizeOf _ = 64 + alignment _ = 16 + peek ptr = + VectorStructStd140 + <$> ( VectorStruct + <$> peekByteOff ptr 0 + <*> (coerce <$> peekByteOff @(Packed Std140 (SSV.Vector 2 (V3 Float))) ptr 16) + <*> peekByteOff ptr 48 + ) + poke ptr (VectorStructStd140 VectorStruct{..}) = do + pokeByteOff ptr 0 vsA + pokeByteOff ptr 16 (Packed @Std140 vsB) + pokeByteOff ptr 48 vsC + +hprop_vectorstruct_std140_round_trip :: Property +hprop_vectorstruct_std140_round_trip = property do + val <- forAll genVectorStruct + let sut = Strided @Std140 val + oracle = VectorStructStd140 val + ptrTripping sut oracle + +newtype VectorStructStd430 = VectorStructStd430 VectorStruct + deriving (Generic, Typeable, Show, Eq) + +instance Storable VectorStructStd430 where + sizeOf _ = 64 + alignment _ = 16 + peek ptr = + VectorStructStd430 + <$> ( VectorStruct + <$> peekByteOff ptr 0 + <*> (coerce <$> peekByteOff @(Packed Std430 (SSV.Vector 2 (V3 Float))) ptr 16) + <*> peekByteOff ptr 48 + ) + poke ptr (VectorStructStd430 VectorStruct{..}) = do + pokeByteOff ptr 0 vsA + pokeByteOff ptr 16 (Packed @Std430 vsB) + pokeByteOff ptr 48 vsC + +hprop_vectorstruct_std430_round_trip :: Property +hprop_vectorstruct_std430_round_trip = property do + val <- forAll genVectorStruct + let sut = Strided @Std430 val + oracle = VectorStructStd430 val + ptrTripping sut oracle + +newtype VectorStructScalar = VectorStructScalar VectorStruct + deriving (Generic, Typeable, Show, Eq) + +instance Storable VectorStructScalar where + sizeOf _ = 32 + alignment _ = 4 + peek ptr = + VectorStructScalar + <$> ( VectorStruct + <$> peekByteOff ptr 0 + <*> (coerce <$> peekByteOff @(Packed Scalar (SSV.Vector 2 (V3 Float))) ptr 4) + <*> peekByteOff ptr 28 + ) + poke ptr (VectorStructScalar VectorStruct{..}) = do + pokeByteOff ptr 0 vsA + pokeByteOff ptr 4 (Packed @Scalar vsB) + pokeByteOff ptr 28 vsC + +hprop_vectorstruct_scalar_round_trip :: Property +hprop_vectorstruct_scalar_round_trip = property do + val <- forAll genVectorStruct + let sut = Strided @Scalar val + oracle = VectorStructScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- ComplexVectorStruct +-------------------------------------------------------------------------------- + +data ComplexVectorStruct = ComplexVectorStruct + { cvsA :: Float + , cvsB :: SSV.Vector 3 (V3 Word16) + , cvsC :: SSV.Vector 2 (V2 Double) + , cvsD :: Float + , cvsE :: Double + } + deriving (Generic, Typeable, Show, Eq) + +genComplexVectorStruct :: Gen ComplexVectorStruct +genComplexVectorStruct = + ComplexVectorStruct + <$> genFloat + <*> SSV.replicateM (genV genInt) + <*> SSV.replicateM (genV genFloat) + <*> genFloat + <*> genFloat + +instance AlignedStorable Std140 ComplexVectorStruct +instance AlignedStorable Std430 ComplexVectorStruct +instance AlignedStorable Scalar ComplexVectorStruct + +newtype ComplexVectorStructStd140 = ComplexVectorStructStd140 ComplexVectorStruct + deriving (Generic, Typeable, Show, Eq) + +instance Storable ComplexVectorStructStd140 where + sizeOf _ = 112 + alignment _ = 16 + peek ptr = + ComplexVectorStructStd140 + <$> ( ComplexVectorStruct + <$> peekByteOff ptr 0 + <*> (coerce <$> peekByteOff @(Packed Std140 (SSV.Vector 3 (V3 Word16))) ptr 16) + <*> (coerce <$> peekByteOff @(Packed Std140 (SSV.Vector 2 (V2 Double))) ptr 64) + <*> peekByteOff ptr 96 + <*> peekByteOff ptr 104 + ) + poke ptr (ComplexVectorStructStd140 ComplexVectorStruct{..}) = do + pokeByteOff ptr 0 cvsA + pokeByteOff ptr 16 (Packed @Std140 cvsB) + pokeByteOff ptr 64 (Packed @Std140 cvsC) + pokeByteOff ptr 96 cvsD + pokeByteOff ptr 104 cvsE + +hprop_complexvectorstruct_std140_round_trip :: Property +hprop_complexvectorstruct_std140_round_trip = property do + val <- forAll genComplexVectorStruct + let sut = Strided @Std140 val + oracle = ComplexVectorStructStd140 val + ptrTripping sut oracle + +newtype ComplexVectorStructStd430 = ComplexVectorStructStd430 ComplexVectorStruct + deriving (Generic, Typeable, Show, Eq) + +instance Storable ComplexVectorStructStd430 where + sizeOf _ = 80 + alignment _ = 16 + peek ptr = + ComplexVectorStructStd430 + <$> ( ComplexVectorStruct + <$> peekByteOff ptr 0 + <*> (coerce <$> peekByteOff @(Packed Std430 (SSV.Vector 3 (V3 Word16))) ptr 8) + <*> (coerce <$> peekByteOff @(Packed Std430 (SSV.Vector 2 (V2 Double))) ptr 32) + <*> peekByteOff ptr 64 + <*> peekByteOff ptr 72 + ) + poke ptr (ComplexVectorStructStd430 ComplexVectorStruct{..}) = do + pokeByteOff ptr 0 cvsA + pokeByteOff ptr 8 (Packed @Std430 cvsB) + pokeByteOff ptr 32 (Packed @Std430 cvsC) + pokeByteOff ptr 64 cvsD + pokeByteOff ptr 72 cvsE + +hprop_complexvectorstruct_std430_round_trip :: Property +hprop_complexvectorstruct_std430_round_trip = property do + val <- forAll genComplexVectorStruct + let sut = Strided @Std430 val + oracle = ComplexVectorStructStd430 val + ptrTripping sut oracle + +newtype ComplexVectorStructScalar = ComplexVectorStructScalar ComplexVectorStruct + deriving (Generic, Typeable, Show, Eq) + +instance Storable ComplexVectorStructScalar where + sizeOf _ = 72 + alignment _ = 8 + peek ptr = + ComplexVectorStructScalar + <$> ( ComplexVectorStruct + <$> peekByteOff ptr 0 + <*> (coerce <$> peekByteOff @(Packed Scalar (SSV.Vector 3 (V3 Word16))) ptr 4) + <*> (coerce <$> peekByteOff @(Packed Scalar (SSV.Vector 2 (V2 Double))) ptr 24) + <*> peekByteOff ptr 56 + <*> peekByteOff ptr 64 + ) + poke ptr (ComplexVectorStructScalar ComplexVectorStruct{..}) = do + pokeByteOff ptr 0 cvsA + pokeByteOff ptr 4 (Packed @Scalar cvsB) + pokeByteOff ptr 24 (Packed @Scalar cvsC) + pokeByteOff ptr 56 (Packed @Scalar cvsD) + pokeByteOff ptr 64 (Packed @Scalar cvsE) + +hprop_complexvectorstruct_scalar_round_trip :: Property +hprop_complexvectorstruct_scalar_round_trip = property do + val <- forAll genComplexVectorStruct + let sut = Strided @Scalar val + oracle = ComplexVectorStructScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- Insanity +-------------------------------------------------------------------------------- + +data Insanity = Insanity + { ina :: Float + , inb :: SV.Vector 7 ComplexVectorStruct + , inc :: Word8 + , ind :: Word64 + , ine :: Word16 + , inf :: V3 Bool + , ing :: SV.Vector 5 Nested + , inh :: V3 Word16 + , ini :: SV.Vector 5 (SV.Vector 2 (SV.Vector 4 Nested)) + , inj :: Bool + , ink :: V3 Double + } + deriving (Generic, Typeable, Show, Eq) + +instance AlignedStorable Std140 Insanity +instance AlignedStorable Std430 Insanity +instance AlignedStorable Scalar Insanity + +genInsanity :: Gen Insanity +genInsanity = + Insanity + <$> genFloat + <*> SV.replicateM genComplexVectorStruct + <*> genInt + <*> genInt + <*> genInt + <*> genV Gen.bool + <*> SV.replicateM genNested + <*> genV genInt + <*> SV.replicateM (SV.replicateM (SV.replicateM genNested)) + <*> Gen.bool + <*> genV genFloat + +newtype InsanityStd140 = InsanityStd140 Insanity + deriving (Generic, Typeable, Show, Eq) + +instance Storable InsanityStd140 where + sizeOf _ = 4512 + alignment _ = 32 + + peek ptr = + InsanityStd140 + <$> ( Insanity + <$> peekByteOff ptr 0 + <*> peekSizedVector (Proxy @ComplexVectorStructStd140) ptr 16 + <*> peekByteOff ptr 800 + <*> peekByteOff ptr 808 + <*> peekByteOff ptr 816 + <*> peekByteOff ptr 832 + <*> peekSizedVector (Proxy @NestedStd140) ptr 848 + <*> peekStd140U16Vec3OracleByteOff ptr 1248 + <*> peekSized3DVector (Proxy @NestedStd140) ptr 1264 + <*> peekByteOff ptr 4464 + <*> peekByteOff ptr 4480 + ) + + poke ptr (InsanityStd140 Insanity{..}) = do + pokeByteOff ptr 0 ina + pokeSizedVector ptr 16 (SV.map ComplexVectorStructStd140 inb) + pokeByteOff ptr 800 inc + pokeByteOff ptr 808 ind + pokeByteOff ptr 816 ine + pokeByteOff ptr 832 inf + pokeSizedVector ptr 848 (SV.map NestedStd140 ing) + pokeStd140U16Vec3OracleByteOff ptr 1248 inh + pokeSized3DVector (Proxy @NestedStd140) ptr 1264 ini + pokeByteOff ptr 4464 inj + pokeByteOff ptr 4480 ink + +hprop_insanity_std140_round_trips :: Property +hprop_insanity_std140_round_trips = withShrinks 10 $ property do + val <- forAll genInsanity + let sut = Strided @Std140 val + oracle = InsanityStd140 val + ptrTripping sut oracle + +newtype InsanityStd430 = InsanityStd430 Insanity + deriving (Generic, Typeable, Show, Eq) + +instance Storable InsanityStd430 where + sizeOf _ = 3584 + alignment _ = 32 + + peek ptr = + InsanityStd430 + <$> ( Insanity + <$> peekByteOff ptr 0 + <*> peekSizedVector (Proxy @ComplexVectorStructStd430) ptr 16 + <*> peekByteOff ptr 576 + <*> peekByteOff ptr 584 + <*> peekByteOff ptr 592 + <*> peekByteOff ptr 608 + <*> peekSizedVector (Proxy @NestedStd430) ptr 624 + <*> peekStd430U16Vec3OracleByteOff ptr 944 + <*> peekSized3DVector (Proxy @NestedStd430) ptr 960 + <*> peekByteOff ptr 3520 + <*> peekByteOff ptr 3552 + ) + + poke ptr (InsanityStd430 Insanity{..}) = do + pokeByteOff ptr 0 ina + pokeSizedVector ptr 16 (SV.map ComplexVectorStructStd430 inb) + pokeByteOff ptr 576 inc + pokeByteOff ptr 584 ind + pokeByteOff ptr 592 ine + pokeByteOff ptr 608 inf + pokeSizedVector ptr 624 (SV.map NestedStd430 ing) + pokeStd430U16Vec3OracleByteOff ptr 944 inh + pokeSized3DVector (Proxy @NestedStd430) ptr 960 ini + pokeByteOff ptr 3520 inj + pokeByteOff ptr 3552 ink + +hprop_insanity_std430_round_trips :: Property +hprop_insanity_std430_round_trips = withShrinks 10 $ property do + val <- forAll genInsanity + let sut = Strided @Std430 val + oracle = InsanityStd430 val + ptrTripping sut oracle + +newtype InsanityScalar = InsanityScalar Insanity + deriving (Generic, Typeable, Show, Eq) + +instance Storable InsanityScalar where + sizeOf _ = 3096 + alignment _ = 8 + + peek ptr = + InsanityScalar + <$> ( Insanity + <$> peekByteOff ptr 0 + <*> peekSizedVector (Proxy @ComplexVectorStructScalar) ptr 8 + <*> peekByteOff ptr 512 + <*> peekByteOff ptr 520 + <*> peekByteOff ptr 528 + <*> peekByteOff ptr 532 + <*> peekSizedVector (Proxy @NestedScalar) ptr 544 + <*> peekStd430U16Vec3OracleByteOff ptr 820 + <*> peekSized3DVector (Proxy @NestedScalar) ptr 832 + <*> peekByteOff ptr 3068 + <*> peekByteOff ptr 3072 + ) + + poke ptr (InsanityScalar Insanity{..}) = do + pokeByteOff ptr 0 ina + pokeSizedVector ptr 8 (SV.map ComplexVectorStructScalar inb) + pokeByteOff ptr 512 inc + pokeByteOff ptr 520 ind + pokeByteOff ptr 528 ine + pokeByteOff ptr 532 inf + pokeSizedVector ptr 544 (SV.map NestedScalar ing) + pokeStd430U16Vec3OracleByteOff ptr 820 inh + pokeSized3DVector (Proxy @NestedScalar) ptr 832 ini + pokeByteOff ptr 3068 inj + pokeByteOff ptr 3072 ink + +hprop_insanity_scalar_round_trips :: Property +hprop_insanity_scalar_round_trips = withShrinks 10 $ property do + val <- forAll genInsanity + let sut = Strided @Scalar val + oracle = InsanityScalar val + ptrTripping sut oracle + +-------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- +genFloat :: (RealFloat a) => Gen a +genFloat = Gen.realFloat (Range.linearFrac (-infinity) infinity) + +genInt :: (Bounded a, Integral a) => Gen a +genInt = Gen.integral (Range.linear minBound maxBound) + +genV :: (Traversable t, Applicative t) => Gen a -> Gen (t a) +genV = sequence . pure + +genMat :: (Traversable t, Applicative t, Traversable f, Applicative f) => Gen a -> Gen (t (f a)) +genMat = sequence . pure . genV + +infinity :: (Fractional a) => a +infinity = 1 / 0 + +peekSizedVector + :: forall n a b c v + . (KnownNat n, Storable a, Coercible a b, GV.Vector v a, GV.Vector v b) + => Proxy a + -> Ptr c + -> Int + -> IO (SGV.Vector v n b) +peekSizedVector _ p baseOffset = SGV.generateM \i -> + coerce <$> peekByteOff @a p (baseOffset + fromIntegral i * sizeOf @a undefined) + +pokeSizedVector + :: forall n a b v + . (KnownNat n, Storable a, GV.Vector v a) + => Ptr b + -> Int + -> SGV.Vector v n a + -> IO () +pokeSizedVector p baseOffset = SGV.imapM_ \i a -> pokeByteOff p (baseOffset + sizeOf @a undefined * fromIntegral i) a + +peekSized3DVector + :: forall n m o a b c v + . ( KnownNat n + , KnownNat m + , KnownNat o + , Storable a + , Coercible a b + , GV.Vector v a + , GV.Vector v b + , GV.Vector v (SGV.Vector v o b) + , GV.Vector v (SGV.Vector v m (SGV.Vector v o b)) + ) + => Proxy a + -> Ptr c + -> Int + -> IO (SGV.Vector v n (SGV.Vector v m (SGV.Vector v o b))) +peekSized3DVector _ p baseOffset = + let strideO = sizeOf @a undefined + strideM = strideO * fromIntegral (natVal @o Proxy) + strideN = strideM * fromIntegral (natVal @m Proxy) + in SGV.generateM \i -> + SGV.generateM \j -> + SGV.generateM \k -> + let offset = baseOffset + fromIntegral i * strideN + fromIntegral j * strideM + fromIntegral k * strideO + in coerce <$> peekByteOff @a p offset + +pokeSized3DVector + :: forall n m o a b c v + . ( KnownNat n + , KnownNat m + , KnownNat o + , Storable a + , Coercible a b + , GV.Vector v a + , GV.Vector v b + , GV.Vector v c + , GV.Vector v (SGV.Vector v o b) + , GV.Vector v (SGV.Vector v m (SGV.Vector v o b)) + ) + => Proxy a + -> Ptr c + -> Int + -> SGV.Vector v n (SGV.Vector v m (SGV.Vector v o b)) + -> IO () +pokeSized3DVector _ p baseOffset = + let strideO = sizeOf @a undefined + strideM = strideO * fromIntegral (natVal @o Proxy) + strideN = strideM * fromIntegral (natVal @m Proxy) + in SGV.imapM_ \i -> + SGV.imapM_ \j -> + SGV.imapM_ \k a -> + let offset = baseOffset + fromIntegral i * strideN + fromIntegral j * strideM + fromIntegral k * strideO + in pokeByteOff @a p offset (coerce a) + +class MatrixStride v a where + matStride :: Proxy (v a) -> MemoryLayout -> Int + +instance MatrixStride V2 Half where + matStride _ = \case + Std140 -> 16 + Std430 -> 4 + Scalar -> 4 + +instance MatrixStride V2 Float where + matStride _ = \case + Std140 -> 16 + Std430 -> 8 + Scalar -> 8 + +instance MatrixStride V2 Double where + matStride _ = \case + Std140 -> 16 + Std430 -> 16 + Scalar -> 8 + +instance MatrixStride V3 Half where + matStride _ = \case + Std140 -> 16 + Std430 -> 8 + Scalar -> 6 + +instance MatrixStride V3 Float where + matStride _ = \case + Std140 -> 16 + Std430 -> 16 + Scalar -> 12 + +instance MatrixStride V3 Double where + matStride _ = \case + Std140 -> 32 + Std430 -> 32 + Scalar -> 24 + +instance MatrixStride V4 Half where + matStride _ = \case + Std140 -> 16 + Std430 -> 8 + Scalar -> 8 + +instance MatrixStride V4 Float where + matStride _ _ = 16 + +instance MatrixStride V4 Double where + matStride _ _ = 32 + +peekMat2Oracle + :: forall a b v. (MatrixStride v a, Storable (v a)) => MemoryLayout -> Ptr b -> Int -> IO (V2 (v a)) +peekMat2Oracle layout ptr off = + let stride = matStride (Proxy @(v a)) layout + in V2 <$> peekByteOff ptr off <*> peekByteOff ptr (off + stride) + +pokeMat2Oracle + :: forall a b v + . (MatrixStride v a, Storable (v a)) + => MemoryLayout + -> Ptr b + -> Int + -> V2 (v a) + -> IO () +pokeMat2Oracle layout ptr off (V2 r1 r2) = do + let stride = matStride (Proxy @(v a)) layout + pokeByteOff ptr off r1 + pokeByteOff ptr (off + stride) r2 + +peekMat3Oracle + :: forall a b v. (MatrixStride v a, Storable (v a)) => MemoryLayout -> Ptr b -> Int -> IO (V3 (v a)) +peekMat3Oracle layout ptr off = + let stride = matStride (Proxy @(v a)) layout + in V3 + <$> peekByteOff ptr off + <*> peekByteOff ptr (off + stride) + <*> peekByteOff ptr (off + stride * 2) + +pokeMat3Oracle + :: forall a b v + . (MatrixStride v a, Storable (v a)) + => MemoryLayout + -> Ptr b + -> Int + -> V3 (v a) + -> IO () +pokeMat3Oracle layout ptr off (V3 r1 r2 r3) = do + let stride = matStride (Proxy @(v a)) layout + pokeByteOff ptr off r1 + pokeByteOff ptr (off + stride) r2 + pokeByteOff ptr (off + stride * 2) r3 + +peekMat4Oracle + :: forall a b v. (MatrixStride v a, Storable (v a)) => MemoryLayout -> Ptr b -> Int -> IO (V4 (v a)) +peekMat4Oracle layout ptr off = + let stride = matStride (Proxy @(v a)) layout + in V4 + <$> peekByteOff ptr off + <*> peekByteOff ptr (off + stride) + <*> peekByteOff ptr (off + stride * 2) + <*> peekByteOff ptr (off + stride * 3) + +pokeMat4Oracle + :: forall a b v + . (MatrixStride v a, Storable (v a)) + => MemoryLayout + -> Ptr b + -> Int + -> V4 (v a) + -> IO () +pokeMat4Oracle layout ptr off (V4 r1 r2 r3 r4) = do + let stride = matStride (Proxy @(v a)) layout + pokeByteOff ptr off r1 + pokeByteOff ptr (off + stride) r2 + pokeByteOff ptr (off + stride * 2) r3 + pokeByteOff ptr (off + stride * 3) r4 + +peekStd140U16Vec3OracleByteOff :: (Storable a) => Ptr b -> Int -> IO (V3 a) +peekStd140U16Vec3OracleByteOff ptr off = + V3 + <$> peekByteOff ptr off + <*> peekByteOff ptr (off + 4) + <*> peekByteOff ptr (off + 8) + +peekStd140U16Mat3OracleByteOff :: Ptr b -> Int -> IO (M33 Word16) +peekStd140U16Mat3OracleByteOff ptr off = + V3 + <$> peekStd140U16Vec3OracleByteOff ptr off + <*> peekStd140U16Vec3OracleByteOff ptr (off + 16) + <*> peekStd140U16Vec3OracleByteOff ptr (off + 32) + +peekStd430U16Vec3OracleByteOff :: (Storable a) => Ptr b -> Int -> IO (V3 a) +peekStd430U16Vec3OracleByteOff ptr off = + V3 + <$> peekByteOff ptr off + <*> peekByteOff ptr (off + 2) + <*> peekByteOff ptr (off + 4) + +pokeStd140U16Vec3OracleByteOff :: Ptr b -> Int -> V3 Word16 -> IO () +pokeStd140U16Vec3OracleByteOff ptr off (V3 x y z) = do + pokeByteOff ptr off x + pokeByteOff ptr (off + 4) y + pokeByteOff ptr (off + 8) z + +pokeStd140U16Mat3OracleByteOff :: Ptr b -> Int -> M33 Word16 -> IO () +pokeStd140U16Mat3OracleByteOff ptr off (V3 r1 r2 r3) = do + pokeStd140U16Vec3OracleByteOff ptr off r1 + pokeStd140U16Vec3OracleByteOff ptr (off + 16) r2 + pokeStd140U16Vec3OracleByteOff ptr (off + 32) r3 + +pokeStd430U16Vec3OracleByteOff :: Ptr b -> Int -> V3 Word16 -> IO () +pokeStd430U16Vec3OracleByteOff ptr off (V3 x y z) = do + pokeByteOff ptr off x + pokeByteOff ptr (off + 2) y + pokeByteOff ptr (off + 4) z + +-- Duplicating this from the main module so it doesn't need to be exported. +roundUpTo :: (Bits a, Num a) => a -> a -> a +roundUpTo multiple val = (val + multiple - 1) .&. complement (multiple - 1)