X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Foreign%2FMarshal%2FAlloc.hs;h=eb4b04b5da3ee9f2b62ff6970b3acfc1236c20a0;hb=9fa9bc17072a58c0bae2cce4764d38677e96ac29;hp=ed16c0167def9284f8a544d6f22ecdec184b9d9f;hpb=7f1f4e7a695c402ddd3a1dc2cc7114e649a78ebc;p=ghc-base.git

diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs
index ed16c01..eb4b04b 100644
--- a/Foreign/Marshal/Alloc.hs
+++ b/Foreign/Marshal/Alloc.hs
@@ -1,15 +1,15 @@
 {-# OPTIONS -fno-implicit-prelude #-}
 -----------------------------------------------------------------------------
--- 
+-- |
 -- Module      :  Foreign.Marshal.Alloc
 -- Copyright   :  (c) The FFI task force 2001
 -- License     :  BSD-style (see the file libraries/core/LICENSE)
 -- 
 -- Maintainer  :  ffi@haskell.org
--- Stability   :  experimental
--- Portability :  non-portable
+-- Stability   :  provisional
+-- Portability :  portable
 --
--- $Id: Alloc.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+-- $Id: Alloc.hs,v 1.6 2002/04/24 16:31:44 simonmar Exp $
 --
 -- Marshalling support: basic routines for memory allocation
 --
@@ -30,12 +30,13 @@ module Foreign.Marshal.Alloc (
 import Data.Maybe
 import Foreign.Ptr	 	( Ptr, nullPtr )
 import Foreign.C.TypesISO 	( CSize )
+import Foreign.Storable  	( Storable(sizeOf) )
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.Exception 	( bracket )
-import GHC.Storable  	( Storable(sizeOf) )
+import GHC.Exception		( bracket )
 import GHC.IOBase
 import GHC.Real
+import GHC.Ptr
 import GHC.Err
 import GHC.Base
 #endif
@@ -75,8 +76,21 @@ alloca  = doAlloca undefined
 --   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
 --
@@ -110,6 +124,6 @@ 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 "malloc"  _malloc  ::          CSize -> IO (Ptr a)
+foreign import ccall unsafe "realloc" _realloc :: Ptr a -> CSize -> IO (Ptr a)
+foreign import ccall unsafe "free"    _free    :: Ptr a -> IO ()