{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples,
ScopedTypeVariables, BangPatterns #-}
module Foreign.Marshal.Alloc (
alloca,
allocaBytes,
allocaBytesAligned,
malloc,
mallocBytes,
calloc,
callocBytes,
realloc,
reallocBytes,
free,
finalizerFree
) where
import Data.Bits ( Bits, (.&.) )
import Data.Maybe
import Foreign.C.Types ( CSize(..) )
import Foreign.Storable ( Storable(sizeOf,alignment) )
import Foreign.ForeignPtr ( FinalizerPtr )
import GHC.IO.Exception
import GHC.Num
import GHC.Real
import GHC.Show
import GHC.Ptr
import GHC.Base
{-# INLINE malloc #-}
malloc :: forall a . Storable a => IO (Ptr a)
malloc :: forall a. Storable a => IO (Ptr a)
malloc = forall a. Int -> IO (Ptr a)
mallocBytes (forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: a))
{-# INLINE calloc #-}
calloc :: forall a . Storable a => IO (Ptr a)
calloc :: forall a. Storable a => IO (Ptr a)
calloc = forall a. Int -> IO (Ptr a)
callocBytes (forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: a))
mallocBytes :: Int -> IO (Ptr a)
mallocBytes :: forall a. Int -> IO (Ptr a)
mallocBytes Int
size = forall a. String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL String
"malloc" (forall a. CSize -> IO (Ptr a)
_malloc (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size))
callocBytes :: Int -> IO (Ptr a)
callocBytes :: forall a. Int -> IO (Ptr a)
callocBytes Int
size = forall a. String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL String
"calloc" forall a b. (a -> b) -> a -> b
$ forall a. CSize -> CSize -> IO (Ptr a)
_calloc CSize
1 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)
{-# INLINE alloca #-}
alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b
alloca :: forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca =
forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned (forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: a)) (forall a. Storable a => a -> Int
alignment (forall a. HasCallStack => a
undefined :: a))
allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
allocaBytes :: forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (I# Int#
size) Ptr a -> IO b
action = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s0 ->
case forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newPinnedByteArray# Int#
size State# RealWorld
s0 of { (# State# RealWorld
s1, MutableByteArray# RealWorld
mbarr# #) ->
case forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mbarr# State# RealWorld
s1 of { (# State# RealWorld
s2, ByteArray#
barr# #) ->
let addr :: Ptr a
addr = forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
barr#) in
case Ptr a -> IO b
action forall {a}. Ptr a
addr of { IO State# RealWorld -> (# State# RealWorld, b #)
action' ->
keepAlive# :: forall a b. a -> State# RealWorld -> (State# RealWorld -> b) -> b
keepAlive# ByteArray#
barr# State# RealWorld
s2 State# RealWorld -> (# State# RealWorld, b #)
action'
}}}
allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned :: forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned !Int
_size !Int
align !Ptr a -> IO b
_action
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall i. (Bits i, Integral i) => i -> Bool
isPowerOfTwo Int
align =
forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$
Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError forall a. Maybe a
Nothing IOErrorType
InvalidArgument
String
"allocaBytesAligned"
(String
"alignment (="forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
alignforall a. [a] -> [a] -> [a]
++String
") must be a power of two!")
forall a. Maybe a
Nothing forall a. Maybe a
Nothing
where
isPowerOfTwo :: (Bits i, Integral i) => i -> Bool
isPowerOfTwo :: forall i. (Bits i, Integral i) => i -> Bool
isPowerOfTwo i
x = i
x forall a. Bits a => a -> a -> a
.&. (i
xforall a. Num a => a -> a -> a
-i
1) forall a. Eq a => a -> a -> Bool
== i
0
allocaBytesAligned !Int
size !Int
align !Ptr a -> IO b
action =
forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAlignedAndUnchecked Int
size Int
align Ptr a -> IO b
action
{-# INLINABLE allocaBytesAligned #-}
allocaBytesAlignedAndUnchecked :: Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAlignedAndUnchecked :: forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAlignedAndUnchecked (I# Int#
size) (I# Int#
align) Ptr a -> IO b
action = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s0 ->
case forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
size Int#
align State# RealWorld
s0 of { (# State# RealWorld
s1, MutableByteArray# RealWorld
mbarr# #) ->
case forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mbarr# State# RealWorld
s1 of { (# State# RealWorld
s2, ByteArray#
barr# #) ->
let addr :: Ptr a
addr = forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
barr#) in
case Ptr a -> IO b
action forall {a}. Ptr a
addr of { IO State# RealWorld -> (# State# RealWorld, b #)
action' ->
keepAlive# :: forall a b. a -> State# RealWorld -> (State# RealWorld -> b) -> b
keepAlive# ByteArray#
barr# State# RealWorld
s2 State# RealWorld -> (# State# RealWorld, b #)
action'
}}}
realloc :: forall a b . Storable b => Ptr a -> IO (Ptr b)
realloc :: forall a b. Storable b => Ptr a -> IO (Ptr b)
realloc Ptr a
ptr = forall a. String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL String
"realloc" (forall a b. Ptr a -> CSize -> IO (Ptr b)
_realloc Ptr a
ptr CSize
size)
where
size :: CSize
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: b))
reallocBytes :: Ptr a -> Int -> IO (Ptr a)
reallocBytes :: forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes Ptr a
ptr Int
0 = do forall a. Ptr a -> IO ()
free Ptr a
ptr; forall (m :: * -> *) a. Monad m => a -> m a
return forall {a}. Ptr a
nullPtr
reallocBytes Ptr a
ptr Int
size =
forall a. String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL String
"realloc" (forall a b. Ptr a -> CSize -> IO (Ptr b)
_realloc Ptr a
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size))
free :: Ptr a -> IO ()
free :: forall a. Ptr a -> IO ()
free = forall a. Ptr a -> IO ()
_free
failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL :: forall a. String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL String
name IO (Ptr a)
f = do
Ptr a
addr <- IO (Ptr a)
f
if Ptr a
addr forall a. Eq a => a -> a -> Bool
== forall {a}. Ptr a
nullPtr
then forall a. IOError -> IO a
ioError (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError forall a. Maybe a
Nothing IOErrorType
ResourceExhausted String
name
String
"out of memory" forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
else forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
addr
foreign import ccall unsafe "stdlib.h malloc" _malloc :: CSize -> IO (Ptr a)
foreign import ccall unsafe "stdlib.h calloc" _calloc :: CSize -> 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 ()
foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FinalizerPtr a