Builder.hs

----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.Ptr.Builder
-- Copyright   :  (c) Sergey Vinokurov 2022
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
----------------------------------------------------------------------------

{-# LANGUAGE MagicHash        #-}
{-# LANGUAGE UnboxedTuples    #-}
{-# LANGUAGE UnliftedNewtypes #-}

module Foreign.Ptr.Builder
  ( Builder
  , withByteArrayLen
  , withPtrLen
  , storable
  , prim
  , Int#
  , ByteArray#

  , BuilderCache
  , coerceBuilderCache
  , withBuilderCache
  ) where

import Data.Primitive.Types as Prim
import Emacs.Module.Assert
import Foreign
import Foreign.Storable as Storable
import GHC.Exts
import GHC.IO

type Writer = Addr# -> Int# -> IO ()

data Builder a = Builder Int# Writer

instance Show (Builder a) where
  showsPrec n (Builder k _) = showParen (n >= 10) (showString "Builder " . showsPrec 11 (I# k))

instance Semigroup (Builder a) where
  {-# INLINE (<>) #-}
  Builder n f <> Builder m g =
    Builder (n +# m) (\ptr off -> f ptr off *> g ptr (off +# n))

instance Monoid (Builder a) where
  {-# INLINE mempty #-}
  mempty = Builder 0# (\_ _ -> pure ())

isPowerOfTwo :: Int# -> Bool
isPowerOfTwo x = isTrue# (and# x' y' `eqWord#` 0##)
  where
    x' = int2Word# x
    y' = int2Word# (x -# 1#)

{-# INLINE withByteArrayLen #-}
withByteArrayLen
  :: forall a b. (WithCallStack, Storable a)
  => BuilderCache a
  -> Builder a
  -> (Int# -> ByteArray# -> IO b)
  -> IO b
withByteArrayLen (BuilderCache cache#) (Builder size f) action =
  emacsAssert (isPowerOfTwo align) "Alignment should be a power of two" $
  IO $ \s0 ->
    case getSizeofMutableByteArray# cache# s0 of
      (# s1, cacheSize #) ->
        let !(# sLast1, barr# #) =
              if isTrue# (cacheSize >=# requiredSize)
              then
                case unIO (f (mutableByteArrayContents# cache#) 0#) s1 of
                  (# s2, () #) ->
                    unsafeFreezeByteArray# cache# s2
              else
                case newAlignedPinnedByteArray# requiredSize align s1 of
                  (# s2, mbarr# #) ->
                    case unIO (f (mutableByteArrayContents# mbarr#) 0#) s2 of
                      (# s3, () #) ->
                        unsafeFreezeByteArray# mbarr# s3
        in
          -- keepAlive# barr# sLast1 (unIO (action size barr#))
          -- Touch is measurably faster but unsound if the action diverges.
          case unIO (action size barr#) sLast1 of
            (# sLast2, res #) ->
              case touch# barr# sLast2 of
                sLast3 -> (# sLast3, res #)
  where
    !requiredSize  = size *# elemSize
    !(I# elemSize) = Storable.sizeOf    (undefined :: a)
    !(I# align)    = Storable.alignment (undefined :: a)

{-# INLINE withPtrLen #-}
withPtrLen
  :: forall a b. (WithCallStack, Storable a)
  => BuilderCache a -> Builder a -> (Int -> Ptr a -> IO b) -> IO b
withPtrLen cache b action =
  withByteArrayLen cache b $ \size barr ->
    action (I# size) (Ptr (byteArrayContents# barr))


{-# INLINE storable #-}
storable :: Storable a => a -> Builder a
storable x = Builder 1# $ \addr off -> pokeElemOff (Ptr addr) (I# off) x

{-# INLINE prim #-}
prim :: Prim a => a -> Builder a
prim x = Builder 1# $ \addr off ->
  IO $ \s ->
    case Prim.writeOffAddr# addr off x s of
      s' -> (# s', () #)

newtype BuilderCache a = BuilderCache { _unBuilderCache :: MutableByteArray# RealWorld }

coerceBuilderCache :: BuilderCache a -> BuilderCache b
coerceBuilderCache = coerce

withBuilderCache :: forall a b. Storable a => Int -> (BuilderCache a -> IO b) -> IO b
withBuilderCache (I# size) f = do
  IO $ \s0 ->
    case newAlignedPinnedByteArray# (size *# elemSize) align s0 of
      (# s1, mbarr #) ->
        keepAlive# mbarr s1 (unIO (f (BuilderCache mbarr)))
  where
    !(I# elemSize) = Storable.sizeOf    (undefined :: a)
    !(I# align)    = Storable.alignment (undefined :: a)