{-
  Copyright 2020 Awake Networks

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

-- | Implementation details of the "Data.ByteString.Reverse" module.
-- Breaking changes will be more frequent in this module; use with caution.

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

module Proto3.Wire.Reverse.Internal
    ( BuildR (..)
    , BuildRState (..)
    , appendBuildR
    , foldlRVector
    , toBuildR
    , fromBuildR
    , etaBuildR
    , runBuildR
    , SealedState (SealedState, sealedSB, totalSB, stateVarSB, statePtrSB, recycledSB)
    , sealBuffer
    , smallChunkSize
    , readState
    , readSpace
    , writeState
    , writeSpace
    , metaDataSize
    , metaDataAlign
    , withUnused
    , withTotal
    , readTotal
    , withLengthOf
    , withLengthOf#
    , reallocate
    , prependChunk
    , ReverseChunks(..)
    , prependReverseChunks
    , ensure
    , ensure#
    , unsafeConsume
    , floatToWord32
    , doubleToWord64
    ) where

import           Control.Exception             ( bracket )
import           Control.Monad.Trans.State.Strict ( State, runState, state )
import qualified Data.ByteString               as B
import qualified Data.ByteString.Internal      as BI
import qualified Data.ByteString.Builder.Extra as BB
import qualified Data.ByteString.Lazy          as BL
import qualified Data.ByteString.Lazy.Internal as BLI
import           Data.IORef                    ( IORef, newIORef,
                                                 readIORef, writeIORef )
import qualified Data.Primitive                as P
import qualified Data.Vector.Generic           as VG
import           Data.Vector.Generic           ( Vector )
import           Data.Word                     ( Word8, Word32, Word64 )
import           Foreign                       ( Storable(..),
                                                 castPtrToStablePtr,
                                                 castStablePtrToPtr,
                                                 freeStablePtr, newStablePtr,
                                                 deRefStablePtr )
import           GHC.Exts                      ( Addr#, Int#, MutVar#,
                                                 RealWorld, StablePtr#, State#,
                                                 addrToAny#, int2Addr#,
                                                 touch# )
import           GHC.ForeignPtr                ( ForeignPtr(..),
                                                 ForeignPtrContents(..) )
import           GHC.IO                        ( IO(..) )
import           GHC.IORef                     ( IORef(..) )
import           GHC.Int                       ( Int(..) )
import           GHC.Ptr                       ( Ptr(..), plusPtr )
import           GHC.Stable                    ( StablePtr(..) )
import           GHC.STRef                     ( STRef(..) )
import           System.IO.Unsafe              ( unsafePerformIO )

#if MIN_VERSION_primitive(0,7,0)
#define PTR P.Ptr
#else
#define PTR P.Addr
#endif

-- $setup
-- >>> :set -XOverloadedStrings

-- | Writes bytes in reverse order, updating the current state.
--
-- It is the responsibility of the execution context and buffer
-- management primitives to ensure that the current buffer remains
-- reachable during builder execution, though completed buffers
-- may be copied to new storage at any time.  Aside from those
-- primitives, 'BuildR' implementations may ignore that issue.
--
-- When combining `BuildR`s with '<>' we expect the best performance
-- when associating to the left.  For example @'foldl' ('<>') 'mempty'@,
-- though unless your 'foldl' iteration starts from the right there may
-- still be issues.  Consider using `Proto3.Wire.Reverse.vectorBuildR`
-- instead of 'foldMap'.
newtype BuildR = BuildR
  (Addr# -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
    -- ^ Both the builder arguments and the returned values are:
    --
    --   1. The starting address of the *used* portion of the current buffer.
    --
    --   2. The number of *unused* bytes in the current buffer.
    --
    --   3. The state token (which does not consume any machine registers).
    --
    -- It seems we cannot preserve register allocation between the arguments
    -- and the returned components, even by including padding.  If GHC were to
    -- allocate registers right-to-left (instead of the current left-to-right),
    -- and if it made sure to allocate the register that it uses for closure
    -- arguments *last* when allocating return registers, then we would stand
    -- a chance of not having to move the state components between registers.
    -- That way @a -> b -> 'BuildR'@ and 'BuildR' would use the same registers
    -- for state components as each other, and a non-inline return from one
    -- could be used to call the other without moving state components.
    --
    -- But in many cases register movements combine with increments.
    -- Also, we have arranged to put only the most frequently-used state
    -- components into registers, which reduces the costs of both moves
    -- and of save/reload pairs.  For example, our tracking of the total
    -- bytes written involves metadata at the start of the current buffer
    -- rather than an additional state register.

instance Semigroup BuildR
  where
    <> :: BuildR -> BuildR -> BuildR
(<>) = BuildR -> BuildR -> BuildR
appendBuildR
    {-# INLINE (<>) #-}

instance Monoid BuildR
  where
    mempty :: BuildR
mempty = (Addr#
 -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
-> BuildR
BuildR (\Addr#
v Int#
u State# RealWorld
s -> (# Addr#
v, Int#
u, State# RealWorld
s #))
#ifdef ghcjs_HOST_OS
    {-# NOINLINE mempty #-}
#else
    {-# INLINE mempty #-}
#endif

    mappend :: BuildR -> BuildR -> BuildR
mappend = BuildR -> BuildR -> BuildR
forall a. Semigroup a => a -> a -> a
(<>)
    {-# INLINE mappend #-}

instance Show BuildR
  where
    showsPrec :: Int -> BuildR -> ShowS
showsPrec Int
prec BuildR
builder =
        Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
          (String -> ShowS
showString String
"Proto3.Wire.Reverse.lazyByteString " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShowS
forall a. Show a => a -> ShowS
shows ByteString
bytes)
      where
        bytes :: ByteString
bytes = (Int, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (BuildR -> (Int, ByteString)
runBuildR BuildR
builder)

-- | Needed for rewrite rules; normally you would use '<>'.
appendBuildR  :: BuildR -> BuildR -> BuildR
appendBuildR :: BuildR -> BuildR -> BuildR
appendBuildR = \BuildR
b BuildR
c ->
  let BuildR Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
f = BuildR
b
      BuildR Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
g = BuildR
c
  in
    (Addr#
 -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
-> BuildR
BuildR (\Addr#
v0 Int#
u0 State# RealWorld
s0 -> case Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
g Addr#
v0 Int#
u0 State# RealWorld
s0 of (# Addr#
v1, Int#
u1, State# RealWorld
s1 #) -> Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
f Addr#
v1 Int#
u1 State# RealWorld
s1)
{-# INLINE CONLIKE [1] appendBuildR #-}

-- | Like 'foldl' but iterates right-to-left, which
-- is often useful when creating reverse builders.
foldlRVector :: Vector v a => (b -> a -> b) -> b -> v a -> b
foldlRVector :: forall (v :: * -> *) a b.
Vector v a =>
(b -> a -> b) -> b -> v a -> b
foldlRVector b -> a -> b
f = \b
z v a
v -> (a -> b -> b) -> b -> v a -> b
forall (v :: * -> *) a b.
Vector v a =>
(a -> b -> b) -> b -> v a -> b
VG.foldr ((b -> a -> b) -> a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> b
f) b
z (v a -> v a
forall (v :: * -> *) a. Vector v a => v a -> v a
VG.reverse v a
v)
  -- It may look like we create a reversed vector here, but thanks to
  -- the rewrite rules in the vector library the vector is never actually
  -- allocated, and instead we directly stream elements from right to left.
{-# INLINE foldlRVector #-}

toBuildR :: (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
toBuildR :: (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
toBuildR Ptr Word8 -> Int -> IO (Ptr Word8, Int)
f =
  (Addr#
 -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
-> BuildR
BuildR ((Addr#
  -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
 -> BuildR)
-> (Addr#
    -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
-> BuildR
forall a b. (a -> b) -> a -> b
$ \Addr#
v0 Int#
u0 State# RealWorld
s0 ->
    let IO State# RealWorld -> (# State# RealWorld, (Ptr Word8, Int) #)
g = Ptr Word8 -> Int -> IO (Ptr Word8, Int)
f (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
v0) (Int# -> Int
I# Int#
u0) in
    case State# RealWorld -> (# State# RealWorld, (Ptr Word8, Int) #)
g State# RealWorld
s0 of (# State# RealWorld
s1, (Ptr Addr#
v1, I# Int#
u1) #) -> (# Addr#
v1, Int#
u1, State# RealWorld
s1 #)

fromBuildR :: BuildR -> Ptr Word8 -> Int -> IO (Ptr Word8, Int)
fromBuildR :: BuildR -> Ptr Word8 -> Int -> IO (Ptr Word8, Int)
fromBuildR (BuildR Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
f) (Ptr Addr#
v0) (I# Int#
u0) =
  (State# RealWorld -> (# State# RealWorld, (Ptr Word8, Int) #))
-> IO (Ptr Word8, Int)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, (Ptr Word8, Int) #))
 -> IO (Ptr Word8, Int))
-> (State# RealWorld -> (# State# RealWorld, (Ptr Word8, Int) #))
-> IO (Ptr Word8, Int)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 -> case Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
f Addr#
v0 Int#
u0 State# RealWorld
s0 of (# Addr#
v1, Int#
u1, State# RealWorld
s1 #) -> (# State# RealWorld
s1, (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
v1, Int# -> Int
I# Int#
u1) #)

-- | Eta-expands a function that produces a 'BuildR', so that
-- its input is not evaluated until the builder state is presented.
--
-- This odd combinator seems to help performance at times, though
-- it may change behavior on nonterminating values of type @a@.
etaBuildR :: (a -> BuildR) -> a -> BuildR
etaBuildR :: forall a. (a -> BuildR) -> a -> BuildR
etaBuildR a -> BuildR
f a
x = (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
toBuildR ((Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR)
-> (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
v Int
u -> BuildR -> Ptr Word8 -> Int -> IO (Ptr Word8, Int)
fromBuildR (a -> BuildR
f a
x) Ptr Word8
v Int
u

-- | The current state of execution of a builder
-- is a @'StablePtr' ('IORef' 'BuildRState')@.
--
-- Current Buffer Layout:
--
-- We devote the first few octets of the current buffer
-- to metadata that does not change very frequently:
--
--   * 'Addr#': cast to 'StablePtr# (IORef BuildRState)'; indirect acceses
--   to the full builder state, which is used relatively infrequently.
--
--   * 'Int#': the total number of non-metadata bytes originally available
--   within the current buffer before we started consuming them,
--   *plus* the number of bytes actually written to previous buffers.
--   We subtract the current unused figure to get the total bytes written.
--
--   * `GHC.Float.Double#`: suitably-aligned scratch space for serialization
--   of 'Double' and 'Float' values.
--
-- Though this choice imposes a small memory overhead in every buffer,
-- it reduces the time and space required to save and restore metadata
-- around the many non-inline calls that typically occur while writing
-- data into the buffer.
data BuildRState = BuildRState
  { BuildRState -> MutableByteArray RealWorld
currentBuffer :: {-# UNPACK #-}!(P.MutableByteArray RealWorld)
      -- ^ Specifies the current buffer.  Note that through this field
      -- every @'StablePtr' ('IORef' 'BuildRState')@ keeps one buffer
      -- reachable until that stable pointer is explicitly destroyed.
  , BuildRState -> ByteString
sealedBuffers :: BL.ByteString
      -- ^ Holds the bytes written to previous buffers.  We arrange for
      -- this field to be in normal form (not just weak head normal form).
      -- But to avoid redundant evaluation we do not mark it strict.
  }

-- | Allocates fields backward from offset 0 relative to some hypothetical
-- address, yielding the total size and alignment requirements, respectively,
-- along with the monadic return value.  The total size includes any padding
-- at the end that is needed to make it a multiple of the overall alignment.
allocateFields :: State (Int, Int) a -> (a, Int, Int)
allocateFields :: forall a. State (Int, Int) a -> (a, Int, Int)
allocateFields State (Int, Int) a
fields = (a
x, Int
size, Int
align)
  where
    (a
x, (Int
off, Int
align)) = State (Int, Int) a -> (Int, Int) -> (a, (Int, Int))
forall s a. State s a -> s -> (a, s)
runState State (Int, Int) a
fields (Int
0, Int
1)
    size :: Int
size = Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
off Int
align Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
off
      -- Aligns the overall size @- off@ by prepending @mod off align@ padding
      -- bytes.  Because @mod off align@ is in @[0, align)@ we are are neither
      -- removing bytes nor adding more than we need.  And for some @k@ we have
      --
      -- > mod off align == off + k * align
      --
      -- and therefore we achieve the precise alignment desired:
      --
      -- > size = (off + k * align) - off == k * align

-- | Within the monadic context established by 'allocateFields',
-- allocates one suitably-aligned field and returns its offset.
-- The argument is only a proxy for its type; we never evaluate it,
-- and therefore you may pass 'undefined'.
--
-- WARNING: We assume that 'max' is the same as 'lcm' for any pair of
-- alignment values, so that we can avoid using 'lcm', which does not
-- evaluate at compile time.  Compile-time evaluation helps our speed.
allocatePrimitiveField :: Storable a => a -> State (Int, Int) Int
allocatePrimitiveField :: forall a. Storable a => a -> State (Int, Int) Int
allocatePrimitiveField a
proxy = ((Int, Int) -> (Int, (Int, Int))) -> State (Int, Int) Int
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (((Int, Int) -> (Int, (Int, Int))) -> State (Int, Int) Int)
-> ((Int, Int) -> (Int, (Int, Int))) -> State (Int, Int) Int
forall a b. (a -> b) -> a -> b
$ \(Int
prevOff, Int
prevAlign) ->
  let fieldWidth :: Int
fieldWidth = a -> Int
forall a. Storable a => a -> Int
sizeOf a
proxy
      fieldAlign :: Int
fieldAlign = a -> Int
forall a. Storable a => a -> Int
alignment a
proxy
      unaligned :: Int
unaligned = Int
prevOff Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fieldWidth
      nextOff :: Int
nextOff = Int
unaligned Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
unaligned Int
fieldAlign
      nextAlign :: Int
nextAlign = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
prevAlign Int
fieldAlign
  in (Int
nextOff, (Int
nextOff, Int
nextAlign))

scratchOffset, spaceOffset, stateOffset, metaDataSize, metaDataAlign :: Int
((Int
scratchOffset, Int
spaceOffset, Int
stateOffset), Int
metaDataSize, Int
metaDataAlign) =
  State (Int, Int) (Int, Int, Int) -> ((Int, Int, Int), Int, Int)
forall a. State (Int, Int) a -> (a, Int, Int)
allocateFields (State (Int, Int) (Int, Int, Int) -> ((Int, Int, Int), Int, Int))
-> State (Int, Int) (Int, Int, Int) -> ((Int, Int, Int), Int, Int)
forall a b. (a -> b) -> a -> b
$
    (,,) (Int -> Int -> Int -> (Int, Int, Int))
-> State (Int, Int) Int
-> StateT (Int, Int) Identity (Int -> Int -> (Int, Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Double -> State (Int, Int) Int
forall a. Storable a => a -> State (Int, Int) Int
allocatePrimitiveField (Double
forall a. HasCallStack => a
undefined :: Double)
         StateT (Int, Int) Identity (Int -> Int -> (Int, Int, Int))
-> State (Int, Int) Int
-> StateT (Int, Int) Identity (Int -> (Int, Int, Int))
forall a b.
StateT (Int, Int) Identity (a -> b)
-> StateT (Int, Int) Identity a -> StateT (Int, Int) Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> State (Int, Int) Int
forall a. Storable a => a -> State (Int, Int) Int
allocatePrimitiveField (Int
forall a. HasCallStack => a
undefined :: Int)
         StateT (Int, Int) Identity (Int -> (Int, Int, Int))
-> State (Int, Int) Int -> State (Int, Int) (Int, Int, Int)
forall a b.
StateT (Int, Int) Identity (a -> b)
-> StateT (Int, Int) Identity a -> StateT (Int, Int) Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr () -> State (Int, Int) Int
forall a. Storable a => a -> State (Int, Int) Int
allocatePrimitiveField (Ptr ()
forall a. HasCallStack => a
undefined :: Ptr ())
               -- Note that we are allocating backward, so this
               -- will put the pointer at the lowest address.

smallChunkSize, defaultChunkSize :: Int
smallChunkSize :: Int
smallChunkSize = Int
BB.smallChunkSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
metaDataSize
defaultChunkSize :: Int
defaultChunkSize = Int
BB.defaultChunkSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
metaDataSize

data MetaData

metaPtr :: Ptr Word8 -> Int -> Ptr MetaData
metaPtr :: Ptr Word8 -> Int -> Ptr MetaData
metaPtr Ptr Word8
v = Ptr Word8 -> Int -> Ptr MetaData
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
v (Int -> Ptr MetaData) -> (Int -> Int) -> Int -> Ptr MetaData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Num a => a -> a
negate

readState :: Ptr MetaData -> IO (StablePtr (IORef BuildRState))
readState :: Ptr MetaData -> IO (StablePtr (IORef BuildRState))
readState Ptr MetaData
m = Ptr () -> StablePtr (IORef BuildRState)
forall a. Ptr () -> StablePtr a
castPtrToStablePtr (Ptr () -> StablePtr (IORef BuildRState))
-> IO (Ptr ()) -> IO (StablePtr (IORef BuildRState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr MetaData -> Int -> IO (Ptr ())
forall b. Ptr b -> Int -> IO (Ptr ())
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr MetaData
m Int
stateOffset

writeState :: Ptr MetaData -> StablePtr (IORef BuildRState) -> IO ()
writeState :: Ptr MetaData -> StablePtr (IORef BuildRState) -> IO ()
writeState Ptr MetaData
m = Ptr MetaData -> Int -> Ptr () -> IO ()
forall b. Ptr b -> Int -> Ptr () -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr MetaData
m Int
stateOffset (Ptr () -> IO ())
-> (StablePtr (IORef BuildRState) -> Ptr ())
-> StablePtr (IORef BuildRState)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StablePtr (IORef BuildRState) -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr

readSpace :: Ptr MetaData -> IO Int
readSpace :: Ptr MetaData -> IO Int
readSpace Ptr MetaData
m = Ptr MetaData -> Int -> IO Int
forall b. Ptr b -> Int -> IO Int
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr MetaData
m Int
spaceOffset

writeSpace :: Ptr MetaData -> Int -> IO ()
writeSpace :: Ptr MetaData -> Int -> IO ()
writeSpace Ptr MetaData
m = Ptr MetaData -> Int -> Int -> IO ()
forall b. Ptr b -> Int -> Int -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr MetaData
m Int
spaceOffset

-- | The arguments are the same as the 'BuildR' arguments.
readTotal :: Ptr Word8 -> Int -> IO Int
readTotal :: Ptr Word8 -> Int -> IO Int
readTotal Ptr Word8
v Int
unused = do
  -- Because we do not wish to update a record of the total
  -- every time we write a byte, instead we record "space",
  -- which changes rarely, and subtract "unused" from it
  -- when we need to compute the total, which is somewhat
  -- frequent but not as frequent as updates to "unused".
  Int
space <- Ptr MetaData -> IO Int
readSpace (Ptr Word8 -> Int -> Ptr MetaData
metaPtr Ptr Word8
v Int
unused)
  let !total :: Int
total = Int
space Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
unused

  -- GHC (at least v8.2.2 and v8.6.5) seems quite eager to delay the above
  -- subtraction, even though we have indicated that the computation of
  -- "total" is strict, and even though delaying the subtraction across
  -- a non-inline call requires saving and restoring two registers
  -- ("space" and "unused") instead of one ("total").  Unless we were to
  -- completely ignore the result of the subtraction, which would be quite
  -- unusual, an eager subtraction is faster.  Therefore we force it:
  Int -> IO Int
strictify Int
total

-- | Sometimes GHC (at least v8.2.2 and v8.6.5) appears to be lazy even with
-- unlifted values, and we apply this combination to force computation so that
-- we do not have to save and restore the several inputs to the computation.
--
-- The implementation requires converting the 'Int#' to a lifted pointer
-- type and then invoking 'touch#' on it, which is slightly questionable
-- because we would crash if the garbage collector actually followed the
-- converted value.  But there would be no reason to collect between the
-- conversion and the 'touch#' because that span involves no computation.
strictify :: Int -> IO Int
strictify :: Int -> IO Int
strictify (I# Int#
x) = (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int)
-> (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
  case Addr# -> (# Any #)
forall a. Addr# -> (# a #)
addrToAny# (Int# -> Addr#
int2Addr# Int#
x) of
    (# Any
y #) -> case Any -> State# RealWorld -> State# RealWorld
forall a. a -> State# RealWorld -> State# RealWorld
touch# Any
y State# RealWorld
s0 of
      State# RealWorld
s1 -> (# State# RealWorld
s1, Int# -> Int
I# Int#
x #)

-- | Allocates a new buffer and stores a pointer to that buffer in
-- the 'currentBuffer' field of the overall builder state, along with the
-- first argument, then returns a pointer to the end of the payload area.
--
-- (This is a manual wrapper around 'newBuffer#'.)
newBuffer ::
  -- | All bytes previously written.
  --
  -- It is ASSUMED that the caller already fully
  -- evaluated this otherwise-lazy 'BL.ByteString'.
  BL.ByteString ->
  -- | Total number of bytes previously written.
  Int ->
  -- | Builder state variable.  The old value of this variable
  -- will NOT be used; rather, it will be overwritten.
  -- Therefore that old value may be 'undefined'.
  IORef BuildRState ->
  -- | Stable pointer to builder state variable.
  StablePtr (IORef BuildRState) ->
  -- | Desired payload size of new current buffer, not counting metadata.
  Int ->
  IO (Ptr Word8)
newBuffer :: ByteString
-> Int
-> IORef BuildRState
-> StablePtr (IORef BuildRState)
-> Int
-> IO (Ptr Word8)
newBuffer ByteString
sealed (I# Int#
total) (IORef (STRef MutVar# RealWorld BuildRState
stateVar)) (StablePtr StablePtr# (IORef BuildRState)
stateSP)
          (I# Int#
unused) =
  (State# RealWorld -> (# State# RealWorld, Ptr Word8 #))
-> IO (Ptr Word8)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Ptr Word8 #))
 -> IO (Ptr Word8))
-> (State# RealWorld -> (# State# RealWorld, Ptr Word8 #))
-> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
    case ByteString
-> Int#
-> MutVar# RealWorld BuildRState
-> StablePtr# (IORef BuildRState)
-> Int#
-> State# RealWorld
-> (# State# RealWorld, Addr# #)
newBuffer# ByteString
sealed Int#
total MutVar# RealWorld BuildRState
stateVar StablePtr# (IORef BuildRState)
stateSP Int#
unused State# RealWorld
s0 of
      (# State# RealWorld
s1, Addr#
addr #) -> (# State# RealWorld
s1, Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
addr #)

newBuffer# ::
  BL.ByteString ->
  Int# ->
  MutVar# RealWorld BuildRState ->
  StablePtr# (IORef BuildRState) ->
  Int# ->
  State# RealWorld ->
  (# State# RealWorld, Addr# #)
newBuffer# :: ByteString
-> Int#
-> MutVar# RealWorld BuildRState
-> StablePtr# (IORef BuildRState)
-> Int#
-> State# RealWorld
-> (# State# RealWorld, Addr# #)
newBuffer# ByteString
sealed Int#
total MutVar# RealWorld BuildRState
stateVar StablePtr# (IORef BuildRState)
stateSP Int#
unused State# RealWorld
s0 =
    case State# RealWorld -> (# State# RealWorld, Ptr Any #)
forall {b}. State# RealWorld -> (# State# RealWorld, Ptr b #)
go State# RealWorld
s0 of
      (# State# RealWorld
s1, Ptr Addr#
addr #) -> (# State# RealWorld
s1, Addr#
addr #)
  where
    IO State# RealWorld -> (# State# RealWorld, Ptr b #)
go = do
      let allocation :: Int
allocation = Int
metaDataSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int# -> Int
I# Int#
unused
      MutableByteArray RealWorld
buf <- Int -> Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> Int -> m (MutableByteArray (PrimState m))
P.newAlignedPinnedByteArray Int
allocation Int
metaDataAlign
      let !(PTR base) = P.mutableByteArrayContents buf
          !v :: Ptr b
v = Ptr Any -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr (Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr Addr#
base) (Int
metaDataSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int# -> Int
I# Int#
unused)
          !m :: Ptr b
m = Ptr Any -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr (Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr Addr#
base) Int
metaDataSize
      Ptr MetaData -> StablePtr (IORef BuildRState) -> IO ()
writeState Ptr MetaData
forall {b}. Ptr b
m (StablePtr# (IORef BuildRState) -> StablePtr (IORef BuildRState)
forall a. StablePtr# a -> StablePtr a
StablePtr StablePtr# (IORef BuildRState)
stateSP)
      Ptr MetaData -> Int -> IO ()
writeSpace Ptr MetaData
forall {b}. Ptr b
m (Int# -> Int
I# Int#
unused Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int# -> Int
I# Int#
total)
      let !nextState :: BuildRState
nextState = BuildRState{currentBuffer :: MutableByteArray RealWorld
currentBuffer = MutableByteArray RealWorld
buf, sealedBuffers :: ByteString
sealedBuffers = ByteString
sealed}
      IORef BuildRState -> BuildRState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (STRef RealWorld BuildRState -> IORef BuildRState
forall a. STRef RealWorld a -> IORef a
IORef (MutVar# RealWorld BuildRState -> STRef RealWorld BuildRState
forall s a. MutVar# s a -> STRef s a
STRef MutVar# RealWorld BuildRState
stateVar)) BuildRState
nextState
      Ptr b -> IO (Ptr b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr b
forall {b}. Ptr b
v

-- | The result of a call to 'sealBuffer'.
data SealedState = SealedState
  { SealedState -> ByteString
sealedSB :: BL.ByteString
      -- ^ All bytes written thus far.
  , SealedState -> Int
totalSB :: {-# UNPACK #-}!Int
      -- ^ The total number of bytes written thus far.
  , SealedState -> IORef BuildRState
stateVarSB :: {-# UNPACK #-}!(IORef BuildRState)
      -- ^ The builder state variable.
      -- This function does NOT modify that variable--it will still
      -- refer to the old buffer unless and until you modify it.
  , SealedState -> StablePtr (IORef BuildRState)
statePtrSB :: {-# UNPACK #-}!(StablePtr (IORef BuildRState))
      -- ^ The stable pointer to the variable referenced by 'stateVarSB'.
  , SealedState -> Maybe (MutableByteArray RealWorld)
recycledSB :: Maybe (P.MutableByteArray RealWorld)
      -- ^ Returns ownership of the old current buffer to the caller
      -- if it is no longer needed to track the already-written bytes.
      --
      -- If you reuse it within the same builder then there is
      -- no need to reset the stable pointer to the state variable,
      -- but please be sure to update the "space" metadatum.
  }

-- | Takes ownership of the current buffer,
-- but sometimes hands it back for reuse.
--
-- If more building is required then please allocate a new current buffer
-- and update the builder state variable accordingly.
--
-- (This is a manual wrapper around 'sealBuffer#'.)
sealBuffer ::
  -- | Pointer to the used portion of the current buffer.
  Ptr Word8 ->
  -- | The number of bytes still unused in the current buffer.
  Int ->
  IO SealedState
sealBuffer :: Ptr Word8 -> Int -> IO SealedState
sealBuffer (Ptr Addr#
addr) (I# Int#
u) = (State# RealWorld -> (# State# RealWorld, SealedState #))
-> IO SealedState
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, SealedState #))
 -> IO SealedState)
-> (State# RealWorld -> (# State# RealWorld, SealedState #))
-> IO SealedState
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
  case Addr#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, ByteString, Int#,
      MutVar# RealWorld BuildRState, StablePtr# (IORef BuildRState),
      Maybe (MutableByteArray RealWorld) #)
sealBuffer# Addr#
addr Int#
u State# RealWorld
s0 of
    (# State# RealWorld
s1, ByteString
sealed, Int#
total, MutVar# RealWorld BuildRState
stateVar, StablePtr# (IORef BuildRState)
statePtr, Maybe (MutableByteArray RealWorld)
recycled #) ->
      (# State# RealWorld
s1
       , SealedState
           { sealedSB :: ByteString
sealedSB = ByteString
sealed
           , totalSB :: Int
totalSB = Int# -> Int
I# Int#
total
           , stateVarSB :: IORef BuildRState
stateVarSB = STRef RealWorld BuildRState -> IORef BuildRState
forall a. STRef RealWorld a -> IORef a
IORef (MutVar# RealWorld BuildRState -> STRef RealWorld BuildRState
forall s a. MutVar# s a -> STRef s a
STRef MutVar# RealWorld BuildRState
stateVar)
           , statePtrSB :: StablePtr (IORef BuildRState)
statePtrSB = StablePtr# (IORef BuildRState) -> StablePtr (IORef BuildRState)
forall a. StablePtr# a -> StablePtr a
StablePtr StablePtr# (IORef BuildRState)
statePtr
           , recycledSB :: Maybe (MutableByteArray RealWorld)
recycledSB = Maybe (MutableByteArray RealWorld)
recycled
           }
       #)

sealBuffer# ::
  Addr# ->
  Int# ->
  State# RealWorld ->
  (# State# RealWorld
   , BL.ByteString
   , Int#
   , MutVar# RealWorld BuildRState
   , StablePtr# (IORef BuildRState)
   , Maybe (P.MutableByteArray RealWorld)
   #)
sealBuffer# :: Addr#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, ByteString, Int#,
      MutVar# RealWorld BuildRState, StablePtr# (IORef BuildRState),
      Maybe (MutableByteArray RealWorld) #)
sealBuffer# Addr#
addr Int#
unused State# RealWorld
s0 =
    case State# RealWorld
-> (# State# RealWorld,
      (ByteString, Int, IORef BuildRState, StablePtr (IORef BuildRState),
       Maybe (MutableByteArray RealWorld)) #)
go State# RealWorld
s0 of
      (# State# RealWorld
s1, (ByteString
sealed, I# Int#
total, IORef (STRef MutVar# RealWorld BuildRState
sv), StablePtr StablePtr# (IORef BuildRState)
sp, Maybe (MutableByteArray RealWorld)
re) #) ->
        (# State# RealWorld
s1, ByteString
sealed, Int#
total, MutVar# RealWorld BuildRState
sv, StablePtr# (IORef BuildRState)
sp, Maybe (MutableByteArray RealWorld)
re #)
  where
    IO State# RealWorld
-> (# State# RealWorld,
      (ByteString, Int, IORef BuildRState, StablePtr (IORef BuildRState),
       Maybe (MutableByteArray RealWorld)) #)
go = do
      let v :: Ptr a
v = Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr Addr#
addr
      StablePtr (IORef BuildRState)
statePtr <- Ptr MetaData -> IO (StablePtr (IORef BuildRState))
readState (Ptr Word8 -> Int -> Ptr MetaData
metaPtr Ptr Word8
forall {b}. Ptr b
v (Int# -> Int
I# Int#
unused))
      IORef BuildRState
stateVar <- StablePtr (IORef BuildRState) -> IO (IORef BuildRState)
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr (IORef BuildRState)
statePtr
      BuildRState { currentBuffer :: BuildRState -> MutableByteArray RealWorld
currentBuffer = MutableByteArray RealWorld
buffer, sealedBuffers :: BuildRState -> ByteString
sealedBuffers = ByteString
oldSealed } <-
       IORef BuildRState -> IO BuildRState
forall a. IORef a -> IO a
readIORef IORef BuildRState
stateVar
      Int
total <- Ptr Word8 -> Int -> IO Int
readTotal Ptr Word8
forall {b}. Ptr b
v (Int# -> Int
I# Int#
unused)
      -- The above call to 'readTotal' is the last access of the current
      -- buffer through a raw pointer made by this function.  Therefore
      -- we must be sure that the current buffer remains reachable at this
      -- point in the state thread.  And we are sure of that fact, because
      -- until a state action frees the stable pointer or modifies the state
      -- variable, the stable pointer will reference the state variable,
      -- which in turn will reference the current buffer.
      let allocation :: Int
allocation = MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
P.sizeofMutableByteArray MutableByteArray RealWorld
buffer Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
metaDataSize
      if Int
allocation Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int# -> Int
I# Int#
unused
        then
          (ByteString, Int, IORef BuildRState, StablePtr (IORef BuildRState),
 Maybe (MutableByteArray RealWorld))
-> IO
     (ByteString, Int, IORef BuildRState, StablePtr (IORef BuildRState),
      Maybe (MutableByteArray RealWorld))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
oldSealed, Int
total, IORef BuildRState
stateVar, StablePtr (IORef BuildRState)
statePtr, MutableByteArray RealWorld -> Maybe (MutableByteArray RealWorld)
forall a. a -> Maybe a
Just MutableByteArray RealWorld
buffer)
        else do
          let !(PTR base) = P.mutableByteArrayContents buffer
              !(P.MutableByteArray MutableByteArray# RealWorld
mba) = MutableByteArray RealWorld
buffer
              fp :: ForeignPtr a
fp = Addr# -> ForeignPtrContents -> ForeignPtr a
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr Addr#
base (MutableByteArray# RealWorld -> ForeignPtrContents
PlainPtr MutableByteArray# RealWorld
mba)
              offset :: Int
offset = Int
metaDataSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int# -> Int
I# Int#
unused
              finish :: ByteString
-> e
-> f (ByteString, Int, IORef BuildRState,
      StablePtr (IORef BuildRState), e)
finish ByteString
trimmed e
recycled = do
                let !newSealed :: ByteString
newSealed = ByteString -> ByteString -> ByteString
BLI.Chunk ByteString
trimmed ByteString
oldSealed
                (ByteString, Int, IORef BuildRState, StablePtr (IORef BuildRState),
 e)
-> f (ByteString, Int, IORef BuildRState,
      StablePtr (IORef BuildRState), e)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
newSealed, Int
total, IORef BuildRState
stateVar, StablePtr (IORef BuildRState)
statePtr, e
recycled)
              untrimmed :: ByteString
untrimmed = ForeignPtr Word8 -> Int -> Int -> ByteString
BI.fromForeignPtr ForeignPtr Word8
forall {a}. ForeignPtr a
fp Int
offset (Int
allocation Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int# -> Int
I# Int#
unused)
          if Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= ByteString -> Int
B.length ByteString
untrimmed
            then ByteString
-> Maybe (MutableByteArray RealWorld)
-> IO
     (ByteString, Int, IORef BuildRState, StablePtr (IORef BuildRState),
      Maybe (MutableByteArray RealWorld))
forall {f :: * -> *} {e}.
Applicative f =>
ByteString
-> e
-> f (ByteString, Int, IORef BuildRState,
      StablePtr (IORef BuildRState), e)
finish ByteString
untrimmed Maybe (MutableByteArray RealWorld)
forall a. Maybe a
Nothing
            else ByteString
-> Maybe (MutableByteArray RealWorld)
-> IO
     (ByteString, Int, IORef BuildRState, StablePtr (IORef BuildRState),
      Maybe (MutableByteArray RealWorld))
forall {f :: * -> *} {e}.
Applicative f =>
ByteString
-> e
-> f (ByteString, Int, IORef BuildRState,
      StablePtr (IORef BuildRState), e)
finish (ByteString -> ByteString
B.copy ByteString
untrimmed) (MutableByteArray RealWorld -> Maybe (MutableByteArray RealWorld)
forall a. a -> Maybe a
Just MutableByteArray RealWorld
buffer)

-- | Like `Proto3.Wire.Reverse.toLazyByteString` but also
-- returns the total length of the lazy 'BL.ByteString',
-- which is computed as a side effect of encoding.
runBuildR :: BuildR -> (Int, BL.ByteString)
runBuildR :: BuildR -> (Int, ByteString)
runBuildR BuildR
f = IO (Int, ByteString) -> (Int, ByteString)
forall a. IO a -> a
unsafePerformIO (IO (Int, ByteString) -> (Int, ByteString))
-> IO (Int, ByteString) -> (Int, ByteString)
forall a b. (a -> b) -> a -> b
$ do
  IORef BuildRState
stateVar <- BuildRState -> IO (IORef BuildRState)
forall a. a -> IO (IORef a)
newIORef BuildRState
forall a. HasCallStack => a
undefined   -- undefined only until 'newBuffer'
  IO (StablePtr (IORef BuildRState))
-> (StablePtr (IORef BuildRState) -> IO ())
-> (StablePtr (IORef BuildRState) -> IO (Int, ByteString))
-> IO (Int, ByteString)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (IORef BuildRState -> IO (StablePtr (IORef BuildRState))
forall a. a -> IO (StablePtr a)
newStablePtr IORef BuildRState
stateVar) StablePtr (IORef BuildRState) -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr ((StablePtr (IORef BuildRState) -> IO (Int, ByteString))
 -> IO (Int, ByteString))
-> (StablePtr (IORef BuildRState) -> IO (Int, ByteString))
-> IO (Int, ByteString)
forall a b. (a -> b) -> a -> b
$ \StablePtr (IORef BuildRState)
statePtr -> do
    let u0 :: Int
u0 = Int
smallChunkSize
    Ptr Word8
v0 <- ByteString
-> Int
-> IORef BuildRState
-> StablePtr (IORef BuildRState)
-> Int
-> IO (Ptr Word8)
newBuffer ByteString
BL.empty Int
0 IORef BuildRState
stateVar StablePtr (IORef BuildRState)
statePtr Int
u0
    (Ptr Word8
v1, Int
u1) <- BuildR -> Ptr Word8 -> Int -> IO (Ptr Word8, Int)
fromBuildR BuildR
f Ptr Word8
v0 Int
u0
    SealedState { sealedSB :: SealedState -> ByteString
sealedSB = ByteString
bytes, totalSB :: SealedState -> Int
totalSB = Int
total } <- Ptr Word8 -> Int -> IO SealedState
sealBuffer Ptr Word8
v1 Int
u1
    (Int, ByteString) -> IO (Int, ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
total, ByteString
bytes)

-- | First reads the number of unused bytes in the current buffer.
withUnused :: (Int -> BuildR) -> BuildR
withUnused :: (Int -> BuildR) -> BuildR
withUnused Int -> BuildR
f = (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
toBuildR ((Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR)
-> (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
v Int
u -> BuildR -> Ptr Word8 -> Int -> IO (Ptr Word8, Int)
fromBuildR (Int -> BuildR
f Int
u) Ptr Word8
v Int
u

-- | First reads the number of bytes previously written.
withTotal :: (Int -> BuildR) -> BuildR
withTotal :: (Int -> BuildR) -> BuildR
withTotal Int -> BuildR
f = (Int# -> BuildR) -> BuildR
withTotal# (\Int#
total -> Int -> BuildR
f (Int# -> Int
I# Int#
total))

-- | First reads the number of bytes previously written.
withTotal# :: (Int# -> BuildR) -> BuildR
withTotal# :: (Int# -> BuildR) -> BuildR
withTotal# Int# -> BuildR
f = (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
toBuildR ((Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR)
-> (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
v Int
u -> do
  I# Int#
total <- Ptr Word8 -> Int -> IO Int
readTotal Ptr Word8
v Int
u
  BuildR -> Ptr Word8 -> Int -> IO (Ptr Word8, Int)
fromBuildR (Int# -> BuildR
f Int#
total) Ptr Word8
v Int
u

-- | Executes the right builder, measuring how many bytes
-- it writes, then provides that figure to the left builder.
withLengthOf :: (Int -> BuildR) -> BuildR -> BuildR
withLengthOf :: (Int -> BuildR) -> BuildR -> BuildR
withLengthOf = \Int -> BuildR
f BuildR
g -> (Int# -> BuildR) -> BuildR -> BuildR
withLengthOf# (\Int#
len -> Int -> BuildR
f (Int# -> Int
I# Int#
len)) BuildR
g
{-# INLINE CONLIKE withLengthOf #-}

-- | Executes the right builder, measuring how many bytes
-- it writes, then provides that figure to the left builder.
withLengthOf# :: (Int# -> BuildR) -> BuildR -> BuildR
withLengthOf# :: (Int# -> BuildR) -> BuildR -> BuildR
withLengthOf# = \Int# -> BuildR
f BuildR
g -> (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
toBuildR ((Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR)
-> (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
v0 Int
u0 -> do
  !Int
before <- Ptr Word8 -> Int -> IO Int
readTotal Ptr Word8
v0 Int
u0
  (Ptr Word8
v1, Int
u1) <- BuildR -> Ptr Word8 -> Int -> IO (Ptr Word8, Int)
fromBuildR BuildR
g Ptr Word8
v0 Int
u0
  !Int
after <- Ptr Word8 -> Int -> IO Int
readTotal Ptr Word8
v1 Int
u1
  let !(I# Int#
len) = Int
after Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
before
  BuildR -> Ptr Word8 -> Int -> IO (Ptr Word8, Int)
fromBuildR (Int# -> BuildR
f Int#
len) Ptr Word8
v1 Int
u1
{-# INLINE CONLIKE [1] withLengthOf# #-}  -- See Prim module for rules.

-- | Seals the current buffer and creates a new
-- one with at least the given number of bytes.
reallocate :: Int -> BuildR
reallocate :: Int -> BuildR
reallocate (I# Int#
required) = Int# -> BuildR
reallocate# Int#
required

reallocate# :: Int# -> BuildR
reallocate# :: Int# -> BuildR
reallocate# Int#
required = (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
toBuildR ((Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR)
-> (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
v0 Int
u0 -> do
  SealedState
    { sealedSB :: SealedState -> ByteString
sealedSB = ByteString
bytes
    , totalSB :: SealedState -> Int
totalSB = Int
total
    , stateVarSB :: SealedState -> IORef BuildRState
stateVarSB = IORef (STRef MutVar# RealWorld BuildRState
stateVar)
    , statePtrSB :: SealedState -> StablePtr (IORef BuildRState)
statePtrSB = StablePtr StablePtr# (IORef BuildRState)
statePtr
    } <- Ptr Word8 -> Int -> IO SealedState
sealBuffer Ptr Word8
v0 Int
u0
  let !u1 :: Int
u1 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int# -> Int
I# Int#
required) Int
defaultChunkSize
  Ptr Word8
v1 <- ByteString
-> Int
-> IORef BuildRState
-> StablePtr (IORef BuildRState)
-> Int
-> IO (Ptr Word8)
newBuffer ByteString
bytes Int
total (STRef RealWorld BuildRState -> IORef BuildRState
forall a. STRef RealWorld a -> IORef a
IORef (MutVar# RealWorld BuildRState -> STRef RealWorld BuildRState
forall s a. MutVar# s a -> STRef s a
STRef MutVar# RealWorld BuildRState
stateVar)) (StablePtr# (IORef BuildRState) -> StablePtr (IORef BuildRState)
forall a. StablePtr# a -> StablePtr a
StablePtr StablePtr# (IORef BuildRState)
statePtr) Int
u1
  (Ptr Word8, Int) -> IO (Ptr Word8, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Word8
v1, Int
u1)
{-# NOINLINE reallocate# #-}  -- Avoid code bloat in library clients.

-- | Called by 'prependChunk' and 'prependReverseChunks'
-- to prepare a current buffer.
--
-- (This is a manual wrapper around 'afterPrependChunks#'.)
afterPrependChunks :: SealedState -> IO (Ptr Word8, Int)
afterPrependChunks :: SealedState -> IO (Ptr Word8, Int)
afterPrependChunks !SealedState
st = (State# RealWorld -> (# State# RealWorld, (Ptr Word8, Int) #))
-> IO (Ptr Word8, Int)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, (Ptr Word8, Int) #))
 -> IO (Ptr Word8, Int))
-> (State# RealWorld -> (# State# RealWorld, (Ptr Word8, Int) #))
-> IO (Ptr Word8, Int)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
  case SealedState
-> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
afterPrependChunks# SealedState
st State# RealWorld
s0 of
    (# Addr#
v1, Int#
u1, State# RealWorld
s1 #) -> (# State# RealWorld
s1, (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
v1, Int# -> Int
I# Int#
u1) #)

afterPrependChunks# ::
  SealedState ->
  State# RealWorld ->
  (# Addr#, Int#, State# RealWorld #)
afterPrependChunks# :: SealedState
-> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
afterPrependChunks# SealedState
                      { sealedSB :: SealedState -> ByteString
sealedSB = ByteString
sealed
                      , totalSB :: SealedState -> Int
totalSB = Int
total
                      , stateVarSB :: SealedState -> IORef BuildRState
stateVarSB = IORef BuildRState
stateVar
                      , statePtrSB :: SealedState -> StablePtr (IORef BuildRState)
statePtrSB = StablePtr (IORef BuildRState)
statePtr
                      , recycledSB :: SealedState -> Maybe (MutableByteArray RealWorld)
recycledSB = Maybe (MutableByteArray RealWorld)
recycled
                      } State# RealWorld
s0 =
    case State# RealWorld -> (# State# RealWorld, (Ptr Word8, Int) #)
go State# RealWorld
s0 of (# State# RealWorld
s2, (Ptr Addr#
v2, I# Int#
u2) #) -> (# Addr#
v2, Int#
u2, State# RealWorld
s2 #)
  where
    IO State# RealWorld -> (# State# RealWorld, (Ptr Word8, Int) #)
go = case Maybe (MutableByteArray RealWorld)
recycled of
      Maybe (MutableByteArray RealWorld)
Nothing -> do
        -- The old buffer is part of 'sealed'.  Allocate a new buffer.
        let u1 :: Int
u1 = Int
defaultChunkSize
        Ptr Word8
v1 <- ByteString
-> Int
-> IORef BuildRState
-> StablePtr (IORef BuildRState)
-> Int
-> IO (Ptr Word8)
newBuffer ByteString
sealed Int
total IORef BuildRState
stateVar StablePtr (IORef BuildRState)
statePtr Int
u1
        (Ptr Word8, Int) -> IO (Ptr Word8, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Word8
v1, Int
u1)

      Just MutableByteArray RealWorld
buf -> do
        -- Recycle the old current buffer, from which
        -- we already copied what we wished to keep.
        let u1 :: Int
u1 = MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
P.sizeofMutableByteArray MutableByteArray RealWorld
buf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
metaDataSize
            !(PTR base) = P.mutableByteArrayContents buf
            !v1 :: Ptr b
v1 = Ptr Any -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr (Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr Addr#
base) (Int
metaDataSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
u1)
            !m :: Ptr b
m = Ptr Any -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr (Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr Addr#
base) Int
metaDataSize
        Ptr MetaData -> Int -> IO ()
writeSpace Ptr MetaData
forall {b}. Ptr b
m (Int
u1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
total)
        let !nextState :: BuildRState
nextState = BuildRState
               { currentBuffer :: MutableByteArray RealWorld
currentBuffer = MutableByteArray RealWorld
buf, sealedBuffers :: ByteString
sealedBuffers = ByteString
sealed }
        IORef BuildRState -> BuildRState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef BuildRState
stateVar BuildRState
nextState
        (Ptr Word8, Int) -> IO (Ptr Word8, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Word8
forall {b}. Ptr b
v1, Int
u1)

-- | Prepends a 'B.ByteString' to the output.
--
-- NOTE: This is a relatively heavyweight operation.  For small
-- strings it may be faster to copy them to the current buffer.
prependChunk :: B.ByteString -> BuildR
prependChunk :: ByteString -> BuildR
prependChunk (BI.PS (ForeignPtr Addr#
ad ForeignPtrContents
ct) (I# Int#
off) (I# Int#
len))
  | Int# -> Int
I# Int#
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = BuildR
forall a. Monoid a => a
mempty
  | Bool
otherwise = (Addr#
 -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
-> BuildR
BuildR (\Addr#
v Int#
u State# RealWorld
s -> Addr#
-> Int#
-> State# RealWorld
-> Addr#
-> ForeignPtrContents
-> Int#
-> Int#
-> (# Addr#, Int#, State# RealWorld #)
prependChunk# Addr#
v Int#
u State# RealWorld
s Addr#
ad ForeignPtrContents
ct Int#
off Int#
len)

prependChunk# ::
  -- | Used bytes.
  Addr# ->
  -- | Count of unused bytes.
  Int# ->
  -- | State token.
  State# RealWorld ->
  -- | Base address of 'B.ByteString'.
  Addr# ->
  -- | Finalizer for 'B.ByteString'.
  ForeignPtrContents ->
  -- | Offset from base of 'B.ByteString'.
  Int# ->
  -- | Length of 'B.ByteString'.
  Int# ->
  (# Addr#, Int#, State# RealWorld #)
prependChunk# :: Addr#
-> Int#
-> State# RealWorld
-> Addr#
-> ForeignPtrContents
-> Int#
-> Int#
-> (# Addr#, Int#, State# RealWorld #)
prependChunk# Addr#
v Int#
u State# RealWorld
s Addr#
ad ForeignPtrContents
ct Int#
off Int#
len = Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
go Addr#
v Int#
u State# RealWorld
s
  where
    BuildR Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
go = (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
toBuildR ((Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR)
-> (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
v1 Int
u1 -> do
      SealedState
        { sealedSB :: SealedState -> ByteString
sealedSB = ByteString
oldSealed
        , totalSB :: SealedState -> Int
totalSB = Int
oldTotal
        , stateVarSB :: SealedState -> IORef BuildRState
stateVarSB = IORef BuildRState
stateVar
        , statePtrSB :: SealedState -> StablePtr (IORef BuildRState)
statePtrSB = StablePtr (IORef BuildRState)
statePtr
        , recycledSB :: SealedState -> Maybe (MutableByteArray RealWorld)
recycledSB = Maybe (MutableByteArray RealWorld)
recycled
        } <- Ptr Word8 -> Int -> IO SealedState
sealBuffer Ptr Word8
v1 Int
u1

      let chunk :: ByteString
chunk = ForeignPtr Word8 -> Int -> Int -> ByteString
BI.PS (Addr# -> ForeignPtrContents -> ForeignPtr Word8
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr Addr#
ad ForeignPtrContents
ct) (Int# -> Int
I# Int#
off) (Int# -> Int
I# Int#
len)

      SealedState -> IO (Ptr Word8, Int)
afterPrependChunks SealedState
        { sealedSB :: ByteString
sealedSB = ByteString -> ByteString -> ByteString
BLI.Chunk ByteString
chunk ByteString
oldSealed
        , totalSB :: Int
totalSB = Int# -> Int
I# Int#
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
oldTotal
        , stateVarSB :: IORef BuildRState
stateVarSB = IORef BuildRState
stateVar
        , statePtrSB :: StablePtr (IORef BuildRState)
statePtrSB = StablePtr (IORef BuildRState)
statePtr
        , recycledSB :: Maybe (MutableByteArray RealWorld)
recycledSB = Maybe (MutableByteArray RealWorld)
recycled
        }

-- | Like 'BL.ByteString', but with the chunks in reverse order,
-- even though the bytes within each chunk are in forward order.
newtype ReverseChunks = ReverseChunks { ReverseChunks -> ByteString
getReverseChunks :: BL.ByteString }

-- | Equivalent to the following, but faster:
--
-- > foldMap prependChunk . reverse . getReverseChunks
--
-- NOTE: This is a relatively heavyweight operation.  For small
-- strings it may be faster to copy them to the current buffer.
prependReverseChunks :: ReverseChunks -> BuildR
prependReverseChunks :: ReverseChunks -> BuildR
prependReverseChunks (ReverseChunks ByteString
BLI.Empty) = BuildR
forall a. Monoid a => a
mempty
prependReverseChunks
  (ReverseChunks (BLI.Chunk (BI.PS (ForeignPtr Addr#
ad ForeignPtrContents
ct) (I# Int#
off) (I# Int#
len)) ByteString
cs)) =
  (Addr#
 -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
-> BuildR
BuildR (\Addr#
v Int#
u State# RealWorld
s -> Addr#
-> Int#
-> State# RealWorld
-> Addr#
-> ForeignPtrContents
-> Int#
-> Int#
-> ByteString
-> (# Addr#, Int#, State# RealWorld #)
prependReverseChunks# Addr#
v Int#
u State# RealWorld
s Addr#
ad ForeignPtrContents
ct Int#
off Int#
len ByteString
cs)

prependReverseChunks# ::
  -- | Used bytes.
  Addr# ->
  -- | Count of unused bytes.
  Int# ->
  -- | State token.
  State# RealWorld ->
  -- | Base address of first 'B.ByteString' chunk.
  Addr# ->
  -- | Finalizer for first 'B.ByteString' chunk.
  ForeignPtrContents ->
  -- | Offset from base of first 'B.ByteString' chunk.
  Int# ->
  -- | Length of first 'B.ByteString' chunk.
  Int# ->
  -- | Other chunks.
  BL.ByteString ->
  (# Addr#, Int#, State# RealWorld #)
prependReverseChunks# :: Addr#
-> Int#
-> State# RealWorld
-> Addr#
-> ForeignPtrContents
-> Int#
-> Int#
-> ByteString
-> (# Addr#, Int#, State# RealWorld #)
prependReverseChunks# Addr#
v0 Int#
u0 State# RealWorld
s0 Addr#
ad ForeignPtrContents
ct Int#
off Int#
len ByteString
cs0 = Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
go Addr#
v0 Int#
u0 State# RealWorld
s0
  where
    BuildR Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
go = (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
toBuildR ((Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR)
-> (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
v1 Int
u1 -> do
      SealedState
        { sealedSB :: SealedState -> ByteString
sealedSB = ByteString
oldSealed
        , totalSB :: SealedState -> Int
totalSB = Int
oldTotal
        , stateVarSB :: SealedState -> IORef BuildRState
stateVarSB = IORef BuildRState
stateVar
        , statePtrSB :: SealedState -> StablePtr (IORef BuildRState)
statePtrSB = StablePtr (IORef BuildRState)
statePtr
        , recycledSB :: SealedState -> Maybe (MutableByteArray RealWorld)
recycledSB = Maybe (MutableByteArray RealWorld)
recycled
        } <- Ptr Word8 -> Int -> IO SealedState
sealBuffer Ptr Word8
v1 Int
u1

      let appendChunks :: Int -> ByteString -> ByteString -> IO (Ptr Word8, Int)
appendChunks !Int
total ByteString
sealed (BLI.Chunk ByteString
c ByteString
cs) =
            Int -> ByteString -> ByteString -> IO (Ptr Word8, Int)
appendChunks (ByteString -> Int
B.length ByteString
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
total) (ByteString -> ByteString -> ByteString
BLI.Chunk ByteString
c ByteString
sealed) ByteString
cs
          appendChunks Int
newTotal ByteString
newSealed ByteString
BLI.Empty =
            SealedState -> IO (Ptr Word8, Int)
afterPrependChunks SealedState
              { sealedSB :: ByteString
sealedSB = ByteString
newSealed
              , totalSB :: Int
totalSB = Int
newTotal
              , stateVarSB :: IORef BuildRState
stateVarSB = IORef BuildRState
stateVar
              , statePtrSB :: StablePtr (IORef BuildRState)
statePtrSB = StablePtr (IORef BuildRState)
statePtr
              , recycledSB :: Maybe (MutableByteArray RealWorld)
recycledSB = Maybe (MutableByteArray RealWorld)
recycled
              }

      let rchunks :: ByteString
rchunks = ByteString -> ByteString -> ByteString
BLI.Chunk (ForeignPtr Word8 -> Int -> Int -> ByteString
BI.PS (Addr# -> ForeignPtrContents -> ForeignPtr Word8
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr Addr#
ad ForeignPtrContents
ct) (Int# -> Int
I# Int#
off) (Int# -> Int
I# Int#
len)) ByteString
cs0

      Int -> ByteString -> ByteString -> IO (Ptr Word8, Int)
appendChunks Int
oldTotal ByteString
oldSealed ByteString
rchunks

-- | Ensures that the current buffer has at least the given
-- number of bytes before executing the given builder.
ensure :: Int -> BuildR -> BuildR
ensure :: Int -> BuildR -> BuildR
ensure (I# Int#
required) BuildR
f = Int# -> BuildR -> BuildR
ensure# Int#
required BuildR
f

ensure# :: Int# -> BuildR -> BuildR
ensure# :: Int# -> BuildR -> BuildR
ensure# Int#
required (BuildR Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
f) = (Addr#
 -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
-> BuildR
BuildR ((Addr#
  -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
 -> BuildR)
-> (Addr#
    -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
-> BuildR
forall a b. (a -> b) -> a -> b
$ \Addr#
v Int#
u State# RealWorld
s ->
  if Int# -> Int
I# Int#
required Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int# -> Int
I# Int#
u
    then Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
f Addr#
v Int#
u State# RealWorld
s
    else let BuildR Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
g = (Addr#
 -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
-> BuildR
BuildR Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
f BuildR -> BuildR -> BuildR
forall a. Semigroup a => a -> a -> a
<> Int# -> BuildR
reallocate# Int#
required in Addr#
-> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)
g Addr#
v Int#
u State# RealWorld
s

-- | ASSUMES that the specified number of bytes is both nonnegative and
-- less than or equal to the number of unused bytes in the current buffer,
-- consumes that number of unused bytes, and provides their starting address.
unsafeConsume :: Int -> (Ptr Word8 -> IO ()) -> BuildR
unsafeConsume :: Int -> (Ptr Word8 -> IO ()) -> BuildR
unsafeConsume = \Int
width Ptr Word8 -> IO ()
f ->
  (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
toBuildR ((Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR)
-> (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
v0 Int
u0 -> do
    let !m :: Int
m = - Int
width
        !v1 :: Ptr b
v1 = Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
v0 Int
m
        !u1 :: Int
u1 = Int
u0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
    Ptr Word8 -> IO ()
f Ptr Word8
forall {b}. Ptr b
v1
    (Ptr Word8, Int) -> IO (Ptr Word8, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Word8
forall {b}. Ptr b
v1, Int
u1)
{-# INLINE unsafeConsume #-}

-- | Given the builder inputs and a 'Float', converts
-- that number to its bit pattern in native byte order.
floatToWord32 :: Ptr Word8 -> Int -> Float -> IO Word32
floatToWord32 :: Ptr Word8 -> Int -> Float -> IO Word32
floatToWord32 Ptr Word8
v Int
u Float
x = do
  let m :: Ptr MetaData
m = Ptr Word8 -> Int -> Ptr MetaData
metaPtr Ptr Word8
v Int
u
  Ptr MetaData -> Int -> Float -> IO ()
forall b. Ptr b -> Int -> Float -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr MetaData
m Int
scratchOffset Float
x
  Ptr MetaData -> Int -> IO Word32
forall b. Ptr b -> Int -> IO Word32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr MetaData
m Int
scratchOffset

-- | Given the builder inputs and a 'Double', converts
-- that number to its bit pattern in native byte order.
doubleToWord64 :: Ptr Word8 -> Int -> Double -> IO Word64
doubleToWord64 :: Ptr Word8 -> Int -> Double -> IO Word64
doubleToWord64 Ptr Word8
v Int
u Double
x = do
  let m :: Ptr MetaData
m = Ptr Word8 -> Int -> Ptr MetaData
metaPtr Ptr Word8
v Int
u
  Ptr MetaData -> Int -> Double -> IO ()
forall b. Ptr b -> Int -> Double -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr MetaData
m Int
scratchOffset Double
x
  Ptr MetaData -> Int -> IO Word64
forall b. Ptr b -> Int -> IO Word64
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr MetaData
m Int
scratchOffset