{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UnboxedTuples #-}

module Unison.Runtime.Stack
  ( K (..),
    GClosure (..),
    Closure
      ( ..,
        DataC,
        PApV,
        CapV,
        PAp,
        Enum,
        Data1,
        Data2,
        DataG,
        Captured,
        Foreign,
        Affine,
        BlackHole,
        UnboxedTypeTag
      ),
    Failure (..),
    Foreign (..),
    foreignRef,
    foreignName,
    BuiltinForeign (..),
    AffineRef (..),
    AEnv,
    DEnv,
    HEnv (..),
    closureTag,
    formDataReplaced,
    unitClosure,
    UnboxedTypeTag (..),
    unboxedTypeTagToInt,
    unboxedTypeTagFromInt,
    IxClosure,
    Callback (..),
    Augment (..),
    Dump (..),
    Stack (..),
    XStack,
    pattern XStack,
    packXStack,
    unpackXStack,
    xStackIOToIO,
    stackIOToIOX,
    estackIOToIOX,
    exStackIOToIO,
    IOXStack,
    IOEXStack,
    apX,
    fpX,
    spX,
    ustkX,
    bstkX,
    Off,
    SZ,
    FP,
    Seg,
    USeg,
    BSeg,
    SegList,
    Val
      ( ..,
        CharVal,
        NatVal,
        DoubleVal,
        IntVal,
        BoolVal,
        UnboxedVal,
        BoxedVal
      ),
    emptyVal,
    falseVal,
    trueVal,
    boxedVal,
    USeq,
    traceK,
    frameDataSize,
    RuntimePanic (..),
    marshalUnwrapForeignIO,
    unull,
    bnull,
    nullSeg,
    peekD,
    peekOffD,
    peekC,
    peekOffC,
    poke,
    pokeD,
    pokeOffD,
    pokeC,
    pokeOffC,
    pokeBool,
    pokeTag,
    peekTag,
    peekTagOff,
    peekI,
    peekOffI,
    peekN,
    peekOffN,
    pokeN,
    pokeOffN,
    pokeI,
    pokeOffI,
    pokeByte,
    peekBi,
    peekOffBi,
    pokeBi,
    pokeOffBi,
    peekBool,
    peekOffBool,
    peekOffS,
    pokeS,
    pokeOffS,
    frameView,
    scount,
    closureTermRefs,
    dumpAP,
    dumpFP,
    alloc,
    peek,
    upeek,
    bpeek,
    peekOff,
    upeekOff,
    bpeekOff,
    bpoke,
    bpokeOff,
    pokeOff,
    upokeT,
    upokeOffT,
    unsafePokeIasN,
    bump,
    bumpn,
    grabSeg,
    truncateSeg,
    ensure,
    duplicate,
    discardFrame,
    saveFrame,
    saveArgs,
    restoreFrame,
    prepareArgs,
    acceptArgs,
    frameArgs,
    augSeg,
    dumpSeg,
    adjustArgs,
    fsize,
    asize,
    useg,
    bseg,
    segFromList,
    traverseListToSeg,
    traverseAccumSegToList,

    -- * Unboxed type tags
    natTypeTag,
    intTypeTag,
    charTypeTag,
    floatTypeTag,
    hasNoAllocations,
    -- pseudo data stuff
    inflateMap,
    deflateMap,
    -- local foreigns that get wrapped
    HashAlgorithm (..),
    Tls (..),
  )
where

import Control.Concurrent (MVar, ThreadId)
import Control.Concurrent.STM (TVar)
import Control.Exception (evaluate, throw, throwIO)
import Control.Monad.Primitive
import Control.Monad.State.Strict (StateT (..))
-- import for `Foreign` section
import Crypto.Hash qualified as Hash
import Data.Atomics qualified as Atomic
import Data.Bits (clearBit)
import Data.Char qualified as Char
import Data.Functor.Classes (Eq1 (..), Ord1 (..))
import Data.IORef (IORef)
import Data.Map.Strict.Internal (Map (..))
import Data.Ord (comparing)
import Data.Primitive (sizeOf)
import Data.Primitive.ByteArray qualified as BA
import Data.Tagged (Tagged (..))
import Data.Word
import Data.X509 qualified as X509
import Foreign.Ptr qualified as Ptr
import GHC.Base
import GHC.Exts as L (IsList (..))
import Language.Haskell.TH qualified as TH
import Network.Socket (Socket)
import Network.TLS qualified as TLS (ClientParams, Context, ServerParams)
import Network.UDP (ClientSockAddr, ListenSocket, UDPSocket)
import Numeric.Natural (Natural)
import System.Clock (TimeSpec)
import System.IO (Handle)
import System.IO.Unsafe (unsafePerformIO)
import System.Mem.StableName (makeStableName)
import System.Process (ProcessHandle)
import Test.Inspection qualified as TI
import Unison.Builtin.Decls as Ty hiding
  ( tlsPrivateKeyRef,
    tlsSignedCertRef,
  )
import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import Unison.Runtime.ANF (Code, PackedTag, Value, maskTags)
import Unison.Runtime.Array as PA
import Unison.Runtime.FFI.DLL
import Unison.Runtime.Foreign.Dynamic
import Unison.Runtime.MCode
import Unison.Runtime.Referenced (Referenced, dereference)
import Unison.Runtime.TypeTags qualified as TT
import Unison.Type qualified as Ty
import Unison.Util.Bytes (Bytes)
import Unison.Util.EnumContainers as EC
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.RefPromise (Promise)
import Unison.Util.Text qualified as U
import Unison.Util.Text.Pattern (CPattern, CharPattern)
import Prelude hiding (words)

#ifdef STACK_CHECK
type DebugCallStack = (HasCallStack :: Constraint)

unboxedSentinel :: Int
unboxedSentinel = -99

boxedSentinel :: Closure
boxedSentinel = (Closure GUnboxedSentinel)

assertBumped :: HasCallStack => Stack -> Off -> IO ()
assertBumped (Stack _ _ sp ustk bstk) i = do
  u <- readByteArray ustk (sp - i)
  b :: BVal <- readArray bstk (sp - i)
  when (u /= unboxedSentinel || not (isBoxedSentinel b)) do
            error $ "Expected stack slot to have been bumped, but it was:" <> show (Val u b)
  where
    isBoxedSentinel :: Closure -> Bool
    isBoxedSentinel (Closure GUnboxedSentinel) = True
    isBoxedSentinel _ = False

assertUnboxed :: HasCallStack => Stack -> Off -> IO ()
assertUnboxed (Stack _ _ sp ustk bstk) i = do
  (u :: Int) <- readByteArray ustk (sp - i)
  b <- readArray bstk (sp - i)
  case b of
    UnboxedTypeTag _ -> pure ()
    _ -> error $ "Expected stack val to be unboxed, but it was:" <> show (Val u b)

pokeSentinelOff :: Stack -> Off -> IO ()
pokeSentinelOff (Stack _ _ sp ustk bstk) off = do
  writeByteArray ustk (sp - off) unboxedSentinel
  writeArray bstk (sp - off) boxedSentinel
#else
-- Don't track callstacks in production, it's expensive
type DebugCallStack = (() :: Constraint)
#endif

newtype Callback = Hook (XStack -> IO ())

instance Eq Callback where Callback
_ == :: Callback -> Callback -> Bool
== Callback
_ = Bool
True

instance Ord Callback where compare :: Callback -> Callback -> Ordering
compare Callback
_ Callback
_ = Ordering
EQ

-- Evaluation stack
data K
  = KE
  | -- callback hook
    CB Callback
  | -- mark continuation with affine prompt
    AMark
      !Int -- pending args
      AEnv -- saved handler environment; intentionally lazy
      !AffineRef -- updateable reference for handler
      !K
  | -- mark continuation with a prompt
    Mark
      !Int -- pending args
      !(EnumSet Word64)
      DEnv -- saved shadowed handlers; intentionally lazy
      !K
  | -- save information about a frame for later resumption
    Push
      !Int -- frame size
      !Int -- pending args
      !CombIx -- resumption section reference
      !Int -- stack guard
      !(RSection Val) -- resumption section
      !K
  | -- saved context during affine handler
    Local
      HEnv -- stored environment; intentionally lazy
      !Int -- pending args
      !K
  | -- holds onto a reference to something to avoid garbage collection
    forall a.
    Keep
      !a -- retained value
      !Int -- pending args
      !K

newtype Closure = Closure {BVal -> GClosure (RComb Val)
unClosure :: (GClosure (RComb Val))}
  deriving stock (Size -> BVal -> ShowS
[BVal] -> ShowS
BVal -> [Char]
(Size -> BVal -> ShowS)
-> (BVal -> [Char]) -> ([BVal] -> ShowS) -> Show BVal
forall a.
(Size -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Size -> BVal -> ShowS
showsPrec :: Size -> BVal -> ShowS
$cshow :: BVal -> [Char]
show :: BVal -> [Char]
$cshowList :: [BVal] -> ShowS
showList :: [BVal] -> ShowS
Show)

-- A handler is 'affine' if its action does not change the structure
-- of the stack except possibly by truncation to that handler. The two
-- scenarios that satisfy this are:
--
--   1. Exception-like handlers that never resume the continuation
--      (this is the truncation case).
--   2. Handlers that call the continuation _in tail position_ and
--      also _with an (affine) handler for the same abilities_. The
--      simplest case is when a handler calls itself recursively to
--      implement a "deep" handler.
--
-- The advantage of affine handlers is that they do not need to be
-- implemented by continuation capture. Case 1 can be implemented by
-- simply _discarding_ the continuation. For case 2, as long as all
-- handlers are affine, it is sufficient to simply keep track of the
-- current state of each handler, and the local environment the
-- handler executes in. The restrictions ensure that these don't
-- change in an arbitrary way—just by stateful updates.
--
-- Non-affine handlers spoil this when they are higher in the stack,
-- because they could change the dynamic environment of handlers below
-- them, and it is no longer simple to properly update the state in
-- place. Possibly this could be handled by modifying affine handler
-- state when reinstating copied continuations in the future.
--
-- If we arrange things such that we use affine versions of handlers
-- until a non-affine one is installed, then we can avoid affine
-- handlers ever being captured in a continuation. This lets us avoid
-- issues with equality of mutable references for efficient affine
-- implementation.
--
-- The calling convention for affine handlers takes an extra argument
-- which enables using associated operations.
type AEnv = EnumMap Word64 AffineRef

-- dynamic environment
type DEnv = EnumMap Word64 Val

-- Handler environment.
--
-- Note: the fields are intentionally not strict. This seems to yield
-- better performance. At a guess, strict fields and being strict in
-- the HEnv requires GHC to emit forcing instructions that cause
-- overhead.
--
-- Instead, components are passed `evaluate` locally when built, or
-- similar.
data HEnv = HEnv {HEnv -> AEnv
aenv :: AEnv, HEnv -> DEnv
denv :: DEnv}

instance Semigroup HEnv where
  HEnv AEnv
la DEnv
ld <> :: HEnv -> HEnv -> HEnv
<> HEnv AEnv
ra DEnv
rd = AEnv -> DEnv -> HEnv
HEnv (AEnv
la AEnv -> AEnv -> AEnv
forall a. Semigroup a => a -> a -> a
<> AEnv
ra) (DEnv
ld DEnv -> DEnv -> DEnv
forall a. Semigroup a => a -> a -> a
<> DEnv
rd)

instance Monoid HEnv where
  mempty :: HEnv
mempty = AEnv -> DEnv -> HEnv
HEnv AEnv
forall a. Monoid a => a
mempty DEnv
forall a. Monoid a => a
mempty
  mappend :: HEnv -> HEnv -> HEnv
mappend = HEnv -> HEnv -> HEnv
forall a. Semigroup a => a -> a -> a
(<>)

-- | Implementation for Unison sequences.
type USeq = Seq Val

type IxClosure = GClosure CombIx

-- Don't re-order these, the ord instance affects Universal.compare
data UnboxedTypeTag
  = CharTag
  | FloatTag
  | IntTag
  | NatTag
  deriving stock (Size -> UnboxedTypeTag -> ShowS
[UnboxedTypeTag] -> ShowS
UnboxedTypeTag -> [Char]
(Size -> UnboxedTypeTag -> ShowS)
-> (UnboxedTypeTag -> [Char])
-> ([UnboxedTypeTag] -> ShowS)
-> Show UnboxedTypeTag
forall a.
(Size -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Size -> UnboxedTypeTag -> ShowS
showsPrec :: Size -> UnboxedTypeTag -> ShowS
$cshow :: UnboxedTypeTag -> [Char]
show :: UnboxedTypeTag -> [Char]
$cshowList :: [UnboxedTypeTag] -> ShowS
showList :: [UnboxedTypeTag] -> ShowS
Show, UnboxedTypeTag -> UnboxedTypeTag -> Bool
(UnboxedTypeTag -> UnboxedTypeTag -> Bool)
-> (UnboxedTypeTag -> UnboxedTypeTag -> Bool) -> Eq UnboxedTypeTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
== :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
$c/= :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
/= :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
Eq, Eq UnboxedTypeTag
Eq UnboxedTypeTag =>
(UnboxedTypeTag -> UnboxedTypeTag -> Ordering)
-> (UnboxedTypeTag -> UnboxedTypeTag -> Bool)
-> (UnboxedTypeTag -> UnboxedTypeTag -> Bool)
-> (UnboxedTypeTag -> UnboxedTypeTag -> Bool)
-> (UnboxedTypeTag -> UnboxedTypeTag -> Bool)
-> (UnboxedTypeTag -> UnboxedTypeTag -> UnboxedTypeTag)
-> (UnboxedTypeTag -> UnboxedTypeTag -> UnboxedTypeTag)
-> Ord UnboxedTypeTag
UnboxedTypeTag -> UnboxedTypeTag -> Bool
UnboxedTypeTag -> UnboxedTypeTag -> Ordering
UnboxedTypeTag -> UnboxedTypeTag -> UnboxedTypeTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnboxedTypeTag -> UnboxedTypeTag -> Ordering
compare :: UnboxedTypeTag -> UnboxedTypeTag -> Ordering
$c< :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
< :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
$c<= :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
<= :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
$c> :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
> :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
$c>= :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
>= :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
$cmax :: UnboxedTypeTag -> UnboxedTypeTag -> UnboxedTypeTag
max :: UnboxedTypeTag -> UnboxedTypeTag -> UnboxedTypeTag
$cmin :: UnboxedTypeTag -> UnboxedTypeTag -> UnboxedTypeTag
min :: UnboxedTypeTag -> UnboxedTypeTag -> UnboxedTypeTag
Ord)

unboxedTypeTagToInt :: UnboxedTypeTag -> Int
unboxedTypeTagToInt :: UnboxedTypeTag -> Size
unboxedTypeTagToInt = \case
  UnboxedTypeTag
CharTag -> Size
0
  UnboxedTypeTag
FloatTag -> Size
1
  UnboxedTypeTag
IntTag -> Size
2
  UnboxedTypeTag
NatTag -> Size
3

unboxedTypeTagFromInt :: (HasCallStack) => Int -> UnboxedTypeTag
unboxedTypeTagFromInt :: HasCallStack => Size -> UnboxedTypeTag
unboxedTypeTagFromInt = \case
  Size
0 -> UnboxedTypeTag
CharTag
  Size
1 -> UnboxedTypeTag
FloatTag
  Size
2 -> UnboxedTypeTag
IntTag
  Size
3 -> UnboxedTypeTag
NatTag
  Size
_ -> [Char] -> UnboxedTypeTag
forall a. HasCallStack => [Char] -> a
error [Char]
"intToUnboxedTypeTag: invalid tag"

data GClosure comb
  = GPAp
      !CombIx
      {-# UNPACK #-} !(GCombInfo comb)
      -- | args
      {-# UNPACK #-} !Seg
  | GEnum !Reference !PackedTag
  | GData1 !Reference !PackedTag !Val
  | GData2 !Reference !PackedTag !Val !Val
  | GDataG !Reference !PackedTag {-# UNPACK #-} !Seg
  | GCaptured
      -- | code cont
      !K
      -- | arg size
      !Int
      -- | u/b data stacks
      {-# UNPACK #-} !Seg
  | GForeign !Foreign
  | -- | The type tag for the value in the corresponding unboxed stack slot.
    --
    --   We should consider adding separate constructors for common builtin type tags.
    --   GHC will optimize nullary constructors into singletons.
    GUnboxedTypeTag !UnboxedTypeTag
  | GAffine
      -- | associated ability numbers
      !(EnumSet Word64)
      -- | original handler environment
      !AEnv
      -- | updateable reference
      !AffineRef
  | GBlackHole
#ifdef STACK_CHECK
  | GUnboxedSentinel
#endif

-- These derived instances are standalone to avoid needing to disable Ormolu for the data declaration above.

deriving stock instance (Show comb) => Show (GClosure comb)

deriving stock instance Functor GClosure

deriving stock instance Foldable GClosure

deriving stock instance Traversable GClosure

-- Wrap IORef to get a trivial `Show` instance
newtype AffineRef = ARef (IORef Closure) deriving (AffineRef -> AffineRef -> Bool
(AffineRef -> AffineRef -> Bool)
-> (AffineRef -> AffineRef -> Bool) -> Eq AffineRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AffineRef -> AffineRef -> Bool
== :: AffineRef -> AffineRef -> Bool
$c/= :: AffineRef -> AffineRef -> Bool
/= :: AffineRef -> AffineRef -> Bool
Eq)

instance Show AffineRef where
  show :: AffineRef -> [Char]
show AffineRef
_ = [Char]
"<AffineRef>"

-- Singleton black hole value to avoid allocation.
blackHole :: Closure
blackHole :: BVal
blackHole = GClosure (RComb Val) -> BVal
Closure GClosure (RComb Val)
forall comb. GClosure comb
GBlackHole
{-# NOINLINE blackHole #-}

pattern PAp :: CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
pattern $mPAp :: forall {r}.
BVal
-> (CombIx -> GCombInfo (RComb Val) -> Seg -> r)
-> ((# #) -> r)
-> r
$bPAp :: CombIx -> GCombInfo (RComb Val) -> Seg -> BVal
PAp cix comb seg = Closure (GPAp cix comb seg)

pattern Enum :: Reference -> PackedTag -> Closure
pattern $mEnum :: forall {r}.
BVal -> (Reference -> PackedTag -> r) -> ((# #) -> r) -> r
$bEnum :: Reference -> PackedTag -> BVal
Enum r t = Closure (GEnum r t)

pattern $mData1 :: forall {r}.
BVal -> (Reference -> PackedTag -> Val -> r) -> ((# #) -> r) -> r
$bData1 :: Reference -> PackedTag -> Val -> BVal
Data1 r t i = Closure (GData1 r t i)

pattern $mData2 :: forall {r}.
BVal
-> (Reference -> PackedTag -> Val -> Val -> r) -> ((# #) -> r) -> r
$bData2 :: Reference -> PackedTag -> Val -> Val -> BVal
Data2 r t i j = Closure (GData2 r t i j)

pattern $mDataG :: forall {r}.
BVal -> (Reference -> PackedTag -> Seg -> r) -> ((# #) -> r) -> r
$bDataG :: Reference -> PackedTag -> Seg -> BVal
DataG r t seg = Closure (GDataG r t seg)

pattern $mCaptured :: forall {r}. BVal -> (K -> Size -> Seg -> r) -> ((# #) -> r) -> r
$bCaptured :: K -> Size -> Seg -> BVal
Captured k a seg = Closure (GCaptured k a seg)

pattern $mForeign :: forall {r}. BVal -> (Foreign -> r) -> ((# #) -> r) -> r
$bForeign :: Foreign -> BVal
Foreign x = Closure (GForeign x)

pattern $mAffine :: forall {r}.
BVal
-> (EnumSet Word64 -> AEnv -> AffineRef -> r) -> ((# #) -> r) -> r
$bAffine :: EnumSet Word64 -> AEnv -> AffineRef -> BVal
Affine ps aenv r = Closure (GAffine ps aenv r)

pattern $mBlackHole :: forall {r}. BVal -> ((# #) -> r) -> ((# #) -> r) -> r
$bBlackHole :: BVal
BlackHole <- Closure GBlackHole
  where
    BlackHole = BVal
blackHole

pattern $mUnboxedTypeTag :: forall {r}. BVal -> (UnboxedTypeTag -> r) -> ((# #) -> r) -> r
$bUnboxedTypeTag :: UnboxedTypeTag -> BVal
UnboxedTypeTag t <- Closure (GUnboxedTypeTag t)
  where
    UnboxedTypeTag UnboxedTypeTag
t = case UnboxedTypeTag
t of
      UnboxedTypeTag
CharTag -> BVal
charTypeTag
      UnboxedTypeTag
FloatTag -> BVal
floatTypeTag
      UnboxedTypeTag
IntTag -> BVal
intTypeTag
      UnboxedTypeTag
NatTag -> BVal
natTypeTag

{-# COMPLETE PAp, Enum, Data1, Data2, DataG, Captured, Foreign, UnboxedTypeTag, BlackHole, Affine #-}

{-# COMPLETE DataC, PAp, Captured, Foreign, BlackHole, UnboxedTypeTag, Affine #-}

{-# COMPLETE DataC, PApV, Captured, Foreign, BlackHole, UnboxedTypeTag, Affine #-}

{-# COMPLETE DataC, PApV, CapV, Foreign, BlackHole, UnboxedTypeTag, Affine #-}

-- We can avoid allocating a closure for common type tags on each poke by having shared top-level closures for them.
natTypeTag :: Closure
natTypeTag :: BVal
natTypeTag = (GClosure (RComb Val) -> BVal
Closure (UnboxedTypeTag -> GClosure (RComb Val)
forall comb. UnboxedTypeTag -> GClosure comb
GUnboxedTypeTag UnboxedTypeTag
NatTag))
{-# NOINLINE natTypeTag #-}

intTypeTag :: Closure
intTypeTag :: BVal
intTypeTag = (GClosure (RComb Val) -> BVal
Closure (UnboxedTypeTag -> GClosure (RComb Val)
forall comb. UnboxedTypeTag -> GClosure comb
GUnboxedTypeTag UnboxedTypeTag
IntTag))
{-# NOINLINE intTypeTag #-}

charTypeTag :: Closure
charTypeTag :: BVal
charTypeTag = (GClosure (RComb Val) -> BVal
Closure (UnboxedTypeTag -> GClosure (RComb Val)
forall comb. UnboxedTypeTag -> GClosure comb
GUnboxedTypeTag UnboxedTypeTag
CharTag))
{-# NOINLINE charTypeTag #-}

floatTypeTag :: Closure
floatTypeTag :: BVal
floatTypeTag = (GClosure (RComb Val) -> BVal
Closure (UnboxedTypeTag -> GClosure (RComb Val)
forall comb. UnboxedTypeTag -> GClosure comb
GUnboxedTypeTag UnboxedTypeTag
FloatTag))
{-# NOINLINE floatTypeTag #-}

traceK :: Reference -> K -> [(Reference, Int)]
traceK :: Reference -> K -> [(Reference, Size)]
traceK Reference
begin = (Reference, Size) -> K -> [(Reference, Size)]
forall {b}. Num b => (Reference, b) -> K -> [(Reference, b)]
dedup (Reference
begin, Size
1)
  where
    dedup :: (Reference, b) -> K -> [(Reference, b)]
dedup (Reference, b)
p (Mark Size
_ EnumSet Word64
_ DEnv
_ K
k) = (Reference, b) -> K -> [(Reference, b)]
dedup (Reference, b)
p K
k
    dedup p :: (Reference, b)
p@(Reference
cur, b
n) (Push Size
_ Size
_ (CIx Reference
r Word64
_ Word64
_) Size
_ RSection Val
_ K
k)
      | Reference
cur Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
r = (Reference, b) -> K -> [(Reference, b)]
dedup (Reference
cur, b
1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
n) K
k
      | Bool
otherwise = (Reference, b)
p (Reference, b) -> [(Reference, b)] -> [(Reference, b)]
forall a. a -> [a] -> [a]
: (Reference, b) -> K -> [(Reference, b)]
dedup (Reference
r, b
1) K
k
    dedup (Reference, b)
p K
_ = [(Reference, b)
p]

splitData :: Closure -> Maybe (Reference, PackedTag, SegList)
splitData :: BVal -> Maybe (Reference, PackedTag, [Val])
splitData = \case
  (Enum Reference
r PackedTag
t) -> (Reference, PackedTag, [Val])
-> Maybe (Reference, PackedTag, [Val])
forall a. a -> Maybe a
Just (Reference
r, PackedTag
t, [])
  (Data1 Reference
r PackedTag
t Val
u) -> (Reference, PackedTag, [Val])
-> Maybe (Reference, PackedTag, [Val])
forall a. a -> Maybe a
Just (Reference
r, PackedTag
t, [Val
u])
  (Data2 Reference
r PackedTag
t Val
i Val
j) -> (Reference, PackedTag, [Val])
-> Maybe (Reference, PackedTag, [Val])
forall a. a -> Maybe a
Just (Reference
r, PackedTag
t, [Val
i, Val
j])
  (DataG Reference
r PackedTag
t Seg
seg) -> (Reference, PackedTag, [Val])
-> Maybe (Reference, PackedTag, [Val])
forall a. a -> Maybe a
Just (Reference
r, PackedTag
t, Seg -> [Val]
segToList Seg
seg)
  BVal
_ -> Maybe (Reference, PackedTag, [Val])
forall a. Maybe a
Nothing

closureTag :: Closure -> PackedTag
closureTag :: BVal -> PackedTag
closureTag (Enum Reference
_ PackedTag
t) = PackedTag
t
closureTag (Data1 Reference
_ PackedTag
t Val
_) = PackedTag
t
closureTag (Data2 Reference
_ PackedTag
t Val
_ Val
_) = PackedTag
t
closureTag (DataG Reference
_ PackedTag
t Seg
_) = PackedTag
t
closureTag BVal
c =
  RuntimePanic -> PackedTag
forall a e. Exception e => e -> a
throw (RuntimePanic -> PackedTag) -> RuntimePanic -> PackedTag
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe Val -> RuntimePanic
Panic [Char]
"closureTag: unexpected closure" (Val -> Maybe Val
forall a. a -> Maybe a
Just (Val -> Maybe Val) -> Val -> Maybe Val
forall a b. (a -> b) -> a -> b
$ BVal -> Val
BoxedVal BVal
c)
{-# INLINE closureTag #-}

-- | Converts a list of integers representing an unboxed segment back into the
-- appropriate segment. Segments are stored backwards in the runtime, so this
-- reverses the list.
useg :: [Int] -> USeg
useg :: [Size] -> ByteArray
useg [Size]
ws = case [Item (PrimArray Size)] -> PrimArray Size
forall l. IsList l => [Item l] -> l
L.fromList ([Item (PrimArray Size)] -> PrimArray Size)
-> [Item (PrimArray Size)] -> PrimArray Size
forall a b. (a -> b) -> a -> b
$ [Size] -> [Size]
forall a. [a] -> [a]
reverse [Size]
ws of
  PrimArray ByteArray#
ba -> ByteArray# -> ByteArray
ByteArray ByteArray#
ba

-- | Converts a boxed segment to a list of closures. The segments are stored
-- backwards, so this reverses the contents.
bsegToList :: BSeg -> [Closure]
bsegToList :: BSeg -> [BVal]
bsegToList = [BVal] -> [BVal]
forall a. [a] -> [a]
reverse ([BVal] -> [BVal]) -> (BSeg -> [BVal]) -> BSeg -> [BVal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BSeg -> [Item BSeg]
BSeg -> [BVal]
forall l. IsList l => l -> [Item l]
L.toList

-- | Converts a list of closures back to a boxed segment. Segments are stored
-- backwards, so this reverses the contents.
bseg :: [Closure] -> BSeg
bseg :: [BVal] -> BSeg
bseg = [Item BSeg] -> BSeg
[BVal] -> BSeg
forall l. IsList l => [Item l] -> l
L.fromList ([BVal] -> BSeg) -> ([BVal] -> [BVal]) -> [BVal] -> BSeg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BVal] -> [BVal]
forall a. [a] -> [a]
reverse

formData :: Reference -> PackedTag -> SegList -> Closure
formData :: Reference -> PackedTag -> [Val] -> BVal
formData Reference
r PackedTag
t [] = Reference -> PackedTag -> BVal
Enum Reference
r PackedTag
t
formData Reference
r PackedTag
t [Val
v1] = Reference -> PackedTag -> Val -> BVal
Data1 Reference
r PackedTag
t Val
v1
formData Reference
r PackedTag
t [Val
v1, Val
v2] = Reference -> PackedTag -> Val -> Val -> BVal
Data2 Reference
r PackedTag
t Val
v1 Val
v2
formData Reference
r PackedTag
t [Val]
segList = Reference -> PackedTag -> Seg -> BVal
DataG Reference
r PackedTag
t ([Val] -> Seg
segFromList [Val]
segList)

formDataSeg :: Reference -> PackedTag -> Seg -> Closure
formDataSeg :: Reference -> PackedTag -> Seg -> BVal
formDataSeg Reference
r PackedTag
t (ByteArray
usg, BSeg
bsg) = case BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
bsg of
  Size
0 -> Reference -> PackedTag -> BVal
Enum Reference
r PackedTag
t
  Size
1 -> Reference -> PackedTag -> Val -> BVal
Data1 Reference
r PackedTag
t (Size -> BVal -> Val
Val (ByteArray -> Size -> Size
forall a. (() :: Constraint, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
usg Size
0) (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
0))
  Size
2 ->
    Reference -> PackedTag -> Val -> Val -> BVal
Data2
      Reference
r
      PackedTag
t
      (Size -> BVal -> Val
Val (ByteArray -> Size -> Size
forall a. (() :: Constraint, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
usg Size
1) (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
1))
      (Size -> BVal -> Val
Val (ByteArray -> Size -> Size
forall a. (() :: Constraint, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
usg Size
0) (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
0))
  Size
_ -> Reference -> PackedTag -> Seg -> BVal
DataG Reference
r PackedTag
t (ByteArray
usg, BSeg
bsg)
{-# INLINE formDataSeg #-}

-- Build a data type, but apply replacements
formDataReplaced :: Reference -> PackedTag -> Seg -> Closure
formDataReplaced :: Reference -> PackedTag -> Seg -> BVal
formDataReplaced Reference
r PackedTag
t sg :: Seg
sg@(ByteArray
usg, BSeg
bsg)
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.mapTipTag = case BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
bsg of
      Size
0 -> BVal
tipClosure
      Size
_ -> [Char] -> BVal
forall a. HasCallStack => [Char] -> a
error [Char]
"formDataReplaced: bad `Map`"
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.mapBinTag = case BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
bsg of
      Size
5
        | !BVal
bk <- BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
3,
          !Size
uk <- ByteArray -> Size -> Size
forall a. (() :: Constraint, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
usg Size
3,
          !BVal
bv <- BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
2,
          !Size
uv <- ByteArray -> Size -> Size
forall a. (() :: Constraint, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
usg Size
2,
          Foreign Foreign
l <- BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
1,
          Just (Map Val Val
ul :: Map Val Val) <- Foreign -> Maybe (Map Val Val)
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
l,
          Foreign Foreign
r <- BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
0,
          Just (Map Val Val
ur :: Map Val Val) <- Foreign -> Maybe (Map Val Val)
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
r,
          Size
sz <- ByteArray -> Size -> Size
forall a. (() :: Constraint, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
usg Size
4,
          Closure (GUnboxedTypeTag UnboxedTypeTag
NatTag) <- BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
4 ->
            Foreign -> BVal
Foreign (Foreign -> BVal)
-> (Map Val Val -> Foreign) -> Map Val Val -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Val Val -> Foreign
WrapMap (Map Val Val -> BVal) -> Map Val Val -> BVal
forall a b. (a -> b) -> a -> b
$
              Size -> Val -> Val -> Map Val Val -> Map Val Val -> Map Val Val
forall k a. Size -> k -> a -> Map k a -> Map k a -> Map k a
Bin Size
sz (Size -> BVal -> Val
Val Size
uk BVal
bk) (Size -> BVal -> Val
Val Size
uv BVal
bv) Map Val Val
ul Map Val Val
ur
      Size
_ -> [Char] -> BVal
forall a. HasCallStack => [Char] -> a
error [Char]
"formDataReplaced: bad `Map`"
  | Bool
otherwise = Reference -> PackedTag -> Seg -> BVal
formDataSeg Reference
r PackedTag
t Seg
sg

tipClosure :: Closure
tipClosure :: BVal
tipClosure = Foreign -> BVal
Foreign (Foreign -> BVal) -> Foreign -> BVal
forall a b. (a -> b) -> a -> b
$ Map Val Val -> Foreign
WrapMap Map Val Val
forall k a. Map k a
Tip

frameDataSize :: K -> Int
frameDataSize :: K -> Size
frameDataSize = Size -> K -> Size
go Size
0
  where
    go :: Size -> K -> Size
go Size
sz K
KE = Size
sz
    go Size
sz (CB Callback
_) = Size
sz
    go Size
sz (Mark Size
a EnumSet Word64
_ DEnv
_ K
k) = Size -> K -> Size
go (Size
sz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
a) K
k
    go Size
sz (Push Size
f Size
a CombIx
_ Size
_ RSection Val
_ K
k) =
      Size -> K -> Size
go (Size
sz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
f Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
a) K
k
    go Size
_ (Keep {}) =
      [Char] -> Size
forall a. HasCallStack => [Char] -> a
error [Char]
"frameDataSize: captured Keep frame"
    go Size
_ (Local {}) =
      [Char] -> Size
forall a. HasCallStack => [Char] -> a
error [Char]
"frameDataSize: captured Local frame"
    go Size
_ (AMark {}) =
      [Char] -> Size
forall a. HasCallStack => [Char] -> a
error [Char]
"frameDataSize: captured AMark frame"

pattern DataC :: Reference -> PackedTag -> SegList -> Closure
pattern $mDataC :: forall {r}.
BVal -> (Reference -> PackedTag -> [Val] -> r) -> ((# #) -> r) -> r
$bDataC :: Reference -> PackedTag -> [Val] -> BVal
DataC rf ct segs <-
  (splitData -> Just (rf, ct, segs))
  where
    DataC Reference
rf PackedTag
ct [Val]
segs = Reference -> PackedTag -> [Val] -> BVal
formData Reference
rf PackedTag
ct [Val]
segs

matchCharVal :: Val -> Maybe Char
matchCharVal :: Val -> Maybe Char
matchCharVal = \case
  (UnboxedVal Size
u UnboxedTypeTag
CharTag) -> Char -> Maybe Char
forall a. a -> Maybe a
Just (Size -> Char
Char.chr Size
u)
  Val
_ -> Maybe Char
forall a. Maybe a
Nothing

pattern CharVal :: Char -> Val
pattern $mCharVal :: forall {r}. Val -> (Char -> r) -> ((# #) -> r) -> r
$bCharVal :: Char -> Val
CharVal c <- (matchCharVal -> Just c)
  where
    CharVal Char
c = Size -> BVal -> Val
Val (Char -> Size
Char.ord Char
c) BVal
charTypeTag

matchNatVal :: Val -> Maybe Word64
matchNatVal :: Val -> Maybe Word64
matchNatVal = \case
  (UnboxedVal Size
u UnboxedTypeTag
NatTag) -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Size -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
u)
  Val
_ -> Maybe Word64
forall a. Maybe a
Nothing

pattern NatVal :: Word64 -> Val
pattern $mNatVal :: forall {r}. Val -> (Word64 -> r) -> ((# #) -> r) -> r
$bNatVal :: Word64 -> Val
NatVal n <- (matchNatVal -> Just n)
  where
    NatVal Word64
n = Size -> BVal -> Val
Val (Word64 -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) BVal
natTypeTag

matchDoubleVal :: Val -> Maybe Double
matchDoubleVal :: Val -> Maybe Double
matchDoubleVal = \case
  (UnboxedVal Size
u UnboxedTypeTag
FloatTag) -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Size -> Double
intToDouble Size
u)
  Val
_ -> Maybe Double
forall a. Maybe a
Nothing

pattern DoubleVal :: Double -> Val
pattern $mDoubleVal :: forall {r}. Val -> (Double -> r) -> ((# #) -> r) -> r
$bDoubleVal :: Double -> Val
DoubleVal d <- (matchDoubleVal -> Just d)
  where
    DoubleVal Double
d = Size -> BVal -> Val
Val (Double -> Size
doubleToInt Double
d) BVal
floatTypeTag

matchIntVal :: Val -> Maybe Int
matchIntVal :: Val -> Maybe Size
matchIntVal = \case
  (UnboxedVal Size
u UnboxedTypeTag
IntTag) -> Size -> Maybe Size
forall a. a -> Maybe a
Just Size
u
  Val
_ -> Maybe Size
forall a. Maybe a
Nothing

pattern IntVal :: Int -> Val
pattern $mIntVal :: forall {r}. Val -> (Size -> r) -> ((# #) -> r) -> r
$bIntVal :: Size -> Val
IntVal i <- (matchIntVal -> Just i)
  where
    IntVal Size
i = Size -> BVal -> Val
Val Size
i BVal
intTypeTag

matchBoolVal :: Val -> Maybe Bool
matchBoolVal :: Val -> Maybe Bool
matchBoolVal = \case
  (BoxedVal (Enum Reference
r PackedTag
t)) | Reference
r Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Ty.booleanRef -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.trueTag)
  Val
_ -> Maybe Bool
forall a. Maybe a
Nothing

pattern BoolVal :: Bool -> Val
pattern $mBoolVal :: forall {r}. Val -> (Bool -> r) -> ((# #) -> r) -> r
$bBoolVal :: Bool -> Val
BoolVal b <- (matchBoolVal -> Just b)
  where
    BoolVal Bool
b = if Bool
b then Val
trueVal else Val
falseVal

-- Define singletons we can use for the bools to prevent allocation where possible.
falseVal :: Val
falseVal :: Val
falseVal = BVal -> Val
BoxedVal (Reference -> PackedTag -> BVal
Enum Reference
Ty.booleanRef PackedTag
TT.falseTag)
{-# NOINLINE falseVal #-}

trueVal :: Val
trueVal :: Val
trueVal = BVal -> Val
BoxedVal (Reference -> PackedTag -> BVal
Enum Reference
Ty.booleanRef PackedTag
TT.trueTag)
{-# NOINLINE trueVal #-}

doubleToInt :: Double -> Int
doubleToInt :: Double -> Size
doubleToInt Double
d = ByteArray -> Size -> Size
forall a. (() :: Constraint, Prim a) => ByteArray -> Size -> a
indexByteArray ([Double] -> ByteArray
forall a. Prim a => [a] -> ByteArray
BA.byteArrayFromList [Double
d]) Size
0
{-# INLINE doubleToInt #-}

intToDouble :: Int -> Double
intToDouble :: Size -> Double
intToDouble Size
w = ByteArray -> Size -> Double
forall a. (() :: Constraint, Prim a) => ByteArray -> Size -> a
indexByteArray ([Size] -> ByteArray
forall a. Prim a => [a] -> ByteArray
BA.byteArrayFromList [Size
w]) Size
0
{-# INLINE intToDouble #-}

type SegList = [Val]

pattern PApV :: CombIx -> RCombInfo Val -> SegList -> Closure
pattern $mPApV :: forall {r}.
BVal
-> (CombIx -> GCombInfo (RComb Val) -> [Val] -> r)
-> ((# #) -> r)
-> r
$bPApV :: CombIx -> GCombInfo (RComb Val) -> [Val] -> BVal
PApV cix rcomb segs <-
  PAp cix rcomb (segToList -> segs)
  where
    PApV CombIx
cix GCombInfo (RComb Val)
rcomb [Val]
segs = CombIx -> GCombInfo (RComb Val) -> Seg -> BVal
PAp CombIx
cix GCombInfo (RComb Val)
rcomb ([Val] -> Seg
segFromList [Val]
segs)

pattern CapV :: K -> Int -> SegList -> Closure
pattern $mCapV :: forall {r}. BVal -> (K -> Size -> [Val] -> r) -> ((# #) -> r) -> r
$bCapV :: K -> Size -> [Val] -> BVal
CapV k a segs <- Captured k a (segToList -> segs)
  where
    CapV K
k Size
a [Val]
segList = K -> Size -> Seg -> BVal
Captured K
k Size
a ([Val] -> Seg
segFromList [Val]
segList)

-- | Converts from the efficient stack form of a segment to the list representation. Segments are stored backwards,
-- so this reverses the contents
segToList :: Seg -> SegList
segToList :: Seg -> [Val]
segToList (ByteArray
u, BSeg
b) =
  (Size -> BVal -> Val) -> [Size] -> [BVal] -> [Val]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Size -> BVal -> Val
Val (ByteArray -> [Size]
ints ByteArray
u) (BSeg -> [BVal]
bsegToList BSeg
b)

-- | Converts an unboxed segment to a list of integers for a more interchangeable
-- representation. The segments are stored in backwards order, so this reverses
-- the contents.
ints :: ByteArray -> [Int]
ints :: ByteArray -> [Size]
ints ByteArray
ba = (Size -> Size) -> [Size] -> [Size]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteArray -> Size -> Size
forall a. (() :: Constraint, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
ba) [Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1, Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
2 .. Size
0]
  where
    n :: Size
n = ByteArray -> Size
sizeofByteArray ByteArray
ba Size -> Size -> Size
forall a. Integral a => a -> a -> a
`div` Size
8

-- | Converts from the list representation of a segment to the efficient stack form. Segments are stored backwards,
-- so this reverses the contents.
segFromList :: SegList -> Seg
segFromList :: [Val] -> Seg
segFromList [Val]
xs =
  [Val]
xs
    [Val] -> ([Val] -> ([Size], [BVal])) -> ([Size], [BVal])
forall a b. a -> (a -> b) -> b
& (Val -> ([Size], [BVal])) -> [Val] -> ([Size], [BVal])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
      ( \(Val Size
unboxed BVal
boxed) -> ([Size
unboxed], [BVal
boxed])
      )
    ([Size], [BVal]) -> (([Size], [BVal]) -> Seg) -> Seg
forall a b. a -> (a -> b) -> b
& \([Size]
us, [BVal]
bs) -> ([Size] -> ByteArray
useg [Size]
us, [BVal] -> BSeg
bseg [BVal]
bs)

traverseListToSeg :: (a -> IO Val) -> [a] -> IO Seg
traverseListToSeg :: forall a. (a -> IO Val) -> [a] -> IO Seg
traverseListToSeg a -> IO Val
f [a]
src = do
  MutableByteArray RealWorld
udst <- Size -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Size -> m (MutableByteArray (PrimState m))
newByteArray (Size -> IO (MutableByteArray (PrimState IO)))
-> Size -> IO (MutableByteArray (PrimState IO))
forall a b. (a -> b) -> a -> b
$ Size -> Size
bytes Size
sz
  MutableArray RealWorld BVal
bdst <- Size -> BVal -> IO (MutableArray (PrimState IO) BVal)
forall (m :: * -> *) a.
PrimMonad m =>
Size -> a -> m (MutableArray (PrimState m) a)
newArray Size
sz BVal
BlackHole
  let fill :: Size -> [a] -> IO Seg
fill Size
_ [] = do
        ByteArray
udst <- MutableByteArray (PrimState IO) -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
udst
        BSeg
bdst <- MutableArray (PrimState IO) BVal -> IO BSeg
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
unsafeFreezeArray MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
bdst
        pure (ByteArray
udst, BSeg
bdst)
      fill Size
i (a
x : [a]
xs) = do
        Val Size
un BVal
bx <- a -> IO Val
f a
x
        MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
udst Size
i Size
un
        MutableArray (PrimState IO) BVal -> Size -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> a -> m ()
writeArray MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
bdst Size
i BVal
bx
        Size -> [a] -> IO Seg
fill (Size
i Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1) [a]
xs
  Size -> [a] -> IO Seg
fill (Size
sz Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1) [a]
src
  where
    sz :: Size
sz = [a] -> Size
forall a. [a] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [a]
src
{-# INLINE traverseListToSeg #-}

-- Note: this traverses the Seg left-to-right, which is backwards in
-- element terms. This is more efficient for building the correct
-- (reversed) list, but it means the effects happen in the opposite
-- order of the resulting values. This is not a problem for intended
-- uses, though, since the effect orders do not really matter.
traverseAccumSegToList ::
  (Val -> StateT s IO a) -> Seg -> StateT s IO [a]
traverseAccumSegToList :: forall s a. (Val -> StateT s IO a) -> Seg -> StateT s IO [a]
traverseAccumSegToList Val -> StateT s IO a
f (ByteArray
usrc, BSeg
bsrc) = (s -> IO ([a], s)) -> StateT s IO [a]
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT \s
s -> s -> [a] -> Size -> IO ([a], s)
go s
s [] Size
0
  where
    sz :: Size
sz = BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
bsrc

    go :: s -> [a] -> Size -> IO ([a], s)
go s
s [a]
xs Size
i
      | Size
i Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Size
sz = do
          let !un :: Size
un = ByteArray -> Size -> Size
forall a. (() :: Constraint, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
usrc Size
i
          BVal
bx <- BSeg -> Size -> IO BVal
forall (m :: * -> *) a. Monad m => Array a -> Size -> m a
indexArrayM BSeg
bsrc Size
i
          (a
x, s
s) <- StateT s IO a -> s -> IO (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Val -> StateT s IO a
f (Size -> BVal -> Val
Val Size
un BVal
bx)) s
s
          a
x <- a -> IO a
forall a. a -> IO a
evaluate a
x
          s -> [a] -> Size -> IO ([a], s)
go s
s (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs) (Size
i Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1)
      | Bool
otherwise = ([a], s) -> IO ([a], s)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
xs, s
s)
{-# INLINE traverseAccumSegToList #-}

data RuntimePanic = Panic String (Maybe Val)
  deriving (Size -> RuntimePanic -> ShowS
[RuntimePanic] -> ShowS
RuntimePanic -> [Char]
(Size -> RuntimePanic -> ShowS)
-> (RuntimePanic -> [Char])
-> ([RuntimePanic] -> ShowS)
-> Show RuntimePanic
forall a.
(Size -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Size -> RuntimePanic -> ShowS
showsPrec :: Size -> RuntimePanic -> ShowS
$cshow :: RuntimePanic -> [Char]
show :: RuntimePanic -> [Char]
$cshowList :: [RuntimePanic] -> ShowS
showList :: [RuntimePanic] -> ShowS
Show)

instance Exception RuntimePanic

marshalUnwrapForeignIO ::
  (HasCallStack, BuiltinForeign a) => Closure -> IO a
marshalUnwrapForeignIO :: forall a. (HasCallStack, BuiltinForeign a) => BVal -> IO a
marshalUnwrapForeignIO (Foreign Foreign
x) = Foreign -> IO a
forall a. (HasCallStack, BuiltinForeign a) => Foreign -> IO a
unwrapForeignIO Foreign
x
marshalUnwrapForeignIO BVal
c =
  RuntimePanic -> IO a
forall e a. Exception e => e -> IO a
throwIO (RuntimePanic -> IO a) -> RuntimePanic -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe Val -> RuntimePanic
Panic [Char]
"marshalUnwrapForeignIO: unhandled closure" (Val -> Maybe Val
forall a. a -> Maybe a
Just Val
v)
  where
    v :: Val
v = BVal -> Val
BoxedVal BVal
c

unwrapForeignIO ::
  forall a. (HasCallStack, BuiltinForeign a) => Foreign -> IO a
unwrapForeignIO :: forall a. (HasCallStack, BuiltinForeign a) => Foreign -> IO a
unwrapForeignIO Foreign
f = IO a -> (a -> IO a) -> Maybe a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO a
err a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO a) -> Maybe a -> IO a
forall a b. (a -> b) -> a -> b
$ Foreign -> Maybe a
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f
  where
    Tagged [Char]
exName = forall f. BuiltinForeign f => Tagged f [Char]
builtinName @a
    v :: Val
v = BVal -> Val
BoxedVal (Foreign -> BVal
Foreign Foreign
f)
    err :: IO a
err = RuntimePanic -> IO a
forall e a. Exception e => e -> IO a
throwIO (RuntimePanic -> IO a) -> RuntimePanic -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe Val -> RuntimePanic
Panic [Char]
msg (Val -> Maybe Val
forall a. a -> Maybe a
Just Val
v)
    msg :: [Char]
msg = [Char]
"unwrapForeignIO: expected `" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
exName [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"

type Off = Int

type SZ = Int

type FP = Int

type UA = MutableByteArray (PrimState IO)

type BA = MutableArray (PrimState IO) Closure

intSize :: Int
intSize :: Size
intSize = Size -> Size
forall a. Prim a => a -> Size
sizeOf (Size
0 :: Int)

words :: Int -> Int
words :: Size -> Size
words Size
n = Size
n Size -> Size -> Size
forall a. Integral a => a -> a -> a
`div` Size
intSize

bytes :: Int -> Int
bytes :: Size -> Size
bytes Size
n = Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
intSize

type Arrs = (UA, BA)

argOnto :: Arrs -> Off -> Arrs -> Off -> Args' -> IO Int
argOnto :: Arrs -> Size -> Arrs -> Size -> Args' -> IO Size
argOnto (MutableByteArray (PrimState IO)
srcUstk, MutableArray (PrimState IO) BVal
srcBstk) Size
srcSp (MutableByteArray (PrimState IO)
dstUstk, MutableArray (PrimState IO) BVal
dstBstk) Size
dstSp Args'
args = do
  -- Both new cp's should be the same, so we can just return one.
  Size
_cp <- MutableByteArray (PrimState IO)
-> Size
-> MutableByteArray (PrimState IO)
-> Size
-> Args'
-> IO Size
uargOnto MutableByteArray (PrimState IO)
srcUstk Size
srcSp MutableByteArray (PrimState IO)
dstUstk Size
dstSp Args'
args
  Size
cp <- MutableArray (PrimState IO) BVal
-> Size
-> MutableArray (PrimState IO) BVal
-> Size
-> Args'
-> IO Size
bargOnto MutableArray (PrimState IO) BVal
srcBstk Size
srcSp MutableArray (PrimState IO) BVal
dstBstk Size
dstSp Args'
args
  pure Size
cp

-- The Caller must ensure that when setting the unboxed stack, the equivalent
-- boxed stack is zeroed out to BlackHole where necessary.
uargOnto :: UA -> Off -> UA -> Off -> Args' -> IO Int
uargOnto :: MutableByteArray (PrimState IO)
-> Size
-> MutableByteArray (PrimState IO)
-> Size
-> Args'
-> IO Size
uargOnto MutableByteArray (PrimState IO)
stk Size
sp MutableByteArray (PrimState IO)
cop Size
cp0 (Arg1 Size
i) = do
  (Size
x :: Int) <- MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
stk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
cop Size
cp Size
x
  pure Size
cp
  where
    cp :: Size
cp = Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1
uargOnto MutableByteArray (PrimState IO)
stk Size
sp MutableByteArray (PrimState IO)
cop Size
cp0 (Arg2 Size
i Size
j) = do
  (Size
x :: Int) <- MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
stk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
  (Size
y :: Int) <- MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
stk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
j)
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
cop Size
cp Size
x
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
cop (Size
cp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1) Size
y
  pure Size
cp
  where
    cp :: Size
cp = Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
2
uargOnto MutableByteArray (PrimState IO)
stk Size
sp MutableByteArray (PrimState IO)
cop Size
cp0 (ArgN PrimArray Size
v) = do
  MutableByteArray RealWorld
buf <-
    if Bool
overwrite
      then Size -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Size -> m (MutableByteArray (PrimState m))
newByteArray (Size -> IO (MutableByteArray (PrimState IO)))
-> Size -> IO (MutableByteArray (PrimState IO))
forall a b. (a -> b) -> a -> b
$ Size -> Size
bytes Size
sz
      else MutableByteArray RealWorld -> IO (MutableByteArray RealWorld)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutableByteArray RealWorld
MutableByteArray (PrimState IO)
cop
  let loop :: Size -> IO ()
loop Size
i
        | Size
i Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Size
0 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise = do
            (Size
x :: Int) <- MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
stk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- PrimArray Size -> Size -> Size
forall a. (() :: Constraint, Prim a) => PrimArray a -> Size -> a
indexPrimArray PrimArray Size
v Size
i)
            MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
buf (Size
boff Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i) Size
x
            Size -> IO ()
loop (Size -> IO ()) -> Size -> IO ()
forall a b. (a -> b) -> a -> b
$ Size
i Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1
  Size -> IO ()
loop (Size -> IO ()) -> Size -> IO ()
forall a b. (a -> b) -> a -> b
$ Size
sz Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
overwrite (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    MutableByteArray (PrimState IO)
-> Size -> MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Size -> MutableByteArray (PrimState m) -> Size -> Size -> m ()
copyMutableByteArray MutableByteArray (PrimState IO)
cop (Size -> Size
bytes (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) MutableByteArray RealWorld
MutableByteArray (PrimState IO)
buf Size
0 (Size -> Size
bytes Size
sz)
  pure Size
cp
  where
    cp :: Size
cp = Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
sz
    sz :: Size
sz = PrimArray Size -> Size
forall a. Prim a => PrimArray a -> Size
sizeofPrimArray PrimArray Size
v
    overwrite :: Bool
overwrite = MutableByteArray RealWorld -> MutableByteArray RealWorld -> Bool
forall s. MutableByteArray s -> MutableByteArray s -> Bool
sameMutableByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
stk MutableByteArray RealWorld
MutableByteArray (PrimState IO)
cop
    boff :: Size
boff | Bool
overwrite = Size
sz Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1 | Bool
otherwise = Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
sz
uargOnto MutableByteArray (PrimState IO)
stk Size
sp MutableByteArray (PrimState IO)
cop Size
cp0 (ArgR Size
i Size
l) = do
  MutableByteArray (PrimState IO)
-> Size -> MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Size -> MutableByteArray (PrimState m) -> Size -> Size -> m ()
moveByteArray MutableByteArray (PrimState IO)
cop Size
cbp MutableByteArray (PrimState IO)
stk Size
sbp (Size -> Size
bytes Size
l)
  pure $ Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
l
  where
    cbp :: Size
cbp = Size -> Size
bytes (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1
    sbp :: Size
sbp = Size -> Size
bytes (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
l Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1

bargOnto :: BA -> Off -> BA -> Off -> Args' -> IO Int
bargOnto :: MutableArray (PrimState IO) BVal
-> Size
-> MutableArray (PrimState IO) BVal
-> Size
-> Args'
-> IO Size
bargOnto MutableArray (PrimState IO) BVal
stk Size
sp MutableArray (PrimState IO) BVal
cop Size
cp0 (Arg1 Size
i) = do
  BVal
x <- MutableArray (PrimState IO) BVal -> Size -> IO BVal
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> m a
readArray MutableArray (PrimState IO) BVal
stk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
  MutableArray (PrimState IO) BVal -> Size -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> a -> m ()
writeArray MutableArray (PrimState IO) BVal
cop Size
cp BVal
x
  pure Size
cp
  where
    cp :: Size
cp = Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1
bargOnto MutableArray (PrimState IO) BVal
stk Size
sp MutableArray (PrimState IO) BVal
cop Size
cp0 (Arg2 Size
i Size
j) = do
  BVal
x <- MutableArray (PrimState IO) BVal -> Size -> IO BVal
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> m a
readArray MutableArray (PrimState IO) BVal
stk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
  BVal
y <- MutableArray (PrimState IO) BVal -> Size -> IO BVal
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> m a
readArray MutableArray (PrimState IO) BVal
stk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
j)
  MutableArray (PrimState IO) BVal -> Size -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> a -> m ()
writeArray MutableArray (PrimState IO) BVal
cop Size
cp BVal
x
  MutableArray (PrimState IO) BVal -> Size -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> a -> m ()
writeArray MutableArray (PrimState IO) BVal
cop (Size
cp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1) BVal
y
  pure Size
cp
  where
    cp :: Size
cp = Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
2
bargOnto MutableArray (PrimState IO) BVal
stk Size
sp MutableArray (PrimState IO) BVal
cop Size
cp0 (ArgN PrimArray Size
v) = do
  MutableArray RealWorld BVal
buf <-
    if Bool
overwrite
      then Size -> BVal -> IO (MutableArray (PrimState IO) BVal)
forall (m :: * -> *) a.
PrimMonad m =>
Size -> a -> m (MutableArray (PrimState m) a)
newArray Size
sz (BVal -> IO (MutableArray (PrimState IO) BVal))
-> BVal -> IO (MutableArray (PrimState IO) BVal)
forall a b. (a -> b) -> a -> b
$ BVal
BlackHole
      else MutableArray RealWorld BVal -> IO (MutableArray RealWorld BVal)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
cop
  let loop :: Size -> IO ()
loop Size
i
        | Size
i Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Size
0 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise = do
            BVal
x <- MutableArray (PrimState IO) BVal -> Size -> IO BVal
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> m a
readArray MutableArray (PrimState IO) BVal
stk (Size -> IO BVal) -> Size -> IO BVal
forall a b. (a -> b) -> a -> b
$ Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- PrimArray Size -> Size -> Size
forall a. (() :: Constraint, Prim a) => PrimArray a -> Size -> a
indexPrimArray PrimArray Size
v Size
i
            MutableArray (PrimState IO) BVal -> Size -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> a -> m ()
writeArray MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
buf (Size
boff Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i) BVal
x
            Size -> IO ()
loop (Size -> IO ()) -> Size -> IO ()
forall a b. (a -> b) -> a -> b
$ Size
i Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1
  Size -> IO ()
loop (Size -> IO ()) -> Size -> IO ()
forall a b. (a -> b) -> a -> b
$ Size
sz Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
overwrite (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    MutableArray (PrimState IO) BVal
-> Size
-> MutableArray (PrimState IO) BVal
-> Size
-> Size
-> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Size -> MutableArray (PrimState m) a -> Size -> Size -> m ()
copyMutableArray MutableArray (PrimState IO) BVal
cop (Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
buf Size
0 Size
sz
  pure Size
cp
  where
    cp :: Size
cp = Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
sz
    sz :: Size
sz = PrimArray Size -> Size
forall a. Prim a => PrimArray a -> Size
sizeofPrimArray PrimArray Size
v
    overwrite :: Bool
overwrite = MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
stk MutableArray RealWorld BVal -> MutableArray RealWorld BVal -> Bool
forall a. Eq a => a -> a -> Bool
== MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
cop
    boff :: Size
boff | Bool
overwrite = Size
sz Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1 | Bool
otherwise = Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
sz
bargOnto MutableArray (PrimState IO) BVal
stk Size
sp MutableArray (PrimState IO) BVal
cop Size
cp0 (ArgR Size
i Size
l) = do
  MutableArray (PrimState IO) BVal
-> Size
-> MutableArray (PrimState IO) BVal
-> Size
-> Size
-> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Size -> MutableArray (PrimState m) a -> Size -> Size -> m ()
copyMutableArray MutableArray (PrimState IO) BVal
cop (Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) MutableArray (PrimState IO) BVal
stk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
l Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Size
l
  pure $ Size
cp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
l

data Dump = A | F Int Int | S

dumpAP :: Int -> Int -> Int -> Dump -> Int
dumpAP :: Size -> Size -> Size -> Dump -> Size
dumpAP Size
_ Size
fp Size
sz d :: Dump
d@(F Size
_ Size
a) = Size -> Size -> Dump -> Size
dumpFP Size
fp Size
sz Dump
d Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
a
dumpAP Size
ap Size
_ Size
_ Dump
_ = Size
ap

dumpFP :: Int -> Int -> Dump -> Int
dumpFP :: Size -> Size -> Dump -> Size
dumpFP Size
fp Size
_ Dump
S = Size
fp
dumpFP Size
fp Size
sz Dump
A = Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
sz
dumpFP Size
fp Size
sz (F Size
n Size
_) = Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
sz Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
n

-- closure augmentation mode
-- instruction, kontinuation, call
data Augment = I | K | C

data Stack = Stack
  { Stack -> Size
ap :: !Int, -- arg pointer
    Stack -> Size
fp :: !Int, -- frame pointer
    Stack -> Size
sp :: !Int, -- stack pointer
    Stack -> MutableByteArray (PrimState IO)
ustk :: {-# UNPACK #-} !(MutableByteArray (PrimState IO)),
    Stack -> MutableArray (PrimState IO) BVal
bstk :: {-# UNPACK #-} !(MutableArray (PrimState IO) Closure)
  }

-- Unboxed representation of the Stack, used to force GHC optimizations in a few spots.
type XStack = (# Int#, Int#, Int#, MutableByteArray# (PrimState IO), MutableArray# (PrimState IO) Closure #)

type IOXStack = State# RealWorld -> (# State# RealWorld, XStack #)

type IOEXStack =
  State# RealWorld -> (# State# RealWorld, Bool, XStack #)

pattern XStack :: Int# -> Int# -> Int# -> MutableByteArray# RealWorld -> MutableArray# RealWorld Closure -> Stack
pattern $mXStack :: forall {r}.
Stack
-> (Int#
    -> Int#
    -> Int#
    -> MutableByteArray# RealWorld
    -> MutableArray# RealWorld BVal
    -> r)
-> ((# #) -> r)
-> r
$bXStack :: Int#
-> Int#
-> Int#
-> MutableByteArray# RealWorld
-> MutableArray# RealWorld BVal
-> Stack
XStack {Stack -> Int#
apX, Stack -> Int#
fpX, Stack -> Int#
spX, Stack -> MutableByteArray# RealWorld
ustkX, Stack -> MutableArray# RealWorld BVal
bstkX} = Stack (I# apX) (I# fpX) (I# spX) (MutableByteArray ustkX) (MutableArray bstkX)

{-# COMPLETE XStack #-}

{-# INLINE XStack #-}

packXStack :: XStack -> Stack
packXStack :: XStack -> Stack
packXStack (# Int#
ap, Int#
fp, Int#
sp, MutableByteArray# (PrimState IO)
ustk, MutableArray# (PrimState IO) BVal
bstk #) = Stack {$sel:ap:Stack :: Size
ap = Int# -> Size
I# Int#
ap, $sel:fp:Stack :: Size
fp = Int# -> Size
I# Int#
fp, $sel:sp:Stack :: Size
sp = Int# -> Size
I# Int#
sp, $sel:ustk:Stack :: MutableByteArray (PrimState IO)
ustk = MutableByteArray# RealWorld -> MutableByteArray RealWorld
forall s. MutableByteArray# s -> MutableByteArray s
MutableByteArray MutableByteArray# RealWorld
MutableByteArray# (PrimState IO)
ustk, $sel:bstk:Stack :: MutableArray (PrimState IO) BVal
bstk = MutableArray# RealWorld BVal -> MutableArray RealWorld BVal
forall s a. MutableArray# s a -> MutableArray s a
MutableArray MutableArray# RealWorld BVal
MutableArray# (PrimState IO) BVal
bstk}
{-# INLINE packXStack #-}

unpackXStack :: Stack -> XStack
unpackXStack :: Stack -> XStack
unpackXStack (Stack (I# Int#
ap) (I# Int#
fp) (I# Int#
sp) (MutableByteArray MutableByteArray# (PrimState IO)
ustk) (MutableArray MutableArray# (PrimState IO) BVal
bstk)) = (# Int#
ap, Int#
fp, Int#
sp, MutableByteArray# (PrimState IO)
ustk, MutableArray# (PrimState IO) BVal
bstk #)
{-# INLINE unpackXStack #-}

xStackIOToIO :: IOXStack -> IO Stack
xStackIOToIO :: IOXStack -> IO Stack
xStackIOToIO IOXStack
f = (State# RealWorld -> (# State# RealWorld, Stack #)) -> IO Stack
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Stack #)) -> IO Stack)
-> (State# RealWorld -> (# State# RealWorld, Stack #)) -> IO Stack
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case IOXStack
f State# RealWorld
s of (# State# RealWorld
s', XStack
x #) -> (# State# RealWorld
s', XStack -> Stack
packXStack XStack
x #)
{-# INLINE xStackIOToIO #-}

stackIOToIOX :: IO Stack -> IOXStack
stackIOToIOX :: IO Stack -> IOXStack
stackIOToIOX (IO State# RealWorld -> (# State# RealWorld, Stack #)
f) = \State# RealWorld
s -> case State# RealWorld -> (# State# RealWorld, Stack #)
f State# RealWorld
s of (# State# RealWorld
s', Stack
x #) -> (# State# RealWorld
s', Stack -> XStack
unpackXStack Stack
x #)
{-# INLINE stackIOToIOX #-}

estackIOToIOX :: IO (Bool, Stack) -> IOEXStack
estackIOToIOX :: IO (Bool, Stack) -> IOEXStack
estackIOToIOX (IO State# RealWorld -> (# State# RealWorld, (Bool, Stack) #)
f) = \State# RealWorld
s -> case State# RealWorld -> (# State# RealWorld, (Bool, Stack) #)
f State# RealWorld
s of
  (# State# RealWorld
s', (Bool
b, Stack
x) #) -> (# State# RealWorld
s', Bool
b, Stack -> XStack
unpackXStack Stack
x #)

exStackIOToIO :: IOEXStack -> IO (Bool, Stack)
exStackIOToIO :: IOEXStack -> IO (Bool, Stack)
exStackIOToIO IOEXStack
f = (State# RealWorld -> (# State# RealWorld, (Bool, Stack) #))
-> IO (Bool, Stack)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, (Bool, Stack) #))
 -> IO (Bool, Stack))
-> (State# RealWorld -> (# State# RealWorld, (Bool, Stack) #))
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case IOEXStack
f State# RealWorld
s of
  (# State# RealWorld
s, Bool
b, XStack
x #) -> (# State# RealWorld
s, (Bool
b, XStack -> Stack
packXStack XStack
x) #)

instance Show Stack where
  show :: Stack -> [Char]
show (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
_ MutableArray (PrimState IO) BVal
_) =
    [Char]
"Stack " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Size -> [Char]
forall a. Show a => a -> [Char]
show Size
ap [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Size -> [Char]
forall a. Show a => a -> [Char]
show Size
fp [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Size -> [Char]
forall a. Show a => a -> [Char]
show Size
sp

type UVal = Int

-- | A runtime value, which is either a boxed or unboxed value, but we may not know which.
--
--   When it represents a boxed value, `getUnboxedVal` is meaningless, but when it represents an unboxed value,
--   `getBoxedVal` tells us its type.
data Val = Val {Val -> Size
getUnboxedVal :: !UVal, Val -> BVal
getBoxedVal :: !BVal}
  deriving (Size -> Val -> ShowS
[Val] -> ShowS
Val -> [Char]
(Size -> Val -> ShowS)
-> (Val -> [Char]) -> ([Val] -> ShowS) -> Show Val
forall a.
(Size -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Size -> Val -> ShowS
showsPrec :: Size -> Val -> ShowS
$cshow :: Val -> [Char]
show :: Val -> [Char]
$cshowList :: [Val] -> ShowS
showList :: [Val] -> ShowS
Show)

instance Ord Val where
  compare :: Val -> Val -> Ordering
compare = Bool -> Val -> Val -> Ordering
compareVal Bool
False

-- | A nulled out value you can use when filling empty arrays, etc.
emptyVal :: Val
emptyVal :: Val
emptyVal = Size -> BVal -> Val
Val (-Size
1) BVal
BlackHole

pattern UnboxedVal :: Int -> UnboxedTypeTag -> Val
pattern $mUnboxedVal :: forall {r}.
Val -> (Size -> UnboxedTypeTag -> r) -> ((# #) -> r) -> r
$bUnboxedVal :: Size -> UnboxedTypeTag -> Val
UnboxedVal v t = (Val v (UnboxedTypeTag t))

valToBoxed :: Val -> Maybe Closure
valToBoxed :: Val -> Maybe BVal
valToBoxed UnboxedVal {} = Maybe BVal
forall a. Maybe a
Nothing
valToBoxed (Val Size
_ BVal
b) = BVal -> Maybe BVal
forall a. a -> Maybe a
Just BVal
b

-- | Matches a Val which is known to be boxed, and returns the closure portion.
pattern BoxedVal :: Closure -> Val
pattern $mBoxedVal :: forall {r}. Val -> (BVal -> r) -> ((# #) -> r) -> r
$bBoxedVal :: BVal -> Val
BoxedVal b <- (valToBoxed -> Just b)
  where
    BoxedVal BVal
b = Size -> BVal -> Val
Val (-Size
1) BVal
b

{-# COMPLETE UnboxedVal, BoxedVal #-}

-- | Lift a boxed val into an Val
boxedVal :: BVal -> Val
boxedVal :: BVal -> Val
boxedVal = Size -> BVal -> Val
Val Size
0

type USeg = ByteArray

type BVal = Closure

type BSeg = Array Closure

type Seg = (USeg, BSeg)

alloc :: IO Stack
alloc :: IO Stack
alloc = do
  MutableByteArray RealWorld
ustk <- Size -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Size -> m (MutableByteArray (PrimState m))
newByteArray Size
4096
  MutableArray RealWorld BVal
bstk <- Size -> BVal -> IO (MutableArray (PrimState IO) BVal)
forall (m :: * -> *) a.
PrimMonad m =>
Size -> a -> m (MutableArray (PrimState m) a)
newArray Size
512 BVal
BlackHole
  pure $ Stack {$sel:ap:Stack :: Size
ap = -Size
1, $sel:fp:Stack :: Size
fp = -Size
1, $sel:sp:Stack :: Size
sp = -Size
1, MutableByteArray RealWorld
MutableByteArray (PrimState IO)
$sel:ustk:Stack :: MutableByteArray (PrimState IO)
ustk :: MutableByteArray RealWorld
ustk, MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
$sel:bstk:Stack :: MutableArray (PrimState IO) BVal
bstk :: MutableArray RealWorld BVal
bstk}
{-# INLINE alloc #-}

{- ORMOLU_DISABLE -}
{- because ormolu-0.7.2.0 can’t handle CPP used within declarations. -}

peek :: (DebugCallStack) => Stack -> IO Val
peek :: (() :: Constraint) => Stack -> IO Val
peek stk :: Stack
stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) = do
  -- Can't use upeek here because in stack-check mode it will assert that the stack slot is unboxed.
  Size
u <- MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk Size
sp
  BVal
b <- (() :: Constraint) => Stack -> IO BVal
Stack -> IO BVal
bpeek Stack
stk
  pure (Size -> BVal -> Val
Val Size
u BVal
b)
{-# INLINE peek #-}

peekI :: (DebugCallStack) => Stack -> IO Int
peekI :: (() :: Constraint) => Stack -> IO Size
peekI _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) = do
#ifdef STACK_CHECK
  assertUnboxed _stk 0
#endif
  MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk Size
sp
{-# INLINE peekI #-}

peekOffI :: (DebugCallStack) => Stack -> Off -> IO Int
peekOffI :: (() :: Constraint) => Stack -> Size -> IO Size
peekOffI _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Size
i = do
#ifdef STACK_CHECK
  assertUnboxed _stk i
#endif
  MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
{-# INLINE peekOffI #-}

bpeek :: (DebugCallStack) => Stack -> IO BVal
bpeek :: (() :: Constraint) => Stack -> IO BVal
bpeek (Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
_ MutableArray (PrimState IO) BVal
bstk) = MutableArray (PrimState IO) BVal -> Size -> IO BVal
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> m a
readArray MutableArray (PrimState IO) BVal
bstk Size
sp
{-# INLINE bpeek #-}

upeek :: (DebugCallStack) => Stack -> IO UVal
upeek :: (() :: Constraint) => Stack -> IO Size
upeek _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) = do
#ifdef STACK_CHECK
  assertUnboxed _stk 0
#endif
  MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk Size
sp
{-# INLINE upeek #-}

peekOff :: (DebugCallStack) => Stack -> Off -> IO Val
peekOff :: (() :: Constraint) => Stack -> Size -> IO Val
peekOff stk :: Stack
stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Size
i = do
  -- Can't use upeekOff here because in stack-check mode it will assert that the stack slot is unboxed.
  Size
u <- MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
  BVal
b <- (() :: Constraint) => Stack -> Size -> IO BVal
Stack -> Size -> IO BVal
bpeekOff Stack
stk Size
i
  pure $ Size -> BVal -> Val
Val Size
u BVal
b
{-# INLINE peekOff #-}

bpeekOff :: (DebugCallStack) => Stack -> Off -> IO BVal
bpeekOff :: (() :: Constraint) => Stack -> Size -> IO BVal
bpeekOff (Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
_ MutableArray (PrimState IO) BVal
bstk) Size
i = MutableArray (PrimState IO) BVal -> Size -> IO BVal
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> m a
readArray MutableArray (PrimState IO) BVal
bstk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
{-# INLINE bpeekOff #-}

upeekOff :: (DebugCallStack) => Stack -> Off -> IO UVal
upeekOff :: (() :: Constraint) => Stack -> Size -> IO Size
upeekOff _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Size
i = do
#ifdef STACK_CHECK
  assertUnboxed _stk i
#endif
  MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
{-# INLINE upeekOff #-}

upokeT :: (DebugCallStack) => Stack -> UVal -> BVal -> IO ()
upokeT :: (() :: Constraint) => Stack -> Size -> BVal -> IO ()
upokeT !stk :: Stack
stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) !Size
u !BVal
t = do
  (() :: Constraint) => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk BVal
t
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
ustk Size
sp Size
u
{-# INLINE upokeT #-}

poke :: (DebugCallStack) => Stack -> Val -> IO ()
poke :: (() :: Constraint) => Stack -> Val -> IO ()
poke _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) (Val Size
u BVal
b) = do
#ifdef STACK_CHECK
  assertBumped _stk 0
#endif
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
ustk Size
sp Size
u
  MutableArray (PrimState IO) BVal -> Size -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> a -> m ()
writeArray MutableArray (PrimState IO) BVal
bstk Size
sp BVal
b
{-# INLINE poke #-}

-- | Sometimes we get back an int from a foreign call which we want to use as a Nat.
-- If we know it's positive and smaller than 2^63 then we can safely store the Int directly as a Nat without
-- checks.
unsafePokeIasN :: (DebugCallStack) => Stack -> Int -> IO ()
unsafePokeIasN :: (() :: Constraint) => Stack -> Size -> IO ()
unsafePokeIasN Stack
stk Size
n = do
  (() :: Constraint) => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
upokeT Stack
stk Size
n BVal
natTypeTag
{-# INLINE unsafePokeIasN #-}

-- | Store an unboxed tag to later match on.
-- Often used to indicate the constructor of a data type that's been unpacked onto the stack,
-- or some tag we're about to branch on.
pokeTag :: (DebugCallStack) => Stack -> Int -> IO ()
pokeTag :: (() :: Constraint) => Stack -> Size -> IO ()
pokeTag =
  -- For now we just use ints, but maybe should have a separate type for tags so we can detect if we're leaking them.
  Stack -> Size -> IO ()
pokeI
{-# INLINE pokeTag #-}

peekTag :: (DebugCallStack) => Stack -> IO Int
peekTag :: (() :: Constraint) => Stack -> IO Size
peekTag = (() :: Constraint) => Stack -> IO Size
Stack -> IO Size
peekI
{-# INLINE peekTag #-}

peekTagOff :: (DebugCallStack) => Stack -> Off -> IO Int
peekTagOff :: (() :: Constraint) => Stack -> Size -> IO Size
peekTagOff = (() :: Constraint) => Stack -> Size -> IO Size
Stack -> Size -> IO Size
peekOffI
{-# INLINE peekTagOff #-}

pokeBool :: (DebugCallStack) => Stack -> Bool -> IO ()
pokeBool :: (() :: Constraint) => Stack -> Bool -> IO ()
pokeBool Stack
stk Bool
b =
  (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk (Val -> IO ()) -> Val -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
b then Val
trueVal else Val
falseVal
{-# INLINE pokeBool #-}

-- | Store a boxed value.
-- We don't bother nulling out the unboxed stack,
-- it's extra work and there's nothing to garbage collect.
bpoke :: (DebugCallStack) => Stack -> BVal -> IO ()
bpoke :: (() :: Constraint) => Stack -> BVal -> IO ()
bpoke _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
_ MutableArray (PrimState IO) BVal
bstk) !BVal
b = do
#ifdef STACK_CHECK
  assertBumped _stk 0
#endif
  MutableArray (PrimState IO) BVal -> Size -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> a -> m ()
writeArray MutableArray (PrimState IO) BVal
bstk Size
sp BVal
b
{-# INLINE bpoke #-}

pokeOff :: (DebugCallStack) => Stack -> Off -> Val -> IO ()
pokeOff :: (() :: Constraint) => Stack -> Size -> Val -> IO ()
pokeOff Stack
stk Size
i (Val Size
u BVal
t) = do
  (() :: Constraint) => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i BVal
t
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray (Stack -> MutableByteArray (PrimState IO)
ustk Stack
stk) (Stack -> Size
sp Stack
stk Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i) Size
u
{-# INLINE pokeOff #-}

upokeOffT :: (DebugCallStack) => Stack -> Off -> UVal -> BVal -> IO ()
upokeOffT :: (() :: Constraint) => Stack -> Size -> Size -> BVal -> IO ()
upokeOffT Stack
stk Size
i Size
u BVal
t = do
  (() :: Constraint) => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i BVal
t
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray (Stack -> MutableByteArray (PrimState IO)
ustk Stack
stk) (Stack -> Size
sp Stack
stk Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i) Size
u
{-# INLINE upokeOffT #-}

bpokeOff :: (DebugCallStack) => Stack -> Off -> BVal -> IO ()
bpokeOff :: (() :: Constraint) => Stack -> Size -> BVal -> IO ()
bpokeOff _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
_ MutableArray (PrimState IO) BVal
bstk) Size
i !BVal
b = do
#ifdef STACK_CHECK
  assertBumped _stk i
#endif
  MutableArray (PrimState IO) BVal -> Size -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Size -> a -> m ()
writeArray MutableArray (PrimState IO) BVal
bstk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i) BVal
b
{-# INLINE bpokeOff #-}

-- | Eats up arguments
grabSeg :: Stack -> SZ -> IO (Seg, Stack)
grabSeg :: Stack -> Size -> IO (Seg, Stack)
grabSeg (Stack Size
_ Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) Size
sze = do
  ByteArray
uSeg <- IO ByteArray
ugrab
  BSeg
bSeg <- IO BSeg
bgrab
  pure $ ((ByteArray
uSeg, BSeg
bSeg), Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack (Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
sze) (Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
sze) (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
sze) MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk)
  where
    ugrab :: IO ByteArray
ugrab = do
      MutableByteArray RealWorld
mut <- Size -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Size -> m (MutableByteArray (PrimState m))
newByteArray Size
bsz
      MutableByteArray (PrimState IO)
-> Size -> MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Size -> MutableByteArray (PrimState m) -> Size -> Size -> m ()
copyMutableByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
mut Size
0 MutableByteArray (PrimState IO)
ustk (Size
bfp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
bsz) Size
bsz
      ByteArray
seg <- MutableByteArray (PrimState IO) -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
mut
      MutableByteArray (PrimState IO)
-> Size -> MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Size -> MutableByteArray (PrimState m) -> Size -> Size -> m ()
moveByteArray MutableByteArray (PrimState IO)
ustk (Size
bfp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
bsz) MutableByteArray (PrimState IO)
ustk Size
bfp Size
fsz
      pure ByteArray
seg
      where
        bsz :: Size
bsz = Size -> Size
bytes Size
sze
        bfp :: Size
bfp = Size -> Size
bytes (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1
        fsz :: Size
fsz = Size -> Size
bytes (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
fp
    bgrab :: IO BSeg
bgrab = do
      BSeg
seg <- MutableArray RealWorld BVal -> IO BSeg
MutableArray (PrimState IO) BVal -> IO BSeg
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
unsafeFreezeArray (MutableArray RealWorld BVal -> IO BSeg)
-> IO (MutableArray RealWorld BVal) -> IO BSeg
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MutableArray (PrimState IO) BVal
-> Size -> Size -> IO (MutableArray (PrimState IO) BVal)
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Size -> Size -> m (MutableArray (PrimState m) a)
cloneMutableArray MutableArray (PrimState IO) BVal
bstk (Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1 Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
sze) Size
sze
      MutableArray (PrimState IO) BVal
-> Size
-> MutableArray (PrimState IO) BVal
-> Size
-> Size
-> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Size -> MutableArray (PrimState m) a -> Size -> Size -> m ()
copyMutableArray MutableArray (PrimState IO) BVal
bstk (Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1 Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
sze) MutableArray (PrimState IO) BVal
bstk (Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Size
fsz
      pure BSeg
seg
      where
        fsz :: Size
fsz = Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
fp
{-# INLINE grabSeg #-}

-- Truncates a portion of a stack, yielding the new stack without the
-- discarded portion. This is analogous to the stack yielded by
-- `grab`, but without doing the work of capturing the discarded
-- portion.
truncateSeg :: Stack -> SZ -> IO Stack
truncateSeg :: Stack -> Size -> IO Stack
truncateSeg (Stack Size
_ Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) Size
sze = do
  MutableByteArray (PrimState IO)
-> Size -> MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Size -> MutableByteArray (PrimState m) -> Size -> Size -> m ()
moveByteArray MutableByteArray (PrimState IO)
ustk (Size
bfp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
bsz) MutableByteArray (PrimState IO)
ustk Size
bfp Size
fsz
  MutableArray (PrimState IO) BVal
-> Size
-> MutableArray (PrimState IO) BVal
-> Size
-> Size
-> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Size -> MutableArray (PrimState m) a -> Size -> Size -> m ()
copyMutableArray MutableArray (PrimState IO) BVal
bstk (Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1 Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
sze) MutableArray (PrimState IO) BVal
bstk (Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Size
fsz
  -- TODO: overwrite stale stack values?
  pure $ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack (Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
sze) (Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
sze) (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
sze) MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
  where
    bfp :: Size
bfp = Size -> Size
bytes (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1
    bsz :: Size
bsz = Size -> Size
bytes Size
sze
    fsz :: Size
fsz = Size -> Size
bytes (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
fp
{-# INLINE truncateSeg #-}

ensure :: Stack -> SZ -> IO Stack
ensure :: Stack -> Size -> IO Stack
ensure stk :: Stack
stk@(Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) Size
sze
  | Size
sze Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
0 = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
  | Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
sze Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1 Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Size
bsz = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
  | Bool
otherwise = do
      MutableArray RealWorld BVal
bstk' <- Size -> BVal -> IO (MutableArray (PrimState IO) BVal)
forall (m :: * -> *) a.
PrimMonad m =>
Size -> a -> m (MutableArray (PrimState m) a)
newArray (Size
bsz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
bext) BVal
BlackHole
      MutableArray (PrimState IO) BVal
-> Size
-> MutableArray (PrimState IO) BVal
-> Size
-> Size
-> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Size -> MutableArray (PrimState m) a -> Size -> Size -> m ()
copyMutableArray MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
bstk' Size
0 MutableArray (PrimState IO) BVal
bstk Size
0 (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1)
      MutableByteArray RealWorld
ustk' <- MutableByteArray (PrimState IO)
-> Size -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> Size -> m (MutableByteArray (PrimState m))
resizeMutableByteArray MutableByteArray (PrimState IO)
ustk (Size
usz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
uext)
      pure $ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap Size
fp Size
sp MutableByteArray RealWorld
MutableByteArray (PrimState IO)
ustk' MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
bstk'
  where
    usz :: Size
usz = MutableByteArray RealWorld -> Size
forall s. MutableByteArray s -> Size
sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
ustk
    bsz :: Size
bsz = MutableArray RealWorld BVal -> Size
forall s a. MutableArray s a -> Size
sizeofMutableArray MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
bstk
    bext :: Size
bext
      | Size
sze Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
1280 = Size
sze Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
512
      | Bool
otherwise = Size
1280
    uext :: Size
uext
      | Size -> Size
bytes Size
sze Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
10240 = Size -> Size
bytes Size
sze Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
4096
      | Bool
otherwise = Size
10240
{-# INLINE ensure #-}

bump :: Stack -> IO Stack
bump :: Stack -> IO Stack
bump (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) = do
  let stk' :: Stack
stk' = Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap Size
fp (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
#ifdef STACK_CHECK
  pokeSentinelOff stk' 0
#endif
  Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk'
{-# INLINE bump #-}

bumpn :: Stack -> SZ -> IO Stack
bumpn :: Stack -> Size -> IO Stack
bumpn (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) Size
n = do
  let stk' :: Stack
stk' = Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap Size
fp (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
n) MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
#ifdef STACK_CHECK
  for_ [0..n-1] $ \i ->
    pokeSentinelOff stk' i
#endif
  Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk'
{-# INLINE bumpn #-}

duplicate :: Stack -> IO Stack
duplicate :: Stack -> IO Stack
duplicate (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) = do
  MutableByteArray RealWorld
ustk' <- IO (MutableByteArray RealWorld)
dupUStk
  MutableArray RealWorld BVal
bstk' <- IO (MutableArray RealWorld BVal)
IO (MutableArray (PrimState IO) BVal)
dupBStk
  pure $ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap Size
fp Size
sp MutableByteArray RealWorld
MutableByteArray (PrimState IO)
ustk' MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
bstk'
  where
    dupUStk :: IO (MutableByteArray RealWorld)
dupUStk = do
      let sz :: Size
sz = MutableByteArray RealWorld -> Size
forall s. MutableByteArray s -> Size
sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
ustk
      MutableByteArray RealWorld
b <- Size -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Size -> m (MutableByteArray (PrimState m))
newByteArray Size
sz
      MutableByteArray (PrimState IO)
-> Size -> MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Size -> MutableByteArray (PrimState m) -> Size -> Size -> m ()
copyMutableByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
b Size
0 MutableByteArray (PrimState IO)
ustk Size
0 Size
sz
      pure MutableByteArray RealWorld
b
    dupBStk :: IO (MutableArray (PrimState IO) BVal)
dupBStk = do
      MutableArray (PrimState IO) BVal
-> Size -> Size -> IO (MutableArray (PrimState IO) BVal)
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Size -> Size -> m (MutableArray (PrimState m) a)
cloneMutableArray MutableArray (PrimState IO) BVal
bstk Size
0 (MutableArray RealWorld BVal -> Size
forall s a. MutableArray s a -> Size
sizeofMutableArray MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
bstk)
{-# INLINE duplicate #-}

discardFrame :: Stack -> IO Stack
discardFrame :: Stack -> IO Stack
discardFrame (Stack Size
ap Size
fp Size
_ MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap Size
fp Size
fp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
{-# INLINE discardFrame #-}

saveFrame :: Stack -> IO (Stack, SZ, SZ)
saveFrame :: Stack -> IO (Stack, Size, Size)
saveFrame (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) = (Stack, Size, Size) -> IO (Stack, Size, Size)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
sp Size
sp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk, Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
fp, Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
ap)
{-# INLINE saveFrame #-}

saveArgs :: Stack -> IO (Stack, SZ)
saveArgs :: Stack -> IO (Stack, Size)
saveArgs (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) = (Stack, Size) -> IO (Stack, Size)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
fp Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk, Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
ap)
{-# INLINE saveArgs #-}

restoreFrame :: Stack -> SZ -> SZ -> IO Stack
restoreFrame :: Stack -> Size -> Size -> IO Stack
restoreFrame (Stack Size
_ Size
fp0 Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) Size
fsz Size
asz = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
  where
    fp :: Size
fp = Size
fp0 Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
fsz
    ap :: Size
ap = Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
asz
{-# INLINE restoreFrame #-}

prepareArgs :: Stack -> Args' -> IO Stack
prepareArgs :: Stack -> Args' -> IO Stack
prepareArgs (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) = \case
  ArgR Size
i Size
l
    | Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
l Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
i Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
sp ->
        Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i) (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i) MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
  Args'
args -> do
    Size
sp <- Arrs -> Size -> Arrs -> Size -> Args' -> IO Size
argOnto (MutableByteArray (PrimState IO)
ustk, MutableArray (PrimState IO) BVal
bstk) Size
sp (MutableByteArray (PrimState IO)
ustk, MutableArray (PrimState IO) BVal
bstk) Size
fp Args'
args
    pure $ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap Size
sp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
{-# INLINE prepareArgs #-}

acceptArgs :: Stack -> Int -> IO Stack
acceptArgs :: Stack -> Size -> IO Stack
acceptArgs (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) Size
n = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap (Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
n) Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
{-# INLINE acceptArgs #-}

frameArgs :: Stack -> IO Stack
frameArgs :: Stack -> IO Stack
frameArgs (Stack Size
ap Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap Size
ap Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
{-# INLINE frameArgs #-}

augSeg :: Augment -> Stack -> Seg -> Maybe Args' -> IO Seg
augSeg :: Augment -> Stack -> Seg -> Maybe Args' -> IO Seg
augSeg Augment
mode (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) (ByteArray
useg, BSeg
bseg) Maybe Args'
margs = do
  ByteArray
useg' <- IO ByteArray
unboxedSeg
  BSeg
bseg' <- IO BSeg
boxedSeg
  pure (ByteArray
useg', BSeg
bseg')
  where
    bpsz :: Size
bpsz
      | Augment
I <- Augment
mode = Size
0
      | Bool
otherwise = Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
ap
    unboxedSeg :: IO ByteArray
unboxedSeg = do
      MutableByteArray RealWorld
cop <- Size -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Size -> m (MutableByteArray (PrimState m))
newByteArray (Size -> IO (MutableByteArray (PrimState IO)))
-> Size -> IO (MutableByteArray (PrimState IO))
forall a b. (a -> b) -> a -> b
$ Size
ssz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
upsz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
asz
      MutableByteArray (PrimState IO)
-> Size -> ByteArray -> Size -> Size -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Size -> ByteArray -> Size -> Size -> m ()
copyByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
cop Size
soff ByteArray
useg Size
0 Size
ssz
      MutableByteArray (PrimState IO)
-> Size -> MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Size -> MutableByteArray (PrimState m) -> Size -> Size -> m ()
copyMutableByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
cop Size
0 MutableByteArray (PrimState IO)
ustk (Size -> Size
bytes (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
ap Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Size
upsz
      Maybe Args' -> (Args' -> IO Size) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Args'
margs ((Args' -> IO Size) -> IO ()) -> (Args' -> IO Size) -> IO ()
forall a b. (a -> b) -> a -> b
$ MutableByteArray (PrimState IO)
-> Size
-> MutableByteArray (PrimState IO)
-> Size
-> Args'
-> IO Size
uargOnto MutableByteArray (PrimState IO)
ustk Size
sp MutableByteArray RealWorld
MutableByteArray (PrimState IO)
cop (Size -> Size
words Size
poff Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
bpsz Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1)
      MutableByteArray (PrimState IO) -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
cop
      where
        ssz :: Size
ssz = ByteArray -> Size
sizeofByteArray ByteArray
useg
        (Size
poff, Size
soff)
          | Augment
K <- Augment
mode = (Size
ssz, Size
0)
          | Bool
otherwise = (Size
0, Size
upsz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
asz)
        upsz :: Size
upsz = Size -> Size
bytes Size
bpsz
        asz :: Size
asz = case Maybe Args'
margs of
          Maybe Args'
Nothing -> Size -> Size
bytes Size
0
          Just (Arg1 Size
_) -> Size -> Size
bytes Size
1
          Just (Arg2 Size
_ Size
_) -> Size -> Size
bytes Size
2
          Just (ArgN PrimArray Size
v) -> Size -> Size
bytes (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ PrimArray Size -> Size
forall a. Prim a => PrimArray a -> Size
sizeofPrimArray PrimArray Size
v
          Just (ArgR Size
_ Size
l) -> Size -> Size
bytes Size
l
    boxedSeg :: IO BSeg
boxedSeg = do
      MutableArray RealWorld BVal
cop <- Size -> BVal -> IO (MutableArray (PrimState IO) BVal)
forall (m :: * -> *) a.
PrimMonad m =>
Size -> a -> m (MutableArray (PrimState m) a)
newArray (Size
ssz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
bpsz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
asz) BVal
BlackHole
      MutableArray (PrimState IO) BVal
-> Size -> BSeg -> Size -> Size -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Size -> Array a -> Size -> Size -> m ()
copyArray MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
cop Size
soff BSeg
bseg Size
0 Size
ssz
      MutableArray (PrimState IO) BVal
-> Size
-> MutableArray (PrimState IO) BVal
-> Size
-> Size
-> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Size -> MutableArray (PrimState m) a -> Size -> Size -> m ()
copyMutableArray MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
cop Size
poff MutableArray (PrimState IO) BVal
bstk (Size
ap Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Size
bpsz
      Maybe Args' -> (Args' -> IO Size) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Args'
margs ((Args' -> IO Size) -> IO ()) -> (Args' -> IO Size) -> IO ()
forall a b. (a -> b) -> a -> b
$ MutableArray (PrimState IO) BVal
-> Size
-> MutableArray (PrimState IO) BVal
-> Size
-> Args'
-> IO Size
bargOnto MutableArray (PrimState IO) BVal
bstk Size
sp MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
cop (Size
poff Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
bpsz Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1)
      MutableArray (PrimState IO) BVal -> IO BSeg
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
unsafeFreezeArray MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
cop
      where
        ssz :: Size
ssz = BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
bseg
        (Size
poff, Size
soff)
          | Augment
K <- Augment
mode = (Size
ssz, Size
0)
          | Bool
otherwise = (Size
0, Size
bpsz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
asz)
        asz :: Size
asz = case Maybe Args'
margs of
          Maybe Args'
Nothing -> Size
0
          Just (Arg1 Size
_) -> Size
1
          Just (Arg2 Size
_ Size
_) -> Size
2
          Just (ArgN PrimArray Size
v) -> PrimArray Size -> Size
forall a. Prim a => PrimArray a -> Size
sizeofPrimArray PrimArray Size
v
          Just (ArgR Size
_ Size
l) -> Size
l
{-# INLINE augSeg #-}

dumpSeg :: Stack -> Seg -> Dump -> IO Stack
dumpSeg :: Stack -> Seg -> Dump -> IO Stack
dumpSeg (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) (ByteArray
useg, BSeg
bseg) Dump
mode = do
  IO ()
dumpUSeg
  IO ()
dumpBSeg
  pure $ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack Size
ap' Size
fp' Size
sp' MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
  where
    sz :: Size
sz = BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
bseg
    sp' :: Size
sp' = Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
sz
    fp' :: Size
fp' = Size -> Size -> Dump -> Size
dumpFP Size
fp Size
sz Dump
mode
    ap' :: Size
ap' = Size -> Size -> Size -> Dump -> Size
dumpAP Size
ap Size
fp Size
sz Dump
mode
    dumpUSeg :: IO ()
dumpUSeg = do
      let ssz :: Size
ssz = ByteArray -> Size
sizeofByteArray ByteArray
useg
      let bsp :: Size
bsp = Size -> Size
bytes (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1
      MutableByteArray (PrimState IO)
-> Size -> ByteArray -> Size -> Size -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Size -> ByteArray -> Size -> Size -> m ()
copyByteArray MutableByteArray (PrimState IO)
ustk Size
bsp ByteArray
useg Size
0 Size
ssz
    dumpBSeg :: IO ()
dumpBSeg = do
      MutableArray (PrimState IO) BVal
-> Size -> BSeg -> Size -> Size -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Size -> Array a -> Size -> Size -> m ()
copyArray MutableArray (PrimState IO) BVal
bstk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) BSeg
bseg Size
0 Size
sz
{-# INLINE dumpSeg #-}

adjustArgs :: Stack -> SZ -> IO Stack
adjustArgs :: Stack -> Size -> IO Stack
adjustArgs (Stack Size
ap Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk) Size
sz = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Size
-> Size
-> Size
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) BVal
-> Stack
Stack (Size
ap Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
sz) Size
fp Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
bstk
{-# INLINE adjustArgs #-}

fsize :: Stack -> SZ
fsize :: Stack -> Size
fsize (Stack Size
_ Size
fp Size
sp MutableByteArray (PrimState IO)
_ MutableArray (PrimState IO) BVal
_) = Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
fp
{-# INLINE fsize #-}

asize :: Stack -> SZ
asize :: Stack -> Size
asize (Stack Size
ap Size
fp Size
_ MutableByteArray (PrimState IO)
_ MutableArray (PrimState IO) BVal
_) = Size
fp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
ap
{-# INLINE asize #-}

peekN :: Stack -> IO Word64
peekN :: Stack -> IO Word64
peekN _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) = do
#ifdef STACK_CHECK
  assertUnboxed _stk 0
#endif
  MutableByteArray (PrimState IO) -> Size -> IO Word64
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk Size
sp
{-# INLINE peekN #-}

peekD :: Stack -> IO Double
peekD :: Stack -> IO Double
peekD _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) = do
#ifdef STACK_CHECK
  assertUnboxed _stk 0
#endif
  MutableByteArray (PrimState IO) -> Size -> IO Double
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk Size
sp
{-# INLINE peekD #-}

peekC :: Stack -> IO Char
peekC :: Stack -> IO Char
peekC Stack
stk = do
  Size -> Char
Char.chr (Size -> Char) -> IO Size -> IO Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (() :: Constraint) => Stack -> IO Size
Stack -> IO Size
peekI Stack
stk
{-# INLINE peekC #-}

peekOffN :: Stack -> Int -> IO Word64
peekOffN :: Stack -> Size -> IO Word64
peekOffN _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Size
i = do
#ifdef STACK_CHECK
  assertUnboxed _stk i
#endif
  MutableByteArray (PrimState IO) -> Size -> IO Word64
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
{-# INLINE peekOffN #-}

peekOffD :: Stack -> Int -> IO Double
peekOffD :: Stack -> Size -> IO Double
peekOffD _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Size
i = do
#ifdef STACK_CHECK
  assertUnboxed _stk i
#endif
  MutableByteArray (PrimState IO) -> Size -> IO Double
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
{-# INLINE peekOffD #-}

peekOffC :: Stack -> Int -> IO Char
peekOffC :: Stack -> Size -> IO Char
peekOffC _stk :: Stack
_stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Size
i = do
#ifdef STACK_CHECK
  assertUnboxed _stk i
#endif
  Size -> Char
Char.chr (Size -> Char) -> IO Size -> IO Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableByteArray (PrimState IO) -> Size -> IO Size
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i)
{-# INLINE peekOffC #-}

{- ORMOLU_ENABLE -}

pokeN :: Stack -> Word64 -> IO ()
pokeN :: Stack -> Word64 -> IO ()
pokeN stk :: Stack
stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Word64
n = do
  (() :: Constraint) => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk BVal
natTypeTag
  MutableByteArray (PrimState IO) -> Size -> Word64 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
ustk Size
sp Word64
n
{-# INLINE pokeN #-}

pokeD :: Stack -> Double -> IO ()
pokeD :: Stack -> Double -> IO ()
pokeD stk :: Stack
stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Double
d = do
  (() :: Constraint) => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk BVal
floatTypeTag
  MutableByteArray (PrimState IO) -> Size -> Double -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
ustk Size
sp Double
d
{-# INLINE pokeD #-}

pokeC :: Stack -> Char -> IO ()
pokeC :: Stack -> Char -> IO ()
pokeC stk :: Stack
stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Char
c = do
  (() :: Constraint) => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk BVal
charTypeTag
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
ustk Size
sp (Char -> Size
Char.ord Char
c)
{-# INLINE pokeC #-}

-- | Note: This is for poking an unboxed value that has the UNISON type 'int', not just any unboxed data.
pokeI :: Stack -> Int -> IO ()
pokeI :: Stack -> Size -> IO ()
pokeI stk :: Stack
stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Size
i = do
  (() :: Constraint) => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk BVal
intTypeTag
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
ustk Size
sp Size
i
{-# INLINE pokeI #-}

pokeByte :: Stack -> Word8 -> IO ()
pokeByte :: Stack -> Word8 -> IO ()
pokeByte Stack
stk Word8
b = do
  -- NOTE: currently we just store bytes as Word64s, but we should have a separate type runtime type tag for them.
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b)
{-# INLINE pokeByte #-}

pokeOffN :: Stack -> Int -> Word64 -> IO ()
pokeOffN :: Stack -> Size -> Word64 -> IO ()
pokeOffN stk :: Stack
stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Size
i Word64
n = do
  (() :: Constraint) => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i BVal
natTypeTag
  MutableByteArray (PrimState IO) -> Size -> Word64 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
ustk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i) Word64
n
{-# INLINE pokeOffN #-}

pokeOffD :: Stack -> Int -> Double -> IO ()
pokeOffD :: Stack -> Size -> Double -> IO ()
pokeOffD stk :: Stack
stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Size
i Double
d = do
  (() :: Constraint) => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i BVal
floatTypeTag
  MutableByteArray (PrimState IO) -> Size -> Double -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
ustk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i) Double
d
{-# INLINE pokeOffD #-}

pokeOffI :: Stack -> Int -> Int -> IO ()
pokeOffI :: Stack -> Size -> Size -> IO ()
pokeOffI stk :: Stack
stk@(Stack Size
_ Size
_ Size
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) BVal
_) Size
i Size
n = do
  (() :: Constraint) => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i BVal
intTypeTag
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> a -> m ()
writeByteArray MutableByteArray (PrimState IO)
ustk (Size
sp Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i) Size
n
{-# INLINE pokeOffI #-}

pokeOffC :: Stack -> Int -> Char -> IO ()
pokeOffC :: Stack -> Size -> Char -> IO ()
pokeOffC Stack
stk Size
i Char
c = do
  (() :: Constraint) => Stack -> Size -> Size -> BVal -> IO ()
Stack -> Size -> Size -> BVal -> IO ()
upokeOffT Stack
stk Size
i (Char -> Size
Char.ord Char
c) BVal
charTypeTag
{-# INLINE pokeOffC #-}

pokeBi :: (BuiltinForeign b) => Stack -> b -> IO ()
pokeBi :: forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk b
x = (() :: Constraint) => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk (Foreign -> BVal
Foreign (Foreign -> BVal) -> Foreign -> BVal
forall a b. (a -> b) -> a -> b
$ b -> Foreign
forall f. BuiltinForeign f => f -> Foreign
wrapBuiltin b
x)
{-# INLINE pokeBi #-}

pokeOffBi :: (BuiltinForeign b) => Stack -> Int -> b -> IO ()
pokeOffBi :: forall b. BuiltinForeign b => Stack -> Size -> b -> IO ()
pokeOffBi Stack
stk Size
i b
x = (() :: Constraint) => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i (Foreign -> BVal
Foreign (Foreign -> BVal) -> Foreign -> BVal
forall a b. (a -> b) -> a -> b
$ b -> Foreign
forall f. BuiltinForeign f => f -> Foreign
wrapBuiltin b
x)
{-# INLINE pokeOffBi #-}

peekBi :: (BuiltinForeign b) => Stack -> IO b
peekBi :: forall b. BuiltinForeign b => Stack -> IO b
peekBi Stack
stk = BVal -> IO b
forall a. (HasCallStack, BuiltinForeign a) => BVal -> IO a
marshalUnwrapForeignIO (BVal -> IO b) -> IO BVal -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> IO BVal
Stack -> IO BVal
bpeek Stack
stk
{-# INLINE peekBi #-}

peekOffBi :: (BuiltinForeign b) => Stack -> Int -> IO b
peekOffBi :: forall b. BuiltinForeign b => Stack -> Size -> IO b
peekOffBi Stack
stk Size
i = BVal -> IO b
forall a. (HasCallStack, BuiltinForeign a) => BVal -> IO a
marshalUnwrapForeignIO (BVal -> IO b) -> IO BVal -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Size -> IO BVal
Stack -> Size -> IO BVal
bpeekOff Stack
stk Size
i
{-# INLINE peekOffBi #-}

peekBool :: Stack -> IO Bool
peekBool :: Stack -> IO Bool
peekBool Stack
stk = do
  BVal
b <- (() :: Constraint) => Stack -> IO BVal
Stack -> IO BVal
bpeek Stack
stk
  pure $ case BVal
b of
    Enum Reference
_ PackedTag
t -> PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
/= PackedTag
TT.falseTag
    BVal
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"peekBool: not a boolean"
{-# INLINE peekBool #-}

peekOffBool :: Stack -> Int -> IO Bool
peekOffBool :: Stack -> Size -> IO Bool
peekOffBool Stack
stk Size
i = do
  BVal
b <- (() :: Constraint) => Stack -> Size -> IO BVal
Stack -> Size -> IO BVal
bpeekOff Stack
stk Size
i
  pure $ case BVal
b of
    Enum Reference
_ PackedTag
t -> PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
/= PackedTag
TT.falseTag
    BVal
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"peekOffBool: not a boolean"
{-# INLINE peekOffBool #-}

peekOffS :: Stack -> Int -> IO USeq
peekOffS :: Stack -> Size -> IO USeq
peekOffS Stack
stk Size
i = BVal -> IO USeq
forall a. (HasCallStack, BuiltinForeign a) => BVal -> IO a
marshalUnwrapForeignIO (BVal -> IO USeq) -> IO BVal -> IO USeq
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Size -> IO BVal
Stack -> Size -> IO BVal
bpeekOff Stack
stk Size
i
{-# INLINE peekOffS #-}

pokeS :: Stack -> USeq -> IO ()
pokeS :: Stack -> USeq -> IO ()
pokeS Stack
stk USeq
s = (() :: Constraint) => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk (Foreign -> BVal
Foreign (Foreign -> BVal) -> Foreign -> BVal
forall a b. (a -> b) -> a -> b
$ USeq -> Foreign
WrapSeq USeq
s)
{-# INLINE pokeS #-}

pokeOffS :: Stack -> Int -> USeq -> IO ()
pokeOffS :: Stack -> Size -> USeq -> IO ()
pokeOffS Stack
stk Size
i USeq
s = (() :: Constraint) => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i (Foreign -> BVal
Foreign (Foreign -> BVal) -> Foreign -> BVal
forall a b. (a -> b) -> a -> b
$ USeq -> Foreign
WrapSeq USeq
s)
{-# INLINE pokeOffS #-}

unull :: USeg
unull :: ByteArray
unull = Size -> [Size] -> ByteArray
forall a. Prim a => Size -> [a] -> ByteArray
byteArrayFromListN Size
0 ([] :: [Int])

bnull :: BSeg
bnull :: BSeg
bnull = Size -> [Item BSeg] -> BSeg
forall l. IsList l => Size -> [Item l] -> l
fromListN Size
0 []

nullSeg :: Seg
nullSeg :: Seg
nullSeg = (ByteArray
unull, BSeg
bnull)

instance Show K where
  show :: K -> [Char]
show K
k = [Char]
"[" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> K -> [Char]
go [Char]
"" K
k
    where
      go :: [Char] -> K -> [Char]
go [Char]
_ K
KE = [Char]
"]"
      go [Char]
_ (CB Callback
_) = [Char]
"]"
      go [Char]
com (Push Size
f Size
a CombIx
ci Size
_g RSection Val
_rsect K
k) =
        [Char]
com [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Size, Size, CombIx) -> [Char]
forall a. Show a => a -> [Char]
show (Size
f, Size
a, CombIx
ci) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> K -> [Char]
go [Char]
"," K
k
      go [Char]
com (Mark Size
a EnumSet Word64
ps DEnv
_ K
k) =
        [Char]
com [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"M " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Size -> [Char]
forall a. Show a => a -> [Char]
show Size
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ EnumSet Word64 -> [Char]
forall a. Show a => a -> [Char]
show EnumSet Word64
ps [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> K -> [Char]
go [Char]
"," K
k
      go [Char]
com (Local HEnv
_ Size
a K
k) =
        [Char]
com [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"L " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Size -> [Char]
forall a. Show a => a -> [Char]
show Size
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> K -> [Char]
go [Char]
"," K
k
      go [Char]
com (AMark Size
a AEnv
_ AffineRef
_ K
k) =
        [Char]
com [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"A " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Size -> [Char]
forall a. Show a => a -> [Char]
show Size
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> K -> [Char]
go [Char]
"," K
k
      go [Char]
com (Keep a
_ Size
a K
k) =
        [Char]
com [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"K " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Size -> [Char]
forall a. Show a => a -> [Char]
show Size
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> K -> [Char]
go [Char]
"," K
k

frameView :: Stack -> IO ()
frameView :: Stack -> IO ()
frameView Stack
stk = [Char] -> IO ()
putStr [Char]
"|" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Size -> IO ()
gof Bool
False Size
0
  where
    fsz :: Size
fsz = Stack -> Size
fsize Stack
stk
    asz :: Size
asz = Stack -> Size
asize Stack
stk
    gof :: Bool -> Size -> IO ()
gof Bool
delim Size
n
      | Size
n Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
>= Size
fsz = [Char] -> IO ()
putStr [Char]
"|" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Size -> IO ()
goa Bool
False Size
0
      | Bool
otherwise = do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
delim (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr [Char]
","
          [Char] -> IO ()
putStr ([Char] -> IO ()) -> (Val -> [Char]) -> Val -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> [Char]
forall a. Show a => a -> [Char]
show (Val -> IO ()) -> IO Val -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Size -> IO Val
Stack -> Size -> IO Val
peekOff Stack
stk Size
n
          Bool -> Size -> IO ()
gof Bool
True (Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1)
    goa :: Bool -> Size -> IO ()
goa Bool
delim Size
n
      | Size
n Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
>= Size
asz = [Char] -> IO ()
putStrLn [Char]
"|.."
      | Bool
otherwise = do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
delim (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr [Char]
","
          [Char] -> IO ()
putStr ([Char] -> IO ()) -> (Val -> [Char]) -> Val -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> [Char]
forall a. Show a => a -> [Char]
show (Val -> IO ()) -> IO Val -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Size -> IO Val
Stack -> Size -> IO Val
peekOff Stack
stk (Size
fsz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
n)
          Bool -> Size -> IO ()
goa Bool
True (Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1)

scount :: Seg -> Int
scount :: Seg -> Size
scount (ByteArray
_, BSeg
bseg) = BSeg -> Size
bscount BSeg
bseg
  where
    bscount :: BSeg -> Int
    bscount :: BSeg -> Size
bscount BSeg
seg = BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
seg

closureTermRefs :: (Monoid m) => (Reference -> m) -> (Closure -> m)
closureTermRefs :: forall m. Monoid m => (Reference -> m) -> BVal -> m
closureTermRefs Reference -> m
f = \case
  PAp (CIx Reference
r Word64
_ Word64
_) GCombInfo (RComb Val)
_ (ByteArray
_useg, BSeg
bseg) ->
    Reference -> m
f Reference
r m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (BVal -> m) -> BSeg -> m
forall m a. Monoid m => (a -> m) -> Array a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Reference -> m) -> BVal -> m
forall m. Monoid m => (Reference -> m) -> BVal -> m
closureTermRefs Reference -> m
f) BSeg
bseg
  (DataC Reference
_ PackedTag
_ [Val]
vs) ->
    [Val]
vs [Val] -> ([Val] -> m) -> m
forall a b. a -> (a -> b) -> b
& (Val -> m) -> [Val] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \case
      BoxedVal BVal
c -> (Reference -> m) -> BVal -> m
forall m. Monoid m => (Reference -> m) -> BVal -> m
closureTermRefs Reference -> m
f BVal
c
      UnboxedVal {} -> m
forall a. Monoid a => a
mempty
  (Captured K
k Size
_ (ByteArray
_useg, BSeg
bseg)) ->
    (Reference -> m) -> K -> m
forall m. Monoid m => (Reference -> m) -> K -> m
contTermRefs Reference -> m
f K
k m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (BVal -> m) -> BSeg -> m
forall m a. Monoid m => (a -> m) -> Array a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Reference -> m) -> BVal -> m
forall m. Monoid m => (Reference -> m) -> BVal -> m
closureTermRefs Reference -> m
f) BSeg
bseg
  (Foreign (WrapSeq USeq
cs)) ->
    (Val -> m) -> USeq -> m
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Val Size
_i BVal
clos) -> (Reference -> m) -> BVal -> m
forall m. Monoid m => (Reference -> m) -> BVal -> m
closureTermRefs Reference -> m
f BVal
clos) USeq
cs
  BVal
_ -> m
forall a. Monoid a => a
mempty

contTermRefs :: (Monoid m) => (Reference -> m) -> K -> m
contTermRefs :: forall m. Monoid m => (Reference -> m) -> K -> m
contTermRefs Reference -> m
f (Mark Size
_ EnumSet Word64
_ DEnv
m K
k) =
  ( DEnv
m DEnv -> (DEnv -> m) -> m
forall a b. a -> (a -> b) -> b
& (Val -> m) -> DEnv -> m
forall m a. Monoid m => (a -> m) -> EnumMap Word64 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \case
      BoxedVal BVal
clo -> (Reference -> m) -> BVal -> m
forall m. Monoid m => (Reference -> m) -> BVal -> m
closureTermRefs Reference -> m
f BVal
clo
      Val
_ -> m
forall a. Monoid a => a
mempty
  )
    m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (Reference -> m) -> K -> m
forall m. Monoid m => (Reference -> m) -> K -> m
contTermRefs Reference -> m
f K
k
contTermRefs Reference -> m
f (Push Size
_ Size
_ (CIx Reference
r Word64
_ Word64
_) Size
_ RSection Val
_ K
k) =
  Reference -> m
f Reference
r m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (Reference -> m) -> K -> m
forall m. Monoid m => (Reference -> m) -> K -> m
contTermRefs Reference -> m
f K
k
contTermRefs Reference -> m
_ K
_ = m
forall a. Monoid a => a
mempty

hasNoAllocations :: TH.Name -> TI.Obligation
hasNoAllocations :: Name -> Obligation
hasNoAllocations Name
n = Name -> Property -> Obligation
TI.mkObligation Name
n Property
TI.NoAllocation

unitClosure :: Closure
unitClosure :: BVal
unitClosure = Reference -> PackedTag -> BVal
Enum Reference
Ty.unitRef PackedTag
TT.unitTag
{-# NOINLINE unitClosure #-}

-- Universal comparison functions

closureNum :: Closure -> Int
closureNum :: BVal -> Size
closureNum PAp {} = Size
0
closureNum DataC {} = Size
1
closureNum Captured {} = Size
2
closureNum Foreign {} = Size
3
closureNum UnboxedTypeTag {} = Size
4
closureNum BlackHole {} = Size
5
closureNum Affine {} = Size
6

-- | The `Eq` instance for `Val` can’t be derived because you need to
-- take into account the fact that if a `Val` is boxed, the unboxed side
-- is garbage and should not be compared.
instance Eq Val where
  UnboxedVal Size
v1 UnboxedTypeTag
t1 == :: Val -> Val -> Bool
== UnboxedVal Size
v2 UnboxedTypeTag
t2 =
    UnboxedTypeTag -> UnboxedTypeTag -> Bool
matchUnboxedTypes UnboxedTypeTag
t1 UnboxedTypeTag
t2 Bool -> Bool -> Bool
&& Size
v1 Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
v2
  BoxedVal BVal
x == BoxedVal BVal
y = BVal
x BVal -> BVal -> Bool
forall a. Eq a => a -> a -> Bool
== BVal
y
  Val
_ == Val
_ = Bool
False

instance Eq Closure where
  DataC Reference
_ PackedTag
ct1 [Val
w1] == :: BVal -> BVal -> Bool
== DataC Reference
_ PackedTag
ct2 [Val
w2] =
    PackedTag -> PackedTag -> Bool
matchTags PackedTag
ct1 PackedTag
ct2 Bool -> Bool -> Bool
&& Val
w1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
w2
  DataC Reference
_ PackedTag
ct1 [Val]
vs1 == DataC Reference
_ PackedTag
ct2 [Val]
vs2 =
    PackedTag
ct1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
ct2 Bool -> Bool -> Bool
&& [Val] -> [Val] -> Bool
eqValList [Val]
vs1 [Val]
vs2
  PApV CombIx
cix1 GCombInfo (RComb Val)
_ [Val]
segs1 == PApV CombIx
cix2 GCombInfo (RComb Val)
_ [Val]
segs2 =
    CombIx
cix1 CombIx -> CombIx -> Bool
forall a. Eq a => a -> a -> Bool
== CombIx
cix2 Bool -> Bool -> Bool
&& [Val] -> [Val] -> Bool
eqValList [Val]
segs1 [Val]
segs2
  CapV K
k1 Size
a1 [Val]
vs1 == CapV K
k2 Size
a2 [Val]
vs2 =
    K
k1 K -> K -> Bool
forall a. Eq a => a -> a -> Bool
== K
k2 Bool -> Bool -> Bool
&& Size
a1 Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
a2 Bool -> Bool -> Bool
&& [Val] -> [Val] -> Bool
eqValList [Val]
vs1 [Val]
vs2
  Foreign Foreign
fl == Foreign Foreign
fr = Foreign
fl Foreign -> Foreign -> Bool
forall a. Eq a => a -> a -> Bool
== Foreign
fr
  BVal
c == BVal
d = BVal -> Size
closureNum BVal
c Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== BVal -> Size
closureNum BVal
d

instance Eq K where
  K
KE == :: K -> K -> Bool
== K
KE = Bool
True
  CB Callback
cb == CB Callback
cb' = Callback
cb Callback -> Callback -> Bool
forall a. Eq a => a -> a -> Bool
== Callback
cb'
  Mark Size
a EnumSet Word64
ps DEnv
m K
k == Mark Size
a' EnumSet Word64
ps' DEnv
m' K
k' =
    Size
a Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
a' Bool -> Bool -> Bool
&& EnumSet Word64
ps EnumSet Word64 -> EnumSet Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== EnumSet Word64
ps' Bool -> Bool -> Bool
&& (Val -> Val -> Bool) -> DEnv -> DEnv -> Bool
forall a b.
(a -> b -> Bool) -> EnumMap Word64 a -> EnumMap Word64 b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
(==) DEnv
m DEnv
m' Bool -> Bool -> Bool
&& K
k K -> K -> Bool
forall a. Eq a => a -> a -> Bool
== K
k'
  Push Size
f Size
a CombIx
ci Size
_ RSection Val
_ K
k == Push Size
f' Size
a' CombIx
ci' Size
_ RSection Val
_ K
k' =
    Size
f Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
f' Bool -> Bool -> Bool
&& Size
a Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
a' Bool -> Bool -> Bool
&& CombIx
ci CombIx -> CombIx -> Bool
forall a. Eq a => a -> a -> Bool
== CombIx
ci' Bool -> Bool -> Bool
&& K
k K -> K -> Bool
forall a. Eq a => a -> a -> Bool
== K
k'
  K
_ == K
_ = Bool
False

eqValList :: [Val] -> [Val] -> Bool
eqValList :: [Val] -> [Val] -> Bool
eqValList [Val]
l [Val]
r = [Val] -> Size
forall a. [a] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [Val]
l Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== [Val] -> Size
forall a. [a] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [Val]
r Bool -> Bool -> Bool
&& [Val]
l [Val] -> [Val] -> Bool
forall a. Eq a => a -> a -> Bool
== [Val]
r

-- IEEE floating point layout is such that comparison as integers
-- somewhat works. Positive floating values map to positive integers
-- and negatives map to negatives. The corner cases are:
--
--   1. If both numbers are negative, ordering is flipped.
--   2. There is both +0 and -0, with -0 being represented as the
--      minimum signed integer.
--   3. NaN does weird things.
--
-- So, the strategy here is to compare normally if one argument is
-- positive, since positive numbers compare normally to others.
-- Otherwise, the sign bit is cleared and the numbers are compared
-- backwards. Clearing the sign bit maps -0 to +0 and maps a negative
-- number to its absolute value (including infinities). The multiple
-- NaN values are just handled according to bit patterns, rather than
-- IEEE specified behavior.
--
-- Transitivity is somewhat non-obvious for this implementation.
--
--   if i <= j and j <= k
--     if j > 0 then k > 0, so all 3 comparisons use `compare`
--     if k > 0 then k > i, since i <= j <= 0
--     if all 3 are <= 0, all 3 comparisons use the alternate
--       comparison, which is transitive via `compare`
compareAsFloat :: Int -> Int -> Ordering
compareAsFloat :: Size -> Size -> Ordering
compareAsFloat Size
i Size
j
  | Size
i Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 Bool -> Bool -> Bool
|| Size
j Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 = Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Size
i Size
j
  | Bool
otherwise = Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Size -> Size
forall {a}. Bits a => a -> a
clear Size
j) (Size -> Size
forall {a}. Bits a => a -> a
clear Size
i)
  where
    clear :: a -> a
clear a
k = a -> Size -> a
forall a. Bits a => a -> Size -> a
clearBit a
k Size
64

compareVal :: Bool -> Val -> Val -> Ordering
compareVal :: Bool -> Val -> Val -> Ordering
compareVal Bool
tyEq = \cases
  (BoxedVal BVal
c1) (BoxedVal BVal
c2) -> Bool -> BVal -> BVal -> Ordering
compareClosure Bool
tyEq BVal
c1 BVal
c2
  (UnboxedVal {}) (BoxedVal {}) -> Ordering
LT
  (BoxedVal {}) (UnboxedVal {}) -> Ordering
GT
  (NatVal Word64
i) (NatVal Word64
j) -> Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
i Word64
j
  (UnboxedVal Size
v1 UnboxedTypeTag
t1) (UnboxedVal Size
v2 UnboxedTypeTag
t2) ->
    Bool
-> (UnboxedTypeTag, Size) -> (UnboxedTypeTag, Size) -> Ordering
compareUnboxed Bool
tyEq (UnboxedTypeTag
t1, Size
v1) (UnboxedTypeTag
t2, Size
v2)

compareClosure :: Bool -> Closure -> Closure -> Ordering
compareClosure :: Bool -> BVal -> BVal -> Ordering
compareClosure Bool
tyEq = \cases
  (DataC Reference
rf1 PackedTag
ct1 [Val]
vs1) (DataC Reference
rf2 PackedTag
ct2 [Val]
vs2) ->
    (if Bool
tyEq Bool -> Bool -> Bool
&& PackedTag
ct1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
/= PackedTag
ct2 then Reference -> Reference -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Reference
rf1 Reference
rf2 else Ordering
EQ)
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (PackedTag -> Word64
maskTags PackedTag
ct1) (PackedTag -> Word64
maskTags PackedTag
ct2)
      -- when comparing corresponding `Any` values, which have
      -- existentials inside check that type references match
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> [Val] -> [Val] -> Ordering
compareValList (Bool
tyEq Bool -> Bool -> Bool
|| Reference
rf1 Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Ty.anyRef) [Val]
vs1 [Val]
vs2
  (PApV CombIx
cix1 GCombInfo (RComb Val)
_ [Val]
segs1) (PApV CombIx
cix2 GCombInfo (RComb Val)
_ [Val]
segs2) ->
    CombIx -> CombIx -> Ordering
forall a. Ord a => a -> a -> Ordering
compare CombIx
cix1 CombIx
cix2
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> [Val] -> [Val] -> Ordering
compareValList Bool
tyEq [Val]
segs1 [Val]
segs2
  (CapV K
k1 Size
a1 [Val]
vs1) (CapV K
k2 Size
a2 [Val]
vs2) ->
    Bool -> K -> K -> Ordering
compareK Bool
tyEq K
k1 K
k2
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Size
a1 Size
a2
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> [Val] -> [Val] -> Ordering
compareValList Bool
True [Val]
vs1 [Val]
vs2
  (Foreign Foreign
fl) (Foreign Foreign
fr) -> Bool -> Foreign -> Foreign -> Ordering
compareForeign Bool
tyEq Foreign
fl Foreign
fr
  (UnboxedTypeTag UnboxedTypeTag
t1) (UnboxedTypeTag UnboxedTypeTag
t2) -> UnboxedTypeTag -> UnboxedTypeTag -> Ordering
forall a. Ord a => a -> a -> Ordering
compare UnboxedTypeTag
t1 UnboxedTypeTag
t2
  (BVal
BlackHole) (BVal
BlackHole) -> Ordering
EQ
  BVal
c BVal
d -> (BVal -> Size) -> BVal -> BVal -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing BVal -> Size
closureNum BVal
c BVal
d

compareUnboxed ::
  Bool -> (UnboxedTypeTag, Int) -> (UnboxedTypeTag, Int) -> Ordering
compareUnboxed :: Bool
-> (UnboxedTypeTag, Size) -> (UnboxedTypeTag, Size) -> Ordering
compareUnboxed Bool
tyEq = \cases
  -- Need to cast to Nat or else maxNat == -1 and it flips comparisons
  -- of large Nats.
  --
  -- TODO: Investigate whether bit-twiddling is faster than using
  -- Haskell's fromIntegral.
  (UnboxedTypeTag
IntTag, Size
n1) (UnboxedTypeTag
IntTag, Size
n2) -> Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Size
n1 Size
n2
  (UnboxedTypeTag
NatTag, Size
n1) (UnboxedTypeTag
NatTag, Size
n2) ->
    Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Size -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
n1 :: Word64) (Size -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
n2 :: Word64)
  (UnboxedTypeTag
NatTag, Size
n1) (UnboxedTypeTag
IntTag, Size
n2)
    | Size
n2 Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Size
0 -> Ordering
GT
    | Bool
otherwise ->
        Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Size -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
n1 :: Word64) (Size -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
n2 :: Word64)
  (UnboxedTypeTag
IntTag, Size
n1) (UnboxedTypeTag
NatTag, Size
n2)
    | Size
n1 Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Size
0 -> Ordering
LT
    | Bool
otherwise ->
        Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Size -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
n1 :: Word64) (Size -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
n2 :: Word64)
  (UnboxedTypeTag
FloatTag, Size
n1) (UnboxedTypeTag
FloatTag, Size
n2) -> Size -> Size -> Ordering
compareAsFloat Size
n1 Size
n2
  (UnboxedTypeTag
t1, Size
v1) (UnboxedTypeTag
t2, Size
v2) ->
    Bool -> Ordering -> Ordering
forall a. Monoid a => Bool -> a -> a
Monoid.whenM Bool
tyEq (UnboxedTypeTag -> UnboxedTypeTag -> Ordering
forall a. Ord a => a -> a -> Ordering
compare UnboxedTypeTag
t1 UnboxedTypeTag
t2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Size
v1 Size
v2

compareValList :: Bool -> [Val] -> [Val] -> Ordering
compareValList :: Bool -> [Val] -> [Val] -> Ordering
compareValList Bool
tyEq [Val]
l [Val]
r =
  Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Val] -> Size
forall a. [a] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [Val]
l) ([Val] -> Size
forall a. [a] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [Val]
r) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> [Ordering] -> Ordering
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ((Val -> Val -> Ordering) -> [Val] -> [Val] -> [Ordering]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Bool -> Val -> Val -> Ordering
compareVal Bool
tyEq) [Val]
l [Val]
r)

compareK :: Bool -> K -> K -> Ordering
compareK :: Bool -> K -> K -> Ordering
compareK Bool
tyEq = \cases
  K
KE K
KE -> Ordering
EQ
  (CB Callback
cb) (CB Callback
cb') -> Callback -> Callback -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Callback
cb Callback
cb'
  (Mark Size
a EnumSet Word64
ps DEnv
m K
k) (Mark Size
a' EnumSet Word64
ps' DEnv
m' K
k') ->
    Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Size
a Size
a'
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> EnumSet Word64 -> EnumSet Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare EnumSet Word64
ps EnumSet Word64
ps'
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (Val -> Val -> Ordering) -> DEnv -> DEnv -> Ordering
forall a b.
(a -> b -> Ordering)
-> EnumMap Word64 a -> EnumMap Word64 b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (Bool -> Val -> Val -> Ordering
compareVal Bool
tyEq) DEnv
m DEnv
m'
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> K -> K -> Ordering
compareK Bool
tyEq K
k K
k'
  (Push Size
f Size
a CombIx
ci Size
_ RSection Val
_sect K
k) (Push Size
f' Size
a' CombIx
ci' Size
_ RSection Val
_sect' K
k') ->
    Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Size
f Size
f'
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Size
a Size
a'
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> CombIx -> CombIx -> Ordering
forall a. Ord a => a -> a -> Ordering
compare CombIx
ci CombIx
ci'
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> K -> K -> Ordering
compareK Bool
tyEq K
k K
k'
  K
KE K
_ -> Ordering
LT
  K
_ K
KE -> Ordering
GT
  (CB {}) K
_ -> Ordering
LT
  K
_ (CB {}) -> Ordering
GT
  (Mark {}) K
_ -> Ordering
LT
  K
_ (Mark {}) -> Ordering
GT
  (Local {}) K
_ -> [Char] -> Ordering
forall a. HasCallStack => [Char] -> a
error [Char]
"compare K: captured Local frame"
  K
_ (Local {}) -> [Char] -> Ordering
forall a. HasCallStack => [Char] -> a
error [Char]
"compare K: captured Local frame"
  (AMark {}) K
_ -> [Char] -> Ordering
forall a. HasCallStack => [Char] -> a
error [Char]
"compare K: captured AMark frame"
  K
_ (AMark {}) -> [Char] -> Ordering
forall a. HasCallStack => [Char] -> a
error [Char]
"compare K: captured AMark frame"
  (Keep {}) K
_ -> [Char] -> Ordering
forall a. HasCallStack => [Char] -> a
error [Char]
"compare K: captured Keep frame"
  K
_ (Keep {}) -> [Char] -> Ordering
forall a. HasCallStack => [Char] -> a
error [Char]
"compare K: captured Keep frame"

-- Note: these are not the same as the Data.Map Eq/Ord instances,
-- because the automatic derivation in unison doesn't consider
-- equivalent maps to be the same. It just checks the exact
-- data structure.
mapEq :: Map Val Val -> Map Val Val -> Bool
mapEq :: Map Val Val -> Map Val Val -> Bool
mapEq Map Val Val
Tip Map Val Val
Tip = Bool
True
mapEq (Bin Size
szl Val
kl Val
vl Map Val Val
ll Map Val Val
rl) (Bin Size
szr Val
kr Val
vr Map Val Val
lr Map Val Val
rr) =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
    [ Size
szl Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
szr,
      Val
kl Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
kr,
      Val
vl Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
vr,
      Map Val Val -> Map Val Val -> Bool
mapEq Map Val Val
ll Map Val Val
lr,
      Map Val Val -> Map Val Val -> Bool
mapEq Map Val Val
rl Map Val Val
rr
    ]
mapEq Map Val Val
_ Map Val Val
_ = Bool
False

mapCmp :: Bool -> Map Val Val -> Map Val Val -> Ordering
mapCmp :: Bool -> Map Val Val -> Map Val Val -> Ordering
mapCmp Bool
_tyEq Map Val Val
Tip Map Val Val
Tip = Ordering
EQ
mapCmp Bool
tyEq (Bin Size
szl Val
kl Val
vl Map Val Val
ll Map Val Val
rl) (Bin Size
szr Val
kr Val
vr Map Val Val
lr Map Val Val
rr) =
  [Ordering] -> Ordering
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Size
szl Size
szr,
      Bool -> Val -> Val -> Ordering
compareVal Bool
tyEq Val
kl Val
kr,
      Bool -> Val -> Val -> Ordering
compareVal Bool
tyEq Val
vl Val
vr,
      Bool -> Map Val Val -> Map Val Val -> Ordering
mapCmp Bool
tyEq Map Val Val
ll Map Val Val
lr,
      Bool -> Map Val Val -> Map Val Val -> Ordering
mapCmp Bool
tyEq Map Val Val
rl Map Val Val
rr
    ]
mapCmp Bool
_ Map Val Val
Tip Bin {} = Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
mapTip Word64
mapBin
mapCmp Bool
_ Bin {} Map Val Val
Tip = Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
mapBin Word64
mapTip

-- serialization doesn't necessarily preserve Int tags, so be
-- more accepting for those.
matchTags :: PackedTag -> PackedTag -> Bool
matchTags :: PackedTag -> PackedTag -> Bool
matchTags PackedTag
ct1 PackedTag
ct2 =
  PackedTag
ct1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
ct2
    Bool -> Bool -> Bool
|| (PackedTag
ct1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.intTag Bool -> Bool -> Bool
&& PackedTag
ct2 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.natTag)
    Bool -> Bool -> Bool
|| (PackedTag
ct1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.natTag Bool -> Bool -> Bool
&& PackedTag
ct2 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.intTag)

-- serialization doesn't necessarily preserve Int tags, so be
-- more accepting for those.
matchUnboxedTypes :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
matchUnboxedTypes :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
matchUnboxedTypes UnboxedTypeTag
ct1 UnboxedTypeTag
ct2 =
  UnboxedTypeTag
ct1 UnboxedTypeTag -> UnboxedTypeTag -> Bool
forall a. Eq a => a -> a -> Bool
== UnboxedTypeTag
ct2
    Bool -> Bool -> Bool
|| (UnboxedTypeTag
ct1 UnboxedTypeTag -> UnboxedTypeTag -> Bool
forall a. Eq a => a -> a -> Bool
== UnboxedTypeTag
IntTag Bool -> Bool -> Bool
&& UnboxedTypeTag
ct2 UnboxedTypeTag -> UnboxedTypeTag -> Bool
forall a. Eq a => a -> a -> Bool
== UnboxedTypeTag
NatTag)
    Bool -> Bool -> Bool
|| (UnboxedTypeTag
ct1 UnboxedTypeTag -> UnboxedTypeTag -> Bool
forall a. Eq a => a -> a -> Bool
== UnboxedTypeTag
NatTag Bool -> Bool -> Bool
&& UnboxedTypeTag
ct2 UnboxedTypeTag -> UnboxedTypeTag -> Bool
forall a. Eq a => a -> a -> Bool
== UnboxedTypeTag
IntTag)

-- Turn the pseudo data version of maps back into the closure that
-- it represents as a unison type.
inflateMap :: Map Val Val -> Closure
inflateMap :: Map Val Val -> BVal
inflateMap Map Val Val
Tip = Reference -> PackedTag -> BVal
Enum Reference
mapRef PackedTag
TT.mapTipTag
inflateMap (Bin Size
sz Val
k Val
v Map Val Val
l Map Val Val
r) =
  Reference -> PackedTag -> [Val] -> BVal
DataC
    Reference
mapRef
    PackedTag
TT.mapBinTag
    [Word64 -> Val
NatVal (Word64 -> Val) -> Word64 -> Val
forall a b. (a -> b) -> a -> b
$ Size -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
sz, Val
k, Val
v, BVal -> Val
BoxedVal (BVal -> Val) -> BVal -> Val
forall a b. (a -> b) -> a -> b
$ Map Val Val -> BVal
inflateMap Map Val Val
l, BVal -> Val
BoxedVal (BVal -> Val) -> BVal -> Val
forall a b. (a -> b) -> a -> b
$ Map Val Val -> BVal
inflateMap Map Val Val
r]

-- Reverses the above conversion, turning a unison data
-- representation of a map back into a Haskell map.
deflateMap :: Closure -> Maybe (Map Val Val)
deflateMap :: BVal -> Maybe (Map Val Val)
deflateMap (Enum Reference
_ PackedTag
t)
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.mapTipTag = Map Val Val -> Maybe (Map Val Val)
forall a. a -> Maybe a
Just Map Val Val
forall k a. Map k a
Tip
deflateMap (DataC Reference
_ PackedTag
t [NatVal Word64
sz, Val
k, Val
v, BoxedVal BVal
l, BoxedVal BVal
r])
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.mapBinTag =
      Size -> Val -> Val -> Map Val Val -> Map Val Val -> Map Val Val
forall k a. Size -> k -> a -> Map k a -> Map k a -> Map k a
Bin (Word64 -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sz) Val
k Val
v (Map Val Val -> Map Val Val -> Map Val Val)
-> Maybe (Map Val Val) -> Maybe (Map Val Val -> Map Val Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BVal -> Maybe (Map Val Val)
deflateMap BVal
l Maybe (Map Val Val -> Map Val Val)
-> Maybe (Map Val Val) -> Maybe (Map Val Val)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BVal -> Maybe (Map Val Val)
deflateMap BVal
r
deflateMap BVal
_ = Maybe (Map Val Val)
forall a. Maybe a
Nothing

-- ------------------------------
-- 'Foreign' value implementation
-- ------------------------------

-- Disjoint union of wraped Haskell values. Originally this was going to
-- be an existential type to enable extensibility, but that never
-- materialized, and a big bunch of cases facilitates some nicer behavior.
data Foreign
  = WrapArray !(Array Val)
  | WrapByteArray !ByteArray
  | WrapBytes !Bytes
  | WrapCDynFunc !CDynFunc
  | WrapCPattern !CPattern
  | WrapCharPattern !CharPattern
  | WrapCode !(Referenced Code)
  | WrapClientSockAddr !ClientSockAddr
  | WrapDLL !DLL
  | WrapFFISpec !FFSpec
  | WrapFFIType !FFType
  | WrapHandle !Handle
  | WrapHashAlgorithm !HashAlgorithm
  | WrapIORef !(IORef Val)
  | WrapInteger !Integer
  | WrapListenSocket !ListenSocket
  | WrapMap !(Map Val Val)
  | WrapMutableByteArray !(MutableByteArray RealWorld)
  | WrapMutableArray !(MutableArray RealWorld Val)
  | WrapMVar !(MVar Val)
  | WrapNatural !Natural
  | WrapProcessHandle !ProcessHandle
  | WrapPromise !(Promise Val)
  | WrapPtr !(Ptr.Ptr ())
  | WrapReference !Reference
  | WrapReferent !Referent
  | WrapSeq !(Seq Val)
  | WrapSocket !Socket
  | WrapText !U.Text
  | WrapThreadId !ThreadId
  | WrapTicket !(Atomic.Ticket Val)
  | WrapTimeSpec !TimeSpec
  | WrapTlsClientParams !TLS.ClientParams
  | WrapTlsServerParams !TLS.ServerParams
  | WrapTls !Tls
  | WrapTVar !(TVar Val)
  | WrapUDPSocket !UDPSocket
  | WrapValue !(Referenced Value)
  | WrapX509PrivKey !X509.PrivKey
  | WrapX509SignedCertificate !X509.SignedCertificate

-- Convenience class for (un)wrapping Haskell values automatically
class BuiltinForeign f where
  builtinName :: Tagged f String
  wrapBuiltin :: f -> Foreign
  maybeUnwrapBuiltin :: Foreign -> Maybe f

foreignRef :: Foreign -> Reference
foreignRef :: Foreign -> Reference
foreignRef WrapArray {} = Reference
Ty.iarrayRef
foreignRef WrapByteArray {} = Reference
Ty.ibytearrayRef
foreignRef WrapBytes {} = Reference
Ty.bytesRef
foreignRef WrapCDynFunc {} = Reference
Ty.ffiFuncRef
foreignRef WrapCPattern {} = Reference
Ty.patternRef
foreignRef WrapCharPattern {} = Reference
Ty.charClassRef
foreignRef WrapCode {} = Reference
Ty.codeRef
foreignRef WrapClientSockAddr {} = Reference
Ty.udpClientSockAddrRef
foreignRef WrapDLL {} = Reference
Ty.ffiDllRef
foreignRef WrapFFISpec {} = Reference
Ty.ffiSpecRef
foreignRef WrapFFIType {} = Reference
Ty.ffiTypeRef
foreignRef WrapHandle {} = Reference
Ty.fileHandleRef
foreignRef WrapHashAlgorithm {} = Reference
Ty.hashAlgorithmRef
foreignRef WrapIORef {} = Reference
Ty.refRef
foreignRef WrapInteger {} = Reference
Ty.integerRef
foreignRef WrapListenSocket {} = Reference
Ty.udpListenSocketRef
foreignRef WrapMap {} = Reference
Ty.hmapRef
foreignRef WrapMutableByteArray {} = Reference
Ty.mbytearrayRef
foreignRef WrapMutableArray {} = Reference
Ty.marrayRef
foreignRef WrapMVar {} = Reference
Ty.mvarRef
foreignRef WrapNatural {} = Reference
Ty.naturalRef
foreignRef WrapProcessHandle {} = Reference
Ty.processHandleRef
foreignRef WrapPromise {} = Reference
Ty.promiseRef
foreignRef WrapPtr {} = Reference
Ty.ffiPtrRef
foreignRef WrapReference {} = Reference
Ty.typeLinkRef
foreignRef WrapReferent {} = Reference
Ty.termLinkRef
foreignRef WrapSeq {} = Reference
Ty.listRef
foreignRef WrapSocket {} = Reference
Ty.socketRef
foreignRef WrapText {} = Reference
Ty.textRef
foreignRef WrapThreadId {} = Reference
Ty.threadIdRef
foreignRef WrapTicket {} = Reference
Ty.ticketRef
foreignRef WrapTimeSpec {} = Reference
Ty.timeSpecRef
foreignRef WrapTlsClientParams {} = Reference
Ty.tlsClientConfigRef
foreignRef WrapTlsServerParams {} = Reference
Ty.tlsServerConfigRef
foreignRef WrapTls {} = Reference
Ty.tlsRef
foreignRef WrapTVar {} = Reference
Ty.tvarRef
foreignRef WrapUDPSocket {} = Reference
Ty.udpSocketRef
foreignRef WrapValue {} = Reference
Ty.valueRef
foreignRef WrapX509PrivKey {} = Reference
Ty.tlsPrivateKeyRef
foreignRef WrapX509SignedCertificate {} = Reference
Ty.tlsSignedCertRef

foreignName :: Foreign -> String
foreignName :: Foreign -> [Char]
foreignName WrapArray {} = [Char]
"Array"
foreignName WrapByteArray {} = [Char]
"ByteArray"
foreignName WrapBytes {} = [Char]
"Bytes"
foreignName WrapCDynFunc {} = [Char]
"DLL.Func"
foreignName WrapCPattern {} = [Char]
"CPattern"
foreignName WrapCharPattern {} = [Char]
"CharPattern"
foreignName WrapCode {} = [Char]
"Code"
foreignName WrapClientSockAddr {} = [Char]
"ClientSockAddr"
foreignName WrapDLL {} = [Char]
"DLL"
foreignName WrapFFIType {} = [Char]
"FFI.Type"
foreignName WrapFFISpec {} = [Char]
"FFI.Spec"
foreignName WrapHandle {} = [Char]
"Handle"
foreignName WrapHashAlgorithm {} = [Char]
"HashAlgorithm"
foreignName WrapIORef {} = [Char]
"IORef"
foreignName WrapInteger {} = [Char]
"Integer"
foreignName WrapListenSocket {} = [Char]
"ListenSocket"
foreignName WrapMap {} = [Char]
"Map"
foreignName WrapMutableByteArray {} = [Char]
"MutableByteArray"
foreignName WrapMutableArray {} = [Char]
"MutableArray"
foreignName WrapMVar {} = [Char]
"MVar"
foreignName WrapNatural {} = [Char]
"Natural"
foreignName WrapProcessHandle {} = [Char]
"ProcessHandle"
foreignName WrapPromise {} = [Char]
"Promise"
foreignName WrapPtr {} = [Char]
"Ptr"
foreignName WrapReference {} = [Char]
"Reference"
foreignName WrapReferent {} = [Char]
"Referent"
foreignName WrapSeq {} = [Char]
"Seq"
foreignName WrapSocket {} = [Char]
"Socket"
foreignName WrapText {} = [Char]
"Text"
foreignName WrapThreadId {} = [Char]
"ThreadId"
foreignName WrapTicket {} = [Char]
"Ticket"
foreignName WrapTimeSpec {} = [Char]
"TimeSpec"
foreignName WrapTlsClientParams {} = [Char]
"ClientParams"
foreignName WrapTlsServerParams {} = [Char]
"ServerParams"
foreignName WrapTls {} = [Char]
"Tls"
foreignName WrapTVar {} = [Char]
"TVar"
foreignName WrapUDPSocket {} = [Char]
"UDPSocket"
foreignName WrapValue {} = [Char]
"Value"
foreignName WrapX509PrivKey {} = [Char]
"X509.PrivKey"
foreignName WrapX509SignedCertificate {} = [Char]
"X509.SignedCertificate"

-- Gets a number corresponding to the foreign constructor. Should just
-- be used for testing whether two values have the same or distinct
-- constructors.
foreignId :: Foreign -> Int
foreignId :: Foreign -> Size
foreignId Foreign
f = Int# -> Size
I# (Foreign -> Int#
forall a. a -> Int#
dataToTag# Foreign
f)

ptrEq :: a -> a -> Bool
ptrEq :: forall a. a -> a -> Bool
ptrEq a
x a
y =
  IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
    StableName a
sn1 <- a -> IO (StableName a)
forall a. a -> IO (StableName a)
makeStableName (a -> IO (StableName a)) -> a -> IO (StableName a)
forall a b. (a -> b) -> a -> b
$! a
x
    StableName a
sn2 <- a -> IO (StableName a)
forall a. a -> IO (StableName a)
makeStableName (a -> IO (StableName a)) -> a -> IO (StableName a)
forall a b. (a -> b) -> a -> b
$! a
y
    return (StableName a
sn1 StableName a -> StableName a -> Bool
forall a. Eq a => a -> a -> Bool
== StableName a
sn2)

instance Eq Foreign where
  WrapArray Array Val
l == :: Foreign -> Foreign -> Bool
== WrapArray Array Val
r = Array Val
l Array Val -> Array Val -> Bool
forall a. Eq a => a -> a -> Bool
== Array Val
r
  WrapText Text
l == WrapText Text
r = Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
r
  WrapReferent Referent
l == WrapReferent Referent
r = Referent
l Referent -> Referent -> Bool
forall a. Eq a => a -> a -> Bool
== Referent
r
  WrapReference Reference
l == WrapReference Reference
r = Reference
l Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
r
  WrapBytes Bytes
l == WrapBytes Bytes
r = Bytes
l Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes
r
  WrapMVar MVar Val
l == WrapMVar MVar Val
r = MVar Val
l MVar Val -> MVar Val -> Bool
forall a. Eq a => a -> a -> Bool
== MVar Val
r
  WrapSeq USeq
l == WrapSeq USeq
r = USeq
l USeq -> USeq -> Bool
forall a. Eq a => a -> a -> Bool
== USeq
r
  WrapTVar TVar Val
l == WrapTVar TVar Val
r = TVar Val
l TVar Val -> TVar Val -> Bool
forall a. Eq a => a -> a -> Bool
== TVar Val
r
  WrapSocket Socket
l == WrapSocket Socket
r = Socket
l Socket -> Socket -> Bool
forall a. Eq a => a -> a -> Bool
== Socket
r
  WrapTls (Tls Socket
l Context
_) == WrapTls (Tls Socket
r Context
_) = Socket
l Socket -> Socket -> Bool
forall a. Eq a => a -> a -> Bool
== Socket
r
  WrapUDPSocket UDPSocket
l == WrapUDPSocket UDPSocket
r = UDPSocket
l UDPSocket -> UDPSocket -> Bool
forall a. Eq a => a -> a -> Bool
== UDPSocket
r
  WrapIORef IORef Val
l == WrapIORef IORef Val
r = IORef Val
l IORef Val -> IORef Val -> Bool
forall a. Eq a => a -> a -> Bool
== IORef Val
r
  WrapThreadId ThreadId
l == WrapThreadId ThreadId
r = ThreadId
l ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
r
  WrapMap Map Val Val
l == WrapMap Map Val Val
r = Map Val Val -> Map Val Val -> Bool
mapEq Map Val Val
l Map Val Val
r
  WrapMutableArray MutableArray RealWorld Val
l == WrapMutableArray MutableArray RealWorld Val
r = MutableArray RealWorld Val
l MutableArray RealWorld Val -> MutableArray RealWorld Val -> Bool
forall a. Eq a => a -> a -> Bool
== MutableArray RealWorld Val
r
  WrapMutableByteArray MutableByteArray RealWorld
l == WrapMutableByteArray MutableByteArray RealWorld
r = MutableByteArray RealWorld
l MutableByteArray RealWorld -> MutableByteArray RealWorld -> Bool
forall a. Eq a => a -> a -> Bool
== MutableByteArray RealWorld
r
  WrapByteArray ByteArray
l == WrapByteArray ByteArray
r = ByteArray
l ByteArray -> ByteArray -> Bool
forall a. Eq a => a -> a -> Bool
== ByteArray
r
  WrapCPattern CPattern
l == WrapCPattern CPattern
r = CPattern
l CPattern -> CPattern -> Bool
forall a. Eq a => a -> a -> Bool
== CPattern
r
  WrapCharPattern CharPattern
l == WrapCharPattern CharPattern
r = CharPattern
l CharPattern -> CharPattern -> Bool
forall a. Eq a => a -> a -> Bool
== CharPattern
r
  WrapCode Referenced Code
l == WrapCode Referenced Code
r = Referenced Code -> Code Reference
forall (t :: * -> *). Referential t => Referenced t -> t Reference
dereference Referenced Code
l Code Reference -> Code Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Referenced Code -> Code Reference
forall (t :: * -> *). Referential t => Referenced t -> t Reference
dereference Referenced Code
r
  WrapInteger Integer
l == WrapInteger Integer
r = Integer
l Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
r
  WrapNatural Natural
l == WrapNatural Natural
r = Natural
l Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
r
  WrapX509SignedCertificate SignedCertificate
l == WrapX509SignedCertificate SignedCertificate
r = SignedCertificate
l SignedCertificate -> SignedCertificate -> Bool
forall a. Eq a => a -> a -> Bool
== SignedCertificate
r
  WrapListenSocket ListenSocket
l == WrapListenSocket ListenSocket
r = ListenSocket
l ListenSocket -> ListenSocket -> Bool
forall a. Eq a => a -> a -> Bool
== ListenSocket
r
  WrapClientSockAddr ClientSockAddr
l == WrapClientSockAddr ClientSockAddr
r = ClientSockAddr
l ClientSockAddr -> ClientSockAddr -> Bool
forall a. Eq a => a -> a -> Bool
== ClientSockAddr
r
  WrapHandle Handle
l == WrapHandle Handle
r = Handle
l Handle -> Handle -> Bool
forall a. Eq a => a -> a -> Bool
== Handle
r
  WrapHashAlgorithm HashAlgorithm
l == WrapHashAlgorithm HashAlgorithm
r = HashAlgorithm -> HashAlgorithm -> Bool
forall a. a -> a -> Bool
ptrEq HashAlgorithm
l HashAlgorithm
r
  WrapTicket Ticket Val
l == WrapTicket Ticket Val
r = Ticket Val
l Ticket Val -> Ticket Val -> Bool
forall a. Eq a => a -> a -> Bool
== Ticket Val
r
  WrapTimeSpec TimeSpec
l == WrapTimeSpec TimeSpec
r = TimeSpec
l TimeSpec -> TimeSpec -> Bool
forall a. Eq a => a -> a -> Bool
== TimeSpec
r
  WrapX509PrivKey PrivKey
l == WrapX509PrivKey PrivKey
r = PrivKey
l PrivKey -> PrivKey -> Bool
forall a. Eq a => a -> a -> Bool
== PrivKey
r
  WrapPtr Ptr ()
l == WrapPtr Ptr ()
r = Ptr ()
l Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
r
  -- these lack Eq instances
  WrapProcessHandle ProcessHandle
l == WrapProcessHandle ProcessHandle
r = ProcessHandle -> ProcessHandle -> Bool
forall a. a -> a -> Bool
ptrEq ProcessHandle
l ProcessHandle
r
  WrapPromise Promise Val
l == WrapPromise Promise Val
r = Promise Val -> Promise Val -> Bool
forall a. a -> a -> Bool
ptrEq Promise Val
l Promise Val
r
  WrapTlsClientParams ClientParams
l == WrapTlsClientParams ClientParams
r = ClientParams -> ClientParams -> Bool
forall a. a -> a -> Bool
ptrEq ClientParams
l ClientParams
r
  WrapTlsServerParams ServerParams
l == WrapTlsServerParams ServerParams
r = ServerParams -> ServerParams -> Bool
forall a. a -> a -> Bool
ptrEq ServerParams
l ServerParams
r
  WrapValue Referenced Value
l == WrapValue Referenced Value
r = Referenced Value -> Referenced Value -> Bool
forall a. a -> a -> Bool
ptrEq Referenced Value
l Referenced Value
r
  Foreign
l == Foreign
r =
    [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$
      [Char]
"Attempting to check equality of values of different types: "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Foreign -> [Char]
foreignName Foreign
l
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` vs `"
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Foreign -> [Char]
foreignName Foreign
r
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"

compareForeign :: Bool -> Foreign -> Foreign -> Ordering
compareForeign :: Bool -> Foreign -> Foreign -> Ordering
compareForeign Bool
_tyEq (WrapText Text
l) (WrapText Text
r) = Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Text
l Text
r
compareForeign Bool
_tyEq (WrapReference Reference
l) (WrapReference Reference
r) = Reference -> Reference -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Reference
l Reference
r
compareForeign Bool
_tyEq (WrapReferent Referent
l) (WrapReferent Referent
r) = Referent -> Referent -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Referent
l Referent
r
compareForeign Bool
_tyEq (WrapBytes Bytes
l) (WrapBytes Bytes
r) = Bytes -> Bytes -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bytes
l Bytes
r
compareForeign Bool
_tyEq (WrapThreadId ThreadId
l) (WrapThreadId ThreadId
r) = ThreadId -> ThreadId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ThreadId
l ThreadId
r
compareForeign Bool
_tyEq (WrapByteArray ByteArray
l) (WrapByteArray ByteArray
r) = ByteArray -> ByteArray -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ByteArray
l ByteArray
r
compareForeign Bool
_tyEq (WrapCPattern CPattern
l) (WrapCPattern CPattern
r) = CPattern -> CPattern -> Ordering
forall a. Ord a => a -> a -> Ordering
compare CPattern
l CPattern
r
compareForeign Bool
_tyEq (WrapCharPattern CharPattern
l) (WrapCharPattern CharPattern
r) = CharPattern -> CharPattern -> Ordering
forall a. Ord a => a -> a -> Ordering
compare CharPattern
l CharPattern
r
compareForeign Bool
_tyEq (WrapInteger Integer
l) (WrapInteger Integer
r) = Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
l Integer
r
compareForeign Bool
_tyEq (WrapNatural Natural
l) (WrapNatural Natural
r) = Natural -> Natural -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Natural
l Natural
r
compareForeign Bool
_tyEq (WrapPtr Ptr ()
l) (WrapPtr Ptr ()
r) = Ptr () -> Ptr () -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Ptr ()
l Ptr ()
r
compareForeign Bool
tyEq (WrapMap Map Val Val
l) (WrapMap Map Val Val
r) = Bool -> Map Val Val -> Map Val Val -> Ordering
mapCmp Bool
tyEq Map Val Val
l Map Val Val
r
compareForeign Bool
tyEq (WrapSeq USeq
l) (WrapSeq USeq
r) =
  (Val -> Val -> Ordering) -> USeq -> USeq -> Ordering
forall a b. (a -> b -> Ordering) -> Seq a -> Seq b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (Bool -> Val -> Val -> Ordering
compareVal Bool
tyEq) USeq
l USeq
r
compareForeign Bool
tyEq (WrapArray Array Val
l) (WrapArray Array Val
r) =
  (Val -> Val -> Ordering) -> Array Val -> Array Val -> Ordering
forall a b. (a -> b -> Ordering) -> Array a -> Array b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (Bool -> Val -> Val -> Ordering
compareVal Bool
tyEq) Array Val
l Array Val
r
compareForeign Bool
_tyEq Foreign
l Foreign
r
  | Foreign -> Size
foreignId Foreign
l Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Foreign -> Size
foreignId Foreign
r =
      [Char] -> Ordering
forall a. HasCallStack => [Char] -> a
error ([Char] -> Ordering) -> [Char] -> Ordering
forall a b. (a -> b) -> a -> b
$
        [Char]
"Do not know how to compare values of type: "
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Foreign -> [Char]
foreignName Foreign
l
  | Bool
otherwise =
      [Char] -> Ordering
forall a. HasCallStack => [Char] -> a
error ([Char] -> Ordering) -> [Char] -> Ordering
forall a b. (a -> b) -> a -> b
$
        [Char]
"Attempting to compare two values of different types: `"
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Foreign -> [Char]
foreignName Foreign
l
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` vs `"
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Foreign -> [Char]
foreignName Foreign
r
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"

instance Ord Foreign where
  compare :: Foreign -> Foreign -> Ordering
compare = Bool -> Foreign -> Foreign -> Ordering
compareForeign Bool
False

instance Show Foreign where
  showsPrec :: Size -> Foreign -> ShowS
showsPrec Size
p Foreign
f =
    Bool -> ShowS -> ShowS
showParen (Size
p Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
9) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      [Char] -> ShowS
showString [Char]
"Wrap "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString (Foreign -> [Char]
foreignName Foreign
f)
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case Foreign
f of
          WrapText Text
t -> Text -> ShowS
forall a. Show a => a -> ShowS
shows Text
t
          Foreign
_ -> [Char] -> ShowS
showString [Char]
"_"

instance BuiltinForeign U.Text where
  builtinName :: Tagged Text [Char]
builtinName = [Char] -> Tagged Text [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Text"
  wrapBuiltin :: Text -> Foreign
wrapBuiltin = Text -> Foreign
WrapText
  maybeUnwrapBuiltin :: Foreign -> Maybe Text
maybeUnwrapBuiltin = \case
    WrapText Text
v -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
v
    Foreign
_ -> Maybe Text
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign Bytes where
  builtinName :: Tagged Bytes [Char]
builtinName = [Char] -> Tagged Bytes [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Bytes"
  wrapBuiltin :: Bytes -> Foreign
wrapBuiltin = Bytes -> Foreign
WrapBytes
  maybeUnwrapBuiltin :: Foreign -> Maybe Bytes
maybeUnwrapBuiltin = \case
    WrapBytes Bytes
v -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
v
    Foreign
_ -> Maybe Bytes
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign Handle where
  builtinName :: Tagged Handle [Char]
builtinName = [Char] -> Tagged Handle [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Handle"
  wrapBuiltin :: Handle -> Foreign
wrapBuiltin = Handle -> Foreign
WrapHandle
  maybeUnwrapBuiltin :: Foreign -> Maybe Handle
maybeUnwrapBuiltin = \case
    WrapHandle Handle
v -> Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
v
    Foreign
_ -> Maybe Handle
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign ProcessHandle where
  builtinName :: Tagged ProcessHandle [Char]
builtinName = [Char] -> Tagged ProcessHandle [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"ProcessHandle"
  wrapBuiltin :: ProcessHandle -> Foreign
wrapBuiltin = ProcessHandle -> Foreign
WrapProcessHandle
  maybeUnwrapBuiltin :: Foreign -> Maybe ProcessHandle
maybeUnwrapBuiltin = \case
    WrapProcessHandle ProcessHandle
v -> ProcessHandle -> Maybe ProcessHandle
forall a. a -> Maybe a
Just ProcessHandle
v
    Foreign
_ -> Maybe ProcessHandle
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (Ptr.Ptr a) where
  builtinName :: Tagged (Ptr a) [Char]
builtinName = [Char] -> Tagged (Ptr a) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Ptr"
  wrapBuiltin :: Ptr a -> Foreign
wrapBuiltin = Ptr () -> Foreign
WrapPtr (Ptr () -> Foreign) -> (Ptr a -> Ptr ()) -> Ptr a -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> Ptr ()
forall a b. Ptr a -> Ptr b
Ptr.castPtr
  maybeUnwrapBuiltin :: Foreign -> Maybe (Ptr a)
maybeUnwrapBuiltin = \case
    WrapPtr Ptr ()
p -> Ptr a -> Maybe (Ptr a)
forall a. a -> Maybe a
Just (Ptr () -> Ptr a
forall a b. Ptr a -> Ptr b
Ptr.castPtr Ptr ()
p)
    Foreign
_ -> Maybe (Ptr a)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

-- | Note: References are assumed to be type links
instance BuiltinForeign Reference where
  builtinName :: Tagged Reference [Char]
builtinName = [Char] -> Tagged Reference [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Reference"
  wrapBuiltin :: Reference -> Foreign
wrapBuiltin = Reference -> Foreign
WrapReference
  maybeUnwrapBuiltin :: Foreign -> Maybe Reference
maybeUnwrapBuiltin = \case
    WrapReference Reference
v -> Reference -> Maybe Reference
forall a. a -> Maybe a
Just Reference
v
    Foreign
_ -> Maybe Reference
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign Referent where
  builtinName :: Tagged Referent [Char]
builtinName = [Char] -> Tagged Referent [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Referent"
  wrapBuiltin :: Referent -> Foreign
wrapBuiltin = Referent -> Foreign
WrapReferent
  maybeUnwrapBuiltin :: Foreign -> Maybe Referent
maybeUnwrapBuiltin = \case
    WrapReferent Referent
v -> Referent -> Maybe Referent
forall a. a -> Maybe a
Just Referent
v
    Foreign
_ -> Maybe Referent
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign Socket where
  builtinName :: Tagged Socket [Char]
builtinName = [Char] -> Tagged Socket [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Socket"
  wrapBuiltin :: Socket -> Foreign
wrapBuiltin = Socket -> Foreign
WrapSocket
  maybeUnwrapBuiltin :: Foreign -> Maybe Socket
maybeUnwrapBuiltin = \case
    WrapSocket Socket
v -> Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
v
    Foreign
_ -> Maybe Socket
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign ListenSocket where
  builtinName :: Tagged ListenSocket [Char]
builtinName = [Char] -> Tagged ListenSocket [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"ListenSocket"
  wrapBuiltin :: ListenSocket -> Foreign
wrapBuiltin = ListenSocket -> Foreign
WrapListenSocket
  maybeUnwrapBuiltin :: Foreign -> Maybe ListenSocket
maybeUnwrapBuiltin = \case
    WrapListenSocket ListenSocket
v -> ListenSocket -> Maybe ListenSocket
forall a. a -> Maybe a
Just ListenSocket
v
    Foreign
_ -> Maybe ListenSocket
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign ClientSockAddr where
  builtinName :: Tagged ClientSockAddr [Char]
builtinName = [Char] -> Tagged ClientSockAddr [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"ClientSockAddr"
  wrapBuiltin :: ClientSockAddr -> Foreign
wrapBuiltin = ClientSockAddr -> Foreign
WrapClientSockAddr
  maybeUnwrapBuiltin :: Foreign -> Maybe ClientSockAddr
maybeUnwrapBuiltin = \case
    WrapClientSockAddr ClientSockAddr
v -> ClientSockAddr -> Maybe ClientSockAddr
forall a. a -> Maybe a
Just ClientSockAddr
v
    Foreign
_ -> Maybe ClientSockAddr
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign UDPSocket where
  builtinName :: Tagged UDPSocket [Char]
builtinName = [Char] -> Tagged UDPSocket [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"UDPSocket"
  wrapBuiltin :: UDPSocket -> Foreign
wrapBuiltin = UDPSocket -> Foreign
WrapUDPSocket
  maybeUnwrapBuiltin :: Foreign -> Maybe UDPSocket
maybeUnwrapBuiltin = \case
    WrapUDPSocket UDPSocket
v -> UDPSocket -> Maybe UDPSocket
forall a. a -> Maybe a
Just UDPSocket
v
    Foreign
_ -> Maybe UDPSocket
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign ThreadId where
  builtinName :: Tagged ThreadId [Char]
builtinName = [Char] -> Tagged ThreadId [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"ThreadId"
  wrapBuiltin :: ThreadId -> Foreign
wrapBuiltin = ThreadId -> Foreign
WrapThreadId
  maybeUnwrapBuiltin :: Foreign -> Maybe ThreadId
maybeUnwrapBuiltin = \case
    WrapThreadId ThreadId
v -> ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
v
    Foreign
_ -> Maybe ThreadId
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign TLS.ClientParams where
  builtinName :: Tagged ClientParams [Char]
builtinName = [Char] -> Tagged ClientParams [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"ClientParams"
  wrapBuiltin :: ClientParams -> Foreign
wrapBuiltin = ClientParams -> Foreign
WrapTlsClientParams
  maybeUnwrapBuiltin :: Foreign -> Maybe ClientParams
maybeUnwrapBuiltin = \case
    WrapTlsClientParams ClientParams
v -> ClientParams -> Maybe ClientParams
forall a. a -> Maybe a
Just ClientParams
v
    Foreign
_ -> Maybe ClientParams
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign TLS.ServerParams where
  builtinName :: Tagged ServerParams [Char]
builtinName = [Char] -> Tagged ServerParams [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"ServerParams"
  wrapBuiltin :: ServerParams -> Foreign
wrapBuiltin = ServerParams -> Foreign
WrapTlsServerParams
  maybeUnwrapBuiltin :: Foreign -> Maybe ServerParams
maybeUnwrapBuiltin = \case
    WrapTlsServerParams ServerParams
v -> ServerParams -> Maybe ServerParams
forall a. a -> Maybe a
Just ServerParams
v
    Foreign
_ -> Maybe ServerParams
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign X509.SignedCertificate where
  builtinName :: Tagged SignedCertificate [Char]
builtinName = [Char] -> Tagged SignedCertificate [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"X509.SignedCertificate"
  wrapBuiltin :: SignedCertificate -> Foreign
wrapBuiltin = SignedCertificate -> Foreign
WrapX509SignedCertificate
  maybeUnwrapBuiltin :: Foreign -> Maybe SignedCertificate
maybeUnwrapBuiltin = \case
    WrapX509SignedCertificate SignedCertificate
v -> SignedCertificate -> Maybe SignedCertificate
forall a. a -> Maybe a
Just SignedCertificate
v
    Foreign
_ -> Maybe SignedCertificate
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign X509.PrivKey where
  builtinName :: Tagged PrivKey [Char]
builtinName = [Char] -> Tagged PrivKey [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"X509.PrivKey"
  wrapBuiltin :: PrivKey -> Foreign
wrapBuiltin = PrivKey -> Foreign
WrapX509PrivKey
  maybeUnwrapBuiltin :: Foreign -> Maybe PrivKey
maybeUnwrapBuiltin = \case
    WrapX509PrivKey PrivKey
v -> PrivKey -> Maybe PrivKey
forall a. a -> Maybe a
Just PrivKey
v
    Foreign
_ -> Maybe PrivKey
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign Tls where
  builtinName :: Tagged Tls [Char]
builtinName = [Char] -> Tagged Tls [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Tls"
  wrapBuiltin :: Tls -> Foreign
wrapBuiltin = Tls -> Foreign
WrapTls
  maybeUnwrapBuiltin :: Foreign -> Maybe Tls
maybeUnwrapBuiltin = \case
    WrapTls Tls
v -> Tls -> Maybe Tls
forall a. a -> Maybe a
Just Tls
v
    Foreign
_ -> Maybe Tls
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (Referenced Code) where
  builtinName :: Tagged (Referenced Code) [Char]
builtinName = [Char] -> Tagged (Referenced Code) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Code"
  wrapBuiltin :: Referenced Code -> Foreign
wrapBuiltin = Referenced Code -> Foreign
WrapCode
  maybeUnwrapBuiltin :: Foreign -> Maybe (Referenced Code)
maybeUnwrapBuiltin = \case
    WrapCode Referenced Code
v -> Referenced Code -> Maybe (Referenced Code)
forall a. a -> Maybe a
Just Referenced Code
v
    Foreign
_ -> Maybe (Referenced Code)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (Referenced Value) where
  builtinName :: Tagged (Referenced Value) [Char]
builtinName = [Char] -> Tagged (Referenced Value) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Value"
  wrapBuiltin :: Referenced Value -> Foreign
wrapBuiltin = Referenced Value -> Foreign
WrapValue
  maybeUnwrapBuiltin :: Foreign -> Maybe (Referenced Value)
maybeUnwrapBuiltin = \case
    WrapValue Referenced Value
v -> Referenced Value -> Maybe (Referenced Value)
forall a. a -> Maybe a
Just Referenced Value
v
    Foreign
_ -> Maybe (Referenced Value)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign TimeSpec where
  builtinName :: Tagged TimeSpec [Char]
builtinName = [Char] -> Tagged TimeSpec [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"TimeSpec"
  wrapBuiltin :: TimeSpec -> Foreign
wrapBuiltin = TimeSpec -> Foreign
WrapTimeSpec
  maybeUnwrapBuiltin :: Foreign -> Maybe TimeSpec
maybeUnwrapBuiltin = \case
    WrapTimeSpec TimeSpec
v -> TimeSpec -> Maybe TimeSpec
forall a. a -> Maybe a
Just TimeSpec
v
    Foreign
_ -> Maybe TimeSpec
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (MutableByteArray RealWorld) where
  builtinName :: Tagged (MutableByteArray RealWorld) [Char]
builtinName = [Char] -> Tagged (MutableByteArray RealWorld) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"MutableByteArray"
  wrapBuiltin :: MutableByteArray RealWorld -> Foreign
wrapBuiltin = MutableByteArray RealWorld -> Foreign
WrapMutableByteArray
  maybeUnwrapBuiltin :: Foreign -> Maybe (MutableByteArray RealWorld)
maybeUnwrapBuiltin = \case
    WrapMutableByteArray MutableByteArray RealWorld
v -> MutableByteArray RealWorld -> Maybe (MutableByteArray RealWorld)
forall a. a -> Maybe a
Just MutableByteArray RealWorld
v
    Foreign
_ -> Maybe (MutableByteArray RealWorld)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign ByteArray where
  builtinName :: Tagged ByteArray [Char]
builtinName = [Char] -> Tagged ByteArray [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"ByteArray"
  wrapBuiltin :: ByteArray -> Foreign
wrapBuiltin = ByteArray -> Foreign
WrapByteArray
  maybeUnwrapBuiltin :: Foreign -> Maybe ByteArray
maybeUnwrapBuiltin = \case
    WrapByteArray ByteArray
v -> ByteArray -> Maybe ByteArray
forall a. a -> Maybe a
Just ByteArray
v
    Foreign
_ -> Maybe ByteArray
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign Integer where
  builtinName :: Tagged Integer [Char]
builtinName = [Char] -> Tagged Integer [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Integer"
  wrapBuiltin :: Integer -> Foreign
wrapBuiltin = Integer -> Foreign
WrapInteger
  maybeUnwrapBuiltin :: Foreign -> Maybe Integer
maybeUnwrapBuiltin = \case
    WrapInteger Integer
v -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
v
    Foreign
_ -> Maybe Integer
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign Natural where
  builtinName :: Tagged Natural [Char]
builtinName = [Char] -> Tagged Natural [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Natural"
  wrapBuiltin :: Natural -> Foreign
wrapBuiltin = Natural -> Foreign
WrapNatural
  maybeUnwrapBuiltin :: Foreign -> Maybe Natural
maybeUnwrapBuiltin = \case
    WrapNatural Natural
v -> Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
v
    Foreign
_ -> Maybe Natural
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign DLL where
  builtinName :: Tagged DLL [Char]
builtinName = [Char] -> Tagged DLL [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"DLL"
  wrapBuiltin :: DLL -> Foreign
wrapBuiltin = DLL -> Foreign
WrapDLL
  maybeUnwrapBuiltin :: Foreign -> Maybe DLL
maybeUnwrapBuiltin = \case
    WrapDLL DLL
v -> DLL -> Maybe DLL
forall a. a -> Maybe a
Just DLL
v
    Foreign
_ -> Maybe DLL
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (Seq Val) where
  builtinName :: Tagged USeq [Char]
builtinName = [Char] -> Tagged USeq [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Seq"
  wrapBuiltin :: USeq -> Foreign
wrapBuiltin = USeq -> Foreign
WrapSeq
  maybeUnwrapBuiltin :: Foreign -> Maybe USeq
maybeUnwrapBuiltin = \case
    WrapSeq USeq
v -> USeq -> Maybe USeq
forall a. a -> Maybe a
Just USeq
v
    Foreign
_ -> Maybe USeq
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (Map Val Val) where
  builtinName :: Tagged (Map Val Val) [Char]
builtinName = [Char] -> Tagged (Map Val Val) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Map"
  wrapBuiltin :: Map Val Val -> Foreign
wrapBuiltin = Map Val Val -> Foreign
WrapMap
  maybeUnwrapBuiltin :: Foreign -> Maybe (Map Val Val)
maybeUnwrapBuiltin = \case
    WrapMap Map Val Val
v -> Map Val Val -> Maybe (Map Val Val)
forall a. a -> Maybe a
Just Map Val Val
v
    Foreign
_ -> Maybe (Map Val Val)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (IORef Val) where
  builtinName :: Tagged (IORef Val) [Char]
builtinName = [Char] -> Tagged (IORef Val) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"IORef"
  wrapBuiltin :: IORef Val -> Foreign
wrapBuiltin = IORef Val -> Foreign
WrapIORef
  maybeUnwrapBuiltin :: Foreign -> Maybe (IORef Val)
maybeUnwrapBuiltin = \case
    WrapIORef IORef Val
v -> IORef Val -> Maybe (IORef Val)
forall a. a -> Maybe a
Just IORef Val
v
    Foreign
_ -> Maybe (IORef Val)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (Atomic.Ticket Val) where
  builtinName :: Tagged (Ticket Val) [Char]
builtinName = [Char] -> Tagged (Ticket Val) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Ticket"
  wrapBuiltin :: Ticket Val -> Foreign
wrapBuiltin = Ticket Val -> Foreign
WrapTicket
  maybeUnwrapBuiltin :: Foreign -> Maybe (Ticket Val)
maybeUnwrapBuiltin = \case
    WrapTicket Ticket Val
v -> Ticket Val -> Maybe (Ticket Val)
forall a. a -> Maybe a
Just Ticket Val
v
    Foreign
_ -> Maybe (Ticket Val)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (MVar Val) where
  builtinName :: Tagged (MVar Val) [Char]
builtinName = [Char] -> Tagged (MVar Val) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"MVar"
  wrapBuiltin :: MVar Val -> Foreign
wrapBuiltin = MVar Val -> Foreign
WrapMVar
  maybeUnwrapBuiltin :: Foreign -> Maybe (MVar Val)
maybeUnwrapBuiltin = \case
    WrapMVar MVar Val
v -> MVar Val -> Maybe (MVar Val)
forall a. a -> Maybe a
Just MVar Val
v
    Foreign
_ -> Maybe (MVar Val)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (TVar Val) where
  builtinName :: Tagged (TVar Val) [Char]
builtinName = [Char] -> Tagged (TVar Val) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"TVar"
  wrapBuiltin :: TVar Val -> Foreign
wrapBuiltin = TVar Val -> Foreign
WrapTVar
  maybeUnwrapBuiltin :: Foreign -> Maybe (TVar Val)
maybeUnwrapBuiltin = \case
    WrapTVar TVar Val
v -> TVar Val -> Maybe (TVar Val)
forall a. a -> Maybe a
Just TVar Val
v
    Foreign
_ -> Maybe (TVar Val)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (Promise Val) where
  builtinName :: Tagged (Promise Val) [Char]
builtinName = [Char] -> Tagged (Promise Val) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Promise"
  wrapBuiltin :: Promise Val -> Foreign
wrapBuiltin = Promise Val -> Foreign
WrapPromise
  maybeUnwrapBuiltin :: Foreign -> Maybe (Promise Val)
maybeUnwrapBuiltin = \case
    WrapPromise Promise Val
v -> Promise Val -> Maybe (Promise Val)
forall a. a -> Maybe a
Just Promise Val
v
    Foreign
_ -> Maybe (Promise Val)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (MutableArray RealWorld Val) where
  builtinName :: Tagged (MutableArray RealWorld Val) [Char]
builtinName = [Char] -> Tagged (MutableArray RealWorld Val) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"MutableArray"
  wrapBuiltin :: MutableArray RealWorld Val -> Foreign
wrapBuiltin = MutableArray RealWorld Val -> Foreign
WrapMutableArray
  maybeUnwrapBuiltin :: Foreign -> Maybe (MutableArray RealWorld Val)
maybeUnwrapBuiltin = \case
    WrapMutableArray MutableArray RealWorld Val
v -> MutableArray RealWorld Val -> Maybe (MutableArray RealWorld Val)
forall a. a -> Maybe a
Just MutableArray RealWorld Val
v
    Foreign
_ -> Maybe (MutableArray RealWorld Val)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (Array Val) where
  builtinName :: Tagged (Array Val) [Char]
builtinName = [Char] -> Tagged (Array Val) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Array"
  wrapBuiltin :: Array Val -> Foreign
wrapBuiltin = Array Val -> Foreign
WrapArray
  maybeUnwrapBuiltin :: Foreign -> Maybe (Array Val)
maybeUnwrapBuiltin = \case
    WrapArray Array Val
v -> Array Val -> Maybe (Array Val)
forall a. a -> Maybe a
Just Array Val
v
    Foreign
_ -> Maybe (Array Val)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

data HashAlgorithm where
  -- Reference is a reference to the hash algorithm
  HashAlgorithm :: (Hash.HashAlgorithm a) => Reference -> a -> HashAlgorithm

data Tls = Tls
  { Tls -> Socket
socket :: Socket,
    Tls -> Context
context :: TLS.Context
  }

instance Eq Tls where
  Tls Socket
s1 Context
_ == :: Tls -> Tls -> Bool
== Tls Socket
s2 Context
_ = Socket
s1 Socket -> Socket -> Bool
forall a. Eq a => a -> a -> Bool
== Socket
s2

data Failure a = Failure Reference U.Text a

instance BuiltinForeign HashAlgorithm where
  builtinName :: Tagged HashAlgorithm [Char]
builtinName = [Char] -> Tagged HashAlgorithm [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"HashAlgorithm"
  wrapBuiltin :: HashAlgorithm -> Foreign
wrapBuiltin = HashAlgorithm -> Foreign
WrapHashAlgorithm
  maybeUnwrapBuiltin :: Foreign -> Maybe HashAlgorithm
maybeUnwrapBuiltin = \case
    WrapHashAlgorithm HashAlgorithm
v -> HashAlgorithm -> Maybe HashAlgorithm
forall a. a -> Maybe a
Just HashAlgorithm
v
    Foreign
_ -> Maybe HashAlgorithm
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign CPattern where
  builtinName :: Tagged CPattern [Char]
builtinName = [Char] -> Tagged CPattern [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"CPattern"
  wrapBuiltin :: CPattern -> Foreign
wrapBuiltin = CPattern -> Foreign
WrapCPattern
  maybeUnwrapBuiltin :: Foreign -> Maybe CPattern
maybeUnwrapBuiltin = \case
    WrapCPattern CPattern
v -> CPattern -> Maybe CPattern
forall a. a -> Maybe a
Just CPattern
v
    Foreign
_ -> Maybe CPattern
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign CharPattern where
  builtinName :: Tagged CharPattern [Char]
builtinName = [Char] -> Tagged CharPattern [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"CharPattern"
  wrapBuiltin :: CharPattern -> Foreign
wrapBuiltin = CharPattern -> Foreign
WrapCharPattern
  maybeUnwrapBuiltin :: Foreign -> Maybe CharPattern
maybeUnwrapBuiltin = \case
    WrapCharPattern CharPattern
v -> CharPattern -> Maybe CharPattern
forall a. a -> Maybe a
Just CharPattern
v
    Foreign
_ -> Maybe CharPattern
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign FFType where
  builtinName :: Tagged FFType [Char]
builtinName = [Char] -> Tagged FFType [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"FFI.Type"
  wrapBuiltin :: FFType -> Foreign
wrapBuiltin = FFType -> Foreign
WrapFFIType
  maybeUnwrapBuiltin :: Foreign -> Maybe FFType
maybeUnwrapBuiltin = \case
    WrapFFIType FFType
v -> FFType -> Maybe FFType
forall a. a -> Maybe a
Just FFType
v
    Foreign
_ -> Maybe FFType
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign FFSpec where
  builtinName :: Tagged FFSpec [Char]
builtinName = [Char] -> Tagged FFSpec [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"FFI.Spec"
  wrapBuiltin :: FFSpec -> Foreign
wrapBuiltin = FFSpec -> Foreign
WrapFFISpec
  maybeUnwrapBuiltin :: Foreign -> Maybe FFSpec
maybeUnwrapBuiltin = \case
    WrapFFISpec FFSpec
v -> FFSpec -> Maybe FFSpec
forall a. a -> Maybe a
Just FFSpec
v
    Foreign
_ -> Maybe FFSpec
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign CDynFunc where
  builtinName :: Tagged CDynFunc [Char]
builtinName = [Char] -> Tagged CDynFunc [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"DLL.Func"
  wrapBuiltin :: CDynFunc -> Foreign
wrapBuiltin = CDynFunc -> Foreign
WrapCDynFunc
  maybeUnwrapBuiltin :: Foreign -> Maybe CDynFunc
maybeUnwrapBuiltin = \case
    WrapCDynFunc CDynFunc
v -> CDynFunc -> Maybe CDynFunc
forall a. a -> Maybe a
Just CDynFunc
v
    Foreign
_ -> Maybe CDynFunc
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}