Foreign/Marshal/Alloc.hs

   1 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  Foreign.Marshal.Alloc
   5 -- Copyright   :  (c) The FFI task force 2001
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  ffi@haskell.org
   9 -- Stability   :  provisional
  10 -- Portability :  portable
  11 --
  12 -- Marshalling support: basic routines for memory allocation
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module Foreign.Marshal.Alloc (
  17   -- * Memory allocation
  18   -- ** Local allocation
  19   alloca,       -- :: Storable a =>        (Ptr a -> IO b) -> IO b
  20   allocaBytes,  -- ::               Int -> (Ptr a -> IO b) -> IO b
  21
  22   -- ** Dynamic allocation
  23   malloc,       -- :: Storable a =>        IO (Ptr a)
  24   mallocBytes,  -- ::               Int -> IO (Ptr a)
  25
  26   realloc,      -- :: Storable b => Ptr a        -> IO (Ptr b)
  27   reallocBytes, -- ::               Ptr a -> Int -> IO (Ptr a)
  28
  29   free,         -- :: Ptr a -> IO ()
  30   finalizerFree -- :: FinalizerPtr a
  31 ) where
  32
  33 import Data.Maybe
  34 import Foreign.C.Types          ( CSize )
  35 import Foreign.Storable         ( Storable(sizeOf,alignment) )
  36
  37 #ifndef __GLASGOW_HASKELL__
  38 import Foreign.Ptr              ( Ptr, nullPtr, FunPtr )
  39 #endif
  40
  41 #ifdef __GLASGOW_HASKELL__
  42 import Foreign.ForeignPtr       ( FinalizerPtr )
  43 import GHC.IO.Exception
  44 import GHC.Real
  45 import GHC.Ptr
  46 import GHC.Err
  47 import GHC.Base
  48 import GHC.Num
  49 #elif defined(__NHC__)
  50 import NHC.FFI                  ( FinalizerPtr, CInt(..) )
  51 import IO                       ( bracket )
  52 #else
  53 import Control.Exception.Base   ( bracket )
  54 #endif
  55
  56 #ifdef __HUGS__
  57 import Hugs.Prelude             ( IOException(IOError),
  58                                   IOErrorType(ResourceExhausted) )
  59 import Hugs.ForeignPtr          ( FinalizerPtr )
  60 #endif
  61
  62
  63 -- exported functions
  64 -- ------------------
  65
  66 -- |Allocate a block of memory that is sufficient to hold values of type
  67 -- @a@.  The size of the area allocated is determined by the 'sizeOf'
  68 -- method from the instance of 'Storable' for the appropriate type.
  69 --
  70 -- The memory may be deallocated using 'free' or 'finalizerFree' when
  71 -- no longer required.
  72 --
  73 {-# INLINE malloc #-}
  74 malloc :: Storable a => IO (Ptr a)
  75 malloc  = doMalloc undefined
  76   where
  77     doMalloc       :: Storable b => b -> IO (Ptr b)
  78     doMalloc dummy  = mallocBytes (sizeOf dummy)
  79
  80 -- |Allocate a block of memory of the given number of bytes.
  81 -- The block of memory is sufficiently aligned for any of the basic
  82 -- foreign types that fits into a memory block of the allocated size.
  83 --
  84 -- The memory may be deallocated using 'free' or 'finalizerFree' when
  85 -- no longer required.
  86 --
  87 mallocBytes      :: Int -> IO (Ptr a)
  88 mallocBytes size  = failWhenNULL "malloc" (_malloc (fromIntegral size))
  89
  90 -- |@'alloca' f@ executes the computation @f@, passing as argument
  91 -- a pointer to a temporarily allocated block of memory sufficient to
  92 -- hold values of type @a@.
  93 --
  94 -- The memory is freed when @f@ terminates (either normally or via an
  95 -- exception), so the pointer passed to @f@ must /not/ be used after this.
  96 --
  97 {-# INLINE alloca #-}
  98 alloca :: Storable a => (Ptr a -> IO b) -> IO b
  99 alloca  = doAlloca undefined
 100   where
 101     doAlloca       :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b'
 102     doAlloca dummy  = allocaBytesAligned (sizeOf dummy) (alignment dummy)
 103
 104 -- |@'allocaBytes' n f@ executes the computation @f@, passing as argument
 105 -- a pointer to a temporarily allocated block of memory of @n@ bytes.
 106 -- The block of memory is sufficiently aligned for any of the basic
 107 -- foreign types that fits into a memory block of the allocated size.
 108 --
 109 -- The memory is freed when @f@ terminates (either normally or via an
 110 -- exception), so the pointer passed to @f@ must /not/ be used after this.
 111 --
 112 #ifdef __GLASGOW_HASKELL__
 113 allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
 114 allocaBytes (I# size) action = IO $ \ s0 ->
 115      case newPinnedByteArray# size s0      of { (# s1, mbarr# #) ->
 116      case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr#  #) ->
 117      let addr = Ptr (byteArrayContents# barr#) in
 118      case action addr     of { IO action' ->
 119      case action' s2      of { (# s3, r #) ->
 120      case touch# barr# s3 of { s4 ->
 121      (# s4, r #)
 122   }}}}}
 123
 124 allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
 125 allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->
 126      case newAlignedPinnedByteArray# size align s0 of { (# s1, mbarr# #) ->
 127      case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr#  #) ->
 128      let addr = Ptr (byteArrayContents# barr#) in
 129      case action addr     of { IO action' ->
 130      case action' s2      of { (# s3, r #) ->
 131      case touch# barr# s3 of { s4 ->
 132      (# s4, r #)
 133   }}}}}
 134 #else
 135 allocaBytes      :: Int -> (Ptr a -> IO b) -> IO b
 136 allocaBytes size  = bracket (mallocBytes size) free
 137
 138 allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
 139 allocaBytesAligned size align = allocaBytes size -- wrong
 140 #endif
 141
 142 -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
 143 -- to the size needed to store values of type @b@.  The returned pointer
 144 -- may refer to an entirely different memory area, but will be suitably
 145 -- aligned to hold values of type @b@.  The contents of the referenced
 146 -- memory area will be the same as of the original pointer up to the
 147 -- minimum of the original size and the size of values of type @b@.
 148 --
 149 -- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like
 150 -- 'malloc'.
 151 --
 152 realloc :: Storable b => Ptr a -> IO (Ptr b)
 153 realloc  = doRealloc undefined
 154   where
 155     doRealloc           :: Storable b' => b' -> Ptr a' -> IO (Ptr b')
 156     doRealloc dummy ptr  = let
 157                              size = fromIntegral (sizeOf dummy)
 158                            in
 159                            failWhenNULL "realloc" (_realloc ptr size)
 160
 161 -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
 162 -- to the given size.  The returned pointer may refer to an entirely
 163 -- different memory area, but will be sufficiently aligned for any of the
 164 -- basic foreign types that fits into a memory block of the given size.
 165 -- The contents of the referenced memory area will be the same as of
 166 -- the original pointer up to the minimum of the original size and the
 167 -- given size.
 168 --
 169 -- If the pointer argument to 'reallocBytes' is 'nullPtr', 'reallocBytes'
 170 -- behaves like 'malloc'.  If the requested size is 0, 'reallocBytes'
 171 -- behaves like 'free'.
 172 --
 173 reallocBytes          :: Ptr a -> Int -> IO (Ptr a)
 174 reallocBytes ptr 0     = do free ptr; return nullPtr
 175 reallocBytes ptr size  =
 176   failWhenNULL "realloc" (_realloc ptr (fromIntegral size))
 177
 178 -- |Free a block of memory that was allocated with 'malloc',
 179 -- 'mallocBytes', 'realloc', 'reallocBytes', 'Foreign.Marshal.Utils.new'
 180 -- or any of the @new@/X/ functions in "Foreign.Marshal.Array" or
 181 -- "Foreign.C.String".
 182 --
 183 free :: Ptr a -> IO ()
 184 free  = _free
 185
 186
 187 -- auxilliary routines
 188 -- -------------------
 189
 190 -- asserts that the pointer returned from the action in the second argument is
 191 -- non-null
 192 --
 193 failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
 194 failWhenNULL name f = do
 195    addr <- f
 196    if addr == nullPtr
 197 #if __GLASGOW_HASKELL__
 198       then ioError (IOError Nothing ResourceExhausted name
 199                                         "out of memory" Nothing Nothing)
 200 #elif __HUGS__
 201       then ioError (IOError Nothing ResourceExhausted name
 202                                         "out of memory" Nothing)
 203 #else
 204       then ioError (userError (name++": out of memory"))
 205 #endif
 206       else return addr
 207
 208 -- basic C routines needed for memory allocation
 209 --
 210 foreign import ccall unsafe "stdlib.h malloc"  _malloc  ::          CSize -> IO (Ptr a)
 211 foreign import ccall unsafe "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b)
 212 foreign import ccall unsafe "stdlib.h free"    _free    :: Ptr a -> IO ()
 213
 214 -- | A pointer to a foreign function equivalent to 'free', which may be
 215 -- used as a finalizer (cf 'Foreign.ForeignPtr.ForeignPtr') for storage
 216 -- allocated with 'malloc', 'mallocBytes', 'realloc' or 'reallocBytes'.
 217 foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FinalizerPtr a