{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples,
             ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.Marshal.Alloc
-- Copyright   :  (c) The FFI task force 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- The module "Foreign.Marshal.Alloc" provides operations to allocate and
-- deallocate blocks of raw memory (i.e., unstructured chunks of memory
-- outside of the area maintained by the Haskell storage manager).  These
-- memory blocks are commonly used to pass compound data structures to
-- foreign functions or to provide space in which compound result values
-- are obtained from foreign functions.
-- 
-- If any of the allocation functions fails, an exception is thrown.
-- In some cases, memory exhaustion may mean the process is terminated.
-- If 'free' or 'reallocBytes' is applied to a memory area
-- that has been allocated with 'alloca' or 'allocaBytes', the
-- behaviour is undefined.  Any further access to memory areas allocated with
-- 'alloca' or 'allocaBytes', after the computation that was passed to
-- the allocation function has terminated, leads to undefined behaviour.  Any
-- further access to the memory area referenced by a pointer passed to
-- 'realloc', 'reallocBytes', or 'free' entails undefined
-- behaviour.
-- 
-- All storage allocated by functions that allocate based on a /size in bytes/
-- must be sufficiently aligned for any of the basic foreign types
-- that fits into the newly allocated storage. All storage allocated by
-- functions that allocate based on a specific type must be sufficiently
-- aligned for that type. Array allocation routines need to obey the same
-- alignment constraints for each array element.
--
-----------------------------------------------------------------------------

module Foreign.Marshal.Alloc (
  -- * Memory allocation
  -- ** Local allocation
  alloca,
  allocaBytes,
  allocaBytesAligned,

  -- ** Dynamic allocation
  malloc,
  mallocBytes,

  calloc,
  callocBytes,

  realloc,
  reallocBytes,

  free,
  finalizerFree
) where

import Data.Maybe
import Foreign.C.Types          ( CSize(..) )
import Foreign.Storable         ( Storable(sizeOf,alignment) )
import Foreign.ForeignPtr       ( FinalizerPtr )
import GHC.IO.Exception
import GHC.Real
import GHC.Ptr
import GHC.Base

-- exported functions
-- ------------------

-- |Allocate a block of memory that is sufficient to hold values of type
-- @a@.  The size of the area allocated is determined by the 'sizeOf'
-- method from the instance of 'Storable' for the appropriate type.
--
-- The memory may be deallocated using 'free' or 'finalizerFree' when
-- no longer required.
--
{-# INLINE malloc #-}
malloc :: forall a . Storable a => IO (Ptr a)
malloc :: IO (Ptr a)
malloc  = Int -> IO (Ptr a)
forall a. Int -> IO (Ptr a)
mallocBytes (a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a))

-- |Like 'malloc' but memory is filled with bytes of value zero.
--
{-# INLINE calloc #-}
calloc :: forall a . Storable a => IO (Ptr a)
calloc :: IO (Ptr a)
calloc = Int -> IO (Ptr a)
forall a. Int -> IO (Ptr a)
callocBytes (a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a))

-- |Allocate a block of memory of the given number of bytes.
-- The block of memory is sufficiently aligned for any of the basic
-- foreign types that fits into a memory block of the allocated size.
--
-- The memory may be deallocated using 'free' or 'finalizerFree' when
-- no longer required.
--
mallocBytes      :: Int -> IO (Ptr a)
mallocBytes :: Int -> IO (Ptr a)
mallocBytes size :: Int
size  = String -> IO (Ptr a) -> IO (Ptr a)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL "malloc" (CSize -> IO (Ptr a)
forall a. CSize -> IO (Ptr a)
_malloc (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size))

-- |Llike 'mallocBytes' but memory is filled with bytes of value zero.
--
callocBytes :: Int -> IO (Ptr a)
callocBytes :: Int -> IO (Ptr a)
callocBytes size :: Int
size = String -> IO (Ptr a) -> IO (Ptr a)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL "calloc" (IO (Ptr a) -> IO (Ptr a)) -> IO (Ptr a) -> IO (Ptr a)
forall a b. (a -> b) -> a -> b
$ CSize -> CSize -> IO (Ptr a)
forall a. CSize -> CSize -> IO (Ptr a)
_calloc 1 (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)

-- |@'alloca' f@ executes the computation @f@, passing as argument
-- a pointer to a temporarily allocated block of memory sufficient to
-- hold values of type @a@.
--
-- The memory is freed when @f@ terminates (either normally or via an
-- exception), so the pointer passed to @f@ must /not/ be used after this.
--
{-# INLINE alloca #-}
alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b
alloca :: (Ptr a -> IO b) -> IO b
alloca  =
  Int -> Int -> (Ptr a -> IO b) -> IO b
forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned (a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)) (a -> Int
forall a. Storable a => a -> Int
alignment (a
forall a. HasCallStack => a
undefined :: a))

-- Note [NOINLINE for touch#]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Both allocaBytes and allocaBytesAligned use the touch#, which is notoriously
-- fragile in the presence of simplification (see #14346). In particular, the
-- simplifier may drop the continuation containing the touch# if it can prove
-- that the action passed to allocaBytes will not return. The hack introduced to
-- fix this for 8.2.2 is to mark allocaBytes as NOINLINE, ensuring that the
-- simplifier can't see the divergence.
--
-- These can be removed once #14375 is fixed, which suggests that we instead do
-- away with touch# in favor of a primitive that will capture the scoping left
-- implicit in the case of touch#.

-- |@'allocaBytes' n f@ executes the computation @f@, passing as argument
-- a pointer to a temporarily allocated block of memory of @n@ bytes.
-- The block of memory is sufficiently aligned for any of the basic
-- foreign types that fits into a memory block of the allocated size.
--
-- The memory is freed when @f@ terminates (either normally or via an
-- exception), so the pointer passed to @f@ must /not/ be used after this.
--
allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
allocaBytes (I# size :: Int#
size) action :: Ptr a -> IO b
action = (State# RealWorld -> (# State# RealWorld, b #)) -> IO b
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, b #)) -> IO b)
-> (State# RealWorld -> (# State# RealWorld, b #)) -> IO b
forall a b. (a -> b) -> a -> b
$ \ s0 :: State# RealWorld
s0 ->
     case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newPinnedByteArray# Int#
size State# RealWorld
s0      of { (# s1 :: State# RealWorld
s1, mbarr# :: MutableByteArray# RealWorld
mbarr# #) ->
     case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mbarr# State# RealWorld
s1 of { (# s2 :: State# RealWorld
s2, barr# :: ByteArray#
barr#  #) ->
     let addr :: Ptr a
addr = Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
barr#) in
     case Ptr a -> IO b
action Ptr a
forall a. Ptr a
addr     of { IO action' :: State# RealWorld -> (# State# RealWorld, b #)
action' ->
     case State# RealWorld -> (# State# RealWorld, b #)
action' State# RealWorld
s2      of { (# s3 :: State# RealWorld
s3, r :: b
r #) ->
     case ByteArray# -> State# RealWorld -> State# RealWorld
forall a. a -> State# RealWorld -> State# RealWorld
touch# ByteArray#
barr# State# RealWorld
s3 of { s4 :: State# RealWorld
s4 ->
     (# State# RealWorld
s4, b
r #)
  }}}}}
-- See Note [NOINLINE for touch#]
{-# NOINLINE allocaBytes #-}

allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned (I# size :: Int#
size) (I# align :: Int#
align) action :: Ptr a -> IO b
action = (State# RealWorld -> (# State# RealWorld, b #)) -> IO b
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, b #)) -> IO b)
-> (State# RealWorld -> (# State# RealWorld, b #)) -> IO b
forall a b. (a -> b) -> a -> b
$ \ s0 :: State# RealWorld
s0 ->
     case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
size Int#
align State# RealWorld
s0 of { (# s1 :: State# RealWorld
s1, mbarr# :: MutableByteArray# RealWorld
mbarr# #) ->
     case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mbarr# State# RealWorld
s1 of { (# s2 :: State# RealWorld
s2, barr# :: ByteArray#
barr#  #) ->
     let addr :: Ptr a
addr = Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
barr#) in
     case Ptr a -> IO b
action Ptr a
forall a. Ptr a
addr     of { IO action' :: State# RealWorld -> (# State# RealWorld, b #)
action' ->
     case State# RealWorld -> (# State# RealWorld, b #)
action' State# RealWorld
s2      of { (# s3 :: State# RealWorld
s3, r :: b
r #) ->
     case ByteArray# -> State# RealWorld -> State# RealWorld
forall a. a -> State# RealWorld -> State# RealWorld
touch# ByteArray#
barr# State# RealWorld
s3 of { s4 :: State# RealWorld
s4 ->
     (# State# RealWorld
s4, b
r #)
  }}}}}
-- See Note [NOINLINE for touch#]
{-# NOINLINE allocaBytesAligned #-}

-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
-- to the size needed to store values of type @b@.  The returned pointer
-- may refer to an entirely different memory area, but will be suitably
-- aligned to hold values of type @b@.  The contents of the referenced
-- memory area will be the same as of the original pointer up to the
-- minimum of the original size and the size of values of type @b@.
--
-- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like
-- 'malloc'.
--
realloc :: forall a b . Storable b => Ptr a -> IO (Ptr b)
realloc :: Ptr a -> IO (Ptr b)
realloc ptr :: Ptr a
ptr = String -> IO (Ptr b) -> IO (Ptr b)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL "realloc" (Ptr a -> CSize -> IO (Ptr b)
forall a b. Ptr a -> CSize -> IO (Ptr b)
_realloc Ptr a
ptr CSize
size)
  where
    size :: CSize
size = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (b -> Int
forall a. Storable a => a -> Int
sizeOf (b
forall a. HasCallStack => a
undefined :: b))

-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
-- to the given size.  The returned pointer may refer to an entirely
-- different memory area, but will be sufficiently aligned for any of the
-- basic foreign types that fits into a memory block of the given size.
-- The contents of the referenced memory area will be the same as of
-- the original pointer up to the minimum of the original size and the
-- given size.
--
-- If the pointer argument to 'reallocBytes' is 'nullPtr', 'reallocBytes'
-- behaves like 'malloc'.  If the requested size is 0, 'reallocBytes'
-- behaves like 'free'.
--
reallocBytes          :: Ptr a -> Int -> IO (Ptr a)
reallocBytes :: Ptr a -> Int -> IO (Ptr a)
reallocBytes ptr :: Ptr a
ptr 0     = do Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
ptr; Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
forall a. Ptr a
nullPtr
reallocBytes ptr :: Ptr a
ptr size :: Int
size  = 
  String -> IO (Ptr a) -> IO (Ptr a)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL "realloc" (Ptr a -> CSize -> IO (Ptr a)
forall a b. Ptr a -> CSize -> IO (Ptr b)
_realloc Ptr a
ptr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size))

-- |Free a block of memory that was allocated with 'malloc',
-- 'mallocBytes', 'realloc', 'reallocBytes', 'Foreign.Marshal.Utils.new'
-- or any of the @new@/X/ functions in "Foreign.Marshal.Array" or
-- "Foreign.C.String".
--
free :: Ptr a -> IO ()
free :: Ptr a -> IO ()
free  = Ptr a -> IO ()
forall a. Ptr a -> IO ()
_free


-- auxiliary routines
-- -------------------

-- asserts that the pointer returned from the action in the second argument is
-- non-null
--
failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL name :: String
name f :: IO (Ptr a)
f = do
   Ptr a
addr <- IO (Ptr a)
f
   if Ptr a
addr Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr
      then IOError -> IO (Ptr a)
forall a. IOError -> IO a
ioError (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
ResourceExhausted String
name 
                                        "out of memory" Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
      else Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
addr

-- basic C routines needed for memory allocation
--
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 ()

-- | A pointer to a foreign function equivalent to 'free', which may be
-- used as a finalizer (cf 'Foreign.ForeignPtr.ForeignPtr') for storage
-- allocated with 'malloc', 'mallocBytes', 'realloc' or 'reallocBytes'.
foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FinalizerPtr a