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

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

    -- * Unboxed type tags
    natTypeTag,
    intTypeTag,
    charTypeTag,
    floatTypeTag,
    hasNoAllocations,
  )
where

import Control.Monad.Primitive
import Data.Char qualified as Char
import Data.IORef (IORef)
import Data.Primitive (sizeOf)
import Data.Primitive.ByteArray qualified as BA
import Data.Tagged (Tagged (..))
import Data.Word
import GHC.Base
import GHC.Exts as L (IsList (..))
import Language.Haskell.TH qualified as TH
import Test.Inspection qualified as TI
import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Runtime.ANF (PackedTag)
import Unison.Runtime.Array
import Unison.Runtime.Foreign
import Unison.Runtime.MCode
import Unison.Runtime.TypeTags qualified as TT
import Unison.Type qualified as Ty
import Unison.Util.EnumContainers as EC
import Prelude hiding (words)

{- ORMOLU_DISABLE -}
#ifdef STACK_CHECK
type DebugCallStack = (HasCallStack :: Constraint)

unboxedSentinel :: Int
unboxedSentinel = -99

boxedSentinel :: Closure
boxedSentinel = (Closure GUnboxedSentinel)

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

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

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

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

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

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

-- Evaluation stack
data K
  = KE
  | -- callback hook
    CB Callback
  | -- mark continuation with a prompt
    Mark
      !Int -- pending args
      !(EnumSet Word64)
      !(EnumMap Word64 Val)
      !K
  | -- save information about a frame for later resumption
    Push
      !Int -- frame size
      !Int -- pending args
      !CombIx -- resumption section reference
      !Int -- stack guard
      !(RSection Val) -- resumption section
      !K

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

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

type IxClosure = GClosure CombIx

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

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

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

{- ORMOLU_DISABLE -}
data GClosure comb
  = GPAp
      !CombIx
      {-# UNPACK #-} !(GCombInfo comb)
      {-# UNPACK #-} !Seg -- args
  | GEnum !Reference !PackedTag
  | GData1 !Reference !PackedTag !Val
  | GData2 !Reference !PackedTag !Val !Val
  | GDataG !Reference !PackedTag {-# UNPACK #-} !Seg
  | -- code cont, arg size, u/b data stacks
    GCaptured !K !Int {-# UNPACK #-} !Seg
  | GForeign !Foreign
  | -- The type tag for the value in the corresponding unboxed stack slot.
    -- We should consider adding separate constructors for common builtin type tags.
    --  GHC will optimize nullary constructors into singletons.
    GUnboxedTypeTag !UnboxedTypeTag
  | GBlackHole
#ifdef STACK_CHECK
  | GUnboxedSentinel
#endif
  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, (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)
{- ORMOLU_ENABLE -}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

traceK :: Reference -> K -> [(Reference, Int)]
traceK :: Reference -> K -> [(Reference, 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
_ EnumSet Word64
_ EnumMap Word64 Val
_ 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
_ (CIx Reference
r Word64
_ Word64
_) Int
_ RSection Val
_ K
k)
      | Reference
cur Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
r = (Reference, b) -> K -> [(Reference, b)]
dedup (Reference
cur, b
1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
n) K
k
      | Bool
otherwise = (Reference, b)
p (Reference, b) -> [(Reference, b)] -> [(Reference, b)]
forall a. a -> [a] -> [a]
: (Reference, b) -> K -> [(Reference, b)]
dedup (Reference
r, b
1) K
k
    dedup (Reference, b)
p K
_ = [(Reference, b)
p]

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

-- | Converts a list of integers representing an unboxed segment back into the
-- appropriate segment. Segments are stored backwards in the runtime, so this
-- reverses the list.
useg :: [Int] -> USeg
useg :: [Int] -> ByteArray
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 :: BSeg -> [Closure]
bsegToList :: BSeg -> [BVal]
bsegToList = [BVal] -> [BVal]
forall a. [a] -> [a]
reverse ([BVal] -> [BVal]) -> (BSeg -> [BVal]) -> BSeg -> [BVal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BSeg -> [Item BSeg]
BSeg -> [BVal]
forall l. IsList l => l -> [Item l]
L.toList

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

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

frameDataSize :: K -> Int
frameDataSize :: K -> Int
frameDataSize = Int -> K -> Int
go Int
0
  where
    go :: Int -> K -> Int
go Int
sz K
KE = Int
sz
    go Int
sz (CB Callback
_) = Int
sz
    go Int
sz (Mark Int
a EnumSet Word64
_ EnumMap Word64 Val
_ K
k) = Int -> K -> Int
go (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a) K
k
    go Int
sz (Push Int
f Int
a CombIx
_ Int
_ RSection Val
_ K
k) =
      Int -> K -> Int
go (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a) K
k

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

type SegList = [Val]

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

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

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

-- | Converts an unboxed segment to a list of integers for a more interchangeable
-- representation. The segments are stored in backwards order, so this reverses
-- the contents.
ints :: ByteArray -> [Int]
ints :: ByteArray -> [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 from the list representation of a segment to the efficient stack form. Segments are stored backwards,
-- so this reverses the contents.
segFromList :: SegList -> Seg
segFromList :: SegList -> Seg
segFromList SegList
xs =
  SegList
xs
    SegList -> (SegList -> ([Int], [BVal])) -> ([Int], [BVal])
forall a b. a -> (a -> b) -> b
& (Val -> ([Int], [BVal])) -> SegList -> ([Int], [BVal])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
      ( \(Val Int
unboxed BVal
boxed) -> ([Int
unboxed], [BVal
boxed])
      )
    ([Int], [BVal]) -> (([Int], [BVal]) -> Seg) -> Seg
forall a b. a -> (a -> b) -> b
& \([Int]
us, [BVal]
bs) -> ([Int] -> ByteArray
useg [Int]
us, [BVal] -> BSeg
bseg [BVal]
bs)

marshalToForeign :: (HasCallStack) => Closure -> Foreign
marshalToForeign :: HasCallStack => BVal -> Foreign
marshalToForeign (Foreign Foreign
x) = Foreign
x
marshalToForeign BVal
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]
++ BVal -> String
forall a. Show a => a -> String
show BVal
c

type Off = Int

type SZ = Int

type FP = Int

type UA = MutableByteArray (PrimState IO)

type BA = MutableArray (PrimState IO) Closure

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

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

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

type Arrs = (UA, BA)

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

-- The Caller must ensure that when setting the unboxed stack, the equivalent
-- boxed stack is zeroed out to BlackHole where necessary.
uargOnto :: UA -> Off -> UA -> Off -> Args' -> IO Int
uargOnto :: 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
cp0 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
  BVal
x <- BA -> Int -> IO BVal
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 -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray BA
cop Int
cp BVal
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
  BVal
x <- BA -> Int -> IO BVal
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)
  BVal
y <- BA -> Int -> IO BVal
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 -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray BA
cop Int
cp BVal
x
  BA -> Int -> BVal -> 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) BVal
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 BVal
buf <-
    if Bool
overwrite
      then Int -> BVal -> IO BA
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
sz (BVal -> IO BA) -> BVal -> IO BA
forall a b. (a -> b) -> a -> b
$ BVal
BlackHole
      else MutableArray RealWorld BVal -> IO (MutableArray RealWorld BVal)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutableArray RealWorld BVal
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
            BVal
x <- BA -> Int -> IO BVal
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> m a
readArray BA
stk (Int -> IO BVal) -> Int -> IO BVal
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 -> BVal -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld BVal
BA
buf (Int
boff Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) BVal
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 BVal
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 BVal
BA
stk MutableArray RealWorld BVal -> MutableArray RealWorld BVal -> Bool
forall a. Eq a => a -> a -> Bool
== MutableArray RealWorld BVal
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

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

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

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

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

{-# COMPLETE XStack #-}

{-# INLINE XStack #-}

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

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

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

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

instance Show Stack where
  show :: Stack -> String
show (Stack Int
ap Int
fp Int
sp UA
_ BA
_) =
    String
"Stack " 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

type UVal = Int

-- | A runtime value, which is either a boxed or unboxed value, but we may not know which.
data Val = Val {Val -> Int
getUnboxedVal :: !UVal, Val -> BVal
getBoxedVal :: !BVal}
  -- The Eq instance for Val is deliberately omitted because you need to take into account the fact that if a Val is boxed, the
  -- unboxed side is garbage and should not be compared.
  -- See universalEq.
  deriving (Int -> Val -> ShowS
SegList -> ShowS
Val -> String
(Int -> Val -> ShowS)
-> (Val -> String) -> (SegList -> ShowS) -> Show Val
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Val -> ShowS
showsPrec :: Int -> Val -> ShowS
$cshow :: Val -> String
show :: Val -> String
$cshowList :: SegList -> ShowS
showList :: SegList -> ShowS
Show)

instance BuiltinForeign (IORef Val) where foreignRef :: Tagged (IORef Val) Reference
foreignRef = Reference -> Tagged (IORef Val) Reference
forall {k} (s :: k) b. b -> Tagged s b
Tagged Reference
Ty.refRef

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

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

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

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

{-# COMPLETE UnboxedVal, BoxedVal #-}

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

type USeg = ByteArray

type BVal = Closure

type BSeg = Array Closure

type Seg = (USeg, BSeg)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Eats up arguments
grab :: Stack -> SZ -> IO (Seg, Stack)
grab :: Stack -> Int -> IO (Seg, Stack)
grab (Stack Int
_ Int
fp Int
sp UA
ustk BA
bstk) Int
sze = do
  ByteArray
uSeg <- IO ByteArray
ugrab
  BSeg
bSeg <- IO BSeg
bgrab
  pure $ ((ByteArray
uSeg, BSeg
bSeg), Int -> Int -> Int -> UA -> BA -> Stack
Stack (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
ustk BA
bstk)
  where
    ugrab :: IO ByteArray
ugrab = do
      MutableByteArray RealWorld
mut <- Int -> IO UA
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
bsz
      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
ustk (Int
bfp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bsz) Int
bsz
      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
ustk (Int
bfp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bsz) UA
ustk Int
bfp Int
fsz
      pure ByteArray
seg
      where
        bsz :: Int
bsz = 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
    bgrab :: IO BSeg
bgrab = do
      BSeg
seg <- MutableArray RealWorld BVal -> IO BSeg
BA -> IO BSeg
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
unsafeFreezeArray (MutableArray RealWorld BVal -> IO BSeg)
-> IO (MutableArray RealWorld BVal) -> IO BSeg
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BA -> Int -> Int -> IO BA
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> Int -> m (MutableArray (PrimState m) a)
cloneMutableArray BA
bstk (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
sze) Int
sze
      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
bstk (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
sze) BA
bstk (Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
fsz
      pure BSeg
seg
      where
        fsz :: Int
fsz = Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fp
{-# INLINE grab #-}

ensure :: Stack -> SZ -> IO Stack
ensure :: Stack -> Int -> IO Stack
ensure stk :: Stack
stk@(Stack Int
ap Int
fp Int
sp UA
ustk BA
bstk) Int
sze
  | Int
sze Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
  | 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
bsz = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
  | Bool
otherwise = do
      MutableArray RealWorld BVal
bstk' <- Int -> BVal -> IO BA
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray (Int
bsz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bext) BVal
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 BVal
BA
bstk' Int
0 BA
bstk Int
0 (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      MutableByteArray RealWorld
ustk' <- UA -> Int -> IO UA
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> Int -> m (MutableByteArray (PrimState m))
resizeMutableByteArray UA
ustk (Int
usz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
uext)
      pure $ Int -> Int -> Int -> UA -> BA -> Stack
Stack Int
ap Int
fp Int
sp MutableByteArray RealWorld
UA
ustk' MutableArray RealWorld BVal
BA
bstk'
  where
    usz :: Int
usz = MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
sizeofMutableByteArray MutableByteArray RealWorld
UA
ustk
    bsz :: Int
bsz = MutableArray RealWorld BVal -> Int
forall s a. MutableArray s a -> Int
sizeofMutableArray MutableArray RealWorld BVal
BA
bstk
    bext :: Int
bext
      | Int
sze Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1280 = Int
sze Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
512
      | Bool
otherwise = Int
1280
    uext :: Int
uext
      | 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 -> IO Stack
bump :: Stack -> IO Stack
bump (Stack Int
ap Int
fp Int
sp UA
ustk BA
bstk) = do
  let stk' :: Stack
stk' = Int -> Int -> Int -> UA -> BA -> Stack
Stack Int
ap Int
fp (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) UA
ustk BA
bstk
#ifdef STACK_CHECK
  pokeSentinelOff stk' 0
#endif
  Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk'
{-# INLINE bump #-}

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

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

discardFrame :: Stack -> IO Stack
discardFrame :: Stack -> IO Stack
discardFrame (Stack Int
ap Int
fp Int
_ UA
ustk BA
bstk) = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> BA -> Stack
Stack Int
ap Int
fp Int
fp UA
ustk BA
bstk
{-# INLINE discardFrame #-}

saveFrame :: Stack -> IO (Stack, SZ, SZ)
saveFrame :: Stack -> IO (Stack, Int, Int)
saveFrame (Stack Int
ap Int
fp Int
sp UA
ustk BA
bstk) = (Stack, Int, Int) -> IO (Stack, Int, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int -> UA -> BA -> Stack
Stack Int
sp Int
sp Int
sp UA
ustk BA
bstk, 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 -> IO (Stack, SZ)
saveArgs :: Stack -> IO (Stack, Int)
saveArgs (Stack Int
ap Int
fp Int
sp UA
ustk BA
bstk) = (Stack, Int) -> IO (Stack, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int -> UA -> BA -> Stack
Stack Int
fp Int
fp Int
sp UA
ustk BA
bstk, Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ap)
{-# INLINE saveArgs #-}

restoreFrame :: Stack -> SZ -> SZ -> IO Stack
restoreFrame :: Stack -> Int -> Int -> IO Stack
restoreFrame (Stack Int
_ Int
fp0 Int
sp UA
ustk BA
bstk) Int
fsz Int
asz = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> BA -> Stack
Stack Int
ap Int
fp Int
sp UA
ustk BA
bstk
  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 -> Args' -> IO Stack
prepareArgs :: Stack -> Args' -> IO Stack
prepareArgs (Stack Int
ap Int
fp Int
sp UA
ustk BA
bstk) = \case
  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 -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> BA -> Stack
Stack 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
ustk BA
bstk
  Args'
args -> do
    Int
sp <- Arrs -> Int -> Arrs -> Int -> Args' -> IO Int
argOnto (UA
ustk, BA
bstk) Int
sp (UA
ustk, BA
bstk) Int
fp Args'
args
    pure $ Int -> Int -> Int -> UA -> BA -> Stack
Stack Int
ap Int
sp Int
sp UA
ustk BA
bstk
{-# INLINE prepareArgs #-}

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

frameArgs :: Stack -> IO Stack
frameArgs :: Stack -> IO Stack
frameArgs (Stack Int
ap Int
_ Int
sp UA
ustk BA
bstk) = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> BA -> Stack
Stack Int
ap Int
ap Int
sp UA
ustk BA
bstk
{-# INLINE frameArgs #-}

augSeg :: Augment -> Stack -> Seg -> Maybe Args' -> IO Seg
augSeg :: Augment -> Stack -> Seg -> Maybe Args' -> IO Seg
augSeg Augment
mode (Stack Int
ap Int
fp Int
sp UA
ustk BA
bstk) (ByteArray
useg, BSeg
bseg) Maybe Args'
margs = do
  ByteArray
useg' <- IO ByteArray
unboxedSeg
  BSeg
bseg' <- IO BSeg
boxedSeg
  pure (ByteArray
useg', BSeg
bseg')
  where
    bpsz :: Int
bpsz
      | Augment
I <- Augment
mode = Int
0
      | Bool
otherwise = Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ap
    unboxedSeg :: IO ByteArray
unboxedSeg = 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
upsz 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
useg 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
ustk (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
upsz
      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
ustk Int
sp MutableByteArray RealWorld
UA
cop (Int -> Int
words Int
poff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bpsz 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
useg
        (Int
poff, Int
soff)
          | Augment
K <- Augment
mode = (Int
ssz, Int
0)
          | Bool
otherwise = (Int
0, Int
upsz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
asz)
        upsz :: Int
upsz = Int -> Int
bytes Int
bpsz
        asz :: Int
asz = case Maybe Args'
margs of
          Maybe Args'
Nothing -> Int -> Int
bytes Int
0
          Just (Arg1 Int
_) -> Int -> Int
bytes Int
1
          Just (Arg2 Int
_ Int
_) -> Int -> Int
bytes Int
2
          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
    boxedSeg :: IO BSeg
boxedSeg = do
      MutableArray RealWorld BVal
cop <- Int -> BVal -> 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
bpsz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
asz) BVal
BlackHole
      BA -> Int -> BSeg -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> Array a -> Int -> Int -> m ()
copyArray MutableArray RealWorld BVal
BA
cop Int
soff BSeg
bseg 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 BVal
BA
cop Int
poff BA
bstk (Int
ap Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
bpsz
      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
bstk Int
sp MutableArray RealWorld BVal
BA
cop (Int
poff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bpsz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      BA -> IO BSeg
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
unsafeFreezeArray MutableArray RealWorld BVal
BA
cop
      where
        ssz :: Int
ssz = BSeg -> Int
forall a. Array a -> Int
sizeofArray BSeg
bseg
        (Int
poff, Int
soff)
          | Augment
K <- Augment
mode = (Int
ssz, Int
0)
          | Bool
otherwise = (Int
0, Int
bpsz 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 -> Seg -> Dump -> IO Stack
dumpSeg :: Stack -> Seg -> Dump -> IO Stack
dumpSeg (Stack Int
ap Int
fp Int
sp UA
ustk BA
bstk) (ByteArray
useg, BSeg
bseg) Dump
mode = do
  IO ()
dumpUSeg
  IO ()
dumpBSeg
  pure $ Int -> Int -> Int -> UA -> BA -> Stack
Stack Int
ap' Int
fp' Int
sp' UA
ustk BA
bstk
  where
    sz :: Int
sz = BSeg -> Int
forall a. Array a -> Int
sizeofArray BSeg
bseg
    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
    dumpUSeg :: IO ()
dumpUSeg = do
      let ssz :: Int
ssz = ByteArray -> Int
sizeofByteArray ByteArray
useg
      let 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
      UA -> Int -> ByteArray -> Int -> Int -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> ByteArray -> Int -> Int -> m ()
copyByteArray UA
ustk Int
bsp ByteArray
useg Int
0 Int
ssz
    dumpBSeg :: IO ()
dumpBSeg = do
      BA -> Int -> BSeg -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> Array a -> Int -> Int -> m ()
copyArray BA
bstk (Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) BSeg
bseg Int
0 Int
sz
{-# INLINE dumpSeg #-}

adjustArgs :: Stack -> SZ -> IO Stack
adjustArgs :: Stack -> Int -> IO Stack
adjustArgs (Stack Int
ap Int
fp Int
sp UA
ustk BA
bstk) Int
sz = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> UA -> BA -> Stack
Stack (Int
ap Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) Int
fp Int
sp UA
ustk BA
bstk
{-# INLINE adjustArgs #-}

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

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

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

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

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

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

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

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

{- ORMOLU_ENABLE -}

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

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

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

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

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

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

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

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

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

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

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

peekBi :: (BuiltinForeign b) => Stack -> IO b
peekBi :: forall b. BuiltinForeign b => Stack -> IO b
peekBi Stack
stk = Foreign -> b
forall a. Foreign -> a
unwrapForeign (Foreign -> b) -> (BVal -> Foreign) -> BVal -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => BVal -> Foreign
BVal -> Foreign
marshalToForeign (BVal -> b) -> IO BVal -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (() :: Constraint) => Stack -> IO BVal
Stack -> IO BVal
bpeek Stack
stk
{-# INLINE peekBi #-}

peekOffBi :: (BuiltinForeign b) => Stack -> Int -> IO b
peekOffBi :: forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i = Foreign -> b
forall a. Foreign -> a
unwrapForeign (Foreign -> b) -> (BVal -> Foreign) -> BVal -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => BVal -> Foreign
BVal -> Foreign
marshalToForeign (BVal -> b) -> IO BVal -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (() :: Constraint) => Stack -> Int -> IO BVal
Stack -> Int -> IO BVal
bpeekOff Stack
stk Int
i
{-# INLINE peekOffBi #-}

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

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

peekOffS :: Stack -> Int -> IO USeq
peekOffS :: Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i =
  Foreign -> USeq
forall a. Foreign -> a
unwrapForeign (Foreign -> USeq) -> (BVal -> Foreign) -> BVal -> USeq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => BVal -> Foreign
BVal -> Foreign
marshalToForeign (BVal -> USeq) -> IO BVal -> IO USeq
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (() :: Constraint) => Stack -> Int -> IO BVal
Stack -> Int -> IO BVal
bpeekOff Stack
stk Int
i
{-# INLINE peekOffS #-}

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

pokeOffS :: Stack -> Int -> USeq -> IO ()
pokeOffS :: Stack -> Int -> USeq -> IO ()
pokeOffS Stack
stk Int
i USeq
s = (() :: Constraint) => Stack -> Int -> BVal -> IO ()
Stack -> Int -> BVal -> IO ()
bpokeOff Stack
stk Int
i (Foreign -> BVal
Foreign (Foreign -> BVal) -> Foreign -> BVal
forall a b. (a -> b) -> a -> b
$ Reference -> USeq -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Ty.listRef USeq
s)
{-# INLINE pokeOffS #-}

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

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

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

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
f Int
a CombIx
ci Int
_g RSection Val
_rsect K
k) =
        String
com String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int, CombIx) -> String
forall a. Show a => a -> String
show (Int
f, Int
a, CombIx
ci) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> K -> String
go String
"," K
k
      go String
com (Mark Int
a EnumSet Word64
ps EnumMap Word64 Val
_ 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
a 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

frameView :: Stack -> IO ()
frameView :: Stack -> IO ()
frameView Stack
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 -> Int
fsize Stack
stk
    asz :: Int
asz = Stack -> Int
asize Stack
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 ()) -> (Val -> String) -> Val -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> String
forall a. Show a => a -> String
show (Val -> IO ()) -> IO Val -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
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 ()) -> (Val -> String) -> Val -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> String
forall a. Show a => a -> String
show (Val -> IO ()) -> IO Val -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
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)

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

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

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

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