X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Foreign%2FMarshal%2FAlloc.hs;h=8f6b889e2f03f82308970b62adaa028e2ecb604c;hb=6075d5f981bbe94387a8322de1b516968dcc000b;hp=eddfff652cb071dc85a74c77757d96fd5a487323;hpb=5545727d5a6a1fc6d5d00f32a92a8fdf0fb7ca77;p=ghc-base.git diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs index eddfff6..8f6b889 100644 --- a/Foreign/Marshal/Alloc.hs +++ b/Foreign/Marshal/Alloc.hs @@ -1,50 +1,59 @@ {-# OPTIONS -fno-implicit-prelude #-} ----------------------------------------------------------------------------- --- +-- | -- 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.2 2001/07/03 11:37:50 simonmar Exp $ --- -- Marshalling support: basic routines for memory allocation -- ----------------------------------------------------------------------------- module Foreign.Marshal.Alloc ( + -- * Allocation malloc, -- :: Storable a => IO (Ptr a) mallocBytes, -- :: Int -> IO (Ptr a) alloca, -- :: Storable a => (Ptr a -> IO b) -> IO b allocaBytes, -- :: Int -> (Ptr a -> IO b) -> IO b - 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 () +#ifdef __HUGS__ + , finalizerFree -- :: FunPtr (Ptr a -> IO ()) +#endif ) where import Data.Maybe -import Foreign.Ptr ( Ptr, nullPtr ) -import Foreign.C.TypesISO ( CSize ) +import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) +import Foreign.C.Types ( CSize, CInt(..) ) +import Foreign.Storable ( Storable(sizeOf) ) #ifdef __GLASGOW_HASKELL__ -import GHC.Exception ( bracket ) -import GHC.Storable ( Storable(sizeOf) ) import GHC.IOBase import GHC.Real +import GHC.Ptr import GHC.Err import GHC.Base +#elif defined(__NHC__) +import IO ( bracket ) +#else +import Control.Exception ( bracket ) #endif -- exported functions -- ------------------ --- allocate space for storable type +-- |Allocate space for storable type. The size of the area allocated +-- is determined by the 'sizeOf' method from the instance of +-- 'Storable' for the appropriate type. -- malloc :: Storable a => IO (Ptr a) malloc = doMalloc undefined @@ -52,16 +61,16 @@ malloc = doMalloc undefined doMalloc :: Storable a => a -> IO (Ptr a) doMalloc dummy = mallocBytes (sizeOf dummy) --- allocate given number of bytes of storage +-- |Allocate given number of bytes of storage, equivalent to C\'s @malloc()@. -- mallocBytes :: Int -> IO (Ptr a) mallocBytes size = failWhenNULL "malloc" (_malloc (fromIntegral size)) --- temporarily allocate space for a storable type +-- |Temporarily allocate space for a storable type. -- --- * 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 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 -- alloca :: Storable a => (Ptr a -> IO b) -> IO b alloca = doAlloca undefined @@ -69,22 +78,49 @@ alloca = doAlloca undefined doAlloca :: Storable a => a -> (Ptr a -> IO b) -> IO b doAlloca dummy = allocaBytes (sizeOf dummy) --- temporarily allocate the given number of bytes of storage +-- |Temporarily allocate the given number of bytes of storage. -- --- * 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 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 -- +#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# #) -> + 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 #) + }}}}} +#else allocaBytes :: Int -> (Ptr a -> IO b) -> IO b allocaBytes size = bracket (mallocBytes size) free +#endif --- adjust a malloc'ed storage area to the given size +-- |Adjust a malloc\'ed storage area to the given size of the required type +-- (corresponds to C\'s @realloc()@). +-- +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) + +-- |Adjust a malloc\'ed storage area to the given size (equivalent to +-- C\'s @realloc()@). -- reallocBytes :: Ptr a -> Int -> IO (Ptr a) reallocBytes ptr size = failWhenNULL "realloc" (_realloc ptr (fromIntegral size)) --- free malloc'ed storage +-- |Free malloc\'ed storage (equivalent to +-- C\'s @free()@) -- free :: Ptr a -> IO () free = _free @@ -110,6 +146,12 @@ 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 () +#ifdef __HUGS__ +-- |A pointer to a foreign function equivalent to @free@, which may be used +-- as a finalizer for storage allocated with @malloc@ or @mallocBytes@. +foreign import ccall unsafe "stdlib.h &free" + finalizerFree :: FunPtr (Ptr a -> IO ()) +#endif