{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module Unison.Runtime.Stack
  ( K (..),
    GClosure (.., DataC, PApV, CapV),
    Closure,
    RClosure,
    IxClosure,
    Callback (..),
    Augment (..),
    Dump (..),
    MEM (..),
    Stack (..),
    Off,
    SZ,
    FP,
    traceK,
    frameDataSize,
    marshalToForeign,
    unull,
    bnull,
    peekD,
    peekOffD,
    pokeD,
    pokeOffD,
    peekN,
    peekOffN,
    pokeN,
    pokeOffN,
    peekBi,
    peekOffBi,
    pokeBi,
    pokeOffBi,
    peekOffS,
    pokeS,
    pokeOffS,
    frameView,
    uscount,
    bscount,
    closureTermRefs,
  )
where

import Control.Monad (when)
import Control.Monad.Primitive
import Data.Foldable as F (for_)
import Data.Kind qualified as Kind
import Data.Sequence (Seq)
import Data.Word
import GHC.Exts as L (IsList (..))
import GHC.Stack (HasCallStack)
import Unison.Reference (Reference)
import Unison.Runtime.ANF as ANF (Mem (..))
import Unison.Runtime.Array
import Unison.Runtime.Foreign
import Unison.Runtime.MCode
import Unison.Type qualified as Ty
import Unison.Util.EnumContainers as EC
import Prelude hiding (words)

newtype Callback = Hook (Stack 'UN -> Stack 'BX -> 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 a prompt
    Mark
      !Int -- pending unboxed args
      !Int -- pending boxed args
      !(EnumSet Word64)
      !(EnumMap Word64 RClosure)
      !K
  | -- save information about a frame for later resumption
    Push
      !Int -- unboxed frame size
      !Int -- boxed frame size
      !Int -- pending unboxed args
      !Int -- pending boxed args
      !RComb -- local continuation reference
      !K
  deriving (K -> K -> Bool
(K -> K -> Bool) -> (K -> K -> Bool) -> Eq K
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: K -> K -> Bool
== :: K -> K -> Bool
$c/= :: K -> K -> Bool
/= :: K -> K -> Bool
Eq, Eq K
Eq K =>
(K -> K -> Ordering)
-> (K -> K -> Bool)
-> (K -> K -> Bool)
-> (K -> K -> Bool)
-> (K -> K -> Bool)
-> (K -> K -> K)
-> (K -> K -> K)
-> Ord K
K -> K -> Bool
K -> K -> Ordering
K -> K -> K
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 :: K -> K -> Ordering
compare :: K -> K -> Ordering
$c< :: K -> K -> Bool
< :: K -> K -> Bool
$c<= :: K -> K -> Bool
<= :: K -> K -> Bool
$c> :: K -> K -> Bool
> :: K -> K -> Bool
$c>= :: K -> K -> Bool
>= :: K -> K -> Bool
$cmax :: K -> K -> K
max :: K -> K -> K
$cmin :: K -> K -> K
min :: K -> K -> K
Ord)

type RClosure = GClosure RComb

type IxClosure = GClosure CombIx

type Closure = GClosure RComb

data GClosure comb
  = PAp
      !comb
      {-# UNPACK #-} !(Seg 'UN) -- unboxed args
      {-  unpack  -}
      !(Seg 'BX) -- boxed args
  | Enum !Reference !Word64
  | DataU1 !Reference !Word64 !Int
  | DataU2 !Reference !Word64 !Int !Int
  | DataB1 !Reference !Word64 !(GClosure comb)
  | DataB2 !Reference !Word64 !(GClosure comb) !(GClosure comb)
  | DataUB !Reference !Word64 !Int !(GClosure comb)
  | DataG !Reference !Word64 !(Seg 'UN) !(Seg 'BX)
  | -- code cont, u/b arg size, u/b data stacks
    Captured !K !Int !Int {-# UNPACK #-} !(Seg 'UN) !(Seg 'BX)
  | Foreign !Foreign
  | BlackHole
  deriving stock (Int -> GClosure comb -> ShowS
[GClosure comb] -> ShowS
GClosure comb -> String
(Int -> GClosure comb -> ShowS)
-> (GClosure comb -> String)
-> ([GClosure comb] -> ShowS)
-> Show (GClosure comb)
forall comb. Show comb => Int -> GClosure comb -> ShowS
forall comb. Show comb => [GClosure comb] -> ShowS
forall comb. Show comb => GClosure comb -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall comb. Show comb => Int -> GClosure comb -> ShowS
showsPrec :: Int -> GClosure comb -> ShowS
$cshow :: forall comb. Show comb => GClosure comb -> String
show :: GClosure comb -> String
$cshowList :: forall comb. Show comb => [GClosure comb] -> ShowS
showList :: [GClosure comb] -> ShowS
Show, GClosure comb -> GClosure comb -> Bool
(GClosure comb -> GClosure comb -> Bool)
-> (GClosure comb -> GClosure comb -> Bool) -> Eq (GClosure comb)
forall comb. Eq comb => GClosure comb -> GClosure comb -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall comb. Eq comb => GClosure comb -> GClosure comb -> Bool
== :: GClosure comb -> GClosure comb -> Bool
$c/= :: forall comb. Eq comb => GClosure comb -> GClosure comb -> Bool
/= :: GClosure comb -> GClosure comb -> Bool
Eq, Eq (GClosure comb)
Eq (GClosure comb) =>
(GClosure comb -> GClosure comb -> Ordering)
-> (GClosure comb -> GClosure comb -> Bool)
-> (GClosure comb -> GClosure comb -> Bool)
-> (GClosure comb -> GClosure comb -> Bool)
-> (GClosure comb -> GClosure comb -> Bool)
-> (GClosure comb -> GClosure comb -> GClosure comb)
-> (GClosure comb -> GClosure comb -> GClosure comb)
-> Ord (GClosure comb)
GClosure comb -> GClosure comb -> Bool
GClosure comb -> GClosure comb -> Ordering
GClosure comb -> GClosure comb -> GClosure comb
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
forall comb. Ord comb => Eq (GClosure comb)
forall comb. Ord comb => GClosure comb -> GClosure comb -> Bool
forall comb. Ord comb => GClosure comb -> GClosure comb -> Ordering
forall comb.
Ord comb =>
GClosure comb -> GClosure comb -> GClosure comb
$ccompare :: forall comb. Ord comb => GClosure comb -> GClosure comb -> Ordering
compare :: GClosure comb -> GClosure comb -> Ordering
$c< :: forall comb. Ord comb => GClosure comb -> GClosure comb -> Bool
< :: GClosure comb -> GClosure comb -> Bool
$c<= :: forall comb. Ord comb => GClosure comb -> GClosure comb -> Bool
<= :: GClosure comb -> GClosure comb -> Bool
$c> :: forall comb. Ord comb => GClosure comb -> GClosure comb -> Bool
> :: GClosure comb -> GClosure comb -> Bool
$c>= :: forall comb. Ord comb => GClosure comb -> GClosure comb -> Bool
>= :: GClosure comb -> GClosure comb -> Bool
$cmax :: forall comb.
Ord comb =>
GClosure comb -> GClosure comb -> GClosure comb
max :: GClosure comb -> GClosure comb -> GClosure comb
$cmin :: forall comb.
Ord comb =>
GClosure comb -> GClosure comb -> GClosure comb
min :: GClosure comb -> GClosure comb -> GClosure comb
Ord, (forall a b. (a -> b) -> GClosure a -> GClosure b)
-> (forall a b. a -> GClosure b -> GClosure a) -> Functor GClosure
forall a b. a -> GClosure b -> GClosure a
forall a b. (a -> b) -> GClosure a -> GClosure b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> GClosure a -> GClosure b
fmap :: forall a b. (a -> b) -> GClosure a -> GClosure b
$c<$ :: forall a b. a -> GClosure b -> GClosure a
<$ :: forall a b. a -> GClosure b -> GClosure a
Functor, (forall m. Monoid m => GClosure m -> m)
-> (forall m a. Monoid m => (a -> m) -> GClosure a -> m)
-> (forall m a. Monoid m => (a -> m) -> GClosure a -> m)
-> (forall a b. (a -> b -> b) -> b -> GClosure a -> b)
-> (forall a b. (a -> b -> b) -> b -> GClosure a -> b)
-> (forall b a. (b -> a -> b) -> b -> GClosure a -> b)
-> (forall b a. (b -> a -> b) -> b -> GClosure a -> b)
-> (forall a. (a -> a -> a) -> GClosure a -> a)
-> (forall a. (a -> a -> a) -> GClosure a -> a)
-> (forall a. GClosure a -> [a])
-> (forall a. GClosure a -> Bool)
-> (forall a. GClosure a -> Int)
-> (forall a. Eq a => a -> GClosure a -> Bool)
-> (forall a. Ord a => GClosure a -> a)
-> (forall a. Ord a => GClosure a -> a)
-> (forall a. Num a => GClosure a -> a)
-> (forall a. Num a => GClosure a -> a)
-> Foldable GClosure
forall a. Eq a => a -> GClosure a -> Bool
forall a. Num a => GClosure a -> a
forall a. Ord a => GClosure a -> a
forall m. Monoid m => GClosure m -> m
forall a. GClosure a -> Bool
forall a. GClosure a -> Int
forall a. GClosure a -> [a]
forall a. (a -> a -> a) -> GClosure a -> a
forall m a. Monoid m => (a -> m) -> GClosure a -> m
forall b a. (b -> a -> b) -> b -> GClosure a -> b
forall a b. (a -> b -> b) -> b -> GClosure a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => GClosure m -> m
fold :: forall m. Monoid m => GClosure m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> GClosure a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> GClosure a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> GClosure a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> GClosure a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> GClosure a -> b
foldr :: forall a b. (a -> b -> b) -> b -> GClosure a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> GClosure a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> GClosure a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> GClosure a -> b
foldl :: forall b a. (b -> a -> b) -> b -> GClosure a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> GClosure a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> GClosure a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> GClosure a -> a
foldr1 :: forall a. (a -> a -> a) -> GClosure a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> GClosure a -> a
foldl1 :: forall a. (a -> a -> a) -> GClosure a -> a
$ctoList :: forall a. GClosure a -> [a]
toList :: forall a. GClosure a -> [a]
$cnull :: forall a. GClosure a -> Bool
null :: forall a. GClosure a -> Bool
$clength :: forall a. GClosure a -> Int
length :: forall a. GClosure a -> Int
$celem :: forall a. Eq a => a -> GClosure a -> Bool
elem :: forall a. Eq a => a -> GClosure a -> Bool
$cmaximum :: forall a. Ord a => GClosure a -> a
maximum :: forall a. Ord a => GClosure a -> a
$cminimum :: forall a. Ord a => GClosure a -> a
minimum :: forall a. Ord a => GClosure a -> a
$csum :: forall a. Num a => GClosure a -> a
sum :: forall a. Num a => GClosure a -> a
$cproduct :: forall a. Num a => GClosure a -> a
product :: forall a. Num a => GClosure a -> a
Foldable, Functor GClosure
Foldable GClosure
(Functor GClosure, Foldable GClosure) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> GClosure a -> f (GClosure b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    GClosure (f a) -> f (GClosure a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> GClosure a -> m (GClosure b))
-> (forall (m :: * -> *) a.
    Monad m =>
    GClosure (m a) -> m (GClosure a))
-> Traversable GClosure
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => GClosure (m a) -> m (GClosure a)
forall (f :: * -> *) a.
Applicative f =>
GClosure (f a) -> f (GClosure a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GClosure a -> m (GClosure b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GClosure a -> f (GClosure b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GClosure a -> f (GClosure b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GClosure a -> f (GClosure b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
GClosure (f a) -> f (GClosure a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
GClosure (f a) -> f (GClosure a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GClosure a -> m (GClosure b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GClosure a -> m (GClosure b)
$csequence :: forall (m :: * -> *) a. Monad m => GClosure (m a) -> m (GClosure a)
sequence :: forall (m :: * -> *) a. Monad m => GClosure (m a) -> m (GClosure a)
Traversable)

traceK :: Reference -> K -> [(Reference, Int)]
traceK :: Reference -> K -> [(Reference, Int)]
traceK Reference
begin = (Reference, Int) -> K -> [(Reference, Int)]
forall {b}. Num b => (Reference, b) -> K -> [(Reference, b)]
dedup (Reference
begin, Int
1)
  where
    dedup :: (Reference, b) -> K -> [(Reference, b)]
dedup (Reference, b)
p (Mark Int
_ Int
_ EnumSet Word64
_ EnumMap Word64 RClosure
_ K
k) = (Reference, b) -> K -> [(Reference, b)]
dedup (Reference, b)
p K
k
    dedup p :: (Reference, b)
p@(Reference
cur, b
n) (Push Int
_ Int
_ Int
_ Int
_ (RComb (CIx Reference
r Word64
_ Word64
_) GComb RComb
_) 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 :: RClosure -> Maybe (Reference, Word64, [Int], [RClosure])
splitData :: RClosure -> Maybe (Reference, Word64, [Int], [RClosure])
splitData (Enum Reference
r Word64
t) = (Reference, Word64, [Int], [RClosure])
-> Maybe (Reference, Word64, [Int], [RClosure])
forall a. a -> Maybe a
Just (Reference
r, Word64
t, [], [])
splitData (DataU1 Reference
r Word64
t Int
i) = (Reference, Word64, [Int], [RClosure])
-> Maybe (Reference, Word64, [Int], [RClosure])
forall a. a -> Maybe a
Just (Reference
r, Word64
t, [Int
i], [])
splitData (DataU2 Reference
r Word64
t Int
i Int
j) = (Reference, Word64, [Int], [RClosure])
-> Maybe (Reference, Word64, [Int], [RClosure])
forall a. a -> Maybe a
Just (Reference
r, Word64
t, [Int
i, Int
j], [])
splitData (DataB1 Reference
r Word64
t RClosure
x) = (Reference, Word64, [Int], [RClosure])
-> Maybe (Reference, Word64, [Int], [RClosure])
forall a. a -> Maybe a
Just (Reference
r, Word64
t, [], [RClosure
x])
splitData (DataB2 Reference
r Word64
t RClosure
x RClosure
y) = (Reference, Word64, [Int], [RClosure])
-> Maybe (Reference, Word64, [Int], [RClosure])
forall a. a -> Maybe a
Just (Reference
r, Word64
t, [], [RClosure
x, RClosure
y])
splitData (DataUB Reference
r Word64
t Int
i RClosure
y) = (Reference, Word64, [Int], [RClosure])
-> Maybe (Reference, Word64, [Int], [RClosure])
forall a. a -> Maybe a
Just (Reference
r, Word64
t, [Int
i], [RClosure
y])
splitData (DataG Reference
r Word64
t Seg 'UN
us Seg 'BX
bs) = (Reference, Word64, [Int], [RClosure])
-> Maybe (Reference, Word64, [Int], [RClosure])
forall a. a -> Maybe a
Just (Reference
r, Word64
t, ByteArray -> [Int]
ints ByteArray
Seg 'UN
us, Seg 'BX -> [RClosure]
bsegToList Seg 'BX
bs)
splitData RClosure
_ = Maybe (Reference, Word64, [Int], [RClosure])
forall a. Maybe a
Nothing

-- | 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 -> [Int]
ints ByteArray
ba = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteArray -> Int -> Int
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
indexByteArray ByteArray
ba) [Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 .. Int
0]
  where
    n :: Int
n = ByteArray -> Int
sizeofByteArray ByteArray
ba Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8

-- | 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] -> Seg 'UN
useg :: [Int] -> Seg 'UN
useg [Int]
ws = case [Item (PrimArray Int)] -> PrimArray Int
forall l. IsList l => [Item l] -> l
L.fromList ([Item (PrimArray Int)] -> PrimArray Int)
-> [Item (PrimArray Int)] -> PrimArray Int
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
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 :: Seg 'BX -> [RClosure]
bsegToList :: Seg 'BX -> [RClosure]
bsegToList = [RClosure] -> [RClosure]
forall a. [a] -> [a]
reverse ([RClosure] -> [RClosure])
-> (Array RClosure -> [RClosure]) -> Array RClosure -> [RClosure]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array RClosure -> [Item (Array RClosure)]
Array RClosure -> [RClosure]
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 :: [RClosure] -> Seg 'BX
bseg :: [RClosure] -> Seg 'BX
bseg = [Item (Array RClosure)] -> Array RClosure
[RClosure] -> Array RClosure
forall l. IsList l => [Item l] -> l
L.fromList ([RClosure] -> Array RClosure)
-> ([RClosure] -> [RClosure]) -> [RClosure] -> Array RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RClosure] -> [RClosure]
forall a. [a] -> [a]
reverse

formData :: Reference -> Word64 -> [Int] -> [RClosure] -> RClosure
formData :: Reference -> Word64 -> [Int] -> [RClosure] -> RClosure
formData Reference
r Word64
t [] [] = Reference -> Word64 -> RClosure
forall comb. Reference -> Word64 -> GClosure comb
Enum Reference
r Word64
t
formData Reference
r Word64
t [Int
i] [] = Reference -> Word64 -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> GClosure comb
DataU1 Reference
r Word64
t Int
i
formData Reference
r Word64
t [Int
i, Int
j] [] = Reference -> Word64 -> Int -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> Int -> GClosure comb
DataU2 Reference
r Word64
t Int
i Int
j
formData Reference
r Word64
t [] [RClosure
x] = Reference -> Word64 -> RClosure -> RClosure
forall comb. Reference -> Word64 -> GClosure comb -> GClosure comb
DataB1 Reference
r Word64
t RClosure
x
formData Reference
r Word64
t [] [RClosure
x, RClosure
y] = Reference -> Word64 -> RClosure -> RClosure -> RClosure
forall comb.
Reference
-> Word64 -> GClosure comb -> GClosure comb -> GClosure comb
DataB2 Reference
r Word64
t RClosure
x RClosure
y
formData Reference
r Word64
t [Int
i] [RClosure
x] = Reference -> Word64 -> Int -> RClosure -> RClosure
forall comb.
Reference -> Word64 -> Int -> GClosure comb -> GClosure comb
DataUB Reference
r Word64
t Int
i RClosure
x
formData Reference
r Word64
t [Int]
us [RClosure]
bs = Reference -> Word64 -> Seg 'UN -> Seg 'BX -> RClosure
forall comb.
Reference -> Word64 -> Seg 'UN -> Seg 'BX -> GClosure comb
DataG Reference
r Word64
t ([Int] -> Seg 'UN
useg [Int]
us) ([RClosure] -> Seg 'BX
bseg [RClosure]
bs)

frameDataSize :: K -> (Int, Int)
frameDataSize :: K -> (Int, Int)
frameDataSize = Int -> Int -> K -> (Int, Int)
go Int
0 Int
0
  where
    go :: Int -> Int -> K -> (Int, Int)
go Int
usz Int
bsz K
KE = (Int
usz, Int
bsz)
    go Int
usz Int
bsz (CB Callback
_) = (Int
usz, Int
bsz)
    go Int
usz Int
bsz (Mark Int
ua Int
ba EnumSet Word64
_ EnumMap Word64 RClosure
_ K
k) = Int -> Int -> K -> (Int, Int)
go (Int
usz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ua) (Int
bsz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ba) K
k
    go Int
usz Int
bsz (Push Int
uf Int
bf Int
ua Int
ba RComb
_ K
k) = Int -> Int -> K -> (Int, Int)
go (Int
usz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
uf Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ua) (Int
bsz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bf Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ba) K
k

pattern DataC :: Reference -> Word64 -> [Int] -> [RClosure] -> RClosure
pattern $mDataC :: forall {r}.
RClosure
-> (Reference -> Word64 -> [Int] -> [RClosure] -> r)
-> ((# #) -> r)
-> r
$bDataC :: Reference -> Word64 -> [Int] -> [RClosure] -> RClosure
DataC rf ct us bs <-
  (splitData -> Just (rf, ct, us, bs))
  where
    DataC Reference
rf Word64
ct [Int]
us [RClosure]
bs = Reference -> Word64 -> [Int] -> [RClosure] -> RClosure
formData Reference
rf Word64
ct [Int]
us [RClosure]
bs

pattern PApV :: RComb -> [Int] -> [RClosure] -> RClosure
pattern $mPApV :: forall {r}.
RClosure
-> (RComb -> [Int] -> [RClosure] -> r) -> ((# #) -> r) -> r
$bPApV :: RComb -> [Int] -> [RClosure] -> RClosure
PApV ic us bs <-
  PAp ic (ints -> us) (bsegToList -> bs)
  where
    PApV RComb
ic [Int]
us [RClosure]
bs = RComb -> Seg 'UN -> Seg 'BX -> RClosure
forall comb. comb -> Seg 'UN -> Seg 'BX -> GClosure comb
PAp RComb
ic ([Int] -> Seg 'UN
useg [Int]
us) ([RClosure] -> Seg 'BX
bseg [RClosure]
bs)

pattern CapV :: K -> Int -> Int -> [Int] -> [RClosure] -> RClosure
pattern $mCapV :: forall {r}.
RClosure
-> (K -> Int -> Int -> [Int] -> [RClosure] -> r)
-> ((# #) -> r)
-> r
$bCapV :: K -> Int -> Int -> [Int] -> [RClosure] -> RClosure
CapV k ua ba us bs <-
  Captured k ua ba (ints -> us) (bsegToList -> bs)
  where
    CapV K
k Int
ua Int
ba [Int]
us [RClosure]
bs = K -> Int -> Int -> Seg 'UN -> Seg 'BX -> RClosure
forall comb. K -> Int -> Int -> Seg 'UN -> Seg 'BX -> GClosure comb
Captured K
k Int
ua Int
ba ([Int] -> Seg 'UN
useg [Int]
us) ([RClosure] -> Seg 'BX
bseg [RClosure]
bs)

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

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

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

marshalToForeign :: (HasCallStack) => RClosure -> Foreign
marshalToForeign :: HasCallStack => RClosure -> Foreign
marshalToForeign (Foreign Foreign
x) = Foreign
x
marshalToForeign RClosure
c =
  String -> Foreign
forall a. HasCallStack => String -> a
error (String -> Foreign) -> String -> Foreign
forall a b. (a -> b) -> a -> b
$ String
"marshalToForeign: unhandled closure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RClosure -> String
forall a. Show a => a -> String
show RClosure
c

type Off = Int

type SZ = Int

type FP = Int

type UA = MutableByteArray (PrimState IO)

type BA = MutableArray (PrimState IO) RClosure

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

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

uargOnto :: UA -> Off -> UA -> Off -> Args' -> IO Int
uargOnto :: UA -> Int -> UA -> Int -> Args' -> IO Int
uargOnto UA
stk Int
sp UA
cop Int
cp0 (Arg1 Int
i) = do
  (Int
x :: Int) <- UA -> Int -> IO Int
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray UA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
  UA -> Int -> Int -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray UA
cop Int
cp Int
x
  pure Int
cp
  where
    cp :: Int
cp = Int
cp0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
uargOnto UA
stk Int
sp UA
cop Int
cp0 (Arg2 Int
i Int
j) = do
  (Int
x :: Int) <- UA -> Int -> IO Int
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray UA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
  (Int
y :: Int) <- UA -> Int -> IO Int
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray UA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
  UA -> Int -> Int -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray UA
cop Int
cp Int
x
  UA -> Int -> Int -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray UA
cop (Int
cp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
y
  pure Int
cp
  where
    cp :: Int
cp = Int
cp0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
uargOnto UA
stk Int
sp UA
cop Int
cp0 (ArgN PrimArray Int
v) = do
  MutableByteArray RealWorld
buf <-
    if Bool
overwrite
      then Int -> IO UA
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray (Int -> IO UA) -> Int -> IO UA
forall a b. (a -> b) -> a -> b
$ Int -> Int
bytes Int
sz
      else MutableByteArray RealWorld -> IO (MutableByteArray RealWorld)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutableByteArray RealWorld
UA
cop
  let loop :: Int -> IO ()
loop Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise = do
            (Int
x :: Int) <- UA -> Int -> IO Int
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray UA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
indexPrimArray PrimArray Int
v Int
i)
            UA -> Int -> Int -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
UA
buf (Int
boff Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Int
x
            Int -> IO ()
loop (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  Int -> IO ()
loop (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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
$
    UA -> Int -> UA -> Int -> Int -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> MutableByteArray (PrimState m) -> Int -> Int -> m ()
copyMutableByteArray UA
cop (Int -> Int
bytes (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
cp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MutableByteArray RealWorld
UA
buf Int
0 (Int -> Int
bytes Int
sz)
  pure Int
cp
  where
    cp :: Int
cp = Int
cp0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz
    sz :: Int
sz = PrimArray Int -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Int
v
    overwrite :: Bool
overwrite = MutableByteArray RealWorld -> MutableByteArray RealWorld -> Bool
forall s. MutableByteArray s -> MutableByteArray s -> Bool
sameMutableByteArray MutableByteArray RealWorld
UA
stk MutableByteArray RealWorld
UA
cop
    boff :: Int
boff | Bool
overwrite = Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 | Bool
otherwise = Int
cp0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz
uargOnto UA
stk Int
sp UA
cop Int
cp0 (ArgR Int
i Int
l) = do
  UA -> Int -> UA -> Int -> Int -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> MutableByteArray (PrimState m) -> Int -> Int -> m ()
moveByteArray UA
cop Int
cbp UA
stk Int
sbp (Int -> Int
bytes Int
l)
  pure $ Int
cp0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l
  where
    cbp :: Int
cbp = Int -> Int
bytes (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
cp0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    sbp :: Int
sbp = Int -> Int
bytes (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

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

data Dump = A | F Int Int | S

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

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

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

class MEM (b :: Mem) where
  data Stack b :: Kind.Type
  type Elem b :: Kind.Type
  type Seg b :: Kind.Type
  alloc :: IO (Stack b)
  peek :: Stack b -> IO (Elem b)
  peekOff :: Stack b -> Off -> IO (Elem b)
  poke :: Stack b -> Elem b -> IO ()
  pokeOff :: Stack b -> Off -> Elem b -> IO ()
  grab :: Stack b -> SZ -> IO (Seg b, Stack b)
  ensure :: Stack b -> SZ -> IO (Stack b)
  bump :: Stack b -> IO (Stack b)
  bumpn :: Stack b -> SZ -> IO (Stack b)
  duplicate :: Stack b -> IO (Stack b)
  discardFrame :: Stack b -> IO (Stack b)
  saveFrame :: Stack b -> IO (Stack b, SZ, SZ)
  saveArgs :: Stack b -> IO (Stack b, SZ)
  restoreFrame :: Stack b -> SZ -> SZ -> IO (Stack b)
  prepareArgs :: Stack b -> Args' -> IO (Stack b)
  acceptArgs :: Stack b -> Int -> IO (Stack b)
  frameArgs :: Stack b -> IO (Stack b)
  augSeg :: Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
  dumpSeg :: Stack b -> Seg b -> Dump -> IO (Stack b)
  adjustArgs :: Stack b -> SZ -> IO (Stack b)
  fsize :: Stack b -> SZ
  asize :: Stack b -> SZ

instance MEM 'UN where
  data Stack 'UN =
    -- Note: uap <= ufp <= usp
    US
    { Stack 'UN -> Int
uap :: !Int, -- arg pointer
      Stack 'UN -> Int
ufp :: !Int, -- frame pointer
      Stack 'UN -> Int
usp :: !Int, -- stack pointer
      Stack 'UN -> UA
ustk :: {-# UNPACK #-} !(MutableByteArray (PrimState IO))
    }
  type Elem 'UN = Int
  type Seg 'UN = ByteArray
  alloc :: IO (Stack 'UN)
alloc = Int -> Int -> Int -> UA -> Stack 'UN
US (-Int
1) (-Int
1) (-Int
1) (MutableByteArray RealWorld -> Stack 'UN)
-> IO (MutableByteArray RealWorld) -> IO (Stack 'UN)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO UA
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
4096
  {-# INLINE alloc #-}
  peek :: Stack 'UN -> IO (Elem 'UN)
peek (US Int
_ Int
_ Int
sp UA
stk) = UA -> Int -> IO Int
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray UA
stk Int
sp
  {-# INLINE peek #-}
  peekOff :: Stack 'UN -> Int -> IO (Elem 'UN)
peekOff (US Int
_ Int
_ Int
sp UA
stk) Int
i = UA -> Int -> IO Int
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray UA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
  {-# INLINE peekOff #-}
  poke :: Stack 'UN -> Elem 'UN -> IO ()
poke (US Int
_ Int
_ Int
sp UA
stk) Elem 'UN
n = UA -> Int -> Int -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray UA
stk Int
sp Int
Elem 'UN
n
  {-# INLINE poke #-}
  pokeOff :: Stack 'UN -> Int -> Elem 'UN -> IO ()
pokeOff (US Int
_ Int
_ Int
sp UA
stk) Int
i Elem 'UN
n = UA -> Int -> Int -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray UA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Int
Elem 'UN
n
  {-# INLINE pokeOff #-}

  -- Eats up arguments
  grab :: Stack 'UN -> Int -> IO (Seg 'UN, Stack 'UN)
grab (US Int
_ Int
fp Int
sp UA
stk) Int
sze = do
    MutableByteArray RealWorld
mut <- Int -> IO UA
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
sz
    UA -> Int -> UA -> Int -> Int -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> MutableByteArray (PrimState m) -> Int -> Int -> m ()
copyMutableByteArray MutableByteArray RealWorld
UA
mut Int
0 UA
stk (Int
bfp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) Int
sz
    ByteArray
seg <- UA -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
UA
mut
    UA -> Int -> UA -> Int -> Int -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> MutableByteArray (PrimState m) -> Int -> Int -> m ()
moveByteArray UA
stk (Int
bfp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) UA
stk Int
bfp Int
fsz
    pure (ByteArray
seg, Int -> Int -> Int -> UA -> Stack 'UN
US (Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sze) (Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sze) (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sze) UA
stk)
    where
      sz :: Int
sz = Int -> Int
bytes Int
sze
      bfp :: Int
bfp = Int -> Int
bytes (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      fsz :: Int
fsz = Int -> Int
bytes (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fp
  {-# INLINE grab #-}

  ensure :: Stack 'UN -> Int -> IO (Stack 'UN)
ensure stki :: Stack 'UN
stki@(US Int
ap Int
fp Int
sp UA
stk) Int
sze
    | Int
sze Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int -> Int
bytes (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sze Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ssz = Stack 'UN -> IO (Stack 'UN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack 'UN
stki
    | Bool
otherwise = do
        MutableByteArray RealWorld
stk' <- UA -> Int -> IO UA
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> Int -> m (MutableByteArray (PrimState m))
resizeMutableByteArray UA
stk (Int
ssz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ext)
        pure $ Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap Int
fp Int
sp MutableByteArray RealWorld
UA
stk'
    where
      ssz :: Int
ssz = MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
sizeofMutableByteArray MutableByteArray RealWorld
UA
stk
      ext :: Int
ext
        | Int -> Int
bytes Int
sze Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10240 = Int -> Int
bytes Int
sze Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4096
        | Bool
otherwise = Int
10240
  {-# INLINE ensure #-}

  bump :: Stack 'UN -> IO (Stack 'UN)
bump (US Int
ap Int
fp Int
sp UA
stk) = Stack 'UN -> IO (Stack 'UN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN -> IO (Stack 'UN)) -> Stack 'UN -> IO (Stack 'UN)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap Int
fp (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) UA
stk
  {-# INLINE bump #-}

  bumpn :: Stack 'UN -> Int -> IO (Stack 'UN)
bumpn (US Int
ap Int
fp Int
sp UA
stk) Int
n = Stack 'UN -> IO (Stack 'UN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN -> IO (Stack 'UN)) -> Stack 'UN -> IO (Stack 'UN)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap Int
fp (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) UA
stk
  {-# INLINE bumpn #-}

  duplicate :: Stack 'UN -> IO (Stack 'UN)
duplicate (US Int
ap Int
fp Int
sp UA
stk) =
    Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap Int
fp Int
sp (MutableByteArray RealWorld -> Stack 'UN)
-> IO (MutableByteArray RealWorld) -> IO (Stack 'UN)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      MutableByteArray RealWorld
b <- Int -> IO UA
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
sz
      UA -> Int -> UA -> Int -> Int -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> MutableByteArray (PrimState m) -> Int -> Int -> m ()
copyMutableByteArray MutableByteArray RealWorld
UA
b Int
0 UA
stk Int
0 Int
sz
      pure MutableByteArray RealWorld
b
    where
      sz :: Int
sz = MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
sizeofMutableByteArray MutableByteArray RealWorld
UA
stk
  {-# INLINE duplicate #-}

  discardFrame :: Stack 'UN -> IO (Stack 'UN)
discardFrame (US Int
ap Int
fp Int
_ UA
stk) = Stack 'UN -> IO (Stack 'UN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN -> IO (Stack 'UN)) -> Stack 'UN -> IO (Stack 'UN)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap Int
fp Int
fp UA
stk
  {-# INLINE discardFrame #-}

  saveFrame :: Stack 'UN -> IO (Stack 'UN, Int, Int)
saveFrame (US Int
ap Int
fp Int
sp UA
stk) = (Stack 'UN, Int, Int) -> IO (Stack 'UN, Int, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int -> UA -> Stack 'UN
US Int
sp Int
sp Int
sp UA
stk, Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fp, Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ap)
  {-# INLINE saveFrame #-}

  saveArgs :: Stack 'UN -> IO (Stack 'UN, Int)
saveArgs (US Int
ap Int
fp Int
sp UA
stk) = (Stack 'UN, Int) -> IO (Stack 'UN, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int -> UA -> Stack 'UN
US Int
fp Int
fp Int
sp UA
stk, Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ap)
  {-# INLINE saveArgs #-}

  restoreFrame :: Stack 'UN -> Int -> Int -> IO (Stack 'UN)
restoreFrame (US Int
_ Int
fp0 Int
sp UA
stk) Int
fsz Int
asz = Stack 'UN -> IO (Stack 'UN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN -> IO (Stack 'UN)) -> Stack 'UN -> IO (Stack 'UN)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap Int
fp Int
sp UA
stk
    where
      fp :: Int
fp = Int
fp0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fsz
      ap :: Int
ap = Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
asz
  {-# INLINE restoreFrame #-}

  prepareArgs :: Stack 'UN -> Args' -> IO (Stack 'UN)
prepareArgs (US Int
ap Int
fp Int
sp UA
stk) (ArgR Int
i Int
l)
    | Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sp = Stack 'UN -> IO (Stack 'UN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN -> IO (Stack 'UN)) -> Stack 'UN -> IO (Stack 'UN)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) UA
stk
  prepareArgs (US Int
ap Int
fp Int
sp UA
stk) Args'
args = do
    Int
sp <- UA -> Int -> UA -> Int -> Args' -> IO Int
uargOnto UA
stk Int
sp UA
stk Int
fp Args'
args
    pure $ Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap Int
sp Int
sp UA
stk
  {-# INLINE prepareArgs #-}

  acceptArgs :: Stack 'UN -> Int -> IO (Stack 'UN)
acceptArgs (US Int
ap Int
fp Int
sp UA
stk) Int
n = Stack 'UN -> IO (Stack 'UN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN -> IO (Stack 'UN)) -> Stack 'UN -> IO (Stack 'UN)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap (Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Int
sp UA
stk
  {-# INLINE acceptArgs #-}

  frameArgs :: Stack 'UN -> IO (Stack 'UN)
frameArgs (US Int
ap Int
_ Int
sp UA
stk) = Stack 'UN -> IO (Stack 'UN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN -> IO (Stack 'UN)) -> Stack 'UN -> IO (Stack 'UN)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap Int
ap Int
sp UA
stk
  {-# INLINE frameArgs #-}

  augSeg :: Augment -> Stack 'UN -> Seg 'UN -> Maybe Args' -> IO (Seg 'UN)
augSeg Augment
mode (US Int
ap Int
fp Int
sp UA
stk) Seg 'UN
seg Maybe Args'
margs = do
    MutableByteArray RealWorld
cop <- Int -> IO UA
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray (Int -> IO UA) -> Int -> IO UA
forall a b. (a -> b) -> a -> b
$ Int
ssz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
psz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
asz
    UA -> Int -> ByteArray -> Int -> Int -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> ByteArray -> Int -> Int -> m ()
copyByteArray MutableByteArray RealWorld
UA
cop Int
soff ByteArray
Seg 'UN
seg Int
0 Int
ssz
    UA -> Int -> UA -> Int -> Int -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> MutableByteArray (PrimState m) -> Int -> Int -> m ()
copyMutableByteArray MutableByteArray RealWorld
UA
cop Int
0 UA
stk (Int -> Int
bytes (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
ap Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
psz
    Maybe Args' -> (Args' -> IO Int) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Args'
margs ((Args' -> IO Int) -> IO ()) -> (Args' -> IO Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ UA -> Int -> UA -> Int -> Args' -> IO Int
uargOnto UA
stk Int
sp MutableByteArray RealWorld
UA
cop (Int -> Int
words Int
poff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    UA -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
UA
cop
    where
      ssz :: Int
ssz = ByteArray -> Int
sizeofByteArray ByteArray
Seg 'UN
seg
      pix :: Int
pix | Augment
I <- Augment
mode = Int
0 | Bool
otherwise = Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ap
      (Int
poff, Int
soff)
        | Augment
K <- Augment
mode = (Int
ssz, Int
0)
        | Bool
otherwise = (Int
0, Int
psz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
asz)
      psz :: Int
psz = Int -> Int
bytes Int
pix
      asz :: Int
asz = case Maybe Args'
margs of
        Maybe Args'
Nothing -> Int
0
        Just (Arg1 Int
_) -> Int
8
        Just (Arg2 Int
_ Int
_) -> Int
16
        Just (ArgN PrimArray Int
v) -> Int -> Int
bytes (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Int
v
        Just (ArgR Int
_ Int
l) -> Int -> Int
bytes Int
l
  {-# INLINE augSeg #-}

  dumpSeg :: Stack 'UN -> Seg 'UN -> Dump -> IO (Stack 'UN)
dumpSeg (US Int
ap Int
fp Int
sp UA
stk) Seg 'UN
seg Dump
mode = do
    UA -> Int -> ByteArray -> Int -> Int -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> ByteArray -> Int -> Int -> m ()
copyByteArray UA
stk Int
bsp ByteArray
Seg 'UN
seg Int
0 Int
ssz
    pure $ Int -> Int -> Int -> UA -> Stack 'UN
US Int
ap' Int
fp' Int
sp' UA
stk
    where
      bsp :: Int
bsp = Int -> Int
bytes (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      ssz :: Int
ssz = ByteArray -> Int
sizeofByteArray ByteArray
Seg 'UN
seg
      sz :: Int
sz = Int -> Int
words Int
ssz
      sp' :: Int
sp' = Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz
      fp' :: Int
fp' = Int -> Int -> Dump -> Int
dumpFP Int
fp Int
sz Dump
mode
      ap' :: Int
ap' = Int -> Int -> Int -> Dump -> Int
dumpAP Int
ap Int
fp Int
sz Dump
mode
  {-# INLINE dumpSeg #-}

  adjustArgs :: Stack 'UN -> Int -> IO (Stack 'UN)
adjustArgs (US Int
ap Int
fp Int
sp UA
stk) Int
sz = Stack 'UN -> IO (Stack 'UN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN -> IO (Stack 'UN)) -> Stack 'UN -> IO (Stack 'UN)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> Stack 'UN
US (Int
ap Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) Int
fp Int
sp UA
stk
  {-# INLINE adjustArgs #-}

  fsize :: Stack 'UN -> Int
fsize (US Int
_ Int
fp Int
sp UA
_) = Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fp
  {-# INLINE fsize #-}

  asize :: Stack 'UN -> Int
asize (US Int
ap Int
fp Int
_ UA
_) = Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ap
  {-# INLINE asize #-}

peekN :: Stack 'UN -> IO Word64
peekN :: Stack 'UN -> IO Word64
peekN (US Int
_ Int
_ Int
sp UA
stk) = UA -> Int -> IO Word64
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray UA
stk Int
sp
{-# INLINE peekN #-}

peekD :: Stack 'UN -> IO Double
peekD :: Stack 'UN -> IO Double
peekD (US Int
_ Int
_ Int
sp UA
stk) = UA -> Int -> IO Double
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray UA
stk Int
sp
{-# INLINE peekD #-}

peekOffN :: Stack 'UN -> Int -> IO Word64
peekOffN :: Stack 'UN -> Int -> IO Word64
peekOffN (US Int
_ Int
_ Int
sp UA
stk) Int
i = UA -> Int -> IO Word64
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray UA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
{-# INLINE peekOffN #-}

peekOffD :: Stack 'UN -> Int -> IO Double
peekOffD :: Stack 'UN -> Int -> IO Double
peekOffD (US Int
_ Int
_ Int
sp UA
stk) Int
i = UA -> Int -> IO Double
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray UA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
{-# INLINE peekOffD #-}

pokeN :: Stack 'UN -> Word64 -> IO ()
pokeN :: Stack 'UN -> Word64 -> IO ()
pokeN (US Int
_ Int
_ Int
sp UA
stk) Word64
n = UA -> Int -> Word64 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray UA
stk Int
sp Word64
n
{-# INLINE pokeN #-}

pokeD :: Stack 'UN -> Double -> IO ()
pokeD :: Stack 'UN -> Double -> IO ()
pokeD (US Int
_ Int
_ Int
sp UA
stk) Double
d = UA -> Int -> Double -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray UA
stk Int
sp Double
d
{-# INLINE pokeD #-}

pokeOffN :: Stack 'UN -> Int -> Word64 -> IO ()
pokeOffN :: Stack 'UN -> Int -> Word64 -> IO ()
pokeOffN (US Int
_ Int
_ Int
sp UA
stk) Int
i Word64
n = UA -> Int -> Word64 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray UA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Word64
n
{-# INLINE pokeOffN #-}

pokeOffD :: Stack 'UN -> Int -> Double -> IO ()
pokeOffD :: Stack 'UN -> Int -> Double -> IO ()
pokeOffD (US Int
_ Int
_ Int
sp UA
stk) Int
i Double
d = UA -> Int -> Double -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray UA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Double
d
{-# INLINE pokeOffD #-}

pokeBi :: (BuiltinForeign b) => Stack 'BX -> b -> IO ()
pokeBi :: forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk b
x = Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure) -> Foreign -> RClosure
forall a b. (a -> b) -> a -> b
$ b -> Foreign
forall f. BuiltinForeign f => f -> Foreign
wrapBuiltin b
x)
{-# INLINE pokeBi #-}

pokeOffBi :: (BuiltinForeign b) => Stack 'BX -> Int -> b -> IO ()
pokeOffBi :: forall b. BuiltinForeign b => Stack 'BX -> Int -> b -> IO ()
pokeOffBi Stack 'BX
bstk Int
i b
x = Stack 'BX -> Int -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'BX
bstk Int
i (Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure) -> Foreign -> RClosure
forall a b. (a -> b) -> a -> b
$ b -> Foreign
forall f. BuiltinForeign f => f -> Foreign
wrapBuiltin b
x)
{-# INLINE pokeOffBi #-}

peekBi :: (BuiltinForeign b) => Stack 'BX -> IO b
peekBi :: forall b. BuiltinForeign b => Stack 'BX -> IO b
peekBi Stack 'BX
bstk = Foreign -> b
forall a. Foreign -> a
unwrapForeign (Foreign -> b) -> (RClosure -> Foreign) -> RClosure -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => RClosure -> Foreign
RClosure -> Foreign
marshalToForeign (RClosure -> b) -> IO RClosure -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack 'BX -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Elem b)
peek Stack 'BX
bstk
{-# INLINE peekBi #-}

peekOffBi :: (BuiltinForeign b) => Stack 'BX -> Int -> IO b
peekOffBi :: forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i = Foreign -> b
forall a. Foreign -> a
unwrapForeign (Foreign -> b) -> (RClosure -> Foreign) -> RClosure -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => RClosure -> Foreign
RClosure -> Foreign
marshalToForeign (RClosure -> b) -> IO RClosure -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
{-# INLINE peekOffBi #-}

peekOffS :: Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS :: Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i =
  Foreign -> Seq RClosure
forall a. Foreign -> a
unwrapForeign (Foreign -> Seq RClosure)
-> (RClosure -> Foreign) -> RClosure -> Seq RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => RClosure -> Foreign
RClosure -> Foreign
marshalToForeign (RClosure -> Seq RClosure) -> IO RClosure -> IO (Seq RClosure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
{-# INLINE peekOffS #-}

pokeS :: Stack 'BX -> Seq RClosure -> IO ()
pokeS :: Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk Seq RClosure
s = Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure) -> Foreign -> RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Seq RClosure -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Ty.listRef Seq RClosure
s)
{-# INLINE pokeS #-}

pokeOffS :: Stack 'BX -> Int -> Seq RClosure -> IO ()
pokeOffS :: Stack 'BX -> Int -> Seq RClosure -> IO ()
pokeOffS Stack 'BX
bstk Int
i Seq RClosure
s = Stack 'BX -> Int -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'BX
bstk Int
i (Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure) -> Foreign -> RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Seq RClosure -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Ty.listRef Seq RClosure
s)
{-# INLINE pokeOffS #-}

unull :: Seg 'UN
unull :: Seg 'UN
unull = Int -> [Int] -> ByteArray
forall a. Prim a => Int -> [a] -> ByteArray
byteArrayFromListN Int
0 ([] :: [Int])

bnull :: Seg 'BX
bnull :: Seg 'BX
bnull = Int -> [Item (Array RClosure)] -> Array RClosure
forall l. IsList l => Int -> [Item l] -> l
fromListN Int
0 []

instance Show (Stack 'BX) where
  show :: Stack 'BX -> String
show (BS Int
ap Int
fp Int
sp BA
_) =
    String
"BS " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ap String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sp

instance Show (Stack 'UN) where
  show :: Stack 'UN -> String
show (US Int
ap Int
fp Int
sp UA
_) =
    String
"US " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ap String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sp

instance Show K where
  show :: K -> String
show K
k = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> K -> String
go String
"" K
k
    where
      go :: String -> K -> String
go String
_ K
KE = String
"]"
      go String
_ (CB Callback
_) = String
"]"
      go String
com (Push Int
uf Int
bf Int
ua Int
ba RComb
ci K
k) =
        String
com String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int, Int, Int, RComb) -> String
forall a. Show a => a -> String
show (Int
uf, Int
bf, Int
ua, Int
ba, RComb
ci) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> K -> String
go String
"," K
k
      go String
com (Mark Int
ua Int
ba EnumSet Word64
ps EnumMap Word64 RClosure
_ K
k) =
        String
com String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"M " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ua String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ba String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ EnumSet Word64 -> String
forall a. Show a => a -> String
show EnumSet Word64
ps String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> K -> String
go String
"," K
k

instance MEM 'BX where
  data Stack 'BX = BS
    { Stack 'BX -> Int
bap :: !Int,
      Stack 'BX -> Int
bfp :: !Int,
      Stack 'BX -> Int
bsp :: !Int,
      Stack 'BX -> BA
bstk :: {-# UNPACK #-} !(MutableArray (PrimState IO) RClosure)
    }
  type Elem 'BX = RClosure
  type Seg 'BX = Array RClosure

  alloc :: IO (Stack 'BX)
alloc = Int -> Int -> Int -> BA -> Stack 'BX
BS (-Int
1) (-Int
1) (-Int
1) (MutableArray RealWorld RClosure -> Stack 'BX)
-> IO (MutableArray RealWorld RClosure) -> IO (Stack 'BX)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> RClosure -> IO BA
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
512 RClosure
forall comb. GClosure comb
BlackHole
  {-# INLINE alloc #-}

  peek :: Stack 'BX -> IO (Elem 'BX)
peek (BS Int
_ Int
_ Int
sp BA
stk) = BA -> Int -> IO RClosure
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> m a
readArray BA
stk Int
sp
  {-# INLINE peek #-}

  peekOff :: Stack 'BX -> Int -> IO (Elem 'BX)
peekOff (BS Int
_ Int
_ Int
sp BA
stk) Int
i = BA -> Int -> IO RClosure
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> m a
readArray BA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
  {-# INLINE peekOff #-}

  poke :: Stack 'BX -> Elem 'BX -> IO ()
poke (BS Int
_ Int
_ Int
sp BA
stk) Elem 'BX
x = BA -> Int -> RClosure -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray BA
stk Int
sp Elem 'BX
RClosure
x
  {-# INLINE poke #-}

  pokeOff :: Stack 'BX -> Int -> Elem 'BX -> IO ()
pokeOff (BS Int
_ Int
_ Int
sp BA
stk) Int
i Elem 'BX
x = BA -> Int -> RClosure -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray BA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Elem 'BX
RClosure
x
  {-# INLINE pokeOff #-}

  grab :: Stack 'BX -> Int -> IO (Seg 'BX, Stack 'BX)
grab (BS Int
_ Int
fp Int
sp BA
stk) Int
sz = do
    Array RClosure
seg <- MutableArray RealWorld RClosure -> IO (Array RClosure)
BA -> IO (Array RClosure)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
unsafeFreezeArray (MutableArray RealWorld RClosure -> IO (Array RClosure))
-> IO (MutableArray RealWorld RClosure) -> IO (Array RClosure)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BA -> Int -> Int -> IO BA
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> Int -> m (MutableArray (PrimState m) a)
cloneMutableArray BA
stk (Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) Int
sz
    BA -> Int -> BA -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> MutableArray (PrimState m) a -> Int -> Int -> m ()
copyMutableArray BA
stk (Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) BA
stk (Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
fsz
    pure (Array RClosure
seg, Int -> Int -> Int -> BA -> Stack 'BX
BS (Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) (Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) BA
stk)
    where
      fsz :: Int
fsz = Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fp
  {-# INLINE grab #-}

  ensure :: Stack 'BX -> Int -> IO (Stack 'BX)
ensure stki :: Stack 'BX
stki@(BS Int
ap Int
fp Int
sp BA
stk) Int
sz
    | Int
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack 'BX
stki
    | Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ssz = Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack 'BX
stki
    | Bool
otherwise = do
        MutableArray RealWorld RClosure
stk' <- Int -> RClosure -> IO BA
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray (Int
ssz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ext) RClosure
forall comb. GClosure comb
BlackHole
        BA -> Int -> BA -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> MutableArray (PrimState m) a -> Int -> Int -> m ()
copyMutableArray MutableArray RealWorld RClosure
BA
stk' Int
0 BA
stk Int
0 (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        pure $ Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap Int
fp Int
sp MutableArray RealWorld RClosure
BA
stk'
    where
      ssz :: Int
ssz = MutableArray RealWorld RClosure -> Int
forall s a. MutableArray s a -> Int
sizeofMutableArray MutableArray RealWorld RClosure
BA
stk
      ext :: Int
ext
        | Int
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1280 = Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
512
        | Bool
otherwise = Int
1280
  {-# INLINE ensure #-}

  bump :: Stack 'BX -> IO (Stack 'BX)
bump (BS Int
ap Int
fp Int
sp BA
stk) = Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'BX -> IO (Stack 'BX)) -> Stack 'BX -> IO (Stack 'BX)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap Int
fp (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) BA
stk
  {-# INLINE bump #-}

  bumpn :: Stack 'BX -> Int -> IO (Stack 'BX)
bumpn (BS Int
ap Int
fp Int
sp BA
stk) Int
n = Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'BX -> IO (Stack 'BX)) -> Stack 'BX -> IO (Stack 'BX)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap Int
fp (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) BA
stk
  {-# INLINE bumpn #-}

  duplicate :: Stack 'BX -> IO (Stack 'BX)
duplicate (BS Int
ap Int
fp Int
sp BA
stk) =
    Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap Int
fp Int
sp (MutableArray RealWorld RClosure -> Stack 'BX)
-> IO (MutableArray RealWorld RClosure) -> IO (Stack 'BX)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BA -> Int -> Int -> IO BA
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> Int -> m (MutableArray (PrimState m) a)
cloneMutableArray BA
stk Int
0 (MutableArray RealWorld RClosure -> Int
forall s a. MutableArray s a -> Int
sizeofMutableArray MutableArray RealWorld RClosure
BA
stk)
  {-# INLINE duplicate #-}

  discardFrame :: Stack 'BX -> IO (Stack 'BX)
discardFrame (BS Int
ap Int
fp Int
_ BA
stk) = Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'BX -> IO (Stack 'BX)) -> Stack 'BX -> IO (Stack 'BX)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap Int
fp Int
fp BA
stk
  {-# INLINE discardFrame #-}

  saveFrame :: Stack 'BX -> IO (Stack 'BX, Int, Int)
saveFrame (BS Int
ap Int
fp Int
sp BA
stk) = (Stack 'BX, Int, Int) -> IO (Stack 'BX, Int, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int -> BA -> Stack 'BX
BS Int
sp Int
sp Int
sp BA
stk, Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fp, Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ap)
  {-# INLINE saveFrame #-}

  saveArgs :: Stack 'BX -> IO (Stack 'BX, Int)
saveArgs (BS Int
ap Int
fp Int
sp BA
stk) = (Stack 'BX, Int) -> IO (Stack 'BX, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int -> BA -> Stack 'BX
BS Int
fp Int
fp Int
sp BA
stk, Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ap)
  {-# INLINE saveArgs #-}

  restoreFrame :: Stack 'BX -> Int -> Int -> IO (Stack 'BX)
restoreFrame (BS Int
_ Int
fp0 Int
sp BA
stk) Int
fsz Int
asz = Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'BX -> IO (Stack 'BX)) -> Stack 'BX -> IO (Stack 'BX)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap Int
fp Int
sp BA
stk
    where
      fp :: Int
fp = Int
fp0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fsz
      ap :: Int
ap = Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
asz
  {-# INLINE restoreFrame #-}

  prepareArgs :: Stack 'BX -> Args' -> IO (Stack 'BX)
prepareArgs (BS Int
ap Int
fp Int
sp BA
stk) (ArgR Int
i Int
l)
    | Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sp = Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'BX -> IO (Stack 'BX)) -> Stack 'BX -> IO (Stack 'BX)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) BA
stk
  prepareArgs (BS Int
ap Int
fp Int
sp BA
stk) Args'
args = do
    Int
sp <- BA -> Int -> BA -> Int -> Args' -> IO Int
bargOnto BA
stk Int
sp BA
stk Int
fp Args'
args
    pure $ Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap Int
sp Int
sp BA
stk
  {-# INLINE prepareArgs #-}

  acceptArgs :: Stack 'BX -> Int -> IO (Stack 'BX)
acceptArgs (BS Int
ap Int
fp Int
sp BA
stk) Int
n = Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'BX -> IO (Stack 'BX)) -> Stack 'BX -> IO (Stack 'BX)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap (Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Int
sp BA
stk
  {-# INLINE acceptArgs #-}

  frameArgs :: Stack 'BX -> IO (Stack 'BX)
frameArgs (BS Int
ap Int
_ Int
sp BA
stk) = Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'BX -> IO (Stack 'BX)) -> Stack 'BX -> IO (Stack 'BX)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap Int
ap Int
sp BA
stk
  {-# INLINE frameArgs #-}

  augSeg :: Augment -> Stack 'BX -> Seg 'BX -> Maybe Args' -> IO (Seg 'BX)
augSeg Augment
mode (BS Int
ap Int
fp Int
sp BA
stk) Seg 'BX
seg Maybe Args'
margs = do
    MutableArray RealWorld RClosure
cop <- Int -> RClosure -> IO BA
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray (Int
ssz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
psz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
asz) RClosure
forall comb. GClosure comb
BlackHole
    BA -> Int -> Array RClosure -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> Array a -> Int -> Int -> m ()
copyArray MutableArray RealWorld RClosure
BA
cop Int
soff Array RClosure
Seg 'BX
seg Int
0 Int
ssz
    BA -> Int -> BA -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> MutableArray (PrimState m) a -> Int -> Int -> m ()
copyMutableArray MutableArray RealWorld RClosure
BA
cop Int
poff BA
stk (Int
ap Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
psz
    Maybe Args' -> (Args' -> IO Int) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Args'
margs ((Args' -> IO Int) -> IO ()) -> (Args' -> IO Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ BA -> Int -> BA -> Int -> Args' -> IO Int
bargOnto BA
stk Int
sp MutableArray RealWorld RClosure
BA
cop (Int
poff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
psz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    BA -> IO (Array RClosure)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
unsafeFreezeArray MutableArray RealWorld RClosure
BA
cop
    where
      ssz :: Int
ssz = Array RClosure -> Int
forall a. Array a -> Int
sizeofArray Array RClosure
Seg 'BX
seg
      psz :: Int
psz | Augment
I <- Augment
mode = Int
0 | Bool
otherwise = Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ap
      (Int
poff, Int
soff)
        | Augment
K <- Augment
mode = (Int
ssz, Int
0)
        | Bool
otherwise = (Int
0, Int
psz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
asz)
      asz :: Int
asz = case Maybe Args'
margs of
        Maybe Args'
Nothing -> Int
0
        Just (Arg1 Int
_) -> Int
1
        Just (Arg2 Int
_ Int
_) -> Int
2
        Just (ArgN PrimArray Int
v) -> PrimArray Int -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Int
v
        Just (ArgR Int
_ Int
l) -> Int
l
  {-# INLINE augSeg #-}

  dumpSeg :: Stack 'BX -> Seg 'BX -> Dump -> IO (Stack 'BX)
dumpSeg (BS Int
ap Int
fp Int
sp BA
stk) Seg 'BX
seg Dump
mode = do
    BA -> Int -> Array RClosure -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> Array a -> Int -> Int -> m ()
copyArray BA
stk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Array RClosure
Seg 'BX
seg Int
0 Int
sz
    pure $ Int -> Int -> Int -> BA -> Stack 'BX
BS Int
ap' Int
fp' Int
sp' BA
stk
    where
      sz :: Int
sz = Array RClosure -> Int
forall a. Array a -> Int
sizeofArray Array RClosure
Seg 'BX
seg
      sp' :: Int
sp' = Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz
      fp' :: Int
fp' = Int -> Int -> Dump -> Int
dumpFP Int
fp Int
sz Dump
mode
      ap' :: Int
ap' = Int -> Int -> Int -> Dump -> Int
dumpAP Int
ap Int
fp Int
sz Dump
mode
  {-# INLINE dumpSeg #-}

  adjustArgs :: Stack 'BX -> Int -> IO (Stack 'BX)
adjustArgs (BS Int
ap Int
fp Int
sp BA
stk) Int
sz = Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'BX -> IO (Stack 'BX)) -> Stack 'BX -> IO (Stack 'BX)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> BA -> Stack 'BX
BS (Int
ap Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) Int
fp Int
sp BA
stk
  {-# INLINE adjustArgs #-}

  fsize :: Stack 'BX -> Int
fsize (BS Int
_ Int
fp Int
sp BA
_) = Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fp
  {-# INLINE fsize #-}

  asize :: Stack 'BX -> Int
asize (BS Int
ap Int
fp Int
_ BA
_) = Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ap

frameView :: (MEM b) => (Show (Elem b)) => Stack b -> IO ()
frameView :: forall (b :: Mem). (MEM b, Show (Elem b)) => Stack b -> IO ()
frameView Stack b
stk = String -> IO ()
putStr String
"|" 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 -> Int -> IO ()
gof Bool
False Int
0
  where
    fsz :: Int
fsz = Stack b -> Int
forall (b :: Mem). MEM b => Stack b -> Int
fsize Stack b
stk
    asz :: Int
asz = Stack b -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack b
stk
    gof :: Bool -> Int -> IO ()
gof Bool
delim Int
n
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
fsz = String -> IO ()
putStr String
"|" 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 -> Int -> IO ()
goa Bool
False Int
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
$ String -> IO ()
putStr String
","
          String -> IO ()
putStr (String -> IO ()) -> (Elem b -> String) -> Elem b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Elem b -> String
forall a. Show a => a -> String
show (Elem b -> IO ()) -> IO (Elem b) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack b -> Int -> IO (Elem b)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack b
stk Int
n
          Bool -> Int -> IO ()
gof Bool
True (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    goa :: Bool -> Int -> IO ()
goa Bool
delim Int
n
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
asz = String -> IO ()
putStrLn String
"|.."
      | 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
$ String -> IO ()
putStr String
","
          String -> IO ()
putStr (String -> IO ()) -> (Elem b -> String) -> Elem b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Elem b -> String
forall a. Show a => a -> String
show (Elem b -> IO ()) -> IO (Elem b) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack b -> Int -> IO (Elem b)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack b
stk (Int
fsz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
          Bool -> Int -> IO ()
goa Bool
True (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

uscount :: Seg 'UN -> Int
uscount :: Seg 'UN -> Int
uscount Seg 'UN
seg = Int -> Int
words (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int
sizeofByteArray ByteArray
Seg 'UN
seg

bscount :: Seg 'BX -> Int
bscount :: Seg 'BX -> Int
bscount Seg 'BX
seg = Array RClosure -> Int
forall a. Array a -> Int
sizeofArray Array RClosure
Seg 'BX
seg

closureTermRefs :: (Monoid m) => (Reference -> m) -> (RClosure -> m)
closureTermRefs :: forall m. Monoid m => (Reference -> m) -> RClosure -> m
closureTermRefs Reference -> m
f (PAp (RComb (CIx Reference
r Word64
_ Word64
_) GComb RComb
_) Seg 'UN
_ Seg 'BX
cs) =
  Reference -> m
f Reference
r m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (RClosure -> m) -> Array RClosure -> 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) -> RClosure -> m
forall m. Monoid m => (Reference -> m) -> RClosure -> m
closureTermRefs Reference -> m
f) Array RClosure
Seg 'BX
cs
closureTermRefs Reference -> m
f (DataB1 Reference
_ Word64
_ RClosure
c) = (Reference -> m) -> RClosure -> m
forall m. Monoid m => (Reference -> m) -> RClosure -> m
closureTermRefs Reference -> m
f RClosure
c
closureTermRefs Reference -> m
f (DataB2 Reference
_ Word64
_ RClosure
c1 RClosure
c2) =
  (Reference -> m) -> RClosure -> m
forall m. Monoid m => (Reference -> m) -> RClosure -> m
closureTermRefs Reference -> m
f RClosure
c1 m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (Reference -> m) -> RClosure -> m
forall m. Monoid m => (Reference -> m) -> RClosure -> m
closureTermRefs Reference -> m
f RClosure
c2
closureTermRefs Reference -> m
f (DataUB Reference
_ Word64
_ Int
_ RClosure
c) =
  (Reference -> m) -> RClosure -> m
forall m. Monoid m => (Reference -> m) -> RClosure -> m
closureTermRefs Reference -> m
f RClosure
c
closureTermRefs Reference -> m
f (Captured K
k Int
_ Int
_ Seg 'UN
_ Seg 'BX
cs) =
  (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
<> (RClosure -> m) -> Array RClosure -> 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) -> RClosure -> m
forall m. Monoid m => (Reference -> m) -> RClosure -> m
closureTermRefs Reference -> m
f) Array RClosure
Seg 'BX
cs
closureTermRefs Reference -> m
f (Foreign Foreign
fo)
  | Just (Seq RClosure
cs :: Seq RClosure) <- Reference -> Foreign -> Maybe (Seq RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Ty.listRef Foreign
fo =
      (RClosure -> m) -> Seq RClosure -> m
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Reference -> m) -> RClosure -> m
forall m. Monoid m => (Reference -> m) -> RClosure -> m
closureTermRefs Reference -> m
f) Seq RClosure
cs
closureTermRefs Reference -> m
_ RClosure
_ = 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 Int
_ Int
_ EnumSet Word64
_ EnumMap Word64 RClosure
m K
k) =
  (RClosure -> m) -> EnumMap Word64 RClosure -> 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 ((Reference -> m) -> RClosure -> m
forall m. Monoid m => (Reference -> m) -> RClosure -> m
closureTermRefs Reference -> m
f) EnumMap Word64 RClosure
m 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 Int
_ Int
_ Int
_ Int
_ (RComb (CIx Reference
r Word64
_ Word64
_) GComb RComb
_) 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