Merge pull request #306 from expipiplus1/joe-alloca

Use allocaBytes instead of allocaBytesAligned where possible

changelog.md

@@ -2,6 +2,9 @@
 
 ## WIP
 
+## [3.11.0.1] - 2021-06-26
+- Use allocaBytes over allocaBytesAligned where possible
+
 ## [3.11] - 2021-06-21
 - Bump API version to v1.2.182
 

generate-new/src/Bespoke.hs

@@ -419,7 +419,7 @@ difficultLengths =
             tellImport ''CChar
             tellImport ''Word32
             tellImportWithAll ''ContT
-            tellImport 'allocaBytesAligned
+            tellImport 'allocaBytes
             tellImport 'lift
             tellQualImport 'BS.length
             tellImport 'copyBytes
@@ -439,9 +439,8 @@ difficultLengths =
                       , "-- Otherwise allocate and copy the bytes"
                       , "else" <+> doBlock
                         [ "let len =" <+> len
-                        , "mem <- ContT $ allocaBytesAligned @Word32"
+                        , "mem <- ContT $ allocaBytes @Word32"
                         <+> "len"
-                        <+> "4"
                         , "lift $ copyBytes mem (castPtr @CChar @Word32"
                         <+> maybeAligned
                         <>  ")"

generate-new/src/Render/Stmts/Poke.hs

@@ -694,12 +694,9 @@ allocArray allocType name elemType size = do
     tellImportWithAll ''ContT
     alloc <- case allocType of
       Uninitialized -> do
-        tellImport 'allocaBytesAligned
-        pure
-          $   "allocaBytesAligned @"
-          <>  elemTyDoc
-          <+> vecSizeDoc
-          <+> viaShow elemAlign
+        let (a, an, af) = chooseAlign elemAlign
+        tellImport an
+        pure $ af (a <+> "@" <> elemTyDoc <+> vecSizeDoc)
       Zeroed -> do
         tellImport 'callocBytes
         tellImport 'free

generate-new/src/Render/Struct.hs

@@ -13,7 +13,6 @@ import           Relude                  hiding ( Handle )
 import           Text.InterpolatedString.Perl6.Unindented
 
 import           Control.Monad.Trans.Cont       ( evalContT )
-import           Foreign.Marshal.Alloc
 import           Foreign.Ptr
 import           Foreign.Storable
 
@@ -381,7 +380,6 @@ toCStructInstance m@MarshaledStruct {..} pokeValue = do
   tellImportWithAll (TyConName "ToCStruct")
   let con         = mkConName msName msName
       Struct {..} = msStruct
-  tellImport 'allocaBytesAligned
   zero    <- pokeZeroCStructDecl m
   pokeDoc <- case pokeValue of
     ContTStmts d -> do
@@ -391,12 +389,13 @@ toCStructInstance m@MarshaledStruct {..} pokeValue = do
   (size, alignment) <- getTypeSize (TypeName msName)
   let unpack = if all (isElided . msmScheme) msMembers then "" else "{..}"
   stub <- toCStructInstanceStub tellImport msStruct
+  let (a, an, af) = chooseAlign sAlignment
+  tellImport an
   tellDoc $ (stub <+> "where") <> line <> indent
     2
     (vsep
-      [ "withCStruct x f = allocaBytesAligned"
-      <+> viaShow sSize
-      <+> viaShow sAlignment
+      [ "withCStruct x f ="
+      <+> af (a <+> viaShow sSize)
       <+> "$ \\p -> pokeCStruct p x (f p)"
       , "pokeCStruct"
       <+> pretty addrVar

generate-new/src/Render/Union.hs

@@ -16,6 +16,7 @@ import           Foreign.Ptr
 import           Language.Haskell.TH            ( mkName )
 
 import           CType
+import qualified Data.Text                     as T
 import           Error
 import           Haskell                       as H
 import           Marshal.Scheme
@@ -30,8 +31,8 @@ import           Render.State
 import           Render.Stmts
 import           Render.Stmts.Poke
 import           Render.Type
+import           Render.Utils                   ( chooseAlign )
 import           Spec.Parse
-import qualified Data.Text as T
 
 renderUnion
   :: ( HasErr r
@@ -184,12 +185,13 @@ toCStructInstance MarshaledStruct {..} = do
   tellImport 'free
 
   (size, alignment) <- getTypeSize (TypeName msName)
+  let (a, an, af) = chooseAlign sAlignment
+  tellImport an
   tellDoc $ "instance ToCStruct" <+> pretty n <+> "where" <> line <> indent
     2
     (vsep
-      [ "withCStruct x f = allocaBytesAligned"
-      <+> viaShow sSize
-      <+> viaShow sAlignment
+      [ "withCStruct x f ="
+      <+> af (a <+> viaShow sSize)
       <+> "$ \\p -> pokeCStruct p x (f p)"
       , "pokeCStruct ::" <+> pokeCStructTDoc
       , "pokeCStruct"

generate-new/src/Render/Utils.hs

@@ -3,8 +3,12 @@ module Render.Utils
 
 import qualified Data.Text                     as T
 import           Data.Text.Prettyprint.Doc
+import           Foreign.Marshal.Alloc          ( allocaBytes
+                                                , allocaBytesAligned
+                                                )
 import           Relude
 import           Text.Wrap
+import qualified Language.Haskell.TH as TH
 
 parenList :: Foldable f => f (Doc ()) -> Doc ()
 parenList = genericList (<>) "(" ")"
@@ -84,3 +88,8 @@ unReservedWord t = if t `elem` (keywords <> preludeWords) then t <> "'" else t
     , "where"
     ]
   preludeWords = ["filter"]
+
+chooseAlign :: Int -> (Doc ann, TH.Name, Doc ann -> Doc ann)
+chooseAlign align = if align <= 8
+  then ("allocaBytes", 'allocaBytes, id)
+  else ("allocaBytesAligned", 'allocaBytesAligned, (<+> viaShow align))

package.yaml

@@ -1,5 +1,5 @@
 name: vulkan
-version: '3.11'
+version: "3.11.0.1"
 synopsis: Bindings to the Vulkan graphics API.
 category: Graphics
 maintainer: Joe Hermaszewski <[email protected]>

src/Vulkan/CStruct/Extends.hs

@@ -21,7 +21,7 @@ module Vulkan.CStruct.Extends  ( BaseOutStructure(..)
 
 import Data.Maybe (fromMaybe)
 import Type.Reflection (typeRep)
-import Foreign.Marshal.Alloc (allocaBytesAligned)
+import Foreign.Marshal.Alloc (allocaBytes)
 import GHC.Base (join)
 import GHC.IO (throwIO)
 import GHC.Ptr (castPtr)
@@ -698,7 +698,7 @@ deriving instance Generic (BaseOutStructure)
 deriving instance Show BaseOutStructure
 
 instance ToCStruct BaseOutStructure where
-  withCStruct x f = allocaBytesAligned 16 8 $ \p -> pokeCStruct p x (f p)
+  withCStruct x f = allocaBytes 16 $ \p -> pokeCStruct p x (f p)
   pokeCStruct p BaseOutStructure{..} f = do
     poke ((p `plusPtr` 0 :: Ptr StructureType)) (sType)
     poke ((p `plusPtr` 8 :: Ptr (Ptr BaseOutStructure))) (next)
@@ -752,7 +752,7 @@ deriving instance Generic (BaseInStructure)
 deriving instance Show BaseInStructure
 
 instance ToCStruct BaseInStructure where
-  withCStruct x f = allocaBytesAligned 16 8 $ \p -> pokeCStruct p x (f p)
+  withCStruct x f = allocaBytes 16 $ \p -> pokeCStruct p x (f p)
   pokeCStruct p BaseInStructure{..} f = do
     poke ((p `plusPtr` 0 :: Ptr StructureType)) (sType)
     poke ((p `plusPtr` 8 :: Ptr (Ptr BaseInStructure))) (next)

src/Vulkan/Core10/AllocationCallbacks.hs

@@ -2,7 +2,7 @@
 -- No documentation found for Chapter "AllocationCallbacks"
 module Vulkan.Core10.AllocationCallbacks  (AllocationCallbacks(..)) where
 
-import Foreign.Marshal.Alloc (allocaBytesAligned)
+import Foreign.Marshal.Alloc (allocaBytes)
 import Foreign.Ptr (plusPtr)
 import Vulkan.CStruct (FromCStruct)
 import Vulkan.CStruct (FromCStruct(..))
@@ -186,7 +186,7 @@ deriving instance Generic (AllocationCallbacks)
 deriving instance Show AllocationCallbacks
 
 instance ToCStruct AllocationCallbacks where
-  withCStruct x f = allocaBytesAligned 48 8 $ \p -> pokeCStruct p x (f p)
+  withCStruct x f = allocaBytes 48 $ \p -> pokeCStruct p x (f p)
   pokeCStruct p AllocationCallbacks{..} f = do
     poke ((p `plusPtr` 0 :: Ptr (Ptr ()))) (userData)
     poke ((p `plusPtr` 8 :: Ptr PFN_vkAllocationFunction)) (pfnAllocation)

src/Vulkan/Core10/Buffer.hs

@@ -17,7 +17,7 @@ import Control.Exception.Base (bracket)
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Data.Typeable (eqT)
-import Foreign.Marshal.Alloc (allocaBytesAligned)
+import Foreign.Marshal.Alloc (allocaBytes)
 import Foreign.Marshal.Alloc (callocBytes)
 import Foreign.Marshal.Alloc (free)
 import GHC.Base (when)
@@ -439,7 +439,7 @@ instance Extensible BufferCreateInfo where
     | otherwise = Nothing
 
 instance (Extendss BufferCreateInfo es, PokeChain es) => ToCStruct (BufferCreateInfo es) where
-  withCStruct x f = allocaBytesAligned 56 8 $ \p -> pokeCStruct p x (f p)
+  withCStruct x f = allocaBytes 56 $ \p -> pokeCStruct p x (f p)
   pokeCStruct p BufferCreateInfo{..} f = evalContT $ do
     lift $ poke ((p `plusPtr` 0 :: Ptr StructureType)) (STRUCTURE_TYPE_BUFFER_CREATE_INFO)
     pNext'' <- fmap castPtr . ContT $ withChain (next)
@@ -449,7 +449,7 @@ instance (Extendss BufferCreateInfo es, PokeChain es) => ToCStruct (BufferCreate
     lift $ poke ((p `plusPtr` 32 :: Ptr BufferUsageFlags)) (usage)
     lift $ poke ((p `plusPtr` 36 :: Ptr SharingMode)) (sharingMode)
     lift $ poke ((p `plusPtr` 40 :: Ptr Word32)) ((fromIntegral (Data.Vector.length $ (queueFamilyIndices)) :: Word32))
-    pPQueueFamilyIndices' <- ContT $ allocaBytesAligned @Word32 ((Data.Vector.length (queueFamilyIndices)) * 4) 4
+    pPQueueFamilyIndices' <- ContT $ allocaBytes @Word32 ((Data.Vector.length (queueFamilyIndices)) * 4)
     lift $ Data.Vector.imapM_ (\i e -> poke (pPQueueFamilyIndices' `plusPtr` (4 * (i)) :: Ptr Word32) (e)) (queueFamilyIndices)
     lift $ poke ((p `plusPtr` 48 :: Ptr (Ptr Word32))) (pPQueueFamilyIndices')
     lift $ f

src/Vulkan/Core10/BufferView.hs

@@ -12,7 +12,7 @@ import Vulkan.Internal.Utils (traceAroundEvent)
 import Control.Exception.Base (bracket)
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
-import Foreign.Marshal.Alloc (allocaBytesAligned)
+import Foreign.Marshal.Alloc (allocaBytes)
 import Foreign.Marshal.Alloc (callocBytes)
 import Foreign.Marshal.Alloc (free)
 import GHC.Base (when)
@@ -369,7 +369,7 @@ deriving instance Generic (BufferViewCreateInfo)
 deriving instance Show BufferViewCreateInfo
 
 instance ToCStruct BufferViewCreateInfo where
-  withCStruct x f = allocaBytesAligned 56 8 $ \p -> pokeCStruct p x (f p)
+  withCStruct x f = allocaBytes 56 $ \p -> pokeCStruct p x (f p)
   pokeCStruct p BufferViewCreateInfo{..} f = do
     poke ((p `plusPtr` 0 :: Ptr StructureType)) (STRUCTURE_TYPE_BUFFER_VIEW_CREATE_INFO)
     poke ((p `plusPtr` 8 :: Ptr (Ptr ()))) (nullPtr)

src/Vulkan/Core10/CommandBuffer.hs

@@ -25,7 +25,7 @@ import Control.Exception.Base (bracket)
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Data.Typeable (eqT)
-import Foreign.Marshal.Alloc (allocaBytesAligned)
+import Foreign.Marshal.Alloc (allocaBytes)
 import Foreign.Marshal.Alloc (callocBytes)
 import Foreign.Marshal.Alloc (free)
 import Foreign.Marshal.Utils (maybePeek)
@@ -294,7 +294,7 @@ freeCommandBuffers device commandPool commandBuffers = liftIO . evalContT $ do
   lift $ unless (vkFreeCommandBuffersPtr /= nullFunPtr) $
     throwIO $ IOError Nothing InvalidArgument "" "The function pointer for vkFreeCommandBuffers is null" Nothing Nothing
   let vkFreeCommandBuffers' = mkVkFreeCommandBuffers vkFreeCommandBuffersPtr
-  pPCommandBuffers <- ContT $ allocaBytesAligned @(Ptr CommandBuffer_T) ((Data.Vector.length (commandBuffers)) * 8) 8
+  pPCommandBuffers <- ContT $ allocaBytes @(Ptr CommandBuffer_T) ((Data.Vector.length (commandBuffers)) * 8)
   lift $ Data.Vector.imapM_ (\i e -> poke (pPCommandBuffers `plusPtr` (8 * (i)) :: Ptr (Ptr CommandBuffer_T)) (commandBufferHandle (e))) (commandBuffers)
   lift $ traceAroundEvent "vkFreeCommandBuffers" (vkFreeCommandBuffers' (deviceHandle (device)) (commandPool) ((fromIntegral (Data.Vector.length $ (commandBuffers)) :: Word32)) (pPCommandBuffers))
   pure $ ()
@@ -608,7 +608,7 @@ deriving instance Generic (CommandBufferAllocateInfo)
 deriving instance Show CommandBufferAllocateInfo
 
 instance ToCStruct CommandBufferAllocateInfo where
-  withCStruct x f = allocaBytesAligned 32 8 $ \p -> pokeCStruct p x (f p)
+  withCStruct x f = allocaBytes 32 $ \p -> pokeCStruct p x (f p)
   pokeCStruct p CommandBufferAllocateInfo{..} f = do
     poke ((p `plusPtr` 0 :: Ptr StructureType)) (STRUCTURE_TYPE_COMMAND_BUFFER_ALLOCATE_INFO)
     poke ((p `plusPtr` 8 :: Ptr (Ptr ()))) (nullPtr)
@@ -785,7 +785,7 @@ instance Extensible CommandBufferInheritanceInfo where
     | otherwise = Nothing
 
 instance (Extendss CommandBufferInheritanceInfo es, PokeChain es) => ToCStruct (CommandBufferInheritanceInfo es) where
-  withCStruct x f = allocaBytesAligned 56 8 $ \p -> pokeCStruct p x (f p)
+  withCStruct x f = allocaBytes 56 $ \p -> pokeCStruct p x (f p)
   pokeCStruct p CommandBufferInheritanceInfo{..} f = evalContT $ do
     lift $ poke ((p `plusPtr` 0 :: Ptr StructureType)) (STRUCTURE_TYPE_COMMAND_BUFFER_INHERITANCE_INFO)
     pNext'' <- fmap castPtr . ContT $ withChain (next)
@@ -903,7 +903,7 @@ instance Extensible CommandBufferBeginInfo where
     | otherwise = Nothing
 
 instance (Extendss CommandBufferBeginInfo es, PokeChain es) => ToCStruct (CommandBufferBeginInfo es) where
-  withCStruct x f = allocaBytesAligned 32 8 $ \p -> pokeCStruct p x (f p)
+  withCStruct x f = allocaBytes 32 $ \p -> pokeCStruct p x (f p)
   pokeCStruct p CommandBufferBeginInfo{..} f = evalContT $ do
     lift $ poke ((p `plusPtr` 0 :: Ptr StructureType)) (STRUCTURE_TYPE_COMMAND_BUFFER_BEGIN_INFO)
     pNext'' <- fmap castPtr . ContT $ withChain (next)