{-# 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
data K
= KE
|
CB Callback
|
Mark
!Int
!Int
!(EnumSet Word64)
!(EnumMap Word64 RClosure)
!K
|
Push
!Int
!Int
!Int
!Int
!RComb
!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)
!(Seg 'BX)
| 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)
|
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
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
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
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
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
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 =
US
{ Stack 'UN -> Int
uap :: !Int,
Stack 'UN -> Int
ufp :: !Int,
Stack 'UN -> Int
usp :: !Int,
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 #-}
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