Merge pull request #251 from expipiplus1/fix-239

Various small fixes

.github/workflows/ci.yml

@@ -18,6 +18,12 @@ jobs:
           # https://github.com/haskell/cabal/issues/6421
           - ghc: 8.10.2
             os: macOS-latest
+          # ghc: loadArchive: Failed reading header from `/Users/runner/work/vulkan/vulkan/dist-newstyle/build/x86_64-osx/ghc-8.6.5/vulkan-3.8.3/build/Vulkan'
+          # ghc: panic! (the 'impossible' happened)
+          #   (GHC version 8.6.5 for x86_64-apple-darwin):
+          # 	loadArchive "/Users/runner/work/vulkan/vulkan/dist-newstyle/build/x86_64-osx/ghc-8.6.5/vulkan-3.8.3/build/Vulkan": failed
+          - ghc: 8.6.5
+            os: macOS-latest
           - os: windows-latest
             ghc: '8.10.2'
         include:
@@ -37,17 +43,14 @@ jobs:
         # Work around https://github.com/polysemy-research/polysemy/issues/390
         cabal-version: '3.0.0.0'
 
-    - uses: actions/cache@v1
-      name: Cache cabal-store
-      with:
-        path: ${{ steps.setup-haskell.outputs.cabal-store }}
-        key: ${{ runner.os }}-${{ matrix.ghc }}-cabal
-
-    - name: Cache dist-newstyle
-      uses: actions/cache@v1
+    - uses: actions/cache@v2
       with:
-        path: dist-newstyle
-        key: ${{ runner.os }}-${{ matrix.ghc }}-dist-newstyle
+        path: |
+          ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
+          dist-newstyle
+        key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
+        restore-keys: |
+          ${{ runner.os }}-${{ matrix.ghc }}-
 
     - name: Install system dependencies Linux
       if: matrix.os == 'ubuntu-20.04'
@@ -107,10 +110,10 @@ jobs:
         sed -ibak '/examples/d' cabal.project
       if: matrix.ghc == '8.6.5'
 
-    - name: Remove generator for all but 8.10.2
+    - name: Remove generator for all but 8.10.3
       run: |
         sed -ibak '/generate-new/d' cabal.project
-      if: matrix.ghc != '8.10.2'
+      if: matrix.ghc != '8.10.3'
 
     # Because of https://github.com/actions/setup-haskell/issues/43 we can't
     # set the cabal version correctly
@@ -177,26 +180,17 @@ jobs:
         enable-stack: true
         ghc-version: '8.10.2'
 
-    - name: Cache stack global package db
-      id: stack-global
-      uses: actions/cache@v1
+    - name: Cache stack things
+      uses: actions/cache@v2
       with:
-        path: ~/.stack
+        path: |
+          ~/.stack
+          .stack-work
         key: ${{ runner.os }}-stack-global-${{ matrix.stack-args }}-${{ hashFiles('**.yaml') }}
         restore-keys: |
           ${{ runner.os }}-stack-global-${{ matrix.stack-args }}
           ${{ runner.os }}-stack-global
 
-    - name: Cache .stack-work
-      id: stack-work
-      uses: actions/cache@v1
-      with:
-        path: .stack-work
-        key: ${{ runner.os }}-stack-work-${{ matrix.stack-args }}-${{ hashFiles('**.yaml') }}
-        restore-keys: |
-          ${{ runner.os }}-stack-work-${{ matrix.stack-args }}
-          ${{ runner.os }}-stack-work
-
     - name: Install system dependencies Linux
       if: matrix.os == 'ubuntu-20.04'
       run: |

VulkanMemoryAllocator/VulkanMemoryAllocator.cabal

@@ -1,11 +1,11 @@
 cabal-version: 2.2
 
--- This file has been generated from package.yaml by hpack version 0.34.2.
+-- This file has been generated from package.yaml by hpack version 0.34.3.
 --
 -- see: https://github.com/sol/hpack
 
 name:           VulkanMemoryAllocator
-version:        0.3.11
+version:        0.3.12
 synopsis:       Bindings to the VulkanMemoryAllocator library
 category:       Graphics
 homepage:       https://github.com/expipiplus1/vulkan#readme
@@ -63,7 +63,7 @@ library
     , bytestring
     , transformers
     , vector
-    , vulkan >=3.6 && <3.9
+    , vulkan >=3.6 && <3.10
   if flag(safe-foreign-calls)
     cpp-options: -DSAFE_FOREIGN_CALLS
   if flag(vma-ndebug)

VulkanMemoryAllocator/changelog.md

@@ -2,8 +2,12 @@
 
 ## WIP
 
+## [0.3.12] - 2021-01-09
+
 - Calling traceEventIO before and after every VulkanMemoryAllocator command if
   `vulkan` was compiled with the `trace-calls` flag
+- Don't bother poking empty vectors in `withZeroCStruct`
+- Bump VMA, fixes compilation issue when vma-recording is enabled.
 
 ## [0.3.11] - 2020-11-30
 

VulkanMemoryAllocator/package.yaml

@@ -1,5 +1,5 @@
 name: VulkanMemoryAllocator
-version: "0.3.11"
+version: "0.3.12"
 synopsis: Bindings to the VulkanMemoryAllocator library
 category: Graphics
 maintainer: Joe Hermaszewski <[email protected]>
@@ -20,7 +20,7 @@ library:
     src/lib.cpp
   dependencies:
     - base <5
-    - vulkan >= 3.6 && < 3.9
+    - vulkan >= 3.6 && < 3.10
     - bytestring
     - transformers
     - vector

VulkanMemoryAllocator/src/VulkanMemoryAllocator.hs

@@ -197,6 +197,7 @@ import GHC.Show (showsPrec)
 import Numeric (showHex)
 import Data.ByteString (packCString)
 import Data.ByteString (useAsCString)
+import Data.Coerce (coerce)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Cont (evalContT)
 import Data.Vector (generateM)
@@ -233,6 +234,7 @@ import Data.Bits (FiniteBits)
 import Data.Typeable (Typeable)
 import Foreign.C.Types (CChar)
 import Foreign.C.Types (CSize)
+import Foreign.C.Types (CSize(..))
 import Foreign.C.Types (CSize(CSize))
 import Foreign.Storable (Storable)
 import Foreign.Storable (Storable(peek))
@@ -799,7 +801,7 @@ makePoolAllocationsLost allocator pool = liftIO . evalContT $ do
   pPLostAllocationCount <- ContT $ bracket (callocBytes @CSize 8) free
   lift $ traceAroundEvent "vmaMakePoolAllocationsLost" ((ffiVmaMakePoolAllocationsLost) (allocator) (pool) (pPLostAllocationCount))
   pLostAllocationCount <- lift $ peek @CSize pPLostAllocationCount
-  pure $ (((\(CSize a) -> a) pLostAllocationCount))
+  pure $ ((coerce @CSize @Word64 pLostAllocationCount))
 
 
 foreign import ccall
@@ -3356,12 +3358,6 @@ instance ToCStruct Stats where
   cStructSize = 3920
   cStructAlignment = 8
   pokeZeroCStruct p f = do
-    unless ((Data.Vector.length $ (mempty)) <= MAX_MEMORY_TYPES) $
-      throwIO $ IOError Nothing InvalidArgument "" "memoryType is too long, a maximum of MAX_MEMORY_TYPES elements are allowed" Nothing Nothing
-    Data.Vector.imapM_ (\i e -> poke ((lowerArrayPtr ((p `plusPtr` 0 :: Ptr (FixedArray MAX_MEMORY_TYPES StatInfo)))) `plusPtr` (80 * (i)) :: Ptr StatInfo) (e)) (mempty)
-    unless ((Data.Vector.length $ (mempty)) <= MAX_MEMORY_HEAPS) $
-      throwIO $ IOError Nothing InvalidArgument "" "memoryHeap is too long, a maximum of MAX_MEMORY_HEAPS elements are allowed" Nothing Nothing
-    Data.Vector.imapM_ (\i e -> poke ((lowerArrayPtr ((p `plusPtr` 2560 :: Ptr (FixedArray MAX_MEMORY_HEAPS StatInfo)))) `plusPtr` (80 * (i)) :: Ptr StatInfo) (e)) (mempty)
     poke ((p `plusPtr` 3840 :: Ptr StatInfo)) (zero)
     f
 
@@ -4014,7 +4010,7 @@ instance FromCStruct PoolCreateInfo where
     maxBlockCount <- peek @CSize ((p `plusPtr` 24 :: Ptr CSize))
     frameInUseCount <- peek @Word32 ((p `plusPtr` 32 :: Ptr Word32))
     pure $ PoolCreateInfo
-             memoryTypeIndex flags blockSize ((\(CSize a) -> a) minBlockCount) ((\(CSize a) -> a) maxBlockCount) frameInUseCount
+             memoryTypeIndex flags blockSize (coerce @CSize @Word64 minBlockCount) (coerce @CSize @Word64 maxBlockCount) frameInUseCount
 
 instance Storable PoolCreateInfo where
   sizeOf ~_ = 40
@@ -4093,7 +4089,7 @@ instance FromCStruct PoolStats where
     unusedRangeSizeMax <- peek @DeviceSize ((p `plusPtr` 32 :: Ptr DeviceSize))
     blockCount <- peek @CSize ((p `plusPtr` 40 :: Ptr CSize))
     pure $ PoolStats
-             size unusedSize ((\(CSize a) -> a) allocationCount) ((\(CSize a) -> a) unusedRangeCount) unusedRangeSizeMax ((\(CSize a) -> a) blockCount)
+             size unusedSize (coerce @CSize @Word64 allocationCount) (coerce @CSize @Word64 unusedRangeCount) unusedRangeSizeMax (coerce @CSize @Word64 blockCount)
 
 instance Storable PoolStats where
   sizeOf ~_ = 48
@@ -4399,19 +4395,13 @@ instance ToCStruct DefragmentationInfo2 where
     lift $ f
   cStructSize = 80
   cStructAlignment = 8
-  pokeZeroCStruct p f = evalContT $ do
-    lift $ poke ((p `plusPtr` 0 :: Ptr DefragmentationFlags)) (zero)
-    pPAllocations' <- ContT $ allocaBytesAligned @Allocation ((Data.Vector.length (mempty)) * 8) 8
-    lift $ Data.Vector.imapM_ (\i e -> poke (pPAllocations' `plusPtr` (8 * (i)) :: Ptr Allocation) (e)) (mempty)
-    lift $ poke ((p `plusPtr` 8 :: Ptr (Ptr Allocation))) (pPAllocations')
-    pPPools' <- ContT $ allocaBytesAligned @Pool ((Data.Vector.length (mempty)) * 8) 8
-    lift $ Data.Vector.imapM_ (\i e -> poke (pPPools' `plusPtr` (8 * (i)) :: Ptr Pool) (e)) (mempty)
-    lift $ poke ((p `plusPtr` 32 :: Ptr (Ptr Pool))) (pPPools')
-    lift $ poke ((p `plusPtr` 40 :: Ptr DeviceSize)) (zero)
-    lift $ poke ((p `plusPtr` 48 :: Ptr Word32)) (zero)
-    lift $ poke ((p `plusPtr` 56 :: Ptr DeviceSize)) (zero)
-    lift $ poke ((p `plusPtr` 64 :: Ptr Word32)) (zero)
-    lift $ f
+  pokeZeroCStruct p f = do
+    poke ((p `plusPtr` 0 :: Ptr DefragmentationFlags)) (zero)
+    poke ((p `plusPtr` 40 :: Ptr DeviceSize)) (zero)
+    poke ((p `plusPtr` 48 :: Ptr Word32)) (zero)
+    poke ((p `plusPtr` 56 :: Ptr DeviceSize)) (zero)
+    poke ((p `plusPtr` 64 :: Ptr Word32)) (zero)
+    f
 
 instance FromCStruct DefragmentationInfo2 where
   peekCStruct p = do

cabal.project

@@ -6,9 +6,4 @@ packages:
   ./examples
   ./generate-new/
 
-source-repository-package
-    type: git
-    location: https://github.com/expipiplus1/brittany.git
-    tag: b80f77c36bda563665c616abbdb1eaaf35b1da1c
-
 allow-newer: strict Cabal

changelog.md

@@ -2,6 +2,15 @@
 
 ## WIP
 
+## [3.10] - 2021-01-09
+- Make zero instance for `TransformMatrixKHR` return identity matrix. See
+  https://github.com/expipiplus1/vulkan/issues/240
+- Remove explicit 'count' field in AccelerationStructureBuildGeometryInfoKHR.
+  See https://github.com/expipiplus1/vulkan/issues/239
+- Do not bother poking empty vectors for zero pokes
+- Use `0` for spec version requirements for SPIRV Requirements, See
+  https://github.com/expipiplus1/vulkan/issues/249
+
 ## [3.8.3] - 2021-01-04
 - Bump API version to v1.2.166
 

default.nix

@@ -16,7 +16,7 @@ let
   packages = p:
     with p;
     [ vulkan vulkan-utils VulkanMemoryAllocator vulkan-examples openxr ]
-    ++ pkgs.lib.optional (p.ghc.version == "8.10.2") generate-new;
+    ++ pkgs.lib.optional (p.ghc.version == "8.10.3") generate-new;
 
 in if forShell then
   haskellPackages.shellFor {

generate-new/khronos-spec/Khronos/SPIRVElements.hs

@@ -226,16 +226,15 @@ extensionNamePattern p = do
   case parseVersion p of
     Just v  -> pure . RequireVersion $ v
     Nothing -> do
-      (namePattern, versionPattern) <- extensionPatterns p
+      (namePattern, _versionPattern) <- extensionPatterns p
       tellImport namePattern
-      tellImport versionPattern
       case siExtensionType p of
         Just DeviceExtension -> pure $ RequireDeviceExtension
           (pretty namePattern)
-          (pretty versionPattern)
+          "0"
         Just InstanceExtension -> pure $ RequireInstanceExtension
           (pretty namePattern)
-          (pretty versionPattern)
+          "0"
         Just UnknownExtensionType ->
           throw $ "Dependency on extension of unknown type: " <> show p
         Nothing -> throw $ "Dependency on unknown extension" <> show p

generate-new/src/Bespoke.hs

@@ -10,6 +10,8 @@ module Bespoke
   , bespokeSizes
   , bespokeOptionality
   , bespokeLengths
+  , bespokeZeroInstances
+  , bespokeZeroCStruct
   , bespokeSchemes
   , BespokeScheme(..)
   , structChainVar
@@ -40,9 +42,10 @@ import           Foreign.Marshal.Utils
 import           Numeric
 
 import           CType
+import           Data.List                      ( lookup )
 import           Error
 import           Foreign.C.String               ( CString )
-import           Foreign.Storable               ( Storable )
+import           Foreign.Storable               ( Storable(poke) )
 import           Haskell                       as H
 import           Marshal.Marshalable
 import           Marshal.Scheme
@@ -787,6 +790,11 @@ bespokeOptionality = \case
     "pBufferInfo"      -> Just (fromList [True])
     "pTexelBufferView" -> Just (fromList [True])
     _                  -> Nothing
+  -- Because we don't marshal ppGeometries, this is not actually optional
+  -- See https://github.com/expipiplus1/vulkan/issues/239
+  "VkAccelerationStructureBuildGeometryInfoKHR" -> \case
+    "pGeometries" -> Just mempty
+    _             -> Nothing
   _ -> const Nothing
 
 bespokeLengths :: CName -> CName -> Maybe (Vector ParameterLength)
@@ -797,6 +805,56 @@ bespokeLengths = \case
     _             -> Nothing
   _ -> const Nothing
 
+bespokeZeroInstances
+  :: ( HasErr r
+     , HasRenderElem r
+     , HasSpecInfo r
+     , HasRenderParams r
+     , HasSiblingInfo StructMember r
+     , HasStmts r
+     )
+  => HasRenderElem r => CName -> Maybe (Sem r ())
+bespokeZeroInstances = flip
+  lookup
+  [ ( "VkTransformMatrixKHR"
+    , do
+      tellImportWithAll (TyConName "Zero")
+      tellDoc [qqi|
+        instance Zero TransformMatrixKHR where
+         zero = TransformMatrixKHR
+                  (1,0,0,0)
+                  (0,1,0,0)
+                  (0,0,1,0)
+      |]
+    )
+  ]
+
+bespokeZeroCStruct
+  :: ( HasErr r
+     , HasRenderElem r
+     , HasSpecInfo r
+     , HasRenderParams r
+     , HasSiblingInfo StructMember r
+     , HasStmts r
+     )
+  => HasRenderElem r => CName -> Maybe (Sem r (Doc ()))
+bespokeZeroCStruct = flip
+  lookup
+  [ ( "VkTransformMatrixKHR"
+    , do
+      tellImport ''CFloat
+      tellImport 'plusPtr
+      tellImportWith ''Storable 'poke
+      pure [qqi|
+        pokeZeroCStruct p f = do
+          poke (p `plusPtr` 0) (CFloat 1)
+          poke (p `plusPtr` 20) (CFloat 1)
+          poke (p `plusPtr` 40) (CFloat 1)
+          f
+      |]
+    )
+  ]
+
 bespokeElements
   :: (HasErr r, HasRenderParams r) => SpecFlavor -> Vector (Sem r RenderElement)
 bespokeElements = \case

generate-new/src/Data/ByteString/Extra.hs

@@ -12,14 +12,3 @@ dropPrefix :: ByteString -> ByteString -> Maybe ByteString
 dropPrefix prefix s = if prefix `BS.isPrefixOf` s
   then Just (BS.drop (BS.length prefix) s)
   else Nothing
-
-strip :: ByteString -> ByteString
-strip = BS.dropWhile (isSpace . w2c) . dropWhileEnd (isSpace . w2c)
-
-dropWhileEnd :: (Word8 -> Bool) -> ByteString -> ByteString
-dropWhileEnd p ps = BS.take (findFromEndUntil (not . p) ps) ps
-
-findFromEndUntil :: (Word8 -> Bool) -> ByteString -> Int
-findFromEndUntil f ps@(PS _ _ l) = case unsnoc ps of
-  Nothing     -> 0
-  Just (b, c) -> if f c then l else findFromEndUntil f b