X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Foreign%2FMarshal%2FAlloc.hs;h=bbc2b98ef20c5bd7db86efad9bd259b5a5561849;hb=98daa4a448e019083d52ccec219a912021a0bfb0;hp=c5ae6a9ac3b4a70aa86c3d6eafcc37d6f3847560;hpb=10de2c656f74562b662c22928be85e1b3ccda796;p=ghc-base.git

diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs
index c5ae6a9..bbc2b98 100644
--- a/Foreign/Marshal/Alloc.hs
+++ b/Foreign/Marshal/Alloc.hs
@@ -9,7 +9,29 @@
 -- Stability   :  provisional
 -- Portability :  portable
 --
--- Marshalling support: basic routines for memory allocation
+-- The module "Foreign.Marshal.Alloc" provides operations to allocate and
+-- deallocate blocks of raw memory (i.e., unstructured chunks of memory
+-- outside of the area maintained by the Haskell storage manager).  These
+-- memory blocks are commonly used to pass compound data structures to
+-- foreign functions or to provide space in which compound result values
+-- are obtained from foreign functions.
+-- 
+-- If any of the allocation functions fails, a value of 'nullPtr' is
+-- produced.  If 'free' or 'reallocBytes' is applied to a memory area
+-- that has been allocated with 'alloca' or 'allocaBytes', the
+-- behaviour is undefined.  Any further access to memory areas allocated with
+-- 'alloca' or 'allocaBytes', after the computation that was passed to
+-- the allocation function has terminated, leads to undefined behaviour.  Any
+-- further access to the memory area referenced by a pointer passed to
+-- 'realloc', 'reallocBytes', or 'free' entails undefined
+-- behaviour.
+-- 
+-- All storage allocated by functions that allocate based on a /size in bytes/
+-- must be sufficiently aligned for any of the basic foreign types
+-- that fits into the newly allocated storage. All storage allocated by
+-- functions that allocate based on a specific type must be sufficiently
+-- aligned for that type. Array allocation routines need to obey the same
+-- alignment constraints for each array element.
 --
 -----------------------------------------------------------------------------
 
@@ -18,6 +40,7 @@ module Foreign.Marshal.Alloc (
   -- ** Local allocation
   alloca,       -- :: Storable a =>        (Ptr a -> IO b) -> IO b
   allocaBytes,  -- ::               Int -> (Ptr a -> IO b) -> IO b
+  allocaBytesAligned,  -- ::        Int -> Int -> (Ptr a -> IO b) -> IO b
 
   -- ** Dynamic allocation
   malloc,       -- :: Storable a =>        IO (Ptr a)
@@ -31,13 +54,16 @@ module Foreign.Marshal.Alloc (
 ) where
 
 import Data.Maybe
-import Foreign.Ptr              ( Ptr, nullPtr, FunPtr )
 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 )
+#endif
 
 #ifdef __GLASGOW_HASKELL__
 import Foreign.ForeignPtr       ( FinalizerPtr )
-import GHC.IOBase
+import GHC.IO.Exception
 import GHC.Real
 import GHC.Ptr
 import GHC.Err
@@ -47,7 +73,7 @@ import GHC.Num
 import NHC.FFI                  ( FinalizerPtr, CInt(..) )
 import IO                       ( bracket )
 #else
-import Control.Exception        ( bracket )
+import Control.Exception.Base   ( bracket )
 #endif
 
 #ifdef __HUGS__
@@ -67,6 +93,7 @@ import Hugs.ForeignPtr          ( FinalizerPtr )
 -- The memory may be deallocated using 'free' or 'finalizerFree' when
 -- no longer required.
 --
+{-# INLINE malloc #-}
 malloc :: Storable a => IO (Ptr a)
 malloc  = doMalloc undefined
   where
@@ -90,11 +117,12 @@ mallocBytes size  = failWhenNULL "malloc" (_malloc (fromIntegral size))
 -- The memory is freed when @f@ terminates (either normally or via an
 -- exception), so the pointer passed to @f@ must /not/ be used after this.
 --
+{-# INLINE alloca #-}
 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.
@@ -106,18 +134,32 @@ alloca  = doAlloca undefined
 --
 #ifdef __GLASGOW_HASKELL__
 allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
-allocaBytes (I# size) action = IO $ \ s ->
-     case newPinnedByteArray# size s      of { (# s, mbarr# #) ->
-     case unsafeFreezeByteArray# mbarr# s of { (# s, barr#  #) ->
+allocaBytes (I# size) action = IO $ \ s0 ->
+     case newPinnedByteArray# size 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 s       of { (# s, r #) ->
-     case touch# barr# s of { s ->
-     (# s, r #)
+     case action addr     of { IO action' ->
+     case action' s2      of { (# s3, r #) ->
+     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'
@@ -175,7 +217,10 @@ failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
 failWhenNULL name f = do
    addr <- f
    if addr == nullPtr
-#if __GLASGOW_HASKELL__ || __HUGS__
+#if __GLASGOW_HASKELL__
+      then ioError (IOError Nothing ResourceExhausted name 
+                                        "out of memory" Nothing Nothing)
+#elif __HUGS__
       then ioError (IOError Nothing ResourceExhausted name 
                                         "out of memory" Nothing)
 #else