{-# OPTIONS_JHC -fno-prelude -fffi #-}
module Foreign.Marshal.Alloc (
  -- * Memory allocation
  -- ** Local allocation
  alloca,       -- :: Storable a =>        (Ptr a -> IO b) -> IO b
  allocaBytes,  -- ::               Int -> (Ptr a -> IO b) -> IO b

  -- ** Dynamic allocation
  malloc,       -- :: Storable a =>        IO (Ptr a)
  mallocBytes,  -- ::               Int -> IO (Ptr a)

  realloc,      -- :: Storable b => Ptr a        -> IO (Ptr b)
  reallocBytes, -- ::		    Ptr a -> Int -> IO (Ptr a)

  free,         -- :: Ptr a -> IO ()
  finalizerFree -- :: FinalizerPtr a
) where

import Foreign.C.Types
import Foreign.Storable
import Jhc.Addr
import Jhc.Basics
import Jhc.IO
import Jhc.Int(unboxInt)
import Jhc.Monad
import Jhc.Num
import Jhc.Order
import qualified Jhc.Options as JO

-- TODO handle exceptions
allocaBytes' :: Int -> (Ptr a -> IO b) -> IO b
allocaBytes' b f = do
    p <- mallocBytes b
    r <- f p
    free p
    return r

allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
allocaBytes num fn = etaIO $ case JO.target of
    JO.GhcHs -> case unboxInt num of n -> alloca__ n (\addr -> fn (boxAddr addr))
    _ -> allocaBytes' num fn

foreign import primitive alloca__ :: Int__ -> (Addr__ -> IO b) -> IO b
foreign import primitive "box" boxAddr :: Addr__ -> Ptr a

-- 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.
--
malloc :: Storable a => IO (Ptr a)
malloc  = doMalloc undefined
doMalloc       :: Storable b => b -> IO (Ptr b)
doMalloc dummy  = mallocBytes (sizeOf dummy)

-- |@'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.
--
alloca :: Storable a => (Ptr a -> IO b) -> IO b
alloca fn  = etaIO $ doAlloca undefined fn where
    doAlloca       :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b'
    doAlloca dummy fn = allocaBytes (sizeOf dummy) fn

{-# INLINE failWhenNULL #-}
failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL name f = do
   addr <- f
   failWhenNULL' name addr

failWhenNULL' :: String -> Ptr a -> IO (Ptr a)
failWhenNULL' name addr = do
   if addr == nullPtr
      then ioError (userError (name++": out of memory"))
      else return addr

-- |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 size  = _malloc (fromIntegral size) >>= failWhenNULL' "malloc"

-- |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 :: Storable b => Ptr a -> IO (Ptr b)
realloc  = doRealloc undefined
doRealloc           :: Storable b' => b' -> Ptr a' -> IO (Ptr b')
doRealloc dummy ptr  = let
                         size = fromIntegral (sizeOf dummy)
                       in
                       (_realloc ptr size) >>= failWhenNULL' "realloc"

-- |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 i | ptr `seq` i `seq` False = undefined
reallocBytes ptr 0     = do free ptr; return nullPtr
reallocBytes ptr size  =
  _realloc ptr (fromIntegral size) >>= failWhenNULL' "realloc"

foreign import ccall "stdlib.h malloc" _malloc :: CSize -> IO (Ptr a)
foreign import ccall "stdlib.h free" free :: Ptr a -> IO ()
foreign import ccall "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b)

-- | 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 :: FunPtr (Ptr a -> IO ())