{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UnboxedTuples #-}
-- The JIT's code generator relies on the optimized layout of GClosure and
-- Val (strict fields unboxed), so this module is always compiled with
-- optimization, even under `stack build --fast`.
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}

module Unison.Runtime.Stack
  ( K (..),
    GClosure (..),
    Closure
      ( ..,
        DataC,
        RecordC,
        PApV,
        CapV,
        PAp,
        Enum,
        Data1,
        Data2,
        Data3,
        Data4,
        Data5,
        Data6,
        DataG,
        RecordG,
        Captured,
        TextC,
        ListC,
        BytesC,
        Foreign,
        Affine,
        BlackHole,
        UnboxedTypeTag
      ),
    Failure (..),
    Foreign (..),
    foreignRef,
    foreignName,
    BuiltinForeign (..),
    AffineRef (..),
    AEnv,
    DEnv,
    emptyDEnv,
    emptyAEnv,
    HEnv (..),
    closureTag,
    dataTag,
    formDataReplaced,
    mapFamily,
    mapReplaced,
    unitClosure,
    UnboxedTypeTag (..),
    unboxedTypeTagToInt,
    unboxedTypeTagFromInt,
    witnessTag,
    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,
    RecordVals,
    recordVals,
    segToList,
    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,
    defaultStackSlots,
    MCombs,
    MSection,
    MBranch,
    MInstr,
    MComb,
    MRef,
    nativeOutWords,
    nativeOutPtrs,
    bstkSlots,
    peek,
    upeek,
    bpeek,
    peekOff,
    upeekOff,
    bpeekOff,
    bpoke,
    bpokeOff,
    pokeOff,
    upokeT,
    upokeOffT,
    unsafePokeIasN,
    bump,
    bumpn,
    grabSeg,
    truncateSeg,
    ensure,
    ensureGenerously,
    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.Vector (Vector)
import Data.Vector qualified as V
import Data.Vector.Mutable qualified as MV
import Data.Word
import Data.X509 qualified as X509
import Foreign.ForeignPtr qualified as Ptr
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.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.Builtin.Decls as Ty
import Unison.Runtime.FFI.DLL
import Unison.Runtime.Foreign.Dynamic
import Unison.Runtime.JIT.Config qualified as JIT
import Unison.Runtime.MCode
import Unison.Runtime.Referenced (Referenced, dereference)
import Unison.Runtime.Signal qualified as Signal
import Unison.Runtime.TypeNumbers qualified as TN
import Unison.Runtime.TypeTags qualified as TT
import Unison.Type qualified as Ty
import Unison.Util.Bytes (Bytes)
import Unison.Util.Deque (Deque)
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
      !(Ptr.Ptr NativeCell) -- native code cell of the resumption section's combinator
      !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

-- The empty dynamic environment, as one shared value. HEnv's fields are
-- lazy, so `HEnv aenv mempty` would store a thunk for the map in an
-- unoptimized build; the JIT's request code reads the environment from
-- native code and leaves a request to the interpreter when a field isn't
-- an evaluated map, so the interpreter builds its environments with this.
emptyDEnv :: DEnv
emptyDEnv :: DEnv
emptyDEnv = [(Word64, Val)] -> DEnv
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
EC.mapFromList []
{-# NOINLINE emptyDEnv #-}

emptyAEnv :: AEnv
emptyAEnv :: AEnv
emptyAEnv = [(Word64, AffineRef)] -> AEnv
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
EC.mapFromList []
{-# NOINLINE emptyAEnv #-}

-- 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.
-- | The runtime's lists.  A strict deque: no thunks inside, so its structure can
-- be read without evaluating anything.
type USeq = Deque Val

type IxClosure = GClosure CombIx

-- Don't re-order these, the ord instance affects Universal.compare
data UnboxedTypeTag
  = CharTag
  | FloatTag
  | IntTag
  | NatTag
  | -- | The value slot of a wide variable holding an unboxed constructor of
    -- this many fields (Unison.Runtime.Wide): the slot's word is the
    -- constructor's packed tag and the fields are in the slots below.
    WitnessTag !Int
  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
  WitnessTag Size
n -> Size
4 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
n

unboxedTypeTagFromInt :: (HasCallStack) => Int -> UnboxedTypeTag
unboxedTypeTagFromInt :: HasCallStack => Size -> UnboxedTypeTag
unboxedTypeTagFromInt = \case
  Size
n | Size
n Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
>= Size
4 -> Size -> UnboxedTypeTag
WitnessTag (Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
4)
  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"

-- | A record's field values, in ascending field-name order. Slot @i@ holds the
-- value of field @i@ of the accompanying 'RecordShape'.
type RecordVals = Vector Val

-- | The code the interpreter runs: MCode over resolved combinators and
-- these values. (Defined here, below the JIT modules, so that the JIT
-- handle can be a field of the code cache without an import cycle.)
type MCombs = RCombs Val

type MSection = RSection Val

type MBranch = RBranch Val

type MInstr = RInstr Val

type MComb = RComb Val

type MRef = RRef Val

-- The constructor order sets the pointer tags native code switches on:
-- the first six constructors get tags 1 to 6 and the rest share tag 7,
-- told apart by their info pointers. Lists, texts, enums and the data
-- constructors with one, two and five fields come first because matches and
-- the text and list primitives are the hot dispatch (five fields is base's
-- Map node, which is native under the JIT: measured 2 to 5% on map rows,
-- benchmarks/2026-10-15-text-list.md); a wider constructor pushes more
-- fields and absorbs the info-table read better, and a partial
-- application is only scrutinized by a call, whose other work dwarfs it
-- (benchmarks/2026-10-15-constructor-order.md). A text, a list and a bytes
-- value are one object each, the rope or the deque their one field (Text
-- is a newtype over the rope); bytes sit at tag 7, after the six, being
-- rarer than texts. A data constructor's fields come
-- first and its reference last, so that with @-funbox-strict-fields@ the
-- closure is the fields' boxed halves, the reference, the packed tag and
-- the fields' unboxed halves: field j's boxed half is pointer j. The
-- segments of a partial application, a wide constructor and a captured
-- continuation are two fields, not a tuple (which couldn't be unpacked),
-- so the closure holds the two arrays directly.
data GClosure comb
  = GList !(Deque Val)
  | GText !U.Text
  | GEnum !PackedTag
  | GData1 !PackedTag !Val
  | GData2 !PackedTag !Val !Val
  | GData5 !PackedTag !Val !Val !Val !Val !Val
  | GData3 !PackedTag !Val !Val !Val
  | GData4 !PackedTag !Val !Val !Val !Val
  | GData6 !PackedTag !Val !Val !Val !Val !Val !Val
  | -- | seven or more fields
    GDataG !PackedTag !USeg !BSeg
  | GBytes !Bytes
  | GPAp
      !CombIx
      {-# UNPACK #-} !(GCombInfo comb)
      -- | args
      !USeg
      !BSeg
  | GCaptured
      -- | code cont
      !K
      -- | arg size
      !Int
      -- | u/b data stacks
      !USeg
      !BSeg
  | GRecord !RecordShape !RecordVals
  | 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 <- (matchPAp -> Just (cix, comb, seg))
  where
    PAp CombIx
cix GCombInfo (RComb Val)
comb (ByteArray
u, BSeg
b) = GClosure (RComb Val) -> BVal
Closure (CombIx
-> GCombInfo (RComb Val)
-> ByteArray
-> BSeg
-> GClosure (RComb Val)
forall comb.
CombIx -> GCombInfo comb -> ByteArray -> BSeg -> GClosure comb
GPAp CombIx
cix GCombInfo (RComb Val)
comb ByteArray
u BSeg
b)

matchPAp :: Closure -> Maybe (CombIx, GCombInfo (RComb Val), Seg)
matchPAp :: BVal -> Maybe (CombIx, GCombInfo (RComb Val), Seg)
matchPAp (Closure (GPAp CombIx
cix GCombInfo (RComb Val)
comb ByteArray
u BSeg
b)) = (CombIx, GCombInfo (RComb Val), Seg)
-> Maybe (CombIx, GCombInfo (RComb Val), Seg)
forall a. a -> Maybe a
Just (CombIx
cix, GCombInfo (RComb Val)
comb, (ByteArray
u, BSeg
b))
matchPAp BVal
_ = Maybe (CombIx, GCombInfo (RComb Val), Seg)
forall a. Maybe a
Nothing
{-# INLINE matchPAp #-}

-- The data constructors carry their packed tag alone: the type's
-- reference is the registry's (Unison.Runtime.TypeNumbers, by the tag's
-- type number), read only at the process boundary and to order values of
-- different types.
pattern Enum :: PackedTag -> Closure
pattern $mEnum :: forall {r}. BVal -> (PackedTag -> r) -> ((# #) -> r) -> r
$bEnum :: PackedTag -> BVal
Enum t = Closure (GEnum t)

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

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

pattern Data3 :: PackedTag -> Val -> Val -> Val -> Closure
pattern $mData3 :: forall {r}.
BVal -> (PackedTag -> Val -> Val -> Val -> r) -> ((# #) -> r) -> r
$bData3 :: PackedTag -> Val -> Val -> Val -> BVal
Data3 t a b c = Closure (GData3 t a b c)

pattern Data4 :: PackedTag -> Val -> Val -> Val -> Val -> Closure
pattern $mData4 :: forall {r}.
BVal
-> (PackedTag -> Val -> Val -> Val -> Val -> r)
-> ((# #) -> r)
-> r
$bData4 :: PackedTag -> Val -> Val -> Val -> Val -> BVal
Data4 t a b c d = Closure (GData4 t a b c d)

pattern Data5 :: PackedTag -> Val -> Val -> Val -> Val -> Val -> Closure
pattern $mData5 :: forall {r}.
BVal
-> (PackedTag -> Val -> Val -> Val -> Val -> Val -> r)
-> ((# #) -> r)
-> r
$bData5 :: PackedTag -> Val -> Val -> Val -> Val -> Val -> BVal
Data5 t a b c d e = Closure (GData5 t a b c d e)

pattern Data6 :: PackedTag -> Val -> Val -> Val -> Val -> Val -> Val -> Closure
pattern $mData6 :: forall {r}.
BVal
-> (PackedTag -> Val -> Val -> Val -> Val -> Val -> Val -> r)
-> ((# #) -> r)
-> r
$bData6 :: PackedTag -> Val -> Val -> Val -> Val -> Val -> Val -> BVal
Data6 t a b c d e f = Closure (GData6 t a b c d e f)

-- | A constructor with seven or more fields (fewer go to the fixed-arity
-- constructors; 'formData' and 'formDataSeg' choose).
pattern DataG :: PackedTag -> Seg -> Closure
pattern $mDataG :: forall {r}. BVal -> (PackedTag -> Seg -> r) -> ((# #) -> r) -> r
$bDataG :: PackedTag -> Seg -> BVal
DataG t seg <- (matchDataG -> Just (t, seg))
  where
    DataG PackedTag
t (ByteArray
u, BSeg
b) = GClosure (RComb Val) -> BVal
Closure (PackedTag -> ByteArray -> BSeg -> GClosure (RComb Val)
forall comb. PackedTag -> ByteArray -> BSeg -> GClosure comb
GDataG PackedTag
t ByteArray
u BSeg
b)

matchDataG :: Closure -> Maybe (PackedTag, Seg)
matchDataG :: BVal -> Maybe (PackedTag, Seg)
matchDataG (Closure (GDataG PackedTag
t ByteArray
u BSeg
b)) = (PackedTag, Seg) -> Maybe (PackedTag, Seg)
forall a. a -> Maybe a
Just (PackedTag
t, (ByteArray
u, BSeg
b))
matchDataG BVal
_ = Maybe (PackedTag, Seg)
forall a. Maybe a
Nothing
{-# INLINE matchDataG #-}

pattern RecordG :: RecordShape -> RecordVals -> Closure
pattern $mRecordG :: forall {r}.
BVal -> (RecordShape -> RecordVals -> r) -> ((# #) -> r) -> r
$bRecordG :: RecordShape -> RecordVals -> BVal
RecordG sh vs = Closure (GRecord sh vs)

pattern Captured :: K -> Int -> Seg -> Closure
pattern $mCaptured :: forall {r}. BVal -> (K -> Size -> Seg -> r) -> ((# #) -> r) -> r
$bCaptured :: K -> Size -> Seg -> BVal
Captured k a seg <- (matchCaptured -> Just (k, a, seg))
  where
    Captured K
k Size
a (ByteArray
u, BSeg
b) = GClosure (RComb Val) -> BVal
Closure (K -> Size -> ByteArray -> BSeg -> GClosure (RComb Val)
forall comb. K -> Size -> ByteArray -> BSeg -> GClosure comb
GCaptured K
k Size
a ByteArray
u BSeg
b)

matchCaptured :: Closure -> Maybe (K, Int, Seg)
matchCaptured :: BVal -> Maybe (K, Size, Seg)
matchCaptured (Closure (GCaptured K
k Size
a ByteArray
u BSeg
b)) = (K, Size, Seg) -> Maybe (K, Size, Seg)
forall a. a -> Maybe a
Just (K
k, Size
a, (ByteArray
u, BSeg
b))
matchCaptured BVal
_ = Maybe (K, Size, Seg)
forall a. Maybe a
Nothing
{-# INLINE matchCaptured #-}

-- | A text: the runtime's one representation of a @Text@ value.
pattern TextC :: U.Text -> Closure
pattern $mTextC :: forall {r}. BVal -> (Text -> r) -> ((# #) -> r) -> r
$bTextC :: Text -> BVal
TextC t = Closure (GText t)

-- | A list: the runtime's one representation of a @List@ value.
pattern ListC :: Deque Val -> Closure
pattern $mListC :: forall {r}. BVal -> (USeq -> r) -> ((# #) -> r) -> r
$bListC :: USeq -> BVal
ListC d = Closure (GList d)

-- | A bytes value: the runtime's one representation of a @Bytes@ value.
pattern BytesC :: Bytes -> Closure
pattern $mBytesC :: forall {r}. BVal -> (Bytes -> r) -> ((# #) -> r) -> r
$bBytesC :: Bytes -> BVal
BytesC b = Closure (GBytes b)

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
      WitnessTag Size
n -> Size -> BVal
witnessTag Size
n

{-# COMPLETE PAp, Enum, Data1, Data2, Data3, Data4, Data5, Data6, DataG, RecordC, Captured, TextC, ListC, BytesC, Foreign, UnboxedTypeTag, BlackHole, Affine #-}

{-# COMPLETE DataC, RecordC, PAp, Captured, TextC, ListC, BytesC, Foreign, BlackHole, UnboxedTypeTag, Affine #-}

{-# COMPLETE DataC, RecordC, PApV, Captured, TextC, ListC, BytesC, Foreign, BlackHole, UnboxedTypeTag, Affine #-}

{-# COMPLETE DataC, RecordC, PApV, CapV, TextC, ListC, BytesC, 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))

-- | The witness closures of unboxed constructors ('WitnessTag'), one per
-- field count, so that writing one allocates nothing.
witnessTag :: Int -> Closure
witnessTag :: Size -> BVal
witnessTag = \case
  Size
0 -> BVal
witnessTag0
  Size
1 -> BVal
witnessTag1
  Size
2 -> BVal
witnessTag2
  Size
n -> GClosure (RComb Val) -> BVal
Closure (UnboxedTypeTag -> GClosure (RComb Val)
forall comb. UnboxedTypeTag -> GClosure comb
GUnboxedTypeTag (Size -> UnboxedTypeTag
WitnessTag Size
n))

witnessTag0, witnessTag1, witnessTag2 :: Closure
witnessTag0 :: BVal
witnessTag0 = GClosure (RComb Val) -> BVal
Closure (UnboxedTypeTag -> GClosure (RComb Val)
forall comb. UnboxedTypeTag -> GClosure comb
GUnboxedTypeTag (Size -> UnboxedTypeTag
WitnessTag Size
0))
{-# NOINLINE witnessTag0 #-}
witnessTag1 :: BVal
witnessTag1 = GClosure (RComb Val) -> BVal
Closure (UnboxedTypeTag -> GClosure (RComb Val)
forall comb. UnboxedTypeTag -> GClosure comb
GUnboxedTypeTag (Size -> UnboxedTypeTag
WitnessTag Size
1))
{-# NOINLINE witnessTag1 #-}
witnessTag2 :: BVal
witnessTag2 = GClosure (RComb Val) -> BVal
Closure (UnboxedTypeTag -> GClosure (RComb Val)
forall comb. UnboxedTypeTag -> GClosure comb
GUnboxedTypeTag (Size -> UnboxedTypeTag
WitnessTag Size
2))
{-# NOINLINE witnessTag2 #-}

{-# 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
_ Ptr NativeCell
_ 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 (PackedTag, SegList)
splitData :: BVal -> Maybe (PackedTag, [Val])
splitData = \case
  (Enum PackedTag
t) -> (PackedTag, [Val]) -> Maybe (PackedTag, [Val])
forall a. a -> Maybe a
Just (PackedTag
t, [])
  (Data1 PackedTag
t Val
a) -> (PackedTag, [Val]) -> Maybe (PackedTag, [Val])
forall a. a -> Maybe a
Just (PackedTag
t, [Val
a])
  (Data2 PackedTag
t Val
a Val
b) -> (PackedTag, [Val]) -> Maybe (PackedTag, [Val])
forall a. a -> Maybe a
Just (PackedTag
t, [Val
a, Val
b])
  (Data3 PackedTag
t Val
a Val
b Val
c) -> (PackedTag, [Val]) -> Maybe (PackedTag, [Val])
forall a. a -> Maybe a
Just (PackedTag
t, [Val
a, Val
b, Val
c])
  (Data4 PackedTag
t Val
a Val
b Val
c Val
d) -> (PackedTag, [Val]) -> Maybe (PackedTag, [Val])
forall a. a -> Maybe a
Just (PackedTag
t, [Val
a, Val
b, Val
c, Val
d])
  (Data5 PackedTag
t Val
a Val
b Val
c Val
d Val
e) -> (PackedTag, [Val]) -> Maybe (PackedTag, [Val])
forall a. a -> Maybe a
Just (PackedTag
t, [Val
a, Val
b, Val
c, Val
d, Val
e])
  (Data6 PackedTag
t Val
a Val
b Val
c Val
d Val
e Val
f) -> (PackedTag, [Val]) -> Maybe (PackedTag, [Val])
forall a. a -> Maybe a
Just (PackedTag
t, [Val
a, Val
b, Val
c, Val
d, Val
e, Val
f])
  (DataG PackedTag
t Seg
seg) -> (PackedTag, [Val]) -> Maybe (PackedTag, [Val])
forall a. a -> Maybe a
Just (PackedTag
t, Seg -> [Val]
segToList Seg
seg)
  BVal
_ -> Maybe (PackedTag, [Val])
forall a. Maybe a
Nothing

-- | The packed tag of a data constructor closure, or Nothing for any other
-- closure.
dataTag :: Closure -> Maybe PackedTag
dataTag :: BVal -> Maybe PackedTag
dataTag (Closure GClosure (RComb Val)
c) = case GClosure (RComb Val)
c of
  GEnum PackedTag
t -> PackedTag -> Maybe PackedTag
forall a. a -> Maybe a
Just PackedTag
t
  GData1 PackedTag
t Val
_ -> PackedTag -> Maybe PackedTag
forall a. a -> Maybe a
Just PackedTag
t
  GData2 PackedTag
t Val
_ Val
_ -> PackedTag -> Maybe PackedTag
forall a. a -> Maybe a
Just PackedTag
t
  GData3 PackedTag
t Val
_ Val
_ Val
_ -> PackedTag -> Maybe PackedTag
forall a. a -> Maybe a
Just PackedTag
t
  GData4 PackedTag
t Val
_ Val
_ Val
_ Val
_ -> PackedTag -> Maybe PackedTag
forall a. a -> Maybe a
Just PackedTag
t
  GData5 PackedTag
t Val
_ Val
_ Val
_ Val
_ Val
_ -> PackedTag -> Maybe PackedTag
forall a. a -> Maybe a
Just PackedTag
t
  GData6 PackedTag
t Val
_ Val
_ Val
_ Val
_ Val
_ Val
_ -> PackedTag -> Maybe PackedTag
forall a. a -> Maybe a
Just PackedTag
t
  GDataG PackedTag
t ByteArray
_ BSeg
_ -> PackedTag -> Maybe PackedTag
forall a. a -> Maybe a
Just PackedTag
t
  GClosure (RComb Val)
_ -> Maybe PackedTag
forall a. Maybe a
Nothing
{-# INLINE dataTag #-}

-- | The number of fields of a data constructor closure.
dataArity :: Closure -> Int
dataArity :: BVal -> Size
dataArity (Closure GClosure (RComb Val)
c) = case GClosure (RComb Val)
c of
  GEnum {} -> Size
0
  GData1 {} -> Size
1
  GData2 {} -> Size
2
  GData3 {} -> Size
3
  GData4 {} -> Size
4
  GData5 {} -> Size
5
  GData6 {} -> Size
6
  GDataG PackedTag
_ ByteArray
_ BSeg
b -> BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
b
  GClosure (RComb Val)
_ -> Size
0
{-# INLINE dataArity #-}

closureTag :: Closure -> PackedTag
closureTag :: BVal -> PackedTag
closureTag BVal
c = case BVal -> Maybe PackedTag
dataTag BVal
c of
  Just PackedTag
t -> PackedTag
t
  Maybe PackedTag
Nothing -> RuntimePanic -> PackedTag
forall a e. (HasCallStack, 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 :: PackedTag -> SegList -> Closure
formData :: PackedTag -> [Val] -> BVal
formData PackedTag
t = \case
  [] -> PackedTag -> BVal
Enum PackedTag
t
  [Val
a] -> PackedTag -> Val -> BVal
Data1 PackedTag
t Val
a
  [Val
a, Val
b] -> PackedTag -> Val -> Val -> BVal
Data2 PackedTag
t Val
a Val
b
  [Val
a, Val
b, Val
c] -> PackedTag -> Val -> Val -> Val -> BVal
Data3 PackedTag
t Val
a Val
b Val
c
  [Val
a, Val
b, Val
c, Val
d] -> PackedTag -> Val -> Val -> Val -> Val -> BVal
Data4 PackedTag
t Val
a Val
b Val
c Val
d
  [Val
a, Val
b, Val
c, Val
d, Val
e] -> PackedTag -> Val -> Val -> Val -> Val -> Val -> BVal
Data5 PackedTag
t Val
a Val
b Val
c Val
d Val
e
  [Val
a, Val
b, Val
c, Val
d, Val
e, Val
f] -> PackedTag -> Val -> Val -> Val -> Val -> Val -> Val -> BVal
Data6 PackedTag
t Val
a Val
b Val
c Val
d Val
e Val
f
  [Val]
segList -> PackedTag -> Seg -> BVal
DataG PackedTag
t ([Val] -> Seg
segFromList [Val]
segList)

-- | A constructor from a segment, which holds the fields backwards (field 0
-- last).
formDataSeg :: PackedTag -> Seg -> Closure
formDataSeg :: PackedTag -> Seg -> BVal
formDataSeg PackedTag
t (ByteArray
usg, BSeg
bsg) = case BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
bsg of
  Size
0 -> PackedTag -> BVal
Enum PackedTag
t
  Size
1 -> PackedTag -> Val -> BVal
Data1 PackedTag
t (Size -> Val
at Size
0)
  Size
2 -> PackedTag -> Val -> Val -> BVal
Data2 PackedTag
t (Size -> Val
at Size
1) (Size -> Val
at Size
0)
  Size
3 -> PackedTag -> Val -> Val -> Val -> BVal
Data3 PackedTag
t (Size -> Val
at Size
2) (Size -> Val
at Size
1) (Size -> Val
at Size
0)
  Size
4 -> PackedTag -> Val -> Val -> Val -> Val -> BVal
Data4 PackedTag
t (Size -> Val
at Size
3) (Size -> Val
at Size
2) (Size -> Val
at Size
1) (Size -> Val
at Size
0)
  Size
5 -> PackedTag -> Val -> Val -> Val -> Val -> Val -> BVal
Data5 PackedTag
t (Size -> Val
at Size
4) (Size -> Val
at Size
3) (Size -> Val
at Size
2) (Size -> Val
at Size
1) (Size -> Val
at Size
0)
  Size
6 -> PackedTag -> Val -> Val -> Val -> Val -> Val -> Val -> BVal
Data6 PackedTag
t (Size -> Val
at Size
5) (Size -> Val
at Size
4) (Size -> Val
at Size
3) (Size -> Val
at Size
2) (Size -> Val
at Size
1) (Size -> Val
at Size
0)
  Size
_ -> PackedTag -> Seg -> BVal
DataG PackedTag
t (ByteArray
usg, BSeg
bsg)
  where
    at :: Size -> Val
at Size
i = Size -> BVal -> Val
Val (ByteArray -> Size -> Size
forall a. (CheckCtx, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
usg Size
i) (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
i)
{-# INLINE formDataSeg #-}

-- | The tag of base's @Map@ type and of the functions on @Map@, @Set@ and
-- @Multimap@, which take and return it (see JIT.Config.ReplacementUse):
-- native code wins on maps below a few thousand keys, the common case,
-- the Haskell map above (JIT/benchmarks/2026-10-11-replacements.md), so
-- the family is left to the JIT.
mapFamily :: JIT.ReplacementUse
mapFamily :: ReplacementUse
mapFamily = ReplacementUse
JIT.InterpreterOnly

-- | Whether the @Map@ type is replaced by the Haskell 'WrapMap' under the
-- current settings.
mapReplaced :: Bool
mapReplaced :: Bool
mapReplaced = ReplacementUse -> Bool
JIT.replacementActive ReplacementUse
mapFamily
{-# NOINLINE mapReplaced #-}

-- Build a data type, but apply replacements
formDataReplaced :: PackedTag -> Seg -> Closure
formDataReplaced :: PackedTag -> Seg -> BVal
formDataReplaced PackedTag
t sg :: Seg
sg@(ByteArray
usg, BSeg
bsg)
  | Bool -> Bool
not Bool
mapReplaced = PackedTag -> Seg -> BVal
formDataSeg PackedTag
t Seg
sg
  | 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. (CheckCtx, 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. (CheckCtx, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
usg Size
2,
          Just (Map Val Val
ul :: Map Val Val) <- BVal -> Maybe (Map Val Val)
forall f. BuiltinForeign f => BVal -> Maybe f
maybeUnwrapBuiltin (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
1),
          Just (Map Val Val
ur :: Map Val Val) <- BVal -> Maybe (Map Val Val)
forall f. BuiltinForeign f => BVal -> Maybe f
maybeUnwrapBuiltin (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
bsg Size
0),
          Size
sz <- ByteArray -> Size -> Size
forall a. (CheckCtx, 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 = PackedTag -> Seg -> BVal
formDataSeg 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
_ Ptr NativeCell
_ 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 :: PackedTag -> SegList -> Closure
pattern $mDataC :: forall {r}. BVal -> (PackedTag -> [Val] -> r) -> ((# #) -> r) -> r
$bDataC :: PackedTag -> [Val] -> BVal
DataC ct segs <-
  (splitData -> Just (ct, segs))
  where
    DataC PackedTag
ct [Val]
segs = PackedTag -> [Val] -> BVal
formData PackedTag
ct [Val]
segs

pattern RecordC :: RecordShape -> RecordVals -> Closure
pattern $mRecordC :: forall {r}.
BVal -> (RecordShape -> RecordVals -> r) -> ((# #) -> r) -> r
$bRecordC :: RecordShape -> RecordVals -> BVal
RecordC sh v <- (RecordG sh v)
  where
    RecordC RecordShape
sh RecordVals
v = RecordShape -> RecordVals -> BVal
RecordG RecordShape
sh RecordVals
v

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 PackedTag
t)) | PackedTag -> Bool
TT.isBooleanTag PackedTag
t -> 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 (PackedTag -> BVal
Enum PackedTag
TT.falseTag)
{-# NOINLINE falseVal #-}

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

doubleToInt :: Double -> Int
doubleToInt :: Double -> Size
doubleToInt Double
d = ByteArray -> Size -> Size
forall a. (CheckCtx, 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. (CheckCtx, 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. (CheckCtx, 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

-- | A record's values from a segment: slot i holds the segment's i-th value
-- (the segments are stored backwards). Every element is an evaluated 'Val',
-- since native code reads the vector's elements as closures.
recordVals :: Seg -> RecordVals
recordVals :: Seg -> RecordVals
recordVals (ByteArray
u, BSeg
b) = (forall s. ST s (MVector s Val)) -> RecordVals
forall a. (forall s. ST s (MVector s a)) -> Vector a
V.create do
  let n :: Size
n = ByteArray -> Size
sizeofByteArray ByteArray
u Size -> Size -> Size
forall a. Integral a => a -> a -> a
`div` Size
8
  MVector s Val
mv <- Size -> ST s (MVector (PrimState (ST s)) Val)
forall (m :: * -> *) a.
PrimMonad m =>
Size -> m (MVector (PrimState m) a)
MV.new Size
n
  let go :: Size -> ST s ()
go Size
i
        | Size
i Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
n = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise = do
            let j :: Size
j = Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1 Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
i
            MVector (PrimState (ST s)) Val -> Size -> Val -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Size -> a -> m ()
MV.write MVector s Val
MVector (PrimState (ST s)) Val
mv Size
i (Val -> ST s ()) -> Val -> ST s ()
forall a b. (a -> b) -> a -> b
$! Size -> BVal -> Val
Val (ByteArray -> Size -> Size
forall a. (CheckCtx, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
u Size
j) (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
b Size
j)
            Size -> ST s ()
go (Size
i Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1)
  Size -> ST s ()
go Size
0
  pure MVector s Val
mv

-- | 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 :: * -> *).
(CheckCtx, 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.
(CheckCtx, 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. (CheckCtx, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
usrc Size
i
          BVal
bx <- BSeg -> Size -> IO BVal
forall (m :: * -> *) a. Applicative 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 ::
  forall a. (HasCallStack, BuiltinForeign a) => Closure -> IO a
marshalUnwrapForeignIO :: forall a. (HasCallStack, BuiltinForeign a) => BVal -> IO a
marshalUnwrapForeignIO BVal
c = 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
$ BVal -> Maybe a
forall f. BuiltinForeign f => BVal -> Maybe f
maybeUnwrapBuiltin BVal
c
  where
    Tagged [Char]
exName = forall f. BuiltinForeign f => Tagged f [Char]
builtinName @a
    err :: IO a
err = RuntimePanic -> IO a
forall e a. (HasCallStack, 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 (BVal -> Val
BoxedVal BVal
c))
    msg :: [Char]
msg = [Char]
"marshalUnwrapForeignIO: 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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. (CheckCtx, Prim a) => PrimArray a -> Size -> a
indexPrimArray PrimArray Size
v Size
i)
            MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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.
(CheckCtx, 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.
(CheckCtx, 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.
(CheckCtx, 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.
(CheckCtx, 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.
(CheckCtx, 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.
(CheckCtx, 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.
(CheckCtx, 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. (CheckCtx, Prim a) => PrimArray a -> Size -> a
indexPrimArray PrimArray Size
v Size
i
            MutableArray (PrimState IO) BVal -> Size -> BVal -> IO ()
forall (m :: * -> *) a.
(CheckCtx, 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.
(CheckCtx, 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.
(CheckCtx, 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 {ap :: Size
ap = Int# -> Size
I# Int#
ap, fp :: Size
fp = Int# -> Size
I# Int#
fp, sp :: Size
sp = Int# -> Size
I# Int#
sp, ustk :: MutableByteArray (PrimState IO)
ustk = MutableByteArray# RealWorld -> MutableByteArray RealWorld
forall s. MutableByteArray# s -> MutableByteArray s
MutableByteArray MutableByteArray# RealWorld
MutableByteArray# (PrimState IO)
ustk, bstk :: 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)

-- | Words past the last slot of the unboxed stack that native code's
-- entry point writes its results to: @ap@, @fp@, @sp@, a count of frame
-- records, and up to eight records of three words. Must match
-- UNISON_JIT_OUT_WORDS in jit_rt.h.
nativeOutWords :: Int
nativeOutWords :: Size
nativeOutWords = Size
28

-- | Pointers past the last slot of the boxed stack, where native code
-- hands heap pointers back so that the collector sees them: the handler
-- environment it was running with when it returned, then one environment
-- per @Local@ frame record it wrote (see @pushRecord@ in Machine.hs). Must
-- match UNISON_JIT_OUT_PTRS in jit_rt.h.
nativeOutPtrs :: Int
nativeOutPtrs :: Size
nativeOutPtrs = Size
33

-- | The slots of a boxed stack: its size less the out-area.
bstkSlots :: MutableArray RealWorld Closure -> Int
bstkSlots :: MutableArray RealWorld BVal -> Size
bstkSlots MutableArray RealWorld BVal
bstk = MutableArray RealWorld BVal -> Size
forall s a. MutableArray s a -> Size
sizeofMutableArray MutableArray RealWorld BVal
bstk Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
nativeOutPtrs
{-# INLINE bstkSlots #-}

-- | The slots a fresh stack has. The JIT's `ustack` stress mode starts with
-- a tiny stack instead, so that growing it is exercised constantly.
defaultStackSlots :: Int
defaultStackSlots :: Size
defaultStackSlots = Size
512

alloc :: Int -> IO Stack
alloc :: Size -> IO Stack
alloc Size
slots = do
  -- Each stack is allocated with an out-area past its last slot
  -- (nativeOutWords, nativeOutPtrs). Native code returns only a status
  -- word through the C calling convention, so it hands everything else
  -- back by writing it there: the new ap, fp and sp and the frame records
  -- on the unboxed stack, and on the boxed stack the handler environment
  -- it ran with, which the collector has to see. The trampoline reads
  -- them after the call (JIT.Native; design.md calls this the out-area). Growing or duplicating a stack keeps the space.
  MutableByteArray RealWorld
ustk <- Size -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Size -> m (MutableByteArray (PrimState m))
newByteArray (Size -> Size
bytes (Size
slots Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
nativeOutWords))
  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
slots Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
nativeOutPtrs) BVal
BlackHole
  pure $ Stack {ap :: Size
ap = -Size
1, fp :: Size
fp = -Size
1, sp :: Size
sp = -Size
1, MutableByteArray RealWorld
MutableByteArray (PrimState IO)
ustk :: MutableByteArray (PrimState IO)
ustk :: MutableByteArray RealWorld
ustk, MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
bstk :: MutableArray (PrimState IO) BVal
bstk :: MutableArray RealWorld BVal
bstk}
{-# INLINE alloc #-}

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

peek :: (DebugCallStack) => Stack -> IO Val
peek :: CheckCtx => 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 :: * -> *).
(CheckCtx, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Size -> m a
readByteArray MutableByteArray (PrimState IO)
ustk Size
sp
  BVal
b <- CheckCtx => 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 :: CheckCtx => 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 :: * -> *).
(CheckCtx, 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 :: CheckCtx => 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 :: * -> *).
(CheckCtx, 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 :: CheckCtx => 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.
(CheckCtx, 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 :: CheckCtx => 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 :: * -> *).
(CheckCtx, 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 :: CheckCtx => 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 :: * -> *).
(CheckCtx, 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 <- CheckCtx => 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 :: CheckCtx => 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.
(CheckCtx, 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 :: CheckCtx => 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 :: * -> *).
(CheckCtx, 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 :: CheckCtx => 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
  CheckCtx => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk BVal
t
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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 :: CheckCtx => 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 :: * -> *).
(CheckCtx, 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.
(CheckCtx, 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 :: CheckCtx => Stack -> Size -> IO ()
unsafePokeIasN Stack
stk Size
n = do
  CheckCtx => 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 :: CheckCtx => 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 :: CheckCtx => Stack -> IO Size
peekTag = CheckCtx => Stack -> IO Size
Stack -> IO Size
peekI
{-# INLINE peekTag #-}

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

pokeBool :: (DebugCallStack) => Stack -> Bool -> IO ()
pokeBool :: CheckCtx => Stack -> Bool -> IO ()
pokeBool Stack
stk Bool
b =
  CheckCtx => 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 :: CheckCtx => 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.
(CheckCtx, 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 :: CheckCtx => Stack -> Size -> Val -> IO ()
pokeOff Stack
stk Size
i (Val Size
u BVal
t) = do
  CheckCtx => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i BVal
t
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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 :: CheckCtx => Stack -> Size -> Size -> BVal -> IO ()
upokeOffT Stack
stk Size
i Size
u BVal
t = do
  CheckCtx => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i BVal
t
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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 :: CheckCtx => 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.
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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.
(CheckCtx, 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.
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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.
(CheckCtx, 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 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
nativeOutPtrs) BVal
BlackHole
      MutableArray (PrimState IO) BVal
-> Size
-> MutableArray (PrimState IO) BVal
-> Size
-> Size
-> IO ()
forall (m :: * -> *) a.
(CheckCtx, 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)
      Size
usz <- MutableByteArray (PrimState IO) -> IO Size
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m Size
getSizeofMutableByteArray MutableByteArray (PrimState IO)
ustk
      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
    bsz :: Size
bsz = MutableArray RealWorld BVal -> Size
bstkSlots 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 #-}

-- | Like 'ensure', but grows by at least the stack's current size. Native
-- code pays for every growth by unwinding all its frames to the
-- interpreter, so it asks for room in big steps.
ensureGenerously :: Stack -> SZ -> IO Stack
ensureGenerously :: Stack -> Size -> IO Stack
ensureGenerously stk :: Stack
stk@(Stack Size
_ Size
_ Size
_ MutableByteArray (PrimState IO)
_ 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
  | Bool
otherwise = Stack -> Size -> IO Stack
ensure Stack
stk (Size -> Size -> Size
forall a. Ord a => a -> a -> a
max Size
sze (MutableArray RealWorld BVal -> Size
bstkSlots MutableArray RealWorld BVal
MutableArray (PrimState IO) BVal
bstk))
{-# INLINE ensureGenerously #-}

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
      Size
sz <- MutableByteArray (PrimState IO) -> IO Size
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m Size
getSizeofMutableByteArray 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 :: * -> *).
(CheckCtx, 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.
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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.
(CheckCtx, 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.
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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.
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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
<$> CheckCtx => 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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 :: * -> *).
(CheckCtx, 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
  CheckCtx => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk BVal
natTypeTag
  MutableByteArray (PrimState IO) -> Size -> Word64 -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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
  CheckCtx => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk BVal
floatTypeTag
  MutableByteArray (PrimState IO) -> Size -> Double -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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
  CheckCtx => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk BVal
charTypeTag
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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
  CheckCtx => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk BVal
intTypeTag
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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
  CheckCtx => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i BVal
natTypeTag
  MutableByteArray (PrimState IO) -> Size -> Word64 -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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
  CheckCtx => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i BVal
floatTypeTag
  MutableByteArray (PrimState IO) -> Size -> Double -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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
  CheckCtx => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i BVal
intTypeTag
  MutableByteArray (PrimState IO) -> Size -> Size -> IO ()
forall a (m :: * -> *).
(CheckCtx, 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
  CheckCtx => 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 = CheckCtx => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk (b -> BVal
forall f. BuiltinForeign f => f -> BVal
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 = CheckCtx => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i (b -> BVal
forall f. BuiltinForeign f => f -> BVal
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
=<< CheckCtx => 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
=<< CheckCtx => 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 <- CheckCtx => Stack -> IO BVal
Stack -> IO BVal
bpeek Stack
stk
  pure $ case BVal
b of
    Enum 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 <- CheckCtx => Stack -> Size -> IO BVal
Stack -> Size -> IO BVal
bpeekOff Stack
stk Size
i
  pure $ case BVal
b of
    Enum 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
=<< CheckCtx => 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 = CheckCtx => Stack -> BVal -> IO ()
Stack -> BVal -> IO ()
bpoke Stack
stk (USeq -> BVal
ListC USeq
s)
{-# INLINE pokeS #-}

pokeOffS :: Stack -> Int -> USeq -> IO ()
pokeOffS :: Stack -> Size -> USeq -> IO ()
pokeOffS Stack
stk Size
i USeq
s = CheckCtx => Stack -> Size -> BVal -> IO ()
Stack -> Size -> BVal -> IO ()
bpokeOff Stack
stk Size
i (USeq -> BVal
ListC 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 Ptr NativeCell
_ 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
=<< CheckCtx => 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
=<< CheckCtx => 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 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
  (ListC USeq
cs) ->
    (Val -> m) -> USeq -> m
forall m a. Monoid m => (a -> m) -> Deque 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
_ Ptr NativeCell
_ 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 = PackedTag -> BVal
Enum 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 TextC {} = Size
3
closureNum ListC {} = Size
3
closureNum BytesC {} = Size
3
closureNum UnboxedTypeTag {} = Size
4
closureNum BlackHole {} = Size
5
closureNum Affine {} = Size
6
closureNum RecordC {} = Size
7

-- | 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

-- | Constructors compare field by field in place: no list of the fields
-- is built (this runs for every key of a replaced @Map@).
instance Eq Closure where
  Enum PackedTag
t1 == :: BVal -> BVal -> Bool
== Enum PackedTag
t2 = PackedTag
t1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t2
  Data1 PackedTag
t1 Val
a1 == Data1 PackedTag
t2 Val
a2 =
    PackedTag -> PackedTag -> Bool
matchTags PackedTag
t1 PackedTag
t2 Bool -> Bool -> Bool
&& Val
a1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
a2
  Data2 PackedTag
t1 Val
a1 Val
b1 == Data2 PackedTag
t2 Val
a2 Val
b2 =
    PackedTag
t1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t2 Bool -> Bool -> Bool
&& Val
a1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
a2 Bool -> Bool -> Bool
&& Val
b1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
b2
  Data3 PackedTag
t1 Val
a1 Val
b1 Val
c1 == Data3 PackedTag
t2 Val
a2 Val
b2 Val
c2 =
    PackedTag
t1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t2 Bool -> Bool -> Bool
&& Val
a1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
a2 Bool -> Bool -> Bool
&& Val
b1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
b2 Bool -> Bool -> Bool
&& Val
c1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
c2
  Data4 PackedTag
t1 Val
a1 Val
b1 Val
c1 Val
d1 == Data4 PackedTag
t2 Val
a2 Val
b2 Val
c2 Val
d2 =
    PackedTag
t1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t2 Bool -> Bool -> Bool
&& Val
a1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
a2 Bool -> Bool -> Bool
&& Val
b1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
b2 Bool -> Bool -> Bool
&& Val
c1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
c2 Bool -> Bool -> Bool
&& Val
d1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
d2
  Data5 PackedTag
t1 Val
a1 Val
b1 Val
c1 Val
d1 Val
e1 == Data5 PackedTag
t2 Val
a2 Val
b2 Val
c2 Val
d2 Val
e2 =
    PackedTag
t1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t2 Bool -> Bool -> Bool
&& Val
a1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
a2 Bool -> Bool -> Bool
&& Val
b1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
b2 Bool -> Bool -> Bool
&& Val
c1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
c2 Bool -> Bool -> Bool
&& Val
d1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
d2 Bool -> Bool -> Bool
&& Val
e1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
e2
  Data6 PackedTag
t1 Val
a1 Val
b1 Val
c1 Val
d1 Val
e1 Val
f1 == Data6 PackedTag
t2 Val
a2 Val
b2 Val
c2 Val
d2 Val
e2 Val
f2 =
    PackedTag
t1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t2 Bool -> Bool -> Bool
&& Val
a1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
a2 Bool -> Bool -> Bool
&& Val
b1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
b2 Bool -> Bool -> Bool
&& Val
c1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
c2 Bool -> Bool -> Bool
&& Val
d1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
d2 Bool -> Bool -> Bool
&& Val
e1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
e2 Bool -> Bool -> Bool
&& Val
f1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
f2
  Closure (GDataG PackedTag
t1 ByteArray
u1 BSeg
b1) == Closure (GDataG PackedTag
t2 ByteArray
u2 BSeg
b2) =
    PackedTag
t1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t2 Bool -> Bool -> Bool
&& ByteArray -> BSeg -> ByteArray -> BSeg -> Bool
eqSegs ByteArray
u1 BSeg
b1 ByteArray
u2 BSeg
b2
  -- constructors of different shapes have different arities, so
  -- different tags
  (BVal -> Maybe PackedTag
dataTag -> Just PackedTag
_) == (BVal -> Maybe PackedTag
dataTag -> Just PackedTag
_) = Bool
False
  -- Shape equality is by field name, so this doesn't depend on intern order.
  RecordC RecordShape
sh1 RecordVals
vs1 == RecordC RecordShape
sh2 RecordVals
vs2 =
    RecordShape
sh1 RecordShape -> RecordShape -> Bool
forall a. Eq a => a -> a -> Bool
== RecordShape
sh2 Bool -> Bool -> Bool
&& [Val] -> [Val] -> Bool
eqValList (RecordVals -> [Val]
forall a. Vector a -> [a]
V.toList RecordVals
vs1) (RecordVals -> [Val]
forall a. Vector a -> [a]
V.toList RecordVals
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
  TextC Text
l == TextC Text
r = Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
r
  ListC USeq
l == ListC USeq
r = USeq
l USeq -> USeq -> Bool
forall a. Eq a => a -> a -> Bool
== USeq
r
  BytesC Bytes
l == BytesC Bytes
r = Bytes
l Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes
r
  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
== Size
3,
      BVal -> Size
closureNum BVal
d Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
3 =
        [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
<> BVal -> [Char]
builtinKindName BVal
c
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` vs `"
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> BVal -> [Char]
builtinKindName BVal
d
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"
    | Bool
otherwise = BVal -> Size
closureNum BVal
c Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== BVal -> Size
closureNum BVal
d

-- | The name of a text, a list, a bytes or a foreign value's kind, for
-- the errors on comparing two of different kinds.
builtinKindName :: Closure -> String
builtinKindName :: BVal -> [Char]
builtinKindName = \case
  TextC {} -> [Char]
"Text"
  ListC {} -> [Char]
"Seq"
  BytesC {} -> [Char]
"Bytes"
  Foreign Foreign
f -> Foreign -> [Char]
foreignName Foreign
f
  BVal
_ -> [Char]
"closure"

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
_ Ptr NativeCell
_ K
k == Push Size
f' Size
a' CombIx
ci' Size
_ RSection Val
_ Ptr NativeCell
_ 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

-- | Two segments, element by element from field 0 (the last slot).
eqSegs :: USeg -> BSeg -> USeg -> BSeg -> Bool
eqSegs :: ByteArray -> BSeg -> ByteArray -> BSeg -> Bool
eqSegs ByteArray
u1 BSeg
b1 ByteArray
u2 BSeg
b2 = Size
n Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
b2 Bool -> Bool -> Bool
&& Size -> Bool
go (Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1)
  where
    n :: Size
n = BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
b1
    go :: Size -> Bool
go Size
i
      | Size
i Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Size
0 = Bool
True
      | Bool
otherwise =
          Size -> BVal -> Val
Val (ByteArray -> Size -> Size
forall a. (CheckCtx, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
u1 Size
i) (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
b1 Size
i) Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Size -> BVal -> Val
Val (ByteArray -> Size -> Size
forall a. (CheckCtx, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
u2 Size
i) (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
b2 Size
i)
            Bool -> Bool -> Bool
&& Size -> Bool
go (Size
i Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1)

-- 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
    -- the sign bit
    clear :: a -> a
clear a
k = a -> Size -> a
forall a. Bits a => a -> Size -> a
clearBit a
k Size
63

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)

-- | Constructors compare by tag, then field by field in place: no list
-- of the fields is built (this is the key order of a replaced @Map@).
compareClosure :: Bool -> Closure -> Closure -> Ordering
compareClosure :: Bool -> BVal -> BVal -> Ordering
compareClosure Bool
tyEq = \cases
  (Enum PackedTag
t1) (Enum PackedTag
t2) -> Bool -> PackedTag -> PackedTag -> Ordering
compareTags Bool
tyEq PackedTag
t1 PackedTag
t2
  (Data1 PackedTag
t1 Val
a1) (Data1 PackedTag
t2 Val
a2) ->
    Bool -> PackedTag -> PackedTag -> Ordering
compareTags Bool
tyEq PackedTag
t1 PackedTag
t2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal (Bool -> PackedTag -> Bool
fieldTyEq Bool
tyEq PackedTag
t1) Val
a1 Val
a2
  (Data2 PackedTag
t1 Val
a1 Val
b1) (Data2 PackedTag
t2 Val
a2 Val
b2) ->
    Bool -> PackedTag -> PackedTag -> Ordering
compareTags Bool
tyEq PackedTag
t1 PackedTag
t2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> case Bool -> PackedTag -> Bool
fieldTyEq Bool
tyEq PackedTag
t1 of
      Bool
e -> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
a1 Val
a2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
b1 Val
b2
  (Data3 PackedTag
t1 Val
a1 Val
b1 Val
c1) (Data3 PackedTag
t2 Val
a2 Val
b2 Val
c2) ->
    Bool -> PackedTag -> PackedTag -> Ordering
compareTags Bool
tyEq PackedTag
t1 PackedTag
t2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> case Bool -> PackedTag -> Bool
fieldTyEq Bool
tyEq PackedTag
t1 of
      Bool
e -> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
a1 Val
a2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
b1 Val
b2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
c1 Val
c2
  (Data4 PackedTag
t1 Val
a1 Val
b1 Val
c1 Val
d1) (Data4 PackedTag
t2 Val
a2 Val
b2 Val
c2 Val
d2) ->
    Bool -> PackedTag -> PackedTag -> Ordering
compareTags Bool
tyEq PackedTag
t1 PackedTag
t2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> case Bool -> PackedTag -> Bool
fieldTyEq Bool
tyEq PackedTag
t1 of
      Bool
e -> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
a1 Val
a2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
b1 Val
b2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
c1 Val
c2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
d1 Val
d2
  (Data5 PackedTag
t1 Val
a1 Val
b1 Val
c1 Val
d1 Val
e1) (Data5 PackedTag
t2 Val
a2 Val
b2 Val
c2 Val
d2 Val
e2) ->
    Bool -> PackedTag -> PackedTag -> Ordering
compareTags Bool
tyEq PackedTag
t1 PackedTag
t2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> case Bool -> PackedTag -> Bool
fieldTyEq Bool
tyEq PackedTag
t1 of
      Bool
e -> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
a1 Val
a2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
b1 Val
b2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
c1 Val
c2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
d1 Val
d2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
e1 Val
e2
  (Data6 PackedTag
t1 Val
a1 Val
b1 Val
c1 Val
d1 Val
e1 Val
f1) (Data6 PackedTag
t2 Val
a2 Val
b2 Val
c2 Val
d2 Val
e2 Val
f2) ->
    Bool -> PackedTag -> PackedTag -> Ordering
compareTags Bool
tyEq PackedTag
t1 PackedTag
t2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> case Bool -> PackedTag -> Bool
fieldTyEq Bool
tyEq PackedTag
t1 of
      Bool
e -> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
a1 Val
a2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
b1 Val
b2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
c1 Val
c2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
d1 Val
d2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
e1 Val
e2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Val -> Val -> Ordering
compareVal Bool
e Val
f1 Val
f2
  (Closure (GDataG PackedTag
t1 ByteArray
u1 BSeg
b1)) (Closure (GDataG PackedTag
t2 ByteArray
u2 BSeg
b2)) ->
    Bool -> PackedTag -> PackedTag -> Ordering
compareTags Bool
tyEq PackedTag
t1 PackedTag
t2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> ByteArray -> BSeg -> ByteArray -> BSeg -> Ordering
compareSegs (Bool -> PackedTag -> Bool
fieldTyEq Bool
tyEq PackedTag
t1) ByteArray
u1 BSeg
b1 ByteArray
u2 BSeg
b2
  -- constructors of different shapes: of different types (compared
  -- universally), whose tags may still agree, then by arity
  c1 :: BVal
c1@(BVal -> Maybe PackedTag
dataTag -> Just PackedTag
t1) c2 :: BVal
c2@(BVal -> Maybe PackedTag
dataTag -> Just PackedTag
t2) ->
    Bool -> PackedTag -> PackedTag -> Ordering
compareTags Bool
tyEq PackedTag
t1 PackedTag
t2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (BVal -> Size
dataArity BVal
c1) (BVal -> Size
dataArity BVal
c2)
  -- Two records of different shapes can reach this once wrapped in `Any`,
  -- which erases their types. Order those by field name -- via the `Ord
  -- RecordShape` instance -- rather than by interned shape id, so the result
  -- doesn't depend on the order field names were first compiled.
  --
  -- Without `tyEq` the static types are known equal, so the shapes match and
  -- the slots line up positionally.
  (RecordC RecordShape
sh1 RecordVals
vs1) (RecordC RecordShape
sh2 RecordVals
vs2)
    | Bool
tyEq, RecordShape
sh1 RecordShape -> RecordShape -> Bool
forall a. Eq a => a -> a -> Bool
/= RecordShape
sh2 -> RecordShape -> RecordShape -> Ordering
forall a. Ord a => a -> a -> Ordering
compare RecordShape
sh1 RecordShape
sh2
    | Bool
otherwise -> Bool -> [Val] -> [Val] -> Ordering
compareValList Bool
tyEq (RecordVals -> [Val]
forall a. Vector a -> [a]
V.toList RecordVals
vs1) (RecordVals -> [Val]
forall a. Vector a -> [a]
V.toList RecordVals
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
  (TextC Text
l) (TextC Text
r) -> Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Text
l Text
r
  (ListC USeq
l) (ListC USeq
r) -> (Val -> Val -> Ordering) -> USeq -> USeq -> Ordering
forall a b. (a -> b -> Ordering) -> Deque a -> Deque 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
  (BytesC Bytes
l) (BytesC Bytes
r) -> Bytes -> Bytes -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bytes
l Bytes
r
  (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
closureNum BVal
c Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
3,
      BVal -> Size
closureNum BVal
d Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
3 ->
        [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
<> BVal -> [Char]
builtinKindName BVal
c
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` vs `"
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> BVal -> [Char]
builtinKindName BVal
d
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"
    | Bool
otherwise -> (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)

-- | Two constructors' tags: values of different types order by their
-- type references, which are the same in every process where the
-- numbers need not be (the order is a replaced Map's, serialized as it
-- is); the registry is consulted only then. Without @tyEq@ the types are
-- known equal and the constructor tags decide.
compareTags :: Bool -> PackedTag -> PackedTag -> Ordering
compareTags :: Bool -> PackedTag -> PackedTag -> Ordering
compareTags Bool
tyEq PackedTag
t1 PackedTag
t2
  | PackedTag
t1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t2 = Ordering
EQ
  | Bool
tyEq,
    PackedTag -> Word64
TT.typeTag PackedTag
t1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= PackedTag -> Word64
TT.typeTag PackedTag
t2 =
      Reference -> Reference -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word64 -> Reference
TN.typeReference (PackedTag -> Word64
TT.typeTag PackedTag
t1)) (Word64 -> Reference
TN.typeReference (PackedTag -> Word64
TT.typeTag PackedTag
t2))
  | Bool
otherwise = Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (PackedTag -> Word64
maskTags PackedTag
t1) (PackedTag -> Word64
maskTags PackedTag
t2)
{-# INLINE compareTags #-}

-- | Whether the fields of a constructor compare their types: the fields
-- of an @Any@ have existential types, which the static types of the
-- values compared say nothing about.
fieldTyEq :: Bool -> PackedTag -> Bool
fieldTyEq :: Bool -> PackedTag -> Bool
fieldTyEq Bool
tyEq PackedTag
t = Bool
tyEq Bool -> Bool -> Bool
|| PackedTag -> Bool
TT.isAnyTag PackedTag
t
{-# INLINE fieldTyEq #-}

-- | Two segments, element by element from field 0 (the last slot).
compareSegs :: Bool -> USeg -> BSeg -> USeg -> BSeg -> Ordering
compareSegs :: Bool -> ByteArray -> BSeg -> ByteArray -> BSeg -> Ordering
compareSegs Bool
tyEq ByteArray
u1 BSeg
b1 ByteArray
u2 BSeg
b2 = Size -> Size -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Size
n (BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
b2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Size -> Ordering
go (Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1)
  where
    n :: Size
n = BSeg -> Size
forall a. Array a -> Size
sizeofArray BSeg
b1
    go :: Size -> Ordering
go Size
i
      | Size
i Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Size
0 = Ordering
EQ
      | Bool
otherwise =
          Bool -> Val -> Val -> Ordering
compareVal Bool
tyEq (Size -> BVal -> Val
Val (ByteArray -> Size -> Size
forall a. (CheckCtx, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
u1 Size
i) (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
b1 Size
i)) (Size -> BVal -> Val
Val (ByteArray -> Size -> Size
forall a. (CheckCtx, Prim a) => ByteArray -> Size -> a
indexByteArray ByteArray
u2 Size
i) (BSeg -> Size -> BVal
forall a. Array a -> Size -> a
indexArray BSeg
b2 Size
i))
            Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Size -> Ordering
go (Size
i Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1)

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 Ptr NativeCell
_ K
k) (Push Size
f' Size
a' CombIx
ci' Size
_ RSection Val
_sect' Ptr NativeCell
_ 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 = PackedTag -> BVal
Enum PackedTag
TT.mapTipTag
inflateMap (Bin Size
sz Val
k Val
v Map Val Val
l Map Val Val
r) =
  PackedTag -> Val -> Val -> Val -> Val -> Val -> BVal
Data5 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 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 (Data5 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.
-- The first six constructors are the ones the builtins unwrap most
-- often (measured 2026-10-15; "Layouts" in JIT/design.md): GHC
-- gives a type's first six constructors their own pointer tags, and a case
-- on any later one reads the info table. Nothing serializes or orders by
-- this order; the Tag instances are explicit. Texts, lists and bytes are
-- closure constructors of their own ('TextC', 'ListC', 'BytesC'), not
-- foreign values.
data Foreign
  = WrapMap !(Map Val Val)
  | WrapArray !(Array Val)
  | WrapNatural !Natural
  | WrapByteArray !ByteArray
  | 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
  | WrapMutableByteArray !(MutableByteArray RealWorld)
  | WrapMutableArray !(MutableArray RealWorld Val)
  | WrapMVar !(MVar Val)
  | WrapProcessHandle !ProcessHandle
  | WrapPromise !(Promise Val)
  | WrapPtr !(Ptr.Ptr ())
  | WrapForeignPtr !(Ptr.ForeignPtr ())
  | WrapReference !Reference
  | WrapReferent !Referent
  | WrapSocket !Socket
  | 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
  | WrapSignal !Signal.Signal
  | WrapSignalSubscription !Signal.Subscription

-- Convenience class for (un)wrapping Haskell values automatically

-- | The closure holding a Haskell value: @Foreign (Wrap... x)@ for most,
-- a 'TextC' or 'ListC' for a text or a list.
class BuiltinForeign f where
  builtinName :: Tagged f String
  wrapBuiltin :: f -> Closure
  maybeUnwrapBuiltin :: Closure -> Maybe f

foreignRef :: Foreign -> Reference
foreignRef :: Foreign -> Reference
foreignRef WrapArray {} = Reference
Ty.iarrayRef
foreignRef WrapSignal {} = Reference
Ty.signalRef
foreignRef WrapSignalSubscription {} = Reference
Ty.signalSubscriptionRef
foreignRef WrapByteArray {} = Reference
Ty.ibytearrayRef
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 WrapForeignPtr {} = Reference
Ty.ffiForeignPtrRef
foreignRef WrapReference {} = Reference
Ty.typeLinkRef
foreignRef WrapReferent {} = Reference
Ty.termLinkRef
foreignRef WrapSocket {} = Reference
Ty.socketRef
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 WrapSignal {} = [Char]
"IO.signal.Signal"
foreignName WrapSignalSubscription {} = [Char]
"IO.signal.Subscription"
foreignName WrapByteArray {} = [Char]
"ByteArray"
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 WrapForeignPtr {} = [Char]
"ForeignPtr"
foreignName WrapReference {} = [Char]
"Reference"
foreignName WrapReferent {} = [Char]
"Referent"
foreignName WrapSocket {} = [Char]
"Socket"
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. DataToTag 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
  WrapSignal Signal
l == :: Foreign -> Foreign -> Bool
== WrapSignal Signal
r = Signal
l Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== Signal
r
  WrapSignalSubscription Subscription
l == WrapSignalSubscription Subscription
r = Subscription
l Subscription -> Subscription -> Bool
forall a. Eq a => a -> a -> Bool
== Subscription
r
  WrapArray Array Val
l == WrapArray Array Val
r = Array Val
l Array Val -> Array Val -> Bool
forall a. Eq a => a -> a -> Bool
== Array Val
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
  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
  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
  WrapForeignPtr ForeignPtr ()
l == WrapForeignPtr ForeignPtr ()
r = ForeignPtr ()
l ForeignPtr () -> ForeignPtr () -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignPtr ()
r
  WrapCDynFunc CDynFunc
l == WrapCDynFunc CDynFunc
r = CDynFunc
l CDynFunc -> CDynFunc -> Bool
forall a. Eq a => a -> a -> Bool
== CDynFunc
r
  WrapFFIType FFType
l == WrapFFIType FFType
r = FFType
l FFType -> FFType -> Bool
forall a. Eq a => a -> a -> Bool
== FFType
r
  WrapFFISpec FFSpec
l == WrapFFISpec FFSpec
r = FFSpec
l FFSpec -> FFSpec -> Bool
forall a. Eq a => a -> a -> Bool
== FFSpec
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
  WrapDLL DLL
l == WrapDLL DLL
r = DLL -> DLL -> Bool
forall a. a -> a -> Bool
ptrEq DLL
l DLL
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 (WrapSignal Signal
l) (WrapSignal Signal
r) = Signal -> Signal -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Signal
l Signal
r
compareForeign Bool
_tyEq (WrapSignalSubscription Subscription
l) (WrapSignalSubscription Subscription
r) = Subscription -> Subscription -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Subscription
l Subscription
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 (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 (WrapForeignPtr ForeignPtr ()
l) (WrapForeignPtr ForeignPtr ()
r) = ForeignPtr () -> ForeignPtr () -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ForeignPtr ()
l ForeignPtr ()
r
compareForeign Bool
_tyEq (WrapCDynFunc CDynFunc
l) (WrapCDynFunc CDynFunc
r) = CDynFunc -> CDynFunc -> Ordering
forall a. Ord a => a -> a -> Ordering
compare CDynFunc
l CDynFunc
r
compareForeign Bool
_tyEq (WrapFFIType FFType
l) (WrapFFIType FFType
r) = FFType -> FFType -> Ordering
forall a. Ord a => a -> a -> Ordering
compare FFType
l FFType
r
compareForeign Bool
_tyEq (WrapFFISpec FFSpec
l) (WrapFFISpec FFSpec
r) = FFSpec -> FFSpec -> Ordering
forall a. Ord a => a -> a -> Ordering
compare FFSpec
l FFSpec
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 (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]
" _"

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 -> BVal
wrapBuiltin = Text -> BVal
TextC
  maybeUnwrapBuiltin :: BVal -> Maybe Text
maybeUnwrapBuiltin = \case
    TextC Text
v -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Bytes -> BVal
BytesC
  maybeUnwrapBuiltin :: BVal -> Maybe Bytes
maybeUnwrapBuiltin = \case
    BytesC Bytes
v -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (Handle -> Foreign) -> Handle -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Foreign
WrapHandle
  maybeUnwrapBuiltin :: BVal -> Maybe Handle
maybeUnwrapBuiltin = \case
    Foreign (WrapHandle Handle
v) -> Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (ProcessHandle -> Foreign) -> ProcessHandle -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessHandle -> Foreign
WrapProcessHandle
  maybeUnwrapBuiltin :: BVal -> Maybe ProcessHandle
maybeUnwrapBuiltin = \case
    Foreign (WrapProcessHandle ProcessHandle
v) -> ProcessHandle -> Maybe ProcessHandle
forall a. a -> Maybe a
Just ProcessHandle
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (Ptr a -> Foreign) -> Ptr a -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: BVal -> Maybe (Ptr a)
maybeUnwrapBuiltin = \case
    Foreign (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)
    BVal
_ -> Maybe (Ptr a)
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (Ptr.ForeignPtr a) where
  builtinName :: Tagged (ForeignPtr a) [Char]
builtinName = [Char] -> Tagged (ForeignPtr a) [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"ForeignPtr"
  wrapBuiltin :: ForeignPtr a -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (ForeignPtr a -> Foreign) -> ForeignPtr a -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr () -> Foreign
WrapForeignPtr (ForeignPtr () -> Foreign)
-> (ForeignPtr a -> ForeignPtr ()) -> ForeignPtr a -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr a -> ForeignPtr ()
forall a b. ForeignPtr a -> ForeignPtr b
Ptr.castForeignPtr
  maybeUnwrapBuiltin :: BVal -> Maybe (ForeignPtr a)
maybeUnwrapBuiltin = \case
    Foreign (WrapForeignPtr ForeignPtr ()
p) -> ForeignPtr a -> Maybe (ForeignPtr a)
forall a. a -> Maybe a
Just (ForeignPtr () -> ForeignPtr a
forall a b. ForeignPtr a -> ForeignPtr b
Ptr.castForeignPtr ForeignPtr ()
p)
    BVal
_ -> Maybe (ForeignPtr 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (Reference -> Foreign) -> Reference -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Foreign
WrapReference
  maybeUnwrapBuiltin :: BVal -> Maybe Reference
maybeUnwrapBuiltin = \case
    Foreign (WrapReference Reference
v) -> Reference -> Maybe Reference
forall a. a -> Maybe a
Just Reference
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (Referent -> Foreign) -> Referent -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Referent -> Foreign
WrapReferent
  maybeUnwrapBuiltin :: BVal -> Maybe Referent
maybeUnwrapBuiltin = \case
    Foreign (WrapReferent Referent
v) -> Referent -> Maybe Referent
forall a. a -> Maybe a
Just Referent
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (Socket -> Foreign) -> Socket -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> Foreign
WrapSocket
  maybeUnwrapBuiltin :: BVal -> Maybe Socket
maybeUnwrapBuiltin = \case
    Foreign (WrapSocket Socket
v) -> Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (ListenSocket -> Foreign) -> ListenSocket -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListenSocket -> Foreign
WrapListenSocket
  maybeUnwrapBuiltin :: BVal -> Maybe ListenSocket
maybeUnwrapBuiltin = \case
    Foreign (WrapListenSocket ListenSocket
v) -> ListenSocket -> Maybe ListenSocket
forall a. a -> Maybe a
Just ListenSocket
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (ClientSockAddr -> Foreign) -> ClientSockAddr -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientSockAddr -> Foreign
WrapClientSockAddr
  maybeUnwrapBuiltin :: BVal -> Maybe ClientSockAddr
maybeUnwrapBuiltin = \case
    Foreign (WrapClientSockAddr ClientSockAddr
v) -> ClientSockAddr -> Maybe ClientSockAddr
forall a. a -> Maybe a
Just ClientSockAddr
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (UDPSocket -> Foreign) -> UDPSocket -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UDPSocket -> Foreign
WrapUDPSocket
  maybeUnwrapBuiltin :: BVal -> Maybe UDPSocket
maybeUnwrapBuiltin = \case
    Foreign (WrapUDPSocket UDPSocket
v) -> UDPSocket -> Maybe UDPSocket
forall a. a -> Maybe a
Just UDPSocket
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (ThreadId -> Foreign) -> ThreadId -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> Foreign
WrapThreadId
  maybeUnwrapBuiltin :: BVal -> Maybe ThreadId
maybeUnwrapBuiltin = \case
    Foreign (WrapThreadId ThreadId
v) -> ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (ClientParams -> Foreign) -> ClientParams -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientParams -> Foreign
WrapTlsClientParams
  maybeUnwrapBuiltin :: BVal -> Maybe ClientParams
maybeUnwrapBuiltin = \case
    Foreign (WrapTlsClientParams ClientParams
v) -> ClientParams -> Maybe ClientParams
forall a. a -> Maybe a
Just ClientParams
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (ServerParams -> Foreign) -> ServerParams -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerParams -> Foreign
WrapTlsServerParams
  maybeUnwrapBuiltin :: BVal -> Maybe ServerParams
maybeUnwrapBuiltin = \case
    Foreign (WrapTlsServerParams ServerParams
v) -> ServerParams -> Maybe ServerParams
forall a. a -> Maybe a
Just ServerParams
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (SignedCertificate -> Foreign) -> SignedCertificate -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedCertificate -> Foreign
WrapX509SignedCertificate
  maybeUnwrapBuiltin :: BVal -> Maybe SignedCertificate
maybeUnwrapBuiltin = \case
    Foreign (WrapX509SignedCertificate SignedCertificate
v) -> SignedCertificate -> Maybe SignedCertificate
forall a. a -> Maybe a
Just SignedCertificate
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (PrivKey -> Foreign) -> PrivKey -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrivKey -> Foreign
WrapX509PrivKey
  maybeUnwrapBuiltin :: BVal -> Maybe PrivKey
maybeUnwrapBuiltin = \case
    Foreign (WrapX509PrivKey PrivKey
v) -> PrivKey -> Maybe PrivKey
forall a. a -> Maybe a
Just PrivKey
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (Tls -> Foreign) -> Tls -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tls -> Foreign
WrapTls
  maybeUnwrapBuiltin :: BVal -> Maybe Tls
maybeUnwrapBuiltin = \case
    Foreign (WrapTls Tls
v) -> Tls -> Maybe Tls
forall a. a -> Maybe a
Just Tls
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (Referenced Code -> Foreign) -> Referenced Code -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Referenced Code -> Foreign
WrapCode
  maybeUnwrapBuiltin :: BVal -> Maybe (Referenced Code)
maybeUnwrapBuiltin = \case
    Foreign (WrapCode Referenced Code
v) -> Referenced Code -> Maybe (Referenced Code)
forall a. a -> Maybe a
Just Referenced Code
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (Referenced Value -> Foreign) -> Referenced Value -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Referenced Value -> Foreign
WrapValue
  maybeUnwrapBuiltin :: BVal -> Maybe (Referenced Value)
maybeUnwrapBuiltin = \case
    Foreign (WrapValue Referenced Value
v) -> Referenced Value -> Maybe (Referenced Value)
forall a. a -> Maybe a
Just Referenced Value
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (TimeSpec -> Foreign) -> TimeSpec -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeSpec -> Foreign
WrapTimeSpec
  maybeUnwrapBuiltin :: BVal -> Maybe TimeSpec
maybeUnwrapBuiltin = \case
    Foreign (WrapTimeSpec TimeSpec
v) -> TimeSpec -> Maybe TimeSpec
forall a. a -> Maybe a
Just TimeSpec
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (MutableByteArray RealWorld -> Foreign)
-> MutableByteArray RealWorld
-> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutableByteArray RealWorld -> Foreign
WrapMutableByteArray
  maybeUnwrapBuiltin :: BVal -> Maybe (MutableByteArray RealWorld)
maybeUnwrapBuiltin = \case
    Foreign (WrapMutableByteArray MutableByteArray RealWorld
v) -> MutableByteArray RealWorld -> Maybe (MutableByteArray RealWorld)
forall a. a -> Maybe a
Just MutableByteArray RealWorld
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (ByteArray -> Foreign) -> ByteArray -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteArray -> Foreign
WrapByteArray
  maybeUnwrapBuiltin :: BVal -> Maybe ByteArray
maybeUnwrapBuiltin = \case
    Foreign (WrapByteArray ByteArray
v) -> ByteArray -> Maybe ByteArray
forall a. a -> Maybe a
Just ByteArray
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (Integer -> Foreign) -> Integer -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Foreign
WrapInteger
  maybeUnwrapBuiltin :: BVal -> Maybe Integer
maybeUnwrapBuiltin = \case
    Foreign (WrapInteger Integer
v) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (Natural -> Foreign) -> Natural -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Foreign
WrapNatural
  maybeUnwrapBuiltin :: BVal -> Maybe Natural
maybeUnwrapBuiltin = \case
    Foreign (WrapNatural Natural
v) -> Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (DLL -> Foreign) -> DLL -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DLL -> Foreign
WrapDLL
  maybeUnwrapBuiltin :: BVal -> Maybe DLL
maybeUnwrapBuiltin = \case
    Foreign (WrapDLL DLL
v) -> DLL -> Maybe DLL
forall a. a -> Maybe a
Just DLL
v
    BVal
_ -> Maybe DLL
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

instance BuiltinForeign (Deque 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 -> BVal
wrapBuiltin = USeq -> BVal
ListC
  maybeUnwrapBuiltin :: BVal -> Maybe USeq
maybeUnwrapBuiltin = \case
    ListC USeq
v -> USeq -> Maybe USeq
forall a. a -> Maybe a
Just USeq
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = 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
  maybeUnwrapBuiltin :: BVal -> Maybe (Map Val Val)
maybeUnwrapBuiltin = \case
    Foreign (WrapMap Map Val Val
v) -> Map Val Val -> Maybe (Map Val Val)
forall a. a -> Maybe a
Just Map Val Val
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (IORef Val -> Foreign) -> IORef Val -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Val -> Foreign
WrapIORef
  maybeUnwrapBuiltin :: BVal -> Maybe (IORef Val)
maybeUnwrapBuiltin = \case
    Foreign (WrapIORef IORef Val
v) -> IORef Val -> Maybe (IORef Val)
forall a. a -> Maybe a
Just IORef Val
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (Ticket Val -> Foreign) -> Ticket Val -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticket Val -> Foreign
WrapTicket
  maybeUnwrapBuiltin :: BVal -> Maybe (Ticket Val)
maybeUnwrapBuiltin = \case
    Foreign (WrapTicket Ticket Val
v) -> Ticket Val -> Maybe (Ticket Val)
forall a. a -> Maybe a
Just Ticket Val
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (MVar Val -> Foreign) -> MVar Val -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Val -> Foreign
WrapMVar
  maybeUnwrapBuiltin :: BVal -> Maybe (MVar Val)
maybeUnwrapBuiltin = \case
    Foreign (WrapMVar MVar Val
v) -> MVar Val -> Maybe (MVar Val)
forall a. a -> Maybe a
Just MVar Val
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (TVar Val -> Foreign) -> TVar Val -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Val -> Foreign
WrapTVar
  maybeUnwrapBuiltin :: BVal -> Maybe (TVar Val)
maybeUnwrapBuiltin = \case
    Foreign (WrapTVar TVar Val
v) -> TVar Val -> Maybe (TVar Val)
forall a. a -> Maybe a
Just TVar Val
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (Promise Val -> Foreign) -> Promise Val -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Promise Val -> Foreign
WrapPromise
  maybeUnwrapBuiltin :: BVal -> Maybe (Promise Val)
maybeUnwrapBuiltin = \case
    Foreign (WrapPromise Promise Val
v) -> Promise Val -> Maybe (Promise Val)
forall a. a -> Maybe a
Just Promise Val
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (MutableArray RealWorld Val -> Foreign)
-> MutableArray RealWorld Val
-> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutableArray RealWorld Val -> Foreign
WrapMutableArray
  maybeUnwrapBuiltin :: BVal -> Maybe (MutableArray RealWorld Val)
maybeUnwrapBuiltin = \case
    Foreign (WrapMutableArray MutableArray RealWorld Val
v) -> MutableArray RealWorld Val -> Maybe (MutableArray RealWorld Val)
forall a. a -> Maybe a
Just MutableArray RealWorld Val
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (Array Val -> Foreign) -> Array Val -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array Val -> Foreign
WrapArray
  maybeUnwrapBuiltin :: BVal -> Maybe (Array Val)
maybeUnwrapBuiltin = \case
    Foreign (WrapArray Array Val
v) -> Array Val -> Maybe (Array Val)
forall a. a -> Maybe a
Just Array Val
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (HashAlgorithm -> Foreign) -> HashAlgorithm -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashAlgorithm -> Foreign
WrapHashAlgorithm
  maybeUnwrapBuiltin :: BVal -> Maybe HashAlgorithm
maybeUnwrapBuiltin = \case
    Foreign (WrapHashAlgorithm HashAlgorithm
v) -> HashAlgorithm -> Maybe HashAlgorithm
forall a. a -> Maybe a
Just HashAlgorithm
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (CPattern -> Foreign) -> CPattern -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPattern -> Foreign
WrapCPattern
  maybeUnwrapBuiltin :: BVal -> Maybe CPattern
maybeUnwrapBuiltin = \case
    Foreign (WrapCPattern CPattern
v) -> CPattern -> Maybe CPattern
forall a. a -> Maybe a
Just CPattern
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (CharPattern -> Foreign) -> CharPattern -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPattern -> Foreign
WrapCharPattern
  maybeUnwrapBuiltin :: BVal -> Maybe CharPattern
maybeUnwrapBuiltin = \case
    Foreign (WrapCharPattern CharPattern
v) -> CharPattern -> Maybe CharPattern
forall a. a -> Maybe a
Just CharPattern
v
    BVal
_ -> Maybe CharPattern
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}

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

instance BuiltinForeign Signal.Subscription where
  builtinName :: Tagged Subscription [Char]
builtinName = [Char] -> Tagged Subscription [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"IO.signal.Subscription"
  wrapBuiltin :: Subscription -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal)
-> (Subscription -> Foreign) -> Subscription -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subscription -> Foreign
WrapSignalSubscription
  maybeUnwrapBuiltin :: BVal -> Maybe Subscription
maybeUnwrapBuiltin = \case
    Foreign (WrapSignalSubscription Subscription
v) -> Subscription -> Maybe Subscription
forall a. a -> Maybe a
Just Subscription
v
    BVal
_ -> Maybe Subscription
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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (FFType -> Foreign) -> FFType -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FFType -> Foreign
WrapFFIType
  maybeUnwrapBuiltin :: BVal -> Maybe FFType
maybeUnwrapBuiltin = \case
    Foreign (WrapFFIType FFType
v) -> FFType -> Maybe FFType
forall a. a -> Maybe a
Just FFType
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (FFSpec -> Foreign) -> FFSpec -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FFSpec -> Foreign
WrapFFISpec
  maybeUnwrapBuiltin :: BVal -> Maybe FFSpec
maybeUnwrapBuiltin = \case
    Foreign (WrapFFISpec FFSpec
v) -> FFSpec -> Maybe FFSpec
forall a. a -> Maybe a
Just FFSpec
v
    BVal
_ -> 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 -> BVal
wrapBuiltin = Foreign -> BVal
Foreign (Foreign -> BVal) -> (CDynFunc -> Foreign) -> CDynFunc -> BVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDynFunc -> Foreign
WrapCDynFunc
  maybeUnwrapBuiltin :: BVal -> Maybe CDynFunc
maybeUnwrapBuiltin = \case
    Foreign (WrapCDynFunc CDynFunc
v) -> CDynFunc -> Maybe CDynFunc
forall a. a -> Maybe a
Just CDynFunc
v
    BVal
_ -> Maybe CDynFunc
forall a. Maybe a
Nothing
  {-# INLINE maybeUnwrapBuiltin #-}