X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Foreign%2FMarshal%2FAlloc.hs;h=ddb4a90baeefb507784e4187526aa32974c252da;hb=41e8fba828acbae1751628af50849f5352b27873;hp=ce5f1c301e6366e533a5d785f6b8ec3697f5ba3b;hpb=3d39b8130899c46c9c96b941fddb4e4784e860dc;p=ghc-base.git diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs index ce5f1c3..ddb4a90 100644 --- a/Foreign/Marshal/Alloc.hs +++ b/Foreign/Marshal/Alloc.hs @@ -1,105 +1,212 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , MagicHash + , UnboxedTuples + , ForeignFunctionInterface + #-} + ----------------------------------------------------------------------------- --- +-- | -- Module : Foreign.Marshal.Alloc -- Copyright : (c) The FFI task force 2001 --- License : BSD-style (see the file libraries/core/LICENSE) +-- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : ffi@haskell.org -- Stability : provisional -- Portability : portable -- --- $Id: Alloc.hs,v 1.3 2001/08/17 12:50:34 simonmar Exp $ --- --- 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. -- ----------------------------------------------------------------------------- module Foreign.Marshal.Alloc ( - malloc, -- :: Storable a => IO (Ptr a) - mallocBytes, -- :: Int -> IO (Ptr a) - + -- * Memory allocation + -- ** 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) + mallocBytes, -- :: Int -> IO (Ptr a) - reallocBytes, -- :: Ptr a -> Int -> IO (Ptr a) + realloc, -- :: Storable b => Ptr a -> IO (Ptr b) + reallocBytes, -- :: Ptr a -> Int -> IO (Ptr a) - free -- :: Ptr a -> IO () + free, -- :: Ptr a -> IO () + finalizerFree -- :: FinalizerPtr a ) where import Data.Maybe -import Foreign.Ptr ( Ptr, nullPtr ) -import Foreign.C.TypesISO ( CSize ) -import Foreign.Storable ( Storable(sizeOf) ) +import Foreign.C.Types ( CSize ) +import Foreign.Storable ( Storable(sizeOf,alignment) ) + +#ifndef __GLASGOW_HASKELL__ +import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) +#endif #ifdef __GLASGOW_HASKELL__ -import GHC.Exception ( bracket ) -import GHC.IOBase +import Foreign.ForeignPtr ( FinalizerPtr ) +import GHC.IO.Exception import GHC.Real import GHC.Ptr import GHC.Err import GHC.Base -import GHC.Prim +#elif defined(__NHC__) +import NHC.FFI ( FinalizerPtr, CInt(..) ) +import IO ( bracket ) +#else +import Control.Exception.Base ( bracket ) +#endif + +#ifdef __HUGS__ +import Hugs.Prelude ( IOException(IOError), + IOErrorType(ResourceExhausted) ) +import Hugs.ForeignPtr ( FinalizerPtr ) #endif -- exported functions -- ------------------ --- allocate space for storable type +-- |Allocate a block of memory that is sufficient to hold values of type +-- @a@. The size of the area allocated is determined by the 'sizeOf' +-- method from the instance of 'Storable' for the appropriate type. -- +-- 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 - doMalloc :: Storable a => a -> IO (Ptr a) + doMalloc :: Storable b => b -> IO (Ptr b) doMalloc dummy = mallocBytes (sizeOf dummy) --- allocate given number of bytes of storage +-- |Allocate a block of memory of the given number of bytes. +-- The block of memory is sufficiently aligned for any of the basic +-- foreign types that fits into a memory block of the allocated size. +-- +-- The memory may be deallocated using 'free' or 'finalizerFree' when +-- no longer required. -- mallocBytes :: Int -> IO (Ptr a) mallocBytes size = failWhenNULL "malloc" (_malloc (fromIntegral size)) --- temporarily allocate space for a storable type +-- |@'alloca' f@ executes the computation @f@, passing as argument +-- a pointer to a temporarily allocated block of memory sufficient to +-- hold values of type @a@. -- --- * the pointer passed as an argument to the function must *not* escape from --- this function; in other words, in `alloca f' the allocated storage must --- not be used after `f' returns +-- 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 :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b' + doAlloca dummy = allocaBytesAligned (sizeOf dummy) (alignment dummy) --- temporarily allocate the given number of bytes of storage +-- |@'allocaBytes' n f@ executes the computation @f@, passing as argument +-- a pointer to a temporarily allocated block of memory of @n@ bytes. +-- The block of memory is sufficiently aligned for any of the basic +-- foreign types that fits into a memory block of the allocated size. -- --- * the pointer passed as an argument to the function must *not* escape from --- this function; in other words, in `allocaBytes n f' the allocated storage --- must not be used after `f' returns +-- 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. -- #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' 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 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 #) }}}}} #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 --- adjust a malloc'ed storage area to the given size +-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' +-- to the size needed to store values of type @b@. The returned pointer +-- may refer to an entirely different memory area, but will be suitably +-- aligned to hold values of type @b@. The contents of the referenced +-- memory area will be the same as of the original pointer up to the +-- minimum of the original size and the size of values of type @b@. +-- +-- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like +-- 'malloc'. +-- +realloc :: Storable b => Ptr a -> IO (Ptr b) +realloc = doRealloc undefined + where + doRealloc :: Storable b' => b' -> Ptr a' -> IO (Ptr b') + doRealloc dummy ptr = let + size = fromIntegral (sizeOf dummy) + in + failWhenNULL "realloc" (_realloc ptr size) + +-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' +-- to the given size. The returned pointer may refer to an entirely +-- different memory area, but will be sufficiently aligned for any of the +-- basic foreign types that fits into a memory block of the given size. +-- The contents of the referenced memory area will be the same as of +-- the original pointer up to the minimum of the original size and the +-- given size. +-- +-- If the pointer argument to 'reallocBytes' is 'nullPtr', 'reallocBytes' +-- behaves like 'malloc'. If the requested size is 0, 'reallocBytes' +-- behaves like 'free'. -- reallocBytes :: Ptr a -> Int -> IO (Ptr a) +reallocBytes ptr 0 = do free ptr; return nullPtr reallocBytes ptr size = failWhenNULL "realloc" (_realloc ptr (fromIntegral size)) --- free malloc'ed storage +-- |Free a block of memory that was allocated with 'malloc', +-- 'mallocBytes', 'realloc', 'reallocBytes', 'Foreign.Marshal.Utils.new' +-- or any of the @new@/X/ functions in "Foreign.Marshal.Array" or +-- "Foreign.C.String". -- free :: Ptr a -> IO () free = _free @@ -115,9 +222,12 @@ failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a) failWhenNULL name f = do addr <- f if addr == nullPtr -#ifdef __GLASGOW_HASKELL__ - then ioException (IOError Nothing ResourceExhausted name - "out of memory" Nothing) +#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 then ioError (userError (name++": out of memory")) #endif @@ -125,6 +235,11 @@ failWhenNULL name f = do -- basic C routines needed for memory allocation -- -foreign import "malloc" unsafe _malloc :: CSize -> IO (Ptr a) -foreign import "realloc" unsafe _realloc :: Ptr a -> CSize -> IO (Ptr a) -foreign import "free" unsafe _free :: Ptr a -> IO () +foreign import ccall unsafe "stdlib.h malloc" _malloc :: CSize -> IO (Ptr a) +foreign import ccall unsafe "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b) +foreign import ccall unsafe "stdlib.h free" _free :: Ptr a -> IO () + +-- | A pointer to a foreign function equivalent to 'free', which may be +-- used as a finalizer (cf 'Foreign.ForeignPtr.ForeignPtr') for storage +-- allocated with 'malloc', 'mallocBytes', 'realloc' or 'reallocBytes'. +foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FinalizerPtr a