diff options
| -rw-r--r-- | libraries/base/Foreign/Marshal/Alloc.hs | 18 | ||||
| -rw-r--r-- | libraries/base/GHC/ForeignPtr.hs | 10 |
2 files changed, 22 insertions, 6 deletions
diff --git a/libraries/base/Foreign/Marshal/Alloc.hs b/libraries/base/Foreign/Marshal/Alloc.hs index 282791ac5e..19cce12581 100644 --- a/libraries/base/Foreign/Marshal/Alloc.hs +++ b/libraries/base/Foreign/Marshal/Alloc.hs @@ -32,7 +32,7 @@ module Foreign.Marshal.Alloc ( import Data.Maybe import Foreign.C.Types ( CSize ) -import Foreign.Storable ( Storable(sizeOf) ) +import Foreign.Storable ( Storable(sizeOf,alignment) ) #ifndef __GLASGOW_HASKELL__ import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) @@ -97,7 +97,7 @@ alloca :: Storable a => (Ptr a -> IO b) -> IO b alloca = doAlloca undefined where doAlloca :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b' - doAlloca dummy = allocaBytes (sizeOf dummy) + doAlloca dummy = allocaBytesAligned (sizeOf dummy) (alignment dummy) -- |@'allocaBytes' n f@ executes the computation @f@, passing as argument -- a pointer to a temporarily allocated block of memory of @n@ bytes. @@ -118,9 +118,23 @@ allocaBytes (I# size) action = IO $ \ s0 -> case touch# barr# s3 of { s4 -> (# s4, r #) }}}}} + +allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b +allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 -> + case newAlignedPinnedByteArray# size align s0 of { (# s1, mbarr# #) -> + case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) -> + let addr = Ptr (byteArrayContents# barr#) in + case action addr of { IO action' -> + case action' s2 of { (# s3, r #) -> + case touch# barr# s3 of { s4 -> + (# s4, r #) + }}}}} #else allocaBytes :: Int -> (Ptr a -> IO b) -> IO b allocaBytes size = bracket (mallocBytes size) free + +allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b +allocaBytesAligned size align = allocaBytes size -- wrong #endif -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs index 50fa58d043..9868942d76 100644 --- a/libraries/base/GHC/ForeignPtr.hs +++ b/libraries/base/GHC/ForeignPtr.hs @@ -152,11 +152,12 @@ mallocForeignPtr = doMalloc undefined doMalloc a = do r <- newIORef (NoFinalizers, []) IO $ \s -> - case newPinnedByteArray# size s of { (# s', mbarr# #) -> + case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (MallocPtr mbarr# r) #) } - where (I# size) = sizeOf a + where (I# size) = sizeOf a + (I# align) = alignment a -- | This function is similar to 'mallocForeignPtr', except that the -- size of the memory required is given explicitly as a number of bytes. @@ -186,11 +187,12 @@ mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a) mallocPlainForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) doMalloc a = IO $ \s -> - case newPinnedByteArray# size s of { (# s', mbarr# #) -> + case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (PlainPtr mbarr#) #) } - where (I# size) = sizeOf a + where (I# size) = sizeOf a + (I# align) = alignment a -- | This function is similar to 'mallocForeignPtrBytes', except that -- the internally an optimised ForeignPtr representation with no |