X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Foreign%2FMarshal%2FAlloc.hs;h=108058a9e58555722b42fd9910d12234615b6c1e;hb=3f6fd26597b7c0e45a8ac51aa07ff1f07b8f7111;hp=ed16c0167def9284f8a544d6f22ecdec184b9d9f;hpb=7f1f4e7a695c402ddd3a1dc2cc7114e649a78ebc;p=ghc-base.git diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs index ed16c01..108058a 100644 --- a/Foreign/Marshal/Alloc.hs +++ b/Foreign/Marshal/Alloc.hs @@ -1,90 +1,182 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- --- +-- | -- 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 : experimental --- Portability : non-portable --- --- $Id: Alloc.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $ +-- Stability : provisional +-- Portability : portable -- -- Marshalling support: basic routines for memory allocation -- ----------------------------------------------------------------------------- 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 - reallocBytes, -- :: Ptr a -> Int -> IO (Ptr a) + -- ** Dynamic allocation + malloc, -- :: Storable a => IO (Ptr a) + mallocBytes, -- :: 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.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.Storable ( Storable(sizeOf) ) -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.Num +#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. -- 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. -- 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 $ \ 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' 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 --- adjust a malloc'ed storage area to the given size +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' +-- 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 @@ -100,9 +192,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 @@ -110,6 +205,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