ghc/lib/std/PrelMarshalAlloc.lhs

   1 % -----------------------------------------------------------------------------
   2 % $Id: PrelMarshalAlloc.lhs,v 1.3 2001/08/08 14:36:14 simonmar Exp $
   3 %
   4 % (c) The FFI task force, 2000
   5 %
   6
   7 Marshalling support: basic routines for memory allocation
   8
   9 \begin{code}
  10 {-# OPTIONS -fno-implicit-prelude #-}
  11
  12 module PrelMarshalAlloc (
  13   malloc,       -- :: Storable a =>        IO (Ptr a)
  14   mallocBytes,  -- ::               Int -> IO (Ptr a)
  15
  16   alloca,       -- :: Storable a =>        (Ptr a -> IO b) -> IO b
  17   allocaBytes,  -- ::               Int -> (Ptr a -> IO b) -> IO b
  18
  19   reallocBytes, -- :: Ptr a -> Int -> IO (Ptr a)
  20
  21   free          -- :: Ptr a -> IO ()
  22 ) where
  23
  24 #ifdef __GLASGOW_HASKELL__
  25 import PrelException    ( bracket )
  26 import PrelPtr          ( Ptr(..), nullPtr )
  27 import PrelStorable     ( Storable(sizeOf) )
  28 import PrelCTypesISO    ( CSize )
  29 import PrelIOBase
  30 import PrelMaybe
  31 import PrelReal
  32 import PrelNum
  33 import PrelErr
  34 import PrelBase
  35 #endif
  36
  37
  38 -- exported functions
  39 -- ------------------
  40
  41 -- allocate space for storable type
  42 --
  43 malloc :: Storable a => IO (Ptr a)
  44 malloc  = doMalloc undefined
  45   where
  46     doMalloc       :: Storable a => a -> IO (Ptr a)
  47     doMalloc dummy  = mallocBytes (sizeOf dummy)
  48
  49 -- allocate given number of bytes of storage
  50 --
  51 mallocBytes      :: Int -> IO (Ptr a)
  52 mallocBytes size  = failWhenNULL "malloc" (_malloc (fromIntegral size))
  53
  54 -- temporarily allocate space for a storable type
  55 --
  56 -- * the pointer passed as an argument to the function must *not* escape from
  57 --   this function; in other words, in `alloca f' the allocated storage must
  58 --   not be used after `f' returns
  59 --
  60 alloca :: Storable a => (Ptr a -> IO b) -> IO b
  61 alloca  = doAlloca undefined
  62   where
  63     doAlloca       :: Storable a => a -> (Ptr a -> IO b) -> IO b
  64     doAlloca dummy  = allocaBytes (sizeOf dummy)
  65
  66 -- temporarily allocate the given number of bytes of storage
  67 --
  68 -- * the pointer passed as an argument to the function must *not* escape from
  69 --   this function; in other words, in `allocaBytes n f' the allocated storage
  70 --   must not be used after `f' returns
  71 --
  72 #ifdef __GLASGOW_HASKELL__
  73 allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
  74 allocaBytes (I# size) action = IO $ \ s ->
  75      case newPinnedByteArray# size s      of { (# s, mbarr# #) ->
  76      case unsafeFreezeByteArray# mbarr# s of { (# s, barr#  #) ->
  77      let addr = Ptr (byteArrayContents# barr#) in
  78      case action addr    of { IO action ->
  79      case action s       of { (# s, r #) ->
  80      case touch# barr# s of { s ->
  81      (# s, r #)
  82   }}}}}
  83 #else
  84 allocaBytes      :: Int -> (Ptr a -> IO b) -> IO b
  85 allocaBytes size  = bracket (mallocBytes size) free
  86 #endif
  87
  88 -- adjust a malloc'ed storage area to the given size
  89 --
  90 reallocBytes          :: Ptr a -> Int -> IO (Ptr a)
  91 reallocBytes ptr size  =
  92   failWhenNULL "realloc" (_realloc ptr (fromIntegral size))
  93
  94 -- free malloc'ed storage
  95 --
  96 free :: Ptr a -> IO ()
  97 free  = _free
  98
  99
 100 -- auxilliary routines
 101 -- -------------------
 102
 103 -- asserts that the pointer returned from the action in the second argument is
 104 -- non-null
 105 --
 106 failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
 107 failWhenNULL name f = do
 108    addr <- f
 109    if addr == nullPtr
 110 #ifdef __GLASGOW_HASKELL__
 111       then ioException (IOError Nothing ResourceExhausted name
 112                                         "out of memory" Nothing)
 113 #else
 114       then ioError (userError (name++": out of memory"))
 115 #endif
 116       else return addr
 117
 118 -- basic C routines needed for memory allocation
 119 --
 120 foreign import "malloc"  unsafe _malloc  ::          CSize -> IO (Ptr a)
 121 foreign import "realloc" unsafe _realloc :: Ptr a -> CSize -> IO (Ptr a)
 122 foreign import "free"    unsafe _free    :: Ptr a -> IO ()
 123
 124 \end{code}