{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
-- TODO: Fix up all the uni-patterns
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Unison.Runtime.Machine where

import Control.Concurrent (ThreadId)
import Control.Concurrent.STM as STM
import Control.Exception
import Data.Bits
import Data.Map.Strict qualified as M
import Data.Ord (comparing)
import Data.Primitive.ByteArray qualified as BA
import Data.Sequence qualified as Sq
import Data.Set qualified as S
import Data.Set qualified as Set
import Data.Text qualified as DTx
import Data.Text.IO qualified as Tx
import Data.Traversable
import GHC.Conc as STM (unsafeIOToSTM)
import Unison.Builtin.Decls (exceptionRef, ioFailureRef)
import Unison.Builtin.Decls qualified as Rf
import Unison.ConstructorReference qualified as CR
import Unison.Prelude hiding (Text)
import Unison.Reference
  ( Reference,
    Reference' (Builtin),
    isBuiltin,
    toShortHash,
  )
import Unison.Referent (Referent, pattern Con, pattern Ref)
import Unison.Runtime.ANF as ANF
  ( CompileExn (..),
    Mem (..),
    SuperGroup,
    foldGroupLinks,
    maskTags,
    packTags,
    valueLinks,
  )
import Unison.Runtime.ANF qualified as ANF
import Unison.Runtime.Array as PA
import Unison.Runtime.Builtin
import Unison.Runtime.Exception
import Unison.Runtime.Foreign
import Unison.Runtime.Foreign.Function
import Unison.Runtime.MCode
import Unison.Runtime.Stack
import Unison.ShortHash qualified as SH
import Unison.Symbol (Symbol)
import Unison.Type qualified as Rf
import Unison.Util.Bytes qualified as By
import Unison.Util.EnumContainers as EC
import Unison.Util.Pretty (toPlainUnbroken)
import Unison.Util.Text qualified as Util.Text
import UnliftIO (IORef)
import UnliftIO qualified
import UnliftIO.Concurrent qualified as UnliftIO

-- | A ref storing every currently active thread.
-- This is helpful for cleaning up orphaned threads when the main process
-- completes. We track threads when running in a host process like UCM,
-- otherwise we don't bother since forked threads are cleaned up automatically on
-- termination.
type ActiveThreads = Maybe (IORef (Set ThreadId))

type Tag = Word64

-- dynamic environment
type DEnv = EnumMap Word64 Closure

data Tracer
  = NoTrace
  | MsgTrace String String String
  | SimpleTrace String

-- code caching environment
data CCache = CCache
  { CCache -> EnumMap Word64 ForeignFunc
foreignFuncs :: EnumMap Word64 ForeignFunc,
    CCache -> Bool
sandboxed :: Bool,
    CCache -> Bool -> RClosure -> Tracer
tracer :: Bool -> Closure -> Tracer,
    CCache -> TVar (EnumMap Word64 RCombs)
combs :: TVar (EnumMap Word64 RCombs),
    CCache -> TVar (EnumMap Word64 Reference)
combRefs :: TVar (EnumMap Word64 Reference),
    CCache -> TVar (EnumMap Word64 Reference)
tagRefs :: TVar (EnumMap Word64 Reference),
    CCache -> TVar Word64
freshTm :: TVar Word64,
    CCache -> TVar Word64
freshTy :: TVar Word64,
    CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed :: TVar (M.Map Reference (SuperGroup Symbol)),
    CCache -> TVar (Map Reference Word64)
refTm :: TVar (M.Map Reference Word64),
    CCache -> TVar (Map Reference Word64)
refTy :: TVar (M.Map Reference Word64),
    CCache -> TVar (Map Reference (Set Reference))
sandbox :: TVar (M.Map Reference (Set Reference))
  }

refNumsTm :: CCache -> IO (M.Map Reference Word64)
refNumsTm :: CCache -> IO (Map Reference Word64)
refNumsTm CCache
cc = TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTm CCache
cc)

refNumsTy :: CCache -> IO (M.Map Reference Word64)
refNumsTy :: CCache -> IO (Map Reference Word64)
refNumsTy CCache
cc = TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTy CCache
cc)

refNumTm :: CCache -> Reference -> IO Word64
refNumTm :: CCache -> Reference -> IO Word64
refNumTm CCache
cc Reference
r =
  CCache -> IO (Map Reference Word64)
refNumsTm CCache
cc IO (Map Reference Word64)
-> (Map Reference Word64 -> IO Word64) -> IO Word64
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r -> Just Word64
w) -> Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
    Map Reference Word64
_ -> [Char] -> IO Word64
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Word64) -> [Char] -> IO Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"refNumTm: unknown reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

refNumTy :: CCache -> Reference -> IO Word64
refNumTy :: CCache -> Reference -> IO Word64
refNumTy CCache
cc Reference
r =
  CCache -> IO (Map Reference Word64)
refNumsTy CCache
cc IO (Map Reference Word64)
-> (Map Reference Word64 -> IO Word64) -> IO Word64
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r -> Just Word64
w) -> Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
    Map Reference Word64
_ -> [Char] -> IO Word64
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Word64) -> [Char] -> IO Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"refNumTy: unknown reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

refNumTy' :: CCache -> Reference -> IO (Maybe Word64)
refNumTy' :: CCache -> Reference -> IO (Maybe Word64)
refNumTy' CCache
cc Reference
r = Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r (Map Reference Word64 -> Maybe Word64)
-> IO (Map Reference Word64) -> IO (Maybe Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CCache -> IO (Map Reference Word64)
refNumsTy CCache
cc

baseCCache :: Bool -> IO CCache
baseCCache :: Bool -> IO CCache
baseCCache Bool
sandboxed = do
  EnumMap Word64 ForeignFunc
-> Bool
-> (Bool -> RClosure -> Tracer)
-> TVar (EnumMap Word64 RCombs)
-> TVar (EnumMap Word64 Reference)
-> TVar (EnumMap Word64 Reference)
-> TVar Word64
-> TVar Word64
-> TVar (Map Reference (SuperGroup Symbol))
-> TVar (Map Reference Word64)
-> TVar (Map Reference Word64)
-> TVar (Map Reference (Set Reference))
-> CCache
CCache EnumMap Word64 ForeignFunc
ffuncs Bool
sandboxed Bool -> RClosure -> Tracer
forall {p} {p}. p -> p -> Tracer
noTrace
    (TVar (EnumMap Word64 RCombs)
 -> TVar (EnumMap Word64 Reference)
 -> TVar (EnumMap Word64 Reference)
 -> TVar Word64
 -> TVar Word64
 -> TVar (Map Reference (SuperGroup Symbol))
 -> TVar (Map Reference Word64)
 -> TVar (Map Reference Word64)
 -> TVar (Map Reference (Set Reference))
 -> CCache)
-> IO (TVar (EnumMap Word64 RCombs))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumMap Word64 RCombs -> IO (TVar (EnumMap Word64 RCombs))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 RCombs
combs
    IO
  (TVar (EnumMap Word64 Reference)
   -> TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar (EnumMap Word64 Reference))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumMap Word64 Reference -> IO (TVar (EnumMap Word64 Reference))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 Reference
builtinTermBackref
    IO
  (TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar (EnumMap Word64 Reference))
-> IO
     (TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumMap Word64 Reference -> IO (TVar (EnumMap Word64 Reference))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 Reference
builtinTypeBackref
    IO
  (TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar Word64)
-> IO
     (TVar Word64
      -> TVar (Map Reference (SuperGroup Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word64 -> IO (TVar Word64)
forall a. a -> IO (TVar a)
newTVarIO Word64
ftm
    IO
  (TVar Word64
   -> TVar (Map Reference (SuperGroup Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar Word64)
-> IO
     (TVar (Map Reference (SuperGroup Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word64 -> IO (TVar Word64)
forall a. a -> IO (TVar a)
newTVarIO Word64
fty
    IO
  (TVar (Map Reference (SuperGroup Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar (Map Reference (SuperGroup Symbol)))
-> IO
     (TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference (SuperGroup Symbol)
-> IO (TVar (Map Reference (SuperGroup Symbol)))
forall a. a -> IO (TVar a)
newTVarIO Map Reference (SuperGroup Symbol)
forall a. Monoid a => a
mempty
    IO
  (TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar (Map Reference Word64))
-> IO
     (TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference)) -> CCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference Word64 -> IO (TVar (Map Reference Word64))
forall a. a -> IO (TVar a)
newTVarIO Map Reference Word64
builtinTermNumbering
    IO
  (TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference)) -> CCache)
-> IO (TVar (Map Reference Word64))
-> IO (TVar (Map Reference (Set Reference)) -> CCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference Word64 -> IO (TVar (Map Reference Word64))
forall a. a -> IO (TVar a)
newTVarIO Map Reference Word64
builtinTypeNumbering
    IO (TVar (Map Reference (Set Reference)) -> CCache)
-> IO (TVar (Map Reference (Set Reference))) -> IO CCache
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference (Set Reference)
-> IO (TVar (Map Reference (Set Reference)))
forall a. a -> IO (TVar a)
newTVarIO Map Reference (Set Reference)
baseSandboxInfo
  where
    ffuncs :: EnumMap Word64 ForeignFunc
ffuncs | Bool
sandboxed = EnumMap Word64 ForeignFunc
sandboxedForeigns | Bool
otherwise = EnumMap Word64 ForeignFunc
builtinForeigns
    noTrace :: p -> p -> Tracer
noTrace p
_ p
_ = Tracer
NoTrace
    ftm :: Word64
ftm = Word64
1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Map Reference Word64 -> Word64
forall a. Ord a => Map Reference a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum Map Reference Word64
builtinTermNumbering
    fty :: Word64
fty = Word64
1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Map Reference Word64 -> Word64
forall a. Ord a => Map Reference a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum Map Reference Word64
builtinTypeNumbering

    rns :: RefNums
rns = RefNums
emptyRNs {dnum = refLookup "ty" builtinTypeNumbering}

    combs :: EnumMap Word64 RCombs
    combs :: EnumMap Word64 RCombs
combs =
      ( (Word64 -> SuperNormal Symbol -> EnumMap Word64 Comb)
-> EnumMap Word64 (SuperNormal Symbol)
-> EnumMap Word64 (EnumMap Word64 Comb)
forall k a b.
EnumKey k =>
(k -> a -> b) -> EnumMap k a -> EnumMap k b
mapWithKey
          (\Word64
k SuperNormal Symbol
v -> let r :: Reference
r = EnumMap Word64 Reference
builtinTermBackref EnumMap Word64 Reference -> Word64 -> Reference
forall k a. EnumKey k => EnumMap k a -> k -> a
! Word64
k in forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal v)
-> EnumMap Word64 Comb
emitComb @Symbol RefNums
rns Reference
r Word64
k RCtx Symbol
forall a. Monoid a => a
mempty (Word64
0, SuperNormal Symbol
v))
          EnumMap Word64 (SuperNormal Symbol)
numberedTermLookup
      )
        EnumMap Word64 (EnumMap Word64 Comb)
-> (EnumMap Word64 (EnumMap Word64 Comb) -> EnumMap Word64 RCombs)
-> EnumMap Word64 RCombs
forall a b. a -> (a -> b) -> b
& Maybe (EnumMap Word64 RCombs)
-> EnumMap Word64 (EnumMap Word64 Comb) -> EnumMap Word64 RCombs
resolveCombs Maybe (EnumMap Word64 RCombs)
forall a. Maybe a
Nothing

info :: (Show a) => String -> a -> IO ()
info :: forall a. Show a => [Char] -> a -> IO ()
info [Char]
ctx a
x = [Char] -> [Char] -> IO ()
infos [Char]
ctx (a -> [Char]
forall a. Show a => a -> [Char]
show a
x)

infos :: String -> String -> IO ()
infos :: [Char] -> [Char] -> IO ()
infos [Char]
ctx [Char]
s = [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
ctx [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

stk'info :: Stack 'BX -> IO ()
stk'info :: Stack 'BX -> IO ()
stk'info s :: Stack 'BX
s@(BS Int
_ Int
_ Int
sp MutableArray (PrimState IO) RClosure
_) = do
  let prn :: Int -> IO ()
prn 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 = Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
s Int
i IO RClosure -> (RClosure -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RClosure -> IO ()
forall a. Show a => a -> IO ()
print IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
prn (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  Int -> IO ()
prn Int
sp

-- Entry point for evaluating a section
eval0 :: CCache -> ActiveThreads -> RSection -> IO ()
eval0 :: CCache -> ActiveThreads -> RSection -> IO ()
eval0 !CCache
env !ActiveThreads
activeThreads !RSection
co = do
  Stack 'UN
ustk <- IO (Stack 'UN)
forall (b :: Mem). MEM b => IO (Stack b)
alloc
  Stack 'BX
bstk <- IO (Stack 'BX)
forall (b :: Mem). MEM b => IO (Stack b)
alloc
  EnumMap Word64 RCombs
cmbs <- TVar (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs)
forall a. TVar a -> IO a
readTVarIO (TVar (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs))
-> TVar (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs)
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (EnumMap Word64 RCombs)
combs CCache
env
  (EnumMap Word64 RClosure
denv, K -> K
k) <-
    EnumMap Word64 RCombs
-> Map Reference Word64
-> Map Reference Word64
-> (EnumMap Word64 RClosure, K -> K)
topDEnv EnumMap Word64 RCombs
cmbs (Map Reference Word64
 -> Map Reference Word64 -> (EnumMap Word64 RClosure, K -> K))
-> IO (Map Reference Word64)
-> IO (Map Reference Word64 -> (EnumMap Word64 RClosure, K -> K))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTy CCache
env) IO (Map Reference Word64 -> (EnumMap Word64 RClosure, K -> K))
-> IO (Map Reference Word64)
-> IO (EnumMap Word64 RClosure, K -> K)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTm CCache
env)
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk (K -> K
k K
KE) Reference
dummyRef RSection
co

topDEnv ::
  EnumMap Word64 RCombs ->
  M.Map Reference Word64 ->
  M.Map Reference Word64 ->
  (DEnv, K -> K)
topDEnv :: EnumMap Word64 RCombs
-> Map Reference Word64
-> Map Reference Word64
-> (EnumMap Word64 RClosure, K -> K)
topDEnv EnumMap Word64 RCombs
combs Map Reference Word64
rfTy Map Reference Word64
rfTm
  | Just Word64
n <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
exceptionRef Map Reference Word64
rfTy,
    -- TODO: Should I special-case this raise ref and pass it down from the top rather than always looking it up?
    Reference
rcrf <- Text -> Reference
forall t h. t -> Reference' t h
Builtin ([Char] -> Text
DTx.pack [Char]
"raise"),
    Just Word64
j <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
rcrf Map Reference Word64
rfTm =
      let cix :: CombIx
cix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
rcrf Word64
j Word64
0)
          comb :: RComb
comb = EnumMap Word64 RCombs -> CombIx -> RComb
rCombSection EnumMap Word64 RCombs
combs CombIx
cix
       in ( Word64 -> RClosure -> EnumMap Word64 RClosure
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
n (RComb -> Seg 'UN -> Seg 'BX -> RClosure
forall comb. comb -> Seg 'UN -> Seg 'BX -> GClosure comb
PAp RComb
comb Seg 'UN
unull Seg 'BX
bnull),
            Int -> Int -> EnumSet Word64 -> EnumMap Word64 RClosure -> K -> K
Mark Int
0 Int
0 (Word64 -> EnumSet Word64
forall k. EnumKey k => k -> EnumSet k
EC.setSingleton Word64
n) EnumMap Word64 RClosure
forall a. Monoid a => a
mempty
          )
topDEnv EnumMap Word64 RCombs
_ Map Reference Word64
_ Map Reference Word64
_ = (EnumMap Word64 RClosure
forall a. Monoid a => a
mempty, K -> K
forall a. a -> a
id)

-- Entry point for evaluating a numbered combinator.
-- An optional callback for the base of the stack may be supplied.
--
-- This is the entry point actually used in the interactive
-- environment currently.
apply0 ::
  Maybe (Stack 'UN -> Stack 'BX -> IO ()) ->
  CCache ->
  ActiveThreads ->
  Word64 ->
  IO ()
apply0 :: Maybe (Stack 'UN -> Stack 'BX -> IO ())
-> CCache -> ActiveThreads -> Word64 -> IO ()
apply0 !Maybe (Stack 'UN -> Stack 'BX -> IO ())
callback !CCache
env !ActiveThreads
threadTracker !Word64
i = do
  Stack 'UN
ustk <- IO (Stack 'UN)
forall (b :: Mem). MEM b => IO (Stack b)
alloc
  Stack 'BX
bstk <- IO (Stack 'BX)
forall (b :: Mem). MEM b => IO (Stack b)
alloc
  EnumMap Word64 Reference
cmbrs <- TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference))
-> TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (EnumMap Word64 Reference)
combRefs CCache
env
  EnumMap Word64 RCombs
cmbs <- TVar (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs)
forall a. TVar a -> IO a
readTVarIO (TVar (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs))
-> TVar (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs)
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (EnumMap Word64 RCombs)
combs CCache
env
  (EnumMap Word64 RClosure
denv, K -> K
kf) <-
    EnumMap Word64 RCombs
-> Map Reference Word64
-> Map Reference Word64
-> (EnumMap Word64 RClosure, K -> K)
topDEnv EnumMap Word64 RCombs
cmbs (Map Reference Word64
 -> Map Reference Word64 -> (EnumMap Word64 RClosure, K -> K))
-> IO (Map Reference Word64)
-> IO (Map Reference Word64 -> (EnumMap Word64 RClosure, K -> K))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTy CCache
env) IO (Map Reference Word64 -> (EnumMap Word64 RClosure, K -> K))
-> IO (Map Reference Word64)
-> IO (EnumMap Word64 RClosure, K -> K)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTm CCache
env)
  Reference
r <- case Word64 -> EnumMap Word64 Reference -> Maybe Reference
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i EnumMap Word64 Reference
cmbrs of
    Just Reference
r -> Reference -> IO Reference
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Reference
r
    Maybe Reference
Nothing -> [Char] -> IO Reference
forall a. HasCallStack => [Char] -> IO a
die [Char]
"apply0: missing reference to entry point"
  let entryComb :: RComb
entryComb = EnumMap Word64 RCombs -> CombIx -> RComb
rCombSection EnumMap Word64 RCombs
cmbs (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
r Word64
i Word64
0)
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Bool
-> Args
-> RClosure
-> IO ()
apply CCache
env EnumMap Word64 RClosure
denv ActiveThreads
threadTracker Stack 'UN
ustk Stack 'BX
bstk (K -> K
kf K
k0) Bool
True Args
ZArgs (RClosure -> IO ()) -> RClosure -> IO ()
forall a b. (a -> b) -> a -> b
$
    RComb -> Seg 'UN -> Seg 'BX -> RClosure
forall comb. comb -> Seg 'UN -> Seg 'BX -> GClosure comb
PAp RComb
entryComb Seg 'UN
unull Seg 'BX
bnull
  where
    k0 :: K
k0 = K
-> ((Stack 'UN -> Stack 'BX -> IO ()) -> K)
-> Maybe (Stack 'UN -> Stack 'BX -> IO ())
-> K
forall b a. b -> (a -> b) -> Maybe a -> b
maybe K
KE (Callback -> K
CB (Callback -> K)
-> ((Stack 'UN -> Stack 'BX -> IO ()) -> Callback)
-> (Stack 'UN -> Stack 'BX -> IO ())
-> K
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stack 'UN -> Stack 'BX -> IO ()) -> Callback
Hook) Maybe (Stack 'UN -> Stack 'BX -> IO ())
callback

-- Apply helper currently used for forking. Creates the new stacks
-- necessary to evaluate a closure with the provided information.
apply1 ::
  (Stack 'UN -> Stack 'BX -> IO ()) ->
  CCache ->
  ActiveThreads ->
  Closure ->
  IO ()
apply1 :: (Stack 'UN -> Stack 'BX -> IO ())
-> CCache -> ActiveThreads -> RClosure -> IO ()
apply1 Stack 'UN -> Stack 'BX -> IO ()
callback CCache
env ActiveThreads
threadTracker RClosure
clo = do
  Stack 'UN
ustk <- IO (Stack 'UN)
forall (b :: Mem). MEM b => IO (Stack b)
alloc
  Stack 'BX
bstk <- IO (Stack 'BX)
forall (b :: Mem). MEM b => IO (Stack b)
alloc
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Bool
-> Args
-> RClosure
-> IO ()
apply CCache
env EnumMap Word64 RClosure
forall a. Monoid a => a
mempty ActiveThreads
threadTracker Stack 'UN
ustk Stack 'BX
bstk K
k0 Bool
True Args
ZArgs RClosure
clo
  where
    k0 :: K
k0 = Callback -> K
CB (Callback -> K) -> Callback -> K
forall a b. (a -> b) -> a -> b
$ (Stack 'UN -> Stack 'BX -> IO ()) -> Callback
Hook Stack 'UN -> Stack 'BX -> IO ()
callback

-- Entry point for evaluating a saved continuation.
--
-- The continuation must be from an evaluation context expecting a
-- unit value.
jump0 ::
  (Stack 'UN -> Stack 'BX -> IO ()) ->
  CCache ->
  ActiveThreads ->
  Closure ->
  IO ()
jump0 :: (Stack 'UN -> Stack 'BX -> IO ())
-> CCache -> ActiveThreads -> RClosure -> IO ()
jump0 !Stack 'UN -> Stack 'BX -> IO ()
callback !CCache
env !ActiveThreads
activeThreads !RClosure
clo = do
  Stack 'UN
ustk <- IO (Stack 'UN)
forall (b :: Mem). MEM b => IO (Stack b)
alloc
  Stack 'BX
bstk <- IO (Stack 'BX)
forall (b :: Mem). MEM b => IO (Stack b)
alloc
  EnumMap Word64 RCombs
cmbs <- TVar (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs)
forall a. TVar a -> IO a
readTVarIO (TVar (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs))
-> TVar (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs)
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (EnumMap Word64 RCombs)
combs CCache
env
  (EnumMap Word64 RClosure
denv, K -> K
kf) <-
    EnumMap Word64 RCombs
-> Map Reference Word64
-> Map Reference Word64
-> (EnumMap Word64 RClosure, K -> K)
topDEnv EnumMap Word64 RCombs
cmbs (Map Reference Word64
 -> Map Reference Word64 -> (EnumMap Word64 RClosure, K -> K))
-> IO (Map Reference Word64)
-> IO (Map Reference Word64 -> (EnumMap Word64 RClosure, K -> K))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTy CCache
env) IO (Map Reference Word64 -> (EnumMap Word64 RClosure, K -> K))
-> IO (Map Reference Word64)
-> IO (EnumMap Word64 RClosure, K -> K)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTm CCache
env)
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Reference -> Word64 -> RClosure
forall comb. Reference -> Word64 -> GClosure comb
Enum Reference
Rf.unitRef Word64
unitTag)
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Args
-> RClosure
-> IO ()
jump CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk (K -> K
kf K
k0) (Int -> Args
BArg1 Int
0) RClosure
clo
  where
    k0 :: K
k0 = Callback -> K
CB ((Stack 'UN -> Stack 'BX -> IO ()) -> Callback
Hook Stack 'UN -> Stack 'BX -> IO ()
callback)

unitValue :: Closure
unitValue :: RClosure
unitValue = Reference -> Word64 -> RClosure
forall comb. Reference -> Word64 -> GClosure comb
Enum Reference
Rf.unitRef Word64
unitTag

lookupDenv :: Word64 -> DEnv -> Closure
lookupDenv :: Word64 -> EnumMap Word64 RClosure -> RClosure
lookupDenv Word64
p EnumMap Word64 RClosure
denv = RClosure -> Maybe RClosure -> RClosure
forall a. a -> Maybe a -> a
fromMaybe RClosure
forall comb. GClosure comb
BlackHole (Maybe RClosure -> RClosure) -> Maybe RClosure -> RClosure
forall a b. (a -> b) -> a -> b
$ Word64 -> EnumMap Word64 RClosure -> Maybe RClosure
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
p EnumMap Word64 RClosure
denv

buildLit :: Reference -> Word64 -> MLit -> Closure
buildLit :: Reference -> Word64 -> MLit -> RClosure
buildLit Reference
rf Word64
tt (MI Int
i) = Reference -> Word64 -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> GClosure comb
DataU1 Reference
rf Word64
tt Int
i
buildLit Reference
_ Word64
_ (MT Text
t) = Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Reference -> Text -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.textRef Text
t)
buildLit Reference
_ Word64
_ (MM Referent' Reference
r) = Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Reference -> Referent' Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef Referent' Reference
r)
buildLit Reference
_ Word64
_ (MY Reference
r) = Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.typeLinkRef Reference
r)
buildLit Reference
_ Word64
_ (MD Double
_) = [Char] -> RClosure
forall a. HasCallStack => [Char] -> a
error [Char]
"buildLit: double"

-- | Execute an instruction
exec ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack 'UN ->
  Stack 'BX ->
  K ->
  Reference ->
  RInstr ->
  IO (DEnv, Stack 'UN, Stack 'BX, K)
exec :: CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RInstr
-> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Info [Char]
tx) = do
  [Char] -> Stack 'UN -> IO ()
forall a. Show a => [Char] -> a -> IO ()
info [Char]
tx Stack 'UN
ustk
  [Char] -> Stack 'BX -> IO ()
forall a. Show a => [Char] -> a -> IO ()
info [Char]
tx Stack 'BX
bstk
  [Char] -> K -> IO ()
forall a. Show a => [Char] -> a -> IO ()
info [Char]
tx K
k
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Name GRef RComb
r Args
args) = do
  Stack 'BX
bstk <- Stack 'UN -> Stack 'BX -> Args -> RClosure -> IO (Stack 'BX)
name Stack 'UN
ustk Stack 'BX
bstk Args
args (RClosure -> IO (Stack 'BX)) -> IO RClosure -> IO (Stack 'BX)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CCache
-> EnumMap Word64 RClosure
-> Stack 'BX
-> GRef RComb
-> IO RClosure
resolve CCache
env EnumMap Word64 RClosure
denv Stack 'BX
bstk GRef RComb
r
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (SetDyn Word64
p Int
i) = do
  RClosure
clo <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  pure (Word64
-> RClosure -> EnumMap Word64 RClosure -> EnumMap Word64 RClosure
forall k a. EnumKey k => k -> a -> EnumMap k a -> EnumMap k a
EC.mapInsert Word64
p RClosure
clo EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Capture Word64
p) = do
  (RClosure
cap, EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k) <- EnumMap Word64 RClosure
-> Stack 'UN
-> Stack 'BX
-> K
-> Word64
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
splitCont EnumMap Word64 RClosure
denv Stack 'UN
ustk Stack 'BX
bstk K
k Word64
p
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
cap
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (UPrim1 UPrim1
op Int
i) = do
  Stack 'UN
ustk <- Stack 'UN -> UPrim1 -> Int -> IO (Stack 'UN)
uprim1 Stack 'UN
ustk UPrim1
op Int
i
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (UPrim2 UPrim2
op Int
i Int
j) = do
  Stack 'UN
ustk <- Stack 'UN -> UPrim2 -> Int -> Int -> IO (Stack 'UN)
uprim2 Stack 'UN
ustk UPrim2
op Int
i Int
j
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim1 BPrim1
MISS Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: isMissing"
  | Bool
otherwise = do
      RClosure
clink <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
      let Ref Reference
link = Foreign -> Referent' Reference
forall a. Foreign -> a
unwrapForeign (Foreign -> Referent' Reference) -> Foreign -> Referent' Reference
forall a b. (a -> b) -> a -> b
$ HasCallStack => RClosure -> Foreign
RClosure -> Foreign
marshalToForeign RClosure
clink
      Map Reference (SuperGroup Symbol)
m <- TVar (Map Reference (SuperGroup Symbol))
-> IO (Map Reference (SuperGroup Symbol))
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed CCache
env)
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      if (Reference
link Reference -> Map Reference (SuperGroup Symbol) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Reference (SuperGroup Symbol)
m) then Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1 else Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim1 BPrim1
CACH Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: cache"
  | Bool
otherwise = do
      Seq RClosure
arg <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i
      [(Reference, SuperGroup Symbol)]
news <- Seq RClosure -> IO [(Reference, SuperGroup Symbol)]
decodeCacheArgument Seq RClosure
arg
      [Reference]
unknown <- [(Reference, SuperGroup Symbol)] -> CCache -> IO [Reference]
cacheAdd [(Reference, SuperGroup Symbol)]
news CCache
env
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      Stack 'BX -> Seq RClosure -> IO ()
pokeS
        Stack 'BX
bstk
        ([RClosure] -> Seq RClosure
forall a. [a] -> Seq a
Sq.fromList ([RClosure] -> Seq RClosure) -> [RClosure] -> Seq RClosure
forall a b. (a -> b) -> a -> b
$ Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure)
-> (Reference -> Foreign) -> Reference -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent' Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef (Referent' Reference -> Foreign)
-> (Reference -> Referent' Reference) -> Reference -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent' Reference
Ref (Reference -> RClosure) -> [Reference] -> [RClosure]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Reference]
unknown)
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim1 BPrim1
CVLD Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: validate"
  | Bool
otherwise = do
      Seq RClosure
arg <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i
      [(Reference, SuperGroup Symbol)]
news <- Seq RClosure -> IO [(Reference, SuperGroup Symbol)]
decodeCacheArgument Seq RClosure
arg
      [(Reference, SuperGroup Symbol)]
-> CCache -> IO (Maybe (Failure RClosure))
codeValidate [(Reference, SuperGroup Symbol)]
news CCache
env IO (Maybe (Failure RClosure))
-> (Maybe (Failure RClosure)
    -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K))
-> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (Failure RClosure)
Nothing -> do
          Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
          Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
          pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
        Just (Failure Reference
ref Text
msg RClosure
clo) -> do
          Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
          Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'BX
bstk Int
3
          Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
          Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure) -> Foreign -> RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.typeLinkRef Reference
ref)
          Stack 'BX -> Int -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> Int -> b -> IO ()
pokeOffBi Stack 'BX
bstk Int
1 Text
msg
          Stack 'BX -> Int -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'BX
bstk Int
2 Elem 'BX
RClosure
clo
          pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim1 BPrim1
LKUP Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: lookup"
  | Bool
otherwise = do
      RClosure
clink <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
      let Ref Reference
link = Foreign -> Referent' Reference
forall a. Foreign -> a
unwrapForeign (Foreign -> Referent' Reference) -> Foreign -> Referent' Reference
forall a b. (a -> b) -> a -> b
$ HasCallStack => RClosure -> Foreign
RClosure -> Foreign
marshalToForeign RClosure
clink
      Map Reference (SuperGroup Symbol)
m <- TVar (Map Reference (SuperGroup Symbol))
-> IO (Map Reference (SuperGroup Symbol))
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed CCache
env)
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'BX
bstk <- case Reference
-> Map Reference (SuperGroup Symbol) -> Maybe (SuperGroup Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
link Map Reference (SuperGroup Symbol)
m of
        Maybe (SuperGroup Symbol)
Nothing
          | Just Word64
w <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
link Map Reference Word64
builtinTermNumbering,
            Just SuperNormal Symbol
sn <- Word64
-> EnumMap Word64 (SuperNormal Symbol)
-> Maybe (SuperNormal Symbol)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w EnumMap Word64 (SuperNormal Symbol)
numberedTermLookup -> do
              Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
              Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
              Stack 'BX
bstk Stack 'BX -> IO () -> IO (Stack 'BX)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack 'BX -> SuperGroup Symbol -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk ([(Symbol, SuperNormal Symbol)]
-> SuperNormal Symbol -> SuperGroup Symbol
forall v. [(v, SuperNormal v)] -> SuperNormal v -> SuperGroup v
ANF.Rec [] SuperNormal Symbol
sn)
          | Bool
otherwise -> Stack 'BX
bstk Stack 'BX -> IO () -> IO (Stack 'BX)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
        Just SuperGroup Symbol
sg -> do
          Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
          Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
          Stack 'BX
bstk Stack 'BX -> IO () -> IO (Stack 'BX)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack 'BX -> SuperGroup Symbol -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk SuperGroup Symbol
sg
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim1 BPrim1
TLTT Int
i) = do
  RClosure
clink <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  let shortHash :: ShortHash
shortHash = case Foreign -> Referent' Reference
forall a. Foreign -> a
unwrapForeign (Foreign -> Referent' Reference) -> Foreign -> Referent' Reference
forall a b. (a -> b) -> a -> b
$ HasCallStack => RClosure -> Foreign
RClosure -> Foreign
marshalToForeign RClosure
clink of
        Ref Reference
r -> Reference -> ShortHash
toShortHash Reference
r
        Con ConstructorReference
r ConstructorType
_ -> ConstructorReference -> ShortHash
CR.toShortHash ConstructorReference
r
  let sh :: Text
sh = Text -> Text
Util.Text.fromText (Text -> Text) -> (ShortHash -> Text) -> ShortHash -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortHash -> Text
SH.toText (ShortHash -> Text) -> ShortHash -> Text
forall a b. (a -> b) -> a -> b
$ ShortHash
shortHash
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk Text
sh
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim1 BPrim1
LOAD Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: load"
  | Bool
otherwise = do
      Value
v <- Stack 'BX -> Int -> IO Value
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      CCache -> Value -> IO (Either [Reference] RClosure)
reifyValue CCache
env Value
v IO (Either [Reference] RClosure)
-> (Either [Reference] RClosure -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left [Reference]
miss -> do
          Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
          Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk (Seq RClosure -> IO ()) -> Seq RClosure -> IO ()
forall a b. (a -> b) -> a -> b
$
            [RClosure] -> Seq RClosure
forall a. [a] -> Seq a
Sq.fromList ([RClosure] -> Seq RClosure) -> [RClosure] -> Seq RClosure
forall a b. (a -> b) -> a -> b
$
              Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure)
-> (Reference -> Foreign) -> Reference -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent' Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef (Referent' Reference -> Foreign)
-> (Reference -> Referent' Reference) -> Reference -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent' Reference
Ref (Reference -> RClosure) -> [Reference] -> [RClosure]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Reference]
miss
        Right RClosure
x -> do
          Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
          Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
x
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim1 BPrim1
VALU Int
i) = do
  EnumMap Word64 Reference
m <- TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (EnumMap Word64 Reference)
tagRefs CCache
env)
  RClosure
c <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Value -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Value -> IO ()) -> IO Value -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EnumMap Word64 Reference -> RClosure -> IO Value
reflectValue EnumMap Word64 Reference
m RClosure
c
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim1 BPrim1
DBTX Int
i)
  | CCache -> Bool
sandboxed CCache
env =
      [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: Debug.toText"
  | Bool
otherwise = do
      RClosure
clo <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'BX
bstk <- case CCache -> Bool -> RClosure -> Tracer
tracer CCache
env Bool
False RClosure
clo of
        Tracer
NoTrace -> Stack 'BX
bstk Stack 'BX -> IO () -> IO (Stack 'BX)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
        MsgTrace [Char]
_ [Char]
_ [Char]
tx -> do
          Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
          Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
          Stack 'BX
bstk Stack 'BX -> IO () -> IO (Stack 'BX)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk ([Char] -> Text
Util.Text.pack [Char]
tx)
        SimpleTrace [Char]
tx -> do
          Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
2
          Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
          Stack 'BX
bstk Stack 'BX -> IO () -> IO (Stack 'BX)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk ([Char] -> Text
Util.Text.pack [Char]
tx)
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim1 BPrim1
SDBL Int
i)
  | CCache -> Bool
sandboxed CCache
env =
      [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: sandboxLinks"
  | Bool
otherwise = do
      Referent' Reference
tl <- Stack 'BX -> Int -> IO (Referent' Reference)
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk (Seq RClosure -> IO ())
-> ([Reference] -> Seq RClosure) -> [Reference] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reference] -> Seq RClosure
encodeSandboxListResult ([Reference] -> IO ()) -> IO [Reference] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CCache -> Referent' Reference -> IO [Reference]
sandboxList CCache
env Referent' Reference
tl
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim1 BPrim1
op Int
i) = do
  (Stack 'UN
ustk, Stack 'BX
bstk) <- Stack 'UN
-> Stack 'BX -> BPrim1 -> Int -> IO (Stack 'UN, Stack 'BX)
bprim1 Stack 'UN
ustk Stack 'BX
bstk BPrim1
op Int
i
  (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
-> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim2 BPrim2
SDBX Int
i Int
j) = do
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i
  RClosure
c <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
j
  [Reference]
l <- Seq RClosure -> IO [Reference]
decodeSandboxArgument Seq RClosure
s
  Bool
b <- CCache -> [Reference] -> RClosure -> IO Bool
checkSandboxing CCache
env [Reference]
l RClosure
c
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
b then Int
Elem 'UN
1 else Int
Elem 'UN
0
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim2 BPrim2
SDBV Int
i Int
j)
  | CCache -> Bool
sandboxed CCache
env =
      [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: Value.validateSandboxed"
  | Bool
otherwise = do
      Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i
      Value
v <- Stack 'BX -> Int -> IO Value
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
      [Reference]
l <- Seq RClosure -> IO [Reference]
decodeSandboxArgument Seq RClosure
s
      Either [Reference] [Reference]
res <- CCache
-> [Reference] -> Value -> IO (Either [Reference] [Reference])
checkValueSandboxing CCache
env [Reference]
l Value
v
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Elem 'BX -> IO ()) -> Elem 'BX -> IO ()
forall a b. (a -> b) -> a -> b
$ Either [Reference] [Reference] -> RClosure
encodeSandboxResult Either [Reference] [Reference]
res
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim2 BPrim2
EQLU Int
i Int
j) = do
  RClosure
x <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  RClosure
y <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ if (Foreign -> Foreign -> Bool) -> RClosure -> RClosure -> Bool
universalEq Foreign -> Foreign -> Bool
forall a. Eq a => a -> a -> Bool
(==) RClosure
x RClosure
y then Int
Elem 'UN
1 else Int
Elem 'UN
0
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim2 BPrim2
CMPU Int
i Int
j) = do
  RClosure
x <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  RClosure
y <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int -> IO ()) -> (Ordering -> Int) -> Ordering -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ordering -> Int
forall a. Enum a => a -> Int
fromEnum (Ordering -> IO ()) -> Ordering -> IO ()
forall a b. (a -> b) -> a -> b
$ (Foreign -> Foreign -> Ordering)
-> RClosure -> RClosure -> Ordering
universalCompare Foreign -> Foreign -> Ordering
forall a. Ord a => a -> a -> Ordering
compare RClosure
x RClosure
y
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
_ !ActiveThreads
_activeThreads !Stack 'UN
_ !Stack 'BX
bstk !K
k Reference
r (BPrim2 BPrim2
THRO Int
i Int
j) = do
  Text
name <- forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi @Util.Text.Text Stack 'BX
bstk Int
i
  RClosure
x <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
j
  RuntimeExn -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall e a. Exception e => e -> IO a
throwIO ([(Reference, Int)] -> Text -> RClosure -> RuntimeExn
BU (Reference -> K -> [(Reference, Int)]
traceK Reference
r K
k) (Text -> Text
Util.Text.toText Text
name) RClosure
x)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim2 BPrim2
TRCE Int
i Int
j)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: trace"
  | Bool
otherwise = do
      Text
tx <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
      RClosure
clo <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
j
      case CCache -> Bool -> RClosure -> Tracer
tracer CCache
env Bool
True RClosure
clo of
        Tracer
NoTrace -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        SimpleTrace [Char]
str -> do
          [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"trace: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Util.Text.unpack Text
tx
          [Char] -> IO ()
putStrLn [Char]
str
        MsgTrace [Char]
msg [Char]
ugl [Char]
pre -> do
          [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"trace: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Util.Text.unpack Text
tx
          [Char] -> IO ()
putStrLn [Char]
""
          [Char] -> IO ()
putStrLn [Char]
msg
          [Char] -> IO ()
putStrLn [Char]
"\nraw structure:\n"
          [Char] -> IO ()
putStrLn [Char]
ugl
          [Char] -> IO ()
putStrLn [Char]
"partial decompilation:\n"
          [Char] -> IO ()
putStrLn [Char]
pre
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_trackThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BPrim2 BPrim2
op Int
i Int
j) = do
  (Stack 'UN
ustk, Stack 'BX
bstk) <- Stack 'UN
-> Stack 'BX -> BPrim2 -> Int -> Int -> IO (Stack 'UN, Stack 'BX)
bprim2 Stack 'UN
ustk Stack 'BX
bstk BPrim2
op Int
i Int
j
  (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
-> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Pack Reference
r Word64
t Args
args) = do
  RClosure
clo <- Stack 'UN
-> Stack 'BX -> Reference -> Word64 -> Args -> IO RClosure
buildData Stack 'UN
ustk Stack 'BX
bstk Reference
r Word64
t Args
args
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
clo
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Unpack Maybe Reference
r Int
i) = do
  (Stack 'UN
ustk, Stack 'BX
bstk) <- Maybe Reference
-> Stack 'UN -> Stack 'BX -> RClosure -> IO (Stack 'UN, Stack 'BX)
dumpData Maybe Reference
r Stack 'UN
ustk Stack 'BX
bstk (RClosure -> IO (Stack 'UN, Stack 'BX))
-> IO RClosure -> IO (Stack 'UN, Stack 'BX)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
-> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Print Int
i) = do
  Text
t <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  Text -> IO ()
Tx.putStrLn (Text -> Text
Util.Text.toText Text
t)
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Lit (MI Int
n)) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
n
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Lit (MD Double
d)) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk Double
d
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Lit (MT Text
t)) = do
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Reference -> Text -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.textRef Text
t))
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Lit (MM Referent' Reference
r)) = do
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Reference -> Referent' Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef Referent' Reference
r))
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Lit (MY Reference
r)) = do
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.typeLinkRef Reference
r))
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (BLit Reference
rf Word64
tt MLit
l) = do
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Elem 'BX -> IO ()) -> Elem 'BX -> IO ()
forall a b. (a -> b) -> a -> b
$ Reference -> Word64 -> MLit -> RClosure
buildLit Reference
rf Word64
tt MLit
l
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Reset EnumSet Word64
ps) = do
  (Stack 'UN
ustk, Int
ua) <- Stack 'UN -> IO (Stack 'UN, Int)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b, Int)
saveArgs Stack 'UN
ustk
  (Stack 'BX
bstk, Int
ba) <- Stack 'BX -> IO (Stack 'BX, Int)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b, Int)
saveArgs Stack 'BX
bstk
  (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
-> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, Int -> Int -> EnumSet Word64 -> EnumMap Word64 RClosure -> K -> K
Mark Int
ua Int
ba EnumSet Word64
ps EnumMap Word64 RClosure
clos K
k)
  where
    clos :: EnumMap Word64 RClosure
clos = EnumMap Word64 RClosure
-> EnumSet Word64 -> EnumMap Word64 RClosure
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys EnumMap Word64 RClosure
denv EnumSet Word64
ps
exec !CCache
_ !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Seq Args
as) = do
  [RClosure]
l <- Stack 'BX -> Args -> IO [RClosure]
closureArgs Stack 'BX
bstk Args
as
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk (Seq RClosure -> IO ()) -> Seq RClosure -> IO ()
forall a b. (a -> b) -> a -> b
$ [RClosure] -> Seq RClosure
forall a. [a] -> Seq a
Sq.fromList [RClosure]
l
  pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
_activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (ForeignCall Bool
_ Word64
w Args
args)
  | Just (FF Stack 'UN -> Stack 'BX -> Args -> IO a
arg Stack 'UN -> Stack 'BX -> r -> IO (Stack 'UN, Stack 'BX)
res a -> IO r
ev) <- Word64 -> EnumMap Word64 ForeignFunc -> Maybe ForeignFunc
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w (CCache -> EnumMap Word64 ForeignFunc
foreignFuncs CCache
env) =
      (Stack 'UN
 -> Stack 'BX -> (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K))
-> (Stack 'UN, Stack 'BX)
-> (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (EnumMap Word64 RClosure
denv,,,K
k)
        ((Stack 'UN, Stack 'BX)
 -> (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K))
-> IO (Stack 'UN, Stack 'BX)
-> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Stack 'UN -> Stack 'BX -> Args -> IO a
arg Stack 'UN
ustk Stack 'BX
bstk Args
args IO a -> (a -> IO r) -> IO r
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO r
ev IO r
-> (r -> IO (Stack 'UN, Stack 'BX)) -> IO (Stack 'UN, Stack 'BX)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack 'UN -> Stack 'BX -> r -> IO (Stack 'UN, Stack 'BX)
res Stack 'UN
ustk Stack 'BX
bstk)
  | Bool
otherwise =
      [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K))
-> [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a b. (a -> b) -> a -> b
$ [Char]
"reference to unknown foreign function: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
w
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Fork Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: fork"
  | Bool
otherwise = do
      ThreadId
tid <- CCache -> ActiveThreads -> RClosure -> IO ThreadId
forkEval CCache
env ActiveThreads
activeThreads (RClosure -> IO ThreadId) -> IO RClosure -> IO ThreadId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (RClosure -> IO ()) -> (ThreadId -> RClosure) -> ThreadId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure)
-> (ThreadId -> Foreign) -> ThreadId -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> ThreadId -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.threadIdRef (ThreadId -> IO ()) -> ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId
tid
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Atomically Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K))
-> [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a b. (a -> b) -> a -> b
$ [Char]
"attempted to use sandboxed operation: atomically"
  | Bool
otherwise = do
      RClosure
c <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      CCache -> ActiveThreads -> (RClosure -> IO ()) -> RClosure -> IO ()
atomicEval CCache
env ActiveThreads
activeThreads (Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk) RClosure
c
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
exec !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (TryForce Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K))
-> [Char] -> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a b. (a -> b) -> a -> b
$ [Char]
"attempted to use sandboxed operation: tryForce"
  | Bool
otherwise = do
      RClosure
c <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      Either SomeException ()
ev <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ CCache -> ActiveThreads -> (RClosure -> IO ()) -> RClosure -> IO ()
nestEval CCache
env ActiveThreads
activeThreads (Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk) RClosure
c
      Stack 'BX
bstk <- Stack 'UN -> Stack 'BX -> Either SomeException () -> IO (Stack 'BX)
encodeExn Stack 'UN
ustk Stack 'BX
bstk Either SomeException ()
ev
      pure (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
{-# INLINE exec #-}

encodeExn ::
  Stack 'UN ->
  Stack 'BX ->
  Either SomeException () ->
  IO (Stack 'BX)
encodeExn :: Stack 'UN -> Stack 'BX -> Either SomeException () -> IO (Stack 'BX)
encodeExn Stack 'UN
ustk Stack 'BX
bstk (Right ()
_) = Stack 'BX
bstk Stack 'BX -> IO () -> IO (Stack 'BX)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
encodeExn Stack 'UN
ustk Stack 'BX
bstk (Left SomeException
exn) = do
  Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'BX
bstk Int
2
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Elem 'BX -> IO ()) -> Elem 'BX -> IO ()
forall a b. (a -> b) -> a -> b
$ Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.typeLinkRef Reference
link)
  Stack 'BX -> Int -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> Int -> b -> IO ()
pokeOffBi Stack 'BX
bstk Int
1 Text
msg
  Stack 'BX
bstk Stack 'BX -> IO () -> IO (Stack 'BX)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack 'BX -> Int -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'BX
bstk Int
2 Elem 'BX
RClosure
extra
  where
    disp :: a -> Text
disp a
e = [Char] -> Text
Util.Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Show a => a -> [Char]
show a
e
    (Reference
link, Text
msg, RClosure
extra)
      | Just (IOException
ioe :: IOException) <- SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn =
          (Reference
Rf.ioFailureRef, IOException -> Text
forall {a}. Show a => a -> Text
disp IOException
ioe, RClosure
unitValue)
      | Just RuntimeExn
re <- SomeException -> Maybe RuntimeExn
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn = case RuntimeExn
re of
          PE CallStack
_stk Pretty ColorText
msg ->
            (Reference
Rf.runtimeFailureRef, [Char] -> Text
Util.Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Pretty ColorText -> [Char]
toPlainUnbroken Pretty ColorText
msg, RClosure
unitValue)
          BU [(Reference, Int)]
_ Text
tx RClosure
cl -> (Reference
Rf.runtimeFailureRef, Text -> Text
Util.Text.fromText Text
tx, RClosure
cl)
      | Just (ArithException
ae :: ArithException) <- SomeException -> Maybe ArithException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn =
          (Reference
Rf.arithmeticFailureRef, ArithException -> Text
forall {a}. Show a => a -> Text
disp ArithException
ae, RClosure
unitValue)
      | Just (NestedAtomically
nae :: NestedAtomically) <- SomeException -> Maybe NestedAtomically
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn =
          (Reference
Rf.stmFailureRef, NestedAtomically -> Text
forall {a}. Show a => a -> Text
disp NestedAtomically
nae, RClosure
unitValue)
      | Just (BlockedIndefinitelyOnSTM
be :: BlockedIndefinitelyOnSTM) <- SomeException -> Maybe BlockedIndefinitelyOnSTM
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn =
          (Reference
Rf.stmFailureRef, BlockedIndefinitelyOnSTM -> Text
forall {a}. Show a => a -> Text
disp BlockedIndefinitelyOnSTM
be, RClosure
unitValue)
      | Just (BlockedIndefinitelyOnMVar
be :: BlockedIndefinitelyOnMVar) <- SomeException -> Maybe BlockedIndefinitelyOnMVar
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn =
          (Reference
Rf.ioFailureRef, BlockedIndefinitelyOnMVar -> Text
forall {a}. Show a => a -> Text
disp BlockedIndefinitelyOnMVar
be, RClosure
unitValue)
      | Just (AsyncException
ie :: AsyncException) <- SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn =
          (Reference
Rf.threadKilledFailureRef, AsyncException -> Text
forall {a}. Show a => a -> Text
disp AsyncException
ie, RClosure
unitValue)
      | Bool
otherwise = (Reference
Rf.miscFailureRef, SomeException -> Text
forall {a}. Show a => a -> Text
disp SomeException
exn, RClosure
unitValue)

numValue :: Maybe Reference -> Closure -> IO Word64
numValue :: Maybe Reference -> RClosure -> IO Word64
numValue Maybe Reference
_ (DataU1 Reference
_ Word64
_ Int
i) = Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
numValue Maybe Reference
mr RClosure
clo =
  [Char] -> IO Word64
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Word64) -> [Char] -> IO Word64
forall a b. (a -> b) -> a -> b
$
    [Char]
"numValue: bad closure: "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RClosure -> [Char]
forall a. Show a => a -> [Char]
show RClosure
clo
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> (Reference -> [Char]) -> Maybe Reference -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\Reference
r -> [Char]
"\nexpected type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r) Maybe Reference
mr

-- | Evaluate a section
eval ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack 'UN ->
  Stack 'BX ->
  K ->
  Reference ->
  RSection ->
  IO ()
eval :: CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
r (Match Int
i (TestT RSection
df Map Text RSection
cs)) = do
  Text
t <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Reference
r (RSection -> IO ()) -> RSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> RSection -> Map Text RSection -> RSection
selectTextBranch Text
t RSection
df Map Text RSection
cs
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
r (Match Int
i GBranch RComb
br) = do
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Reference
r (RSection -> IO ()) -> RSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> GBranch RComb -> RSection
selectBranch Word64
n GBranch RComb
br
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
r (DMatch Maybe Reference
mr Int
i GBranch RComb
br) = do
  (Word64
t, Stack 'UN
ustk, Stack 'BX
bstk) <- Maybe Reference
-> Stack 'UN
-> Stack 'BX
-> RClosure
-> IO (Word64, Stack 'UN, Stack 'BX)
dumpDataNoTag Maybe Reference
mr Stack 'UN
ustk Stack 'BX
bstk (RClosure -> IO (Word64, Stack 'UN, Stack 'BX))
-> IO RClosure -> IO (Word64, Stack 'UN, Stack 'BX)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Reference
r (RSection -> IO ()) -> RSection -> IO ()
forall a b. (a -> b) -> a -> b
$
    Word64 -> GBranch RComb -> RSection
selectBranch (Word64 -> Word64
maskTags Word64
t) GBranch RComb
br
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
r (NMatch Maybe Reference
mr Int
i GBranch RComb
br) = do
  Word64
n <- Maybe Reference -> RClosure -> IO Word64
numValue Maybe Reference
mr (RClosure -> IO Word64) -> IO RClosure -> IO Word64
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Reference
r (RSection -> IO ()) -> RSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> GBranch RComb -> RSection
selectBranch Word64
n GBranch RComb
br
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
r (RMatch Int
i RSection
pu EnumMap Word64 (GBranch RComb)
br) = do
  (Word64
t, Stack 'UN
ustk, Stack 'BX
bstk) <- Maybe Reference
-> Stack 'UN
-> Stack 'BX
-> RClosure
-> IO (Word64, Stack 'UN, Stack 'BX)
dumpDataNoTag Maybe Reference
forall a. Maybe a
Nothing Stack 'UN
ustk Stack 'BX
bstk (RClosure -> IO (Word64, Stack 'UN, Stack 'BX))
-> IO RClosure -> IO (Word64, Stack 'UN, Stack 'BX)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  if Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
    then CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Reference
r RSection
pu
    else case Word64 -> (RTag, CTag)
ANF.unpackTags Word64
t of
      (RTag -> Word64
forall t. Tag t => t -> Word64
ANF.rawTag -> Word64
e, CTag -> Word64
forall t. Tag t => t -> Word64
ANF.rawTag -> Word64
t)
        | Just GBranch RComb
ebs <- Word64 -> EnumMap Word64 (GBranch RComb) -> Maybe (GBranch RComb)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
e EnumMap Word64 (GBranch RComb)
br ->
            CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Reference
r (RSection -> IO ()) -> RSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> GBranch RComb -> RSection
selectBranch Word64
t GBranch RComb
ebs
        | Bool
otherwise -> [Char] -> CCache -> Word64 -> IO ()
forall a. [Char] -> CCache -> Word64 -> IO a
unhandledErr [Char]
"eval" CCache
env Word64
e
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Yield Args
args)
  | Stack 'UN -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'UN
ustk Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Stack 'BX -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'BX
bstk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0,
    BArg1 Int
i <- Args
args =
      Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i IO RClosure -> (RClosure -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Bool
-> Args
-> RClosure
-> IO ()
apply CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Bool
False Args
ZArgs
  | Bool
otherwise = do
      (Stack 'UN
ustk, Stack 'BX
bstk) <- Stack 'UN -> Stack 'BX -> Args -> IO (Stack 'UN, Stack 'BX)
moveArgs Stack 'UN
ustk Stack 'BX
bstk Args
args
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
frameArgs Stack 'UN
ustk
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
frameArgs Stack 'BX
bstk
      CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> IO ()
yield CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (App Bool
ck GRef RComb
r Args
args) =
  CCache
-> EnumMap Word64 RClosure
-> Stack 'BX
-> GRef RComb
-> IO RClosure
resolve CCache
env EnumMap Word64 RClosure
denv Stack 'BX
bstk GRef RComb
r
    IO RClosure -> (RClosure -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Bool
-> Args
-> RClosure
-> IO ()
apply CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Bool
ck Args
args
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Call Bool
ck RComb
rcomb Args
args) =
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Bool
-> Args
-> RComb
-> IO ()
enter CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Bool
ck Args
args RComb
rcomb
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
_ (Jump Int
i Args
args) =
  Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i IO RClosure -> (RClosure -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Args
-> RClosure
-> IO ()
jump CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Args
args
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
r (Let RSection
nw RComb
cix) = do
  (Stack 'UN
ustk, Int
ufsz, Int
uasz) <- Stack 'UN -> IO (Stack 'UN, Int, Int)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b, Int, Int)
saveFrame Stack 'UN
ustk
  (Stack 'BX
bstk, Int
bfsz, Int
basz) <- Stack 'BX -> IO (Stack 'BX, Int, Int)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b, Int, Int)
saveFrame Stack 'BX
bstk
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk (Int -> Int -> Int -> Int -> RComb -> K -> K
Push Int
ufsz Int
bfsz Int
uasz Int
basz RComb
cix K
k) Reference
r RSection
nw
eval !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k Reference
r (Ins RInstr
i RSection
nx) = do
  (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k) <- CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RInstr
-> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
exec CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Reference
r RInstr
i
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Reference
r RSection
nx
eval !CCache
_ !EnumMap Word64 RClosure
_ !ActiveThreads
_ !Stack 'UN
_activeThreads !Stack 'BX
_ !K
_ Reference
_ RSection
Exit = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
eval !CCache
_ !EnumMap Word64 RClosure
_ !ActiveThreads
_ !Stack 'UN
_activeThreads !Stack 'BX
_ !K
_ Reference
_ (Die [Char]
s) = [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
die [Char]
s
{-# NOINLINE eval #-}

forkEval :: CCache -> ActiveThreads -> Closure -> IO ThreadId
forkEval :: CCache -> ActiveThreads -> RClosure -> IO ThreadId
forkEval CCache
env ActiveThreads
activeThreads RClosure
clo =
  do
    ThreadId
threadId <-
      IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
UnliftIO.forkFinally
        ((Stack 'UN -> Stack 'BX -> IO ())
-> CCache -> ActiveThreads -> RClosure -> IO ()
apply1 Stack 'UN -> Stack 'BX -> IO ()
err CCache
env ActiveThreads
activeThreads RClosure
clo)
        (IO () -> Either SomeException () -> IO ()
forall a b. a -> b -> a
const IO ()
cleanupThread)
    ThreadId -> IO ()
trackThread ThreadId
threadId
    pure ThreadId
threadId
  where
    err :: Stack 'UN -> Stack 'BX -> IO ()
    err :: Stack 'UN -> Stack 'BX -> IO ()
err Stack 'UN
_ Stack 'BX
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    trackThread :: ThreadId -> IO ()
    trackThread :: ThreadId -> IO ()
trackThread ThreadId
threadID = do
      case ActiveThreads
activeThreads of
        ActiveThreads
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just IORef (Set ThreadId)
activeThreads -> IORef (Set ThreadId)
-> (Set ThreadId -> (Set ThreadId, ())) -> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
UnliftIO.atomicModifyIORef' IORef (Set ThreadId)
activeThreads (\Set ThreadId
ids -> (ThreadId -> Set ThreadId -> Set ThreadId
forall a. Ord a => a -> Set a -> Set a
Set.insert ThreadId
threadID Set ThreadId
ids, ()))
    cleanupThread :: IO ()
    cleanupThread :: IO ()
cleanupThread = do
      case ActiveThreads
activeThreads of
        ActiveThreads
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just IORef (Set ThreadId)
activeThreads -> do
          ThreadId
myThreadId <- IO ThreadId
forall (m :: * -> *). MonadIO m => m ThreadId
UnliftIO.myThreadId
          IORef (Set ThreadId)
-> (Set ThreadId -> (Set ThreadId, ())) -> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
UnliftIO.atomicModifyIORef' IORef (Set ThreadId)
activeThreads (\Set ThreadId
ids -> (ThreadId -> Set ThreadId -> Set ThreadId
forall a. Ord a => a -> Set a -> Set a
Set.delete ThreadId
myThreadId Set ThreadId
ids, ()))
{-# INLINE forkEval #-}

nestEval :: CCache -> ActiveThreads -> (Closure -> IO ()) -> Closure -> IO ()
nestEval :: CCache -> ActiveThreads -> (RClosure -> IO ()) -> RClosure -> IO ()
nestEval CCache
env ActiveThreads
activeThreads RClosure -> IO ()
write RClosure
clo = (Stack 'UN -> Stack 'BX -> IO ())
-> CCache -> ActiveThreads -> RClosure -> IO ()
apply1 Stack 'UN -> Stack 'BX -> IO ()
readBack CCache
env ActiveThreads
activeThreads RClosure
clo
  where
    readBack :: Stack 'UN -> Stack 'BX -> IO ()
readBack Stack 'UN
_ Stack 'BX
bstk = Stack 'BX -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Elem b)
peek Stack 'BX
bstk IO RClosure -> (RClosure -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RClosure -> IO ()
write
{-# INLINE nestEval #-}

atomicEval :: CCache -> ActiveThreads -> (Closure -> IO ()) -> Closure -> IO ()
atomicEval :: CCache -> ActiveThreads -> (RClosure -> IO ()) -> RClosure -> IO ()
atomicEval CCache
env ActiveThreads
activeThreads RClosure -> IO ()
write RClosure
clo =
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (IO () -> STM ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> STM ()
forall a. IO a -> STM a
unsafeIOToSTM (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CCache -> ActiveThreads -> (RClosure -> IO ()) -> RClosure -> IO ()
nestEval CCache
env ActiveThreads
activeThreads RClosure -> IO ()
write RClosure
clo
{-# INLINE atomicEval #-}

-- fast path application
enter ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack 'UN ->
  Stack 'BX ->
  K ->
  Bool ->
  Args ->
  RComb ->
  IO ()
enter :: CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Bool
-> Args
-> RComb
-> IO ()
enter !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k !Bool
ck !Args
args !RComb
rcomb = do
  Stack 'UN
ustk <- if Bool
ck then Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
ensure Stack 'UN
ustk Int
uf else Stack 'UN -> IO (Stack 'UN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack 'UN
ustk
  Stack 'BX
bstk <- if Bool
ck then Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
ensure Stack 'BX
bstk Int
bf else Stack 'BX -> IO (Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack 'BX
bstk
  (Stack 'UN
ustk, Stack 'BX
bstk) <- Stack 'UN -> Stack 'BX -> Args -> IO (Stack 'UN, Stack 'BX)
moveArgs Stack 'UN
ustk Stack 'BX
bstk Args
args
  Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
acceptArgs Stack 'UN
ustk Int
ua
  Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
acceptArgs Stack 'BX
bstk Int
ba
  -- TODO: start putting references in `Call` if we ever start
  -- detecting saturated calls.
  CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Reference
dummyRef RSection
entry
  where
    (RComb CombIx
_ (Lam Int
ua Int
ba Int
uf Int
bf RSection
entry)) = RComb
rcomb
{-# INLINE enter #-}

-- fast path by-name delaying
name :: Stack 'UN -> Stack 'BX -> Args -> Closure -> IO (Stack 'BX)
name :: Stack 'UN -> Stack 'BX -> Args -> RClosure -> IO (Stack 'BX)
name !Stack 'UN
ustk !Stack 'BX
bstk !Args
args RClosure
clo = case RClosure
clo of
  PAp RComb
comb Seg 'UN
useg Seg 'BX
bseg -> do
    (ByteArray
useg, Array RClosure
bseg) <- Augment
-> Stack 'UN
-> Stack 'BX
-> Seg 'UN
-> Seg 'BX
-> Args
-> IO (Seg 'UN, Seg 'BX)
closeArgs Augment
I Stack 'UN
ustk Stack 'BX
bstk Seg 'UN
useg Seg 'BX
bseg Args
args
    Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
    Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Elem 'BX -> IO ()) -> Elem 'BX -> IO ()
forall a b. (a -> b) -> a -> b
$ RComb -> Seg 'UN -> Seg 'BX -> RClosure
forall comb. comb -> Seg 'UN -> Seg 'BX -> GClosure comb
PAp RComb
comb ByteArray
Seg 'UN
useg Array RClosure
Seg 'BX
bseg
    pure Stack 'BX
bstk
  RClosure
_ -> [Char] -> IO (Stack 'BX)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (Stack 'BX)) -> [Char] -> IO (Stack 'BX)
forall a b. (a -> b) -> a -> b
$ [Char]
"naming non-function: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RClosure -> [Char]
forall a. Show a => a -> [Char]
show RClosure
clo
{-# INLINE name #-}

-- slow path application
apply ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack 'UN ->
  Stack 'BX ->
  K ->
  Bool ->
  Args ->
  Closure ->
  IO ()
apply :: CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Bool
-> Args
-> RClosure
-> IO ()
apply !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k !Bool
ck !Args
args (PAp RComb
comb Seg 'UN
useg Seg 'BX
bseg) =
  case RComb -> GComb RComb
unRComb RComb
comb of
    Lam Int
ua Int
ba Int
uf Int
bf RSection
entry
      | Bool
ck Bool -> Bool -> Bool
|| Int
ua Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
uac Bool -> Bool -> Bool
&& Int
ba Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
bac -> do
          Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
ensure Stack 'UN
ustk Int
uf
          Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
ensure Stack 'BX
bstk Int
bf
          (Stack 'UN
ustk, Stack 'BX
bstk) <- Stack 'UN -> Stack 'BX -> Args -> IO (Stack 'UN, Stack 'BX)
moveArgs Stack 'UN
ustk Stack 'BX
bstk Args
args
          Stack 'UN
ustk <- Stack 'UN -> Seg 'UN -> Dump -> IO (Stack 'UN)
forall (b :: Mem).
MEM b =>
Stack b -> Seg b -> Dump -> IO (Stack b)
dumpSeg Stack 'UN
ustk Seg 'UN
useg Dump
A
          Stack 'BX
bstk <- Stack 'BX -> Seg 'BX -> Dump -> IO (Stack 'BX)
forall (b :: Mem).
MEM b =>
Stack b -> Seg b -> Dump -> IO (Stack b)
dumpSeg Stack 'BX
bstk Seg 'BX
bseg Dump
A
          Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
acceptArgs Stack 'UN
ustk Int
ua
          Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
acceptArgs Stack 'BX
bstk Int
ba
          CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k (RComb -> Reference
rCombRef RComb
comb) RSection
entry
      | Bool
otherwise -> do
          (ByteArray
useg, Array RClosure
bseg) <- Augment
-> Stack 'UN
-> Stack 'BX
-> Seg 'UN
-> Seg 'BX
-> Args
-> IO (Seg 'UN, Seg 'BX)
closeArgs Augment
C Stack 'UN
ustk Stack 'BX
bstk Seg 'UN
useg Seg 'BX
bseg Args
args
          Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame (Stack 'UN -> IO (Stack 'UN)) -> IO (Stack 'UN) -> IO (Stack 'UN)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
frameArgs Stack 'UN
ustk
          Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame (Stack 'BX -> IO (Stack 'BX)) -> IO (Stack 'BX) -> IO (Stack 'BX)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
frameArgs Stack 'BX
bstk
          Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
          Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (Elem 'BX -> IO ()) -> Elem 'BX -> IO ()
forall a b. (a -> b) -> a -> b
$ RComb -> Seg 'UN -> Seg 'BX -> RClosure
forall comb. comb -> Seg 'UN -> Seg 'BX -> GClosure comb
PAp RComb
comb ByteArray
Seg 'UN
useg Array RClosure
Seg 'BX
bseg
          CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> IO ()
yield CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k
  where
    uac :: Int
uac = Stack 'UN -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'UN
ustk Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Args -> Int
ucount Args
args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Seg 'UN -> Int
uscount Seg 'UN
useg
    bac :: Int
bac = Stack 'BX -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'BX
bstk Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Args -> Int
bcount Args
args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Seg 'BX -> Int
bscount Seg 'BX
bseg
apply !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k !Bool
_ !Args
args RClosure
clo
  | Args
ZArgs <- Args
args,
    Stack 'UN -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'UN
ustk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0,
    Stack 'BX -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'BX
bstk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'UN
ustk
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'BX
bstk
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
clo
      CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> IO ()
yield CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k
  | Bool
otherwise = [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"applying non-function: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RClosure -> [Char]
forall a. Show a => a -> [Char]
show RClosure
clo
{-# INLINE apply #-}

jump ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack 'UN ->
  Stack 'BX ->
  K ->
  Args ->
  Closure ->
  IO ()
jump :: CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Args
-> RClosure
-> IO ()
jump !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k !Args
args RClosure
clo = case RClosure
clo of
  Captured K
sk0 Int
ua Int
ba Seg 'UN
useg Seg 'BX
bseg -> do
    let (Int
up, Int
bp, K
sk) = K -> (Int, Int, K)
adjust K
sk0
    (ByteArray
useg, Array RClosure
bseg) <- Augment
-> Stack 'UN
-> Stack 'BX
-> Seg 'UN
-> Seg 'BX
-> Args
-> IO (Seg 'UN, Seg 'BX)
closeArgs Augment
K Stack 'UN
ustk Stack 'BX
bstk Seg 'UN
useg Seg 'BX
bseg Args
args
    Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'UN
ustk
    Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'BX
bstk
    Stack 'UN
ustk <- Stack 'UN -> Seg 'UN -> Dump -> IO (Stack 'UN)
forall (b :: Mem).
MEM b =>
Stack b -> Seg b -> Dump -> IO (Stack b)
dumpSeg Stack 'UN
ustk ByteArray
Seg 'UN
useg (Dump -> IO (Stack 'UN)) -> Dump -> IO (Stack 'UN)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Dump
F (Args -> Int
ucount Args
args) Int
ua
    Stack 'BX
bstk <- Stack 'BX -> Seg 'BX -> Dump -> IO (Stack 'BX)
forall (b :: Mem).
MEM b =>
Stack b -> Seg b -> Dump -> IO (Stack b)
dumpSeg Stack 'BX
bstk Array RClosure
Seg 'BX
bseg (Dump -> IO (Stack 'BX)) -> Dump -> IO (Stack 'BX)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Dump
F (Args -> Int
bcount Args
args) Int
ba
    Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
adjustArgs Stack 'UN
ustk Int
up
    Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
adjustArgs Stack 'BX
bstk Int
bp
    CCache
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> EnumMap Word64 RClosure
-> K
-> K
-> IO ()
repush CCache
env ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk EnumMap Word64 RClosure
denv K
sk K
k
  RClosure
_ -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
die [Char]
"jump: non-cont"
  where
    -- Adjusts a repushed continuation to account for pending arguments. If
    -- there are any frames in the pushed continuation, the nearest one needs to
    -- record the additional pending arguments.
    --
    -- If the repushed continuation has no frames, then the arguments are still
    -- pending, and the result stacks need to be adjusted. Hence the 3 results.
    adjust :: K -> (Int, Int, K)
adjust (Mark Int
ua Int
ba EnumSet Word64
rs EnumMap Word64 RClosure
denv K
k) =
      (Int
0, Int
0, Int -> Int -> EnumSet Word64 -> EnumMap Word64 RClosure -> K -> K
Mark (Int
ua Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Stack 'UN -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'UN
ustk) (Int
ba Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Stack 'BX -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'BX
bstk) EnumSet Word64
rs EnumMap Word64 RClosure
denv K
k)
    adjust (Push Int
un Int
bn Int
ua Int
ba RComb
cix K
k) =
      (Int
0, Int
0, Int -> Int -> Int -> Int -> RComb -> K -> K
Push Int
un Int
bn (Int
ua Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Stack 'UN -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'UN
ustk) (Int
ba Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Stack 'BX -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'BX
bstk) RComb
cix K
k)
    adjust K
k = (Stack 'UN -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'UN
ustk, Stack 'BX -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'BX
bstk, K
k)
{-# INLINE jump #-}

repush ::
  CCache ->
  ActiveThreads ->
  Stack 'UN ->
  Stack 'BX ->
  DEnv ->
  K ->
  K ->
  IO ()
repush :: CCache
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> EnumMap Word64 RClosure
-> K
-> K
-> IO ()
repush !CCache
env !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk = EnumMap Word64 RClosure -> K -> K -> IO ()
go
  where
    go :: EnumMap Word64 RClosure -> K -> K -> IO ()
go !EnumMap Word64 RClosure
denv K
KE !K
k = CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> IO ()
yield CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k
    go !EnumMap Word64 RClosure
denv (Mark Int
ua Int
ba EnumSet Word64
ps EnumMap Word64 RClosure
cs K
sk) !K
k = EnumMap Word64 RClosure -> K -> K -> IO ()
go EnumMap Word64 RClosure
denv' K
sk (K -> IO ()) -> K -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> EnumSet Word64 -> EnumMap Word64 RClosure -> K -> K
Mark Int
ua Int
ba EnumSet Word64
ps EnumMap Word64 RClosure
cs' K
k
      where
        denv' :: EnumMap Word64 RClosure
denv' = EnumMap Word64 RClosure
cs EnumMap Word64 RClosure
-> EnumMap Word64 RClosure -> EnumMap Word64 RClosure
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 RClosure
-> EnumSet Word64 -> EnumMap Word64 RClosure
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.withoutKeys EnumMap Word64 RClosure
denv EnumSet Word64
ps
        cs' :: EnumMap Word64 RClosure
cs' = EnumMap Word64 RClosure
-> EnumSet Word64 -> EnumMap Word64 RClosure
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys EnumMap Word64 RClosure
denv EnumSet Word64
ps
    go !EnumMap Word64 RClosure
denv (Push Int
un Int
bn Int
ua Int
ba RComb
nx K
sk) !K
k =
      EnumMap Word64 RClosure -> K -> K -> IO ()
go EnumMap Word64 RClosure
denv K
sk (K -> IO ()) -> K -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> RComb -> K -> K
Push Int
un Int
bn Int
ua Int
ba RComb
nx K
k
    go !EnumMap Word64 RClosure
_ (CB Callback
_) !K
_ = [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
die [Char]
"repush: impossible"
{-# INLINE repush #-}

moveArgs ::
  Stack 'UN ->
  Stack 'BX ->
  Args ->
  IO (Stack 'UN, Stack 'BX)
moveArgs :: Stack 'UN -> Stack 'BX -> Args -> IO (Stack 'UN, Stack 'BX)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk Args
ZArgs = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'UN
ustk
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'BX
bstk
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (DArgV Int
i Int
j) = do
  Stack 'UN
ustk <-
    if Int
ul Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then Stack 'UN -> Args' -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'UN
ustk (Int -> Int -> Args'
ArgR Int
0 Int
ul)
      else Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'UN
ustk
  Stack 'BX
bstk <-
    if Int
bl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then Stack 'BX -> Args' -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'BX
bstk (Int -> Int -> Args'
ArgR Int
0 Int
bl)
      else Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'BX
bstk
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
  where
    ul :: Int
ul = Stack 'UN -> Int
forall (b :: Mem). MEM b => Stack b -> Int
fsize Stack 'UN
ustk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i
    bl :: Int
bl = Stack 'BX -> Int
forall (b :: Mem). MEM b => Stack b -> Int
fsize Stack 'BX
bstk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (UArg1 Int
i) = do
  Stack 'UN
ustk <- Stack 'UN -> Args' -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'UN
ustk (Int -> Args'
Arg1 Int
i)
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'BX
bstk
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (UArg2 Int
i Int
j) = do
  Stack 'UN
ustk <- Stack 'UN -> Args' -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'UN
ustk (Int -> Int -> Args'
Arg2 Int
i Int
j)
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'BX
bstk
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (UArgR Int
i Int
l) = do
  Stack 'UN
ustk <- Stack 'UN -> Args' -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'UN
ustk (Int -> Int -> Args'
ArgR Int
i Int
l)
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'BX
bstk
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (BArg1 Int
i) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'UN
ustk
  Stack 'BX
bstk <- Stack 'BX -> Args' -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'BX
bstk (Int -> Args'
Arg1 Int
i)
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (BArg2 Int
i Int
j) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'UN
ustk
  Stack 'BX
bstk <- Stack 'BX -> Args' -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'BX
bstk (Int -> Int -> Args'
Arg2 Int
i Int
j)
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (BArgR Int
i Int
l) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'UN
ustk
  Stack 'BX
bstk <- Stack 'BX -> Args' -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'BX
bstk (Int -> Int -> Args'
ArgR Int
i Int
l)
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (DArg2 Int
i Int
j) = do
  Stack 'UN
ustk <- Stack 'UN -> Args' -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'UN
ustk (Int -> Args'
Arg1 Int
i)
  Stack 'BX
bstk <- Stack 'BX -> Args' -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'BX
bstk (Int -> Args'
Arg1 Int
j)
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (DArgR Int
ui Int
ul Int
bi Int
bl) = do
  Stack 'UN
ustk <- Stack 'UN -> Args' -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'UN
ustk (Int -> Int -> Args'
ArgR Int
ui Int
ul)
  Stack 'BX
bstk <- Stack 'BX -> Args' -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'BX
bstk (Int -> Int -> Args'
ArgR Int
bi Int
bl)
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (UArgN PrimArray Int
as) = do
  Stack 'UN
ustk <- Stack 'UN -> Args' -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'UN
ustk (PrimArray Int -> Args'
ArgN PrimArray Int
as)
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'BX
bstk
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (BArgN PrimArray Int
as) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
discardFrame Stack 'UN
ustk
  Stack 'BX
bstk <- Stack 'BX -> Args' -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'BX
bstk (PrimArray Int -> Args'
ArgN PrimArray Int
as)
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
moveArgs !Stack 'UN
ustk !Stack 'BX
bstk (DArgN PrimArray Int
us PrimArray Int
bs) = do
  Stack 'UN
ustk <- Stack 'UN -> Args' -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'UN
ustk (PrimArray Int -> Args'
ArgN PrimArray Int
us)
  Stack 'BX
bstk <- Stack 'BX -> Args' -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Args' -> IO (Stack b)
prepareArgs Stack 'BX
bstk (PrimArray Int -> Args'
ArgN PrimArray Int
bs)
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
{-# INLINE moveArgs #-}

closureArgs :: Stack 'BX -> Args -> IO [Closure]
closureArgs :: Stack 'BX -> Args -> IO [RClosure]
closureArgs !Stack 'BX
_ Args
ZArgs = [RClosure] -> IO [RClosure]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
closureArgs !Stack 'BX
bstk (BArg1 Int
i) = do
  RClosure
x <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  pure [RClosure
x]
closureArgs !Stack 'BX
bstk (BArg2 Int
i Int
j) = do
  RClosure
x <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  RClosure
y <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
j
  pure [RClosure
x, RClosure
y]
closureArgs !Stack 'BX
bstk (BArgR Int
i Int
l) =
  [Int] -> (Int -> IO RClosure) -> IO [RClosure]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
l [Int
i ..]) (Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk)
closureArgs !Stack 'BX
bstk (BArgN PrimArray Int
bs) =
  [Int] -> (Int -> IO RClosure) -> IO [RClosure]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (PrimArray Int -> [Int]
forall a. Prim a => PrimArray a -> [a]
PA.primArrayToList PrimArray Int
bs) (Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk)
closureArgs !Stack 'BX
_ Args
_ =
  [Char] -> IO [RClosure]
forall a. HasCallStack => [Char] -> a
error [Char]
"closure arguments can only be boxed."
{-# INLINE closureArgs #-}

buildData ::
  Stack 'UN -> Stack 'BX -> Reference -> Tag -> Args -> IO Closure
buildData :: Stack 'UN
-> Stack 'BX -> Reference -> Word64 -> Args -> IO RClosure
buildData !Stack 'UN
_ !Stack 'BX
_ !Reference
r !Word64
t Args
ZArgs = RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure) -> RClosure -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Word64 -> RClosure
forall comb. Reference -> Word64 -> GClosure comb
Enum Reference
r Word64
t
buildData !Stack 'UN
ustk !Stack 'BX
_ !Reference
r !Word64
t (UArg1 Int
i) = do
  Int
x <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  pure $ Reference -> Word64 -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> GClosure comb
DataU1 Reference
r Word64
t Int
x
buildData !Stack 'UN
ustk !Stack 'BX
_ !Reference
r !Word64
t (UArg2 Int
i Int
j) = do
  Int
x <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Int
y <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  pure $ Reference -> Word64 -> Int -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> Int -> GClosure comb
DataU2 Reference
r Word64
t Int
x Int
y
buildData !Stack 'UN
_ !Stack 'BX
bstk !Reference
r !Word64
t (BArg1 Int
i) = do
  RClosure
x <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  pure $ Reference -> Word64 -> RClosure -> RClosure
forall comb. Reference -> Word64 -> GClosure comb -> GClosure comb
DataB1 Reference
r Word64
t RClosure
x
buildData !Stack 'UN
_ !Stack 'BX
bstk !Reference
r !Word64
t (BArg2 Int
i Int
j) = do
  RClosure
x <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  RClosure
y <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
j
  pure $ Reference -> Word64 -> RClosure -> RClosure -> RClosure
forall comb.
Reference
-> Word64 -> GClosure comb -> GClosure comb -> GClosure comb
DataB2 Reference
r Word64
t RClosure
x RClosure
y
buildData !Stack 'UN
ustk !Stack 'BX
bstk !Reference
r !Word64
t (DArg2 Int
i Int
j) = do
  Int
x <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  RClosure
y <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
j
  pure $ Reference -> Word64 -> Int -> RClosure -> RClosure
forall comb.
Reference -> Word64 -> Int -> GClosure comb -> GClosure comb
DataUB Reference
r Word64
t Int
x RClosure
y
buildData !Stack 'UN
ustk !Stack 'BX
_ !Reference
r !Word64
t (UArgR Int
i Int
l) = do
  ByteArray
useg <- Augment -> Stack 'UN -> Seg 'UN -> Maybe Args' -> IO (Seg 'UN)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
I Stack 'UN
ustk Seg 'UN
unull (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
i Int
l)
  pure $ Reference -> Word64 -> Seg 'UN -> Seg 'BX -> RClosure
forall comb.
Reference -> Word64 -> Seg 'UN -> Seg 'BX -> GClosure comb
DataG Reference
r Word64
t ByteArray
Seg 'UN
useg Seg 'BX
bnull
buildData !Stack 'UN
_ !Stack 'BX
bstk !Reference
r !Word64
t (BArgR Int
i Int
l) = do
  Array RClosure
bseg <- Augment -> Stack 'BX -> Seg 'BX -> Maybe Args' -> IO (Seg 'BX)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
I Stack 'BX
bstk Seg 'BX
bnull (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
i Int
l)
  pure $ Reference -> Word64 -> Seg 'UN -> Seg 'BX -> RClosure
forall comb.
Reference -> Word64 -> Seg 'UN -> Seg 'BX -> GClosure comb
DataG Reference
r Word64
t Seg 'UN
unull Array RClosure
Seg 'BX
bseg
buildData !Stack 'UN
ustk !Stack 'BX
bstk !Reference
r !Word64
t (DArgR Int
ui Int
ul Int
bi Int
bl) = do
  ByteArray
useg <- Augment -> Stack 'UN -> Seg 'UN -> Maybe Args' -> IO (Seg 'UN)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
I Stack 'UN
ustk Seg 'UN
unull (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
ui Int
ul)
  Array RClosure
bseg <- Augment -> Stack 'BX -> Seg 'BX -> Maybe Args' -> IO (Seg 'BX)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
I Stack 'BX
bstk Seg 'BX
bnull (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
bi Int
bl)
  pure $ Reference -> Word64 -> Seg 'UN -> Seg 'BX -> RClosure
forall comb.
Reference -> Word64 -> Seg 'UN -> Seg 'BX -> GClosure comb
DataG Reference
r Word64
t ByteArray
Seg 'UN
useg Array RClosure
Seg 'BX
bseg
buildData !Stack 'UN
ustk !Stack 'BX
_ !Reference
r !Word64
t (UArgN PrimArray Int
as) = do
  ByteArray
useg <- Augment -> Stack 'UN -> Seg 'UN -> Maybe Args' -> IO (Seg 'UN)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
I Stack 'UN
ustk Seg 'UN
unull (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Args'
ArgN PrimArray Int
as)
  pure $ Reference -> Word64 -> Seg 'UN -> Seg 'BX -> RClosure
forall comb.
Reference -> Word64 -> Seg 'UN -> Seg 'BX -> GClosure comb
DataG Reference
r Word64
t ByteArray
Seg 'UN
useg Seg 'BX
bnull
buildData !Stack 'UN
_ !Stack 'BX
bstk !Reference
r !Word64
t (BArgN PrimArray Int
as) = do
  Array RClosure
bseg <- Augment -> Stack 'BX -> Seg 'BX -> Maybe Args' -> IO (Seg 'BX)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
I Stack 'BX
bstk Seg 'BX
bnull (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Args'
ArgN PrimArray Int
as)
  pure $ Reference -> Word64 -> Seg 'UN -> Seg 'BX -> RClosure
forall comb.
Reference -> Word64 -> Seg 'UN -> Seg 'BX -> GClosure comb
DataG Reference
r Word64
t Seg 'UN
unull Array RClosure
Seg 'BX
bseg
buildData !Stack 'UN
ustk !Stack 'BX
bstk !Reference
r !Word64
t (DArgN PrimArray Int
us PrimArray Int
bs) = do
  ByteArray
useg <- Augment -> Stack 'UN -> Seg 'UN -> Maybe Args' -> IO (Seg 'UN)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
I Stack 'UN
ustk Seg 'UN
unull (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Args'
ArgN PrimArray Int
us)
  Array RClosure
bseg <- Augment -> Stack 'BX -> Seg 'BX -> Maybe Args' -> IO (Seg 'BX)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
I Stack 'BX
bstk Seg 'BX
bnull (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Args'
ArgN PrimArray Int
bs)
  pure $ Reference -> Word64 -> Seg 'UN -> Seg 'BX -> RClosure
forall comb.
Reference -> Word64 -> Seg 'UN -> Seg 'BX -> GClosure comb
DataG Reference
r Word64
t ByteArray
Seg 'UN
useg Array RClosure
Seg 'BX
bseg
buildData !Stack 'UN
ustk !Stack 'BX
bstk !Reference
r !Word64
t (DArgV Int
ui Int
bi) = do
  ByteArray
useg <-
    if Int
ul Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then Augment -> Stack 'UN -> Seg 'UN -> Maybe Args' -> IO (Seg 'UN)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
I Stack 'UN
ustk Seg 'UN
unull (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
0 Int
ul)
      else ByteArray -> IO ByteArray
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteArray
Seg 'UN
unull
  Array RClosure
bseg <-
    if Int
bl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then Augment -> Stack 'BX -> Seg 'BX -> Maybe Args' -> IO (Seg 'BX)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
I Stack 'BX
bstk Seg 'BX
bnull (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
0 Int
bl)
      else Array RClosure -> IO (Array RClosure)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Array RClosure
Seg 'BX
bnull
  pure $ Reference -> Word64 -> Seg 'UN -> Seg 'BX -> RClosure
forall comb.
Reference -> Word64 -> Seg 'UN -> Seg 'BX -> GClosure comb
DataG Reference
r Word64
t ByteArray
Seg 'UN
useg Array RClosure
Seg 'BX
bseg
  where
    ul :: Int
ul = Stack 'UN -> Int
forall (b :: Mem). MEM b => Stack b -> Int
fsize Stack 'UN
ustk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ui
    bl :: Int
bl = Stack 'BX -> Int
forall (b :: Mem). MEM b => Stack b -> Int
fsize Stack 'BX
bstk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bi
{-# INLINE buildData #-}

-- Dumps a data type closure to the stack without writing its tag.
-- Instead, the tag is returned for direct case analysis.
dumpDataNoTag ::
  Maybe Reference ->
  Stack 'UN ->
  Stack 'BX ->
  Closure ->
  IO (Word64, Stack 'UN, Stack 'BX)
dumpDataNoTag :: Maybe Reference
-> Stack 'UN
-> Stack 'BX
-> RClosure
-> IO (Word64, Stack 'UN, Stack 'BX)
dumpDataNoTag !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (Enum Reference
_ Word64
t) = (Word64, Stack 'UN, Stack 'BX) -> IO (Word64, Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64
t, Stack 'UN
ustk, Stack 'BX
bstk)
dumpDataNoTag !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataU1 Reference
_ Word64
t Int
x) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
x
  pure (Word64
t, Stack 'UN
ustk, Stack 'BX
bstk)
dumpDataNoTag !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataU2 Reference
_ Word64
t Int
x Int
y) = do
  Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
2
  Stack 'UN -> Int -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'UN
ustk Int
1 Int
Elem 'UN
y
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
x
  pure (Word64
t, Stack 'UN
ustk, Stack 'BX
bstk)
dumpDataNoTag !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataB1 Reference
_ Word64
t RClosure
x) = do
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
x
  pure (Word64
t, Stack 'UN
ustk, Stack 'BX
bstk)
dumpDataNoTag !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataB2 Reference
_ Word64
t RClosure
x RClosure
y) = do
  Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'BX
bstk Int
2
  Stack 'BX -> Int -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'BX
bstk Int
1 Elem 'BX
RClosure
y
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
x
  pure (Word64
t, Stack 'UN
ustk, Stack 'BX
bstk)
dumpDataNoTag !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataUB Reference
_ Word64
t Int
x RClosure
y) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
x
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
y
  pure (Word64
t, Stack 'UN
ustk, Stack 'BX
bstk)
dumpDataNoTag !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataG Reference
_ Word64
t Seg 'UN
us Seg 'BX
bs) = do
  Stack 'UN
ustk <- Stack 'UN -> Seg 'UN -> Dump -> IO (Stack 'UN)
forall (b :: Mem).
MEM b =>
Stack b -> Seg b -> Dump -> IO (Stack b)
dumpSeg Stack 'UN
ustk Seg 'UN
us Dump
S
  Stack 'BX
bstk <- Stack 'BX -> Seg 'BX -> Dump -> IO (Stack 'BX)
forall (b :: Mem).
MEM b =>
Stack b -> Seg b -> Dump -> IO (Stack b)
dumpSeg Stack 'BX
bstk Seg 'BX
bs Dump
S
  pure (Word64
t, Stack 'UN
ustk, Stack 'BX
bstk)
dumpDataNoTag !Maybe Reference
mr !Stack 'UN
_ !Stack 'BX
_ RClosure
clo =
  [Char] -> IO (Word64, Stack 'UN, Stack 'BX)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (Word64, Stack 'UN, Stack 'BX))
-> [Char] -> IO (Word64, Stack 'UN, Stack 'BX)
forall a b. (a -> b) -> a -> b
$
    [Char]
"dumpDataNoTag: bad closure: "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RClosure -> [Char]
forall a. Show a => a -> [Char]
show RClosure
clo
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> (Reference -> [Char]) -> Maybe Reference -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\Reference
r -> [Char]
"\nexpected type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r) Maybe Reference
mr
{-# INLINE dumpDataNoTag #-}

dumpData ::
  Maybe Reference ->
  Stack 'UN ->
  Stack 'BX ->
  Closure ->
  IO (Stack 'UN, Stack 'BX)
dumpData :: Maybe Reference
-> Stack 'UN -> Stack 'BX -> RClosure -> IO (Stack 'UN, Stack 'BX)
dumpData !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (Enum Reference
_ Word64
t) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
maskTags Word64
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
dumpData !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataU1 Reference
_ Word64
t Int
x) = do
  Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
2
  Stack 'UN -> Int -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'UN
ustk Int
1 Int
Elem 'UN
x
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
maskTags Word64
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
dumpData !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataU2 Reference
_ Word64
t Int
x Int
y) = do
  Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
3
  Stack 'UN -> Int -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'UN
ustk Int
2 Int
Elem 'UN
y
  Stack 'UN -> Int -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'UN
ustk Int
1 Int
Elem 'UN
x
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
maskTags Word64
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
dumpData !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataB1 Reference
_ Word64
t RClosure
x) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
x
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
maskTags Word64
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
dumpData !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataB2 Reference
_ Word64
t RClosure
x RClosure
y) = do
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'BX
bstk Int
2
  Stack 'BX -> Int -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'BX
bstk Int
1 Elem 'BX
RClosure
y
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
x
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
maskTags Word64
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
dumpData !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataUB Reference
_ Word64
t Int
x RClosure
y) = do
  Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
2
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'UN -> Int -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'UN
ustk Int
1 Int
Elem 'UN
x
  Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
y
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
maskTags Word64
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
dumpData !Maybe Reference
_ !Stack 'UN
ustk !Stack 'BX
bstk (DataG Reference
_ Word64
t Seg 'UN
us Seg 'BX
bs) = do
  Stack 'UN
ustk <- Stack 'UN -> Seg 'UN -> Dump -> IO (Stack 'UN)
forall (b :: Mem).
MEM b =>
Stack b -> Seg b -> Dump -> IO (Stack b)
dumpSeg Stack 'UN
ustk Seg 'UN
us Dump
S
  Stack 'BX
bstk <- Stack 'BX -> Seg 'BX -> Dump -> IO (Stack 'BX)
forall (b :: Mem).
MEM b =>
Stack b -> Seg b -> Dump -> IO (Stack b)
dumpSeg Stack 'BX
bstk Seg 'BX
bs Dump
S
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
maskTags Word64
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
dumpData !Maybe Reference
mr !Stack 'UN
_ !Stack 'BX
_ RClosure
clo =
  [Char] -> IO (Stack 'UN, Stack 'BX)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (Stack 'UN, Stack 'BX))
-> [Char] -> IO (Stack 'UN, Stack 'BX)
forall a b. (a -> b) -> a -> b
$
    [Char]
"dumpData: bad closure: "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RClosure -> [Char]
forall a. Show a => a -> [Char]
show RClosure
clo
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> (Reference -> [Char]) -> Maybe Reference -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\Reference
r -> [Char]
"\nexpected type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r) Maybe Reference
mr
{-# INLINE dumpData #-}

-- Note: although the representation allows it, it is impossible
-- to under-apply one sort of argument while over-applying the
-- other. Thus, it is unnecessary to worry about doing tricks to
-- only grab a certain number of arguments.
closeArgs ::
  Augment ->
  Stack 'UN ->
  Stack 'BX ->
  Seg 'UN ->
  Seg 'BX ->
  Args ->
  IO (Seg 'UN, Seg 'BX)
closeArgs :: Augment
-> Stack 'UN
-> Stack 'BX
-> Seg 'UN
-> Seg 'BX
-> Args
-> IO (Seg 'UN, Seg 'BX)
closeArgs Augment
mode !Stack 'UN
ustk !Stack 'BX
bstk !Seg 'UN
useg !Seg 'BX
bseg Args
args =
  (,)
    (ByteArray -> Array RClosure -> (ByteArray, Array RClosure))
-> IO ByteArray
-> IO (Array RClosure -> (ByteArray, Array RClosure))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Augment -> Stack 'UN -> Seg 'UN -> Maybe Args' -> IO (Seg 'UN)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
mode Stack 'UN
ustk Seg 'UN
useg Maybe Args'
uargs
    IO (Array RClosure -> (ByteArray, Array RClosure))
-> IO (Array RClosure) -> IO (ByteArray, Array RClosure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Augment -> Stack 'BX -> Seg 'BX -> Maybe Args' -> IO (Seg 'BX)
forall (b :: Mem).
MEM b =>
Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b)
augSeg Augment
mode Stack 'BX
bstk Seg 'BX
bseg Maybe Args'
bargs
  where
    (Maybe Args'
uargs, Maybe Args'
bargs) = case Args
args of
      Args
ZArgs -> (Maybe Args'
forall a. Maybe a
Nothing, Maybe Args'
forall a. Maybe a
Nothing)
      UArg1 Int
i -> (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Args'
Arg1 Int
i, Maybe Args'
forall a. Maybe a
Nothing)
      BArg1 Int
i -> (Maybe Args'
forall a. Maybe a
Nothing, Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Args'
Arg1 Int
i)
      UArg2 Int
i Int
j -> (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
Arg2 Int
i Int
j, Maybe Args'
forall a. Maybe a
Nothing)
      BArg2 Int
i Int
j -> (Maybe Args'
forall a. Maybe a
Nothing, Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
Arg2 Int
i Int
j)
      UArgR Int
i Int
l -> (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
i Int
l, Maybe Args'
forall a. Maybe a
Nothing)
      BArgR Int
i Int
l -> (Maybe Args'
forall a. Maybe a
Nothing, Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
i Int
l)
      DArg2 Int
i Int
j -> (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Args'
Arg1 Int
i, Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Args'
Arg1 Int
j)
      DArgR Int
ui Int
ul Int
bi Int
bl -> (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
ui Int
ul, Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
bi Int
bl)
      UArgN PrimArray Int
as -> (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Args'
ArgN PrimArray Int
as, Maybe Args'
forall a. Maybe a
Nothing)
      BArgN PrimArray Int
as -> (Maybe Args'
forall a. Maybe a
Nothing, Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Args'
ArgN PrimArray Int
as)
      DArgN PrimArray Int
us PrimArray Int
bs -> (Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Args'
ArgN PrimArray Int
us, Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Args'
ArgN PrimArray Int
bs)
      DArgV Int
ui Int
bi -> (Maybe Args'
ua, Maybe Args'
ba)
        where
          ua :: Maybe Args'
ua
            | Int
ul Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
0 Int
ul
            | Bool
otherwise = Maybe Args'
forall a. Maybe a
Nothing
          ba :: Maybe Args'
ba
            | Int
bl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Args' -> Maybe Args'
forall a. a -> Maybe a
Just (Args' -> Maybe Args') -> Args' -> Maybe Args'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args'
ArgR Int
0 Int
bl
            | Bool
otherwise = Maybe Args'
forall a. Maybe a
Nothing
          ul :: Int
ul = Stack 'UN -> Int
forall (b :: Mem). MEM b => Stack b -> Int
fsize Stack 'UN
ustk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ui
          bl :: Int
bl = Stack 'BX -> Int
forall (b :: Mem). MEM b => Stack b -> Int
fsize Stack 'BX
bstk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bi

peekForeign :: Stack 'BX -> Int -> IO a
peekForeign :: forall a. Stack 'BX -> Int -> IO a
peekForeign Stack 'BX
bstk Int
i =
  Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i IO RClosure -> (RClosure -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Foreign Foreign
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ Foreign -> a
forall a. Foreign -> a
unwrapForeign Foreign
x
    RClosure
_ -> [Char] -> IO a
forall a. HasCallStack => [Char] -> IO a
die [Char]
"bad foreign argument"
{-# INLINE peekForeign #-}

uprim1 :: Stack 'UN -> UPrim1 -> Int -> IO (Stack 'UN)
uprim1 :: Stack 'UN -> UPrim1 -> Int -> IO (Stack 'UN)
uprim1 !Stack 'UN
ustk UPrim1
DECI !Int
i = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
INCI !Int
i = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
NEGI !Int
i = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (-Int
m)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
SGNI !Int
i = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int -> Int
forall a. Num a => a -> a
signum Int
m)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
ABSF !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Num a => a -> a
abs Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
CEIL !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
FLOR !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
TRNF !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
RNDF !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
EXPF !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
exp Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
LOGF !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
log Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
SQRT !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
sqrt Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
COSF !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
cos Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
SINF !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
sin Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
TANF !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
tan Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
COSH !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
cosh Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
SINH !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
sinh Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
TANH !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
tanh Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
ACOS !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
acos Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
ASIN !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
asin Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
ATAN !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
atan Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
ASNH !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
asinh Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
ACSH !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
acosh Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
ATNH !Int
i = do
  Double
d <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double
forall a. Floating a => a -> a
atanh Double
d)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
ITOF !Int
i = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
NTOF !Int
i = do
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
LZRO !Int
i = do
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Word64 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros Word64
n)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
TZRO !Int
i = do
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Word64 -> Int
forall b. FiniteBits b => b -> Int
countTrailingZeros Word64
n)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
POPC !Int
i = do
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Word64 -> Int
forall a. Bits a => a -> Int
popCount Word64
n)
  pure Stack 'UN
ustk
uprim1 !Stack 'UN
ustk UPrim1
COMN !Int
i = do
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64 -> Word64
forall a. Bits a => a -> a
complement Word64
n)
  pure Stack 'UN
ustk
{-# INLINE uprim1 #-}

uprim2 :: Stack 'UN -> UPrim2 -> Int -> Int -> IO (Stack 'UN)
uprim2 :: Stack 'UN -> UPrim2 -> Int -> Int -> IO (Stack 'UN)
uprim2 !Stack 'UN
ustk UPrim2
ADDI !Int
i !Int
j = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
SUBI !Int
i !Int
j = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
MULI !Int
i !Int
j = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
DIVI !Int
i !Int
j = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
MODI !Int
i !Int
j = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
SHLI !Int
i !Int
j = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int
m Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
SHRI !Int
i !Int
j = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int
m Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
SHRN !Int
i !Int
j = do
  Word64
m <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64
m Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
POWI !Int
i !Int
j = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Int
m Int -> Word64 -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Word64
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
EQLI !Int
i !Int
j = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n then Int
Elem 'UN
1 else Int
Elem 'UN
0
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
LEQI !Int
i !Int
j = do
  Int
m <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n then Int
Elem 'UN
1 else Int
Elem 'UN
0
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
LEQN !Int
i !Int
j = do
  Word64
m <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ if Word64
m Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
n then Int
Elem 'UN
1 else Int
Elem 'UN
0
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
DIVN !Int
i !Int
j = do
  Word64
m <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64
m Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
MODN !Int
i !Int
j = do
  Word64
m <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64
m Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
n)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
ADDF !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
SUBF !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
MULF !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
DIVF !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
LOGB !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
x Double
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
POWF !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double
x Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
MAXF !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
x Double
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
MINF !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
x Double
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
EQLF !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (if Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
y then Int
Elem 'UN
1 else Int
Elem 'UN
0)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
LEQF !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (if Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
y then Int
Elem 'UN
1 else Int
Elem 'UN
0)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
ATN2 !Int
i !Int
j = do
  Double
x <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Double
y <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Double -> IO ()
pokeD Stack 'UN
ustk (Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 Double
x Double
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
ANDN !Int
i !Int
j = do
  Word64
x <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Word64
y <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
IORN !Int
i !Int
j = do
  Word64
x <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Word64
y <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
y)
  pure Stack 'UN
ustk
uprim2 !Stack 'UN
ustk UPrim2
XORN !Int
i !Int
j = do
  Word64
x <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Word64
y <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Word64 -> IO ()
pokeN Stack 'UN
ustk (Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
xor Word64
x Word64
y)
  pure Stack 'UN
ustk
{-# INLINE uprim2 #-}

bprim1 ::
  Stack 'UN ->
  Stack 'BX ->
  BPrim1 ->
  Int ->
  IO (Stack 'UN, Stack 'BX)
bprim1 :: Stack 'UN
-> Stack 'BX -> BPrim1 -> Int -> IO (Stack 'UN, Stack 'BX)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
SIZT Int
i = do
  Text
t <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Int
Util.Text.size Text
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
SIZS Int
i = do
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ Seq RClosure -> Int
forall a. Seq a -> Int
Sq.length Seq RClosure
s
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
ITOT Int
i = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Text -> IO ()) -> ([Char] -> Text) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Util.Text.pack ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
NTOT Int
i = do
  Word64
n <- Stack 'UN -> Int -> IO Word64
peekOffN Stack 'UN
ustk Int
i
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Text -> IO ()) -> ([Char] -> Text) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Util.Text.pack ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
FTOT Int
i = do
  Double
f <- Stack 'UN -> Int -> IO Double
peekOffD Stack 'UN
ustk Int
i
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Text -> IO ()) -> ([Char] -> Text) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Util.Text.pack ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
f
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
USNC Int
i =
  Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i IO Text
-> (Text -> IO (Stack 'UN, Stack 'BX)) -> IO (Stack 'UN, Stack 'BX)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t -> case Text -> Maybe (Text, Char)
Util.Text.unsnoc Text
t of
    Maybe (Text, Char)
Nothing -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
    Just (Text
t, Char
c) -> do
      Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
2
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      Stack 'UN -> Int -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'UN
ustk Int
1 (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
      Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk Text
t
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
UCNS Int
i =
  Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i IO Text
-> (Text -> IO (Stack 'UN, Stack 'BX)) -> IO (Stack 'UN, Stack 'BX)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t -> case Text -> Maybe (Char, Text)
Util.Text.uncons Text
t of
    Maybe (Char, Text)
Nothing -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
    Just (Char
c, Text
t) -> do
      Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
2
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      Stack 'UN -> Int -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'UN
ustk Int
1 (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
      Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk Text
t
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
TTOI Int
i =
  Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i IO Text
-> (Text -> IO (Stack 'UN, Stack 'BX)) -> IO (Stack 'UN, Stack 'BX)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t -> case [Char] -> Maybe Integer
forall {a}. Read a => [Char] -> Maybe a
readm ([Char] -> Maybe Integer) -> [Char] -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Util.Text.unpack Text
t of
    Just Integer
n
      | Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
minBound :: Int) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
        Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int) -> do
          Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
2
          Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
          Stack 'UN -> Int -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'UN
ustk Int
1 (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
          pure (Stack 'UN
ustk, Stack 'BX
bstk)
    Maybe Integer
_ -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
  where
    readm :: [Char] -> Maybe a
readm (Char
'+' : [Char]
s) = [Char] -> Maybe a
forall {a}. Read a => [Char] -> Maybe a
readMaybe [Char]
s
    readm [Char]
s = [Char] -> Maybe a
forall {a}. Read a => [Char] -> Maybe a
readMaybe [Char]
s
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
TTON Int
i =
  Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i IO Text
-> (Text -> IO (Stack 'UN, Stack 'BX)) -> IO (Stack 'UN, Stack 'BX)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t -> case [Char] -> Maybe Integer
forall {a}. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe Integer) -> [Char] -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Util.Text.unpack Text
t of
    Just Integer
n
      | Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
        Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
forall a. Bounded a => a
maxBound :: Word) -> do
          Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
2
          Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
          Stack 'UN -> Int -> Word64 -> IO ()
pokeOffN Stack 'UN
ustk Int
1 (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
n)
          pure (Stack 'UN
ustk, Stack 'BX
bstk)
    Maybe Integer
_ -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
TTOF Int
i =
  Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i IO Text
-> (Text -> IO (Stack 'UN, Stack 'BX)) -> IO (Stack 'UN, Stack 'BX)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t -> case [Char] -> Maybe Double
forall {a}. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe Double) -> [Char] -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Util.Text.unpack Text
t of
    Maybe Double
Nothing -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
    Just Double
f -> do
      Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
2
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
      Stack 'UN -> Int -> Double -> IO ()
pokeOffD Stack 'UN
ustk Int
1 Double
f
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
VWLS Int
i =
  Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i IO (Seq RClosure)
-> (Seq RClosure -> IO (Stack 'UN, Stack 'BX))
-> IO (Stack 'UN, Stack 'BX)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Seq RClosure
Sq.Empty -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
    RClosure
x Sq.:<| Seq RClosure
xs -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
      Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'BX
bstk Int
2
      Stack 'BX -> Int -> Seq RClosure -> IO ()
pokeOffS Stack 'BX
bstk Int
1 Seq RClosure
xs
      Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
x
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
VWRS Int
i =
  Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i IO (Seq RClosure)
-> (Seq RClosure -> IO (Stack 'UN, Stack 'BX))
-> IO (Stack 'UN, Stack 'BX)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Seq RClosure
Sq.Empty -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
    Seq RClosure
xs Sq.:|> RClosure
x -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
      Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'BX
bstk Int
2
      Stack 'BX -> Int -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Int -> Elem b -> IO ()
pokeOff Stack 'BX
bstk Int
1 Elem 'BX
RClosure
x
      Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk Seq RClosure
xs
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
PAKT Int
i = do
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Text -> IO ()) -> (Seq Char -> Text) -> Seq Char -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Util.Text.pack ([Char] -> Text) -> (Seq Char -> [Char]) -> Seq Char -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Char -> [Char]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Char -> IO ()) -> Seq Char -> IO ()
forall a b. (a -> b) -> a -> b
$ RClosure -> Char
forall {a} {comb}. (Enum a, Show comb) => GClosure comb -> a
clo2char (RClosure -> Char) -> Seq RClosure -> Seq Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq RClosure
s
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
  where
    clo2char :: GClosure comb -> a
clo2char (DataU1 Reference
_ Word64
t Int
i) | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
charTag = Int -> a
forall a. Enum a => Int -> a
toEnum Int
i
    clo2char GClosure comb
c = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"pack text: non-character closure: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GClosure comb -> [Char]
forall a. Show a => a -> [Char]
show GClosure comb
c
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
UPKT Int
i = do
  Text
t <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk
    (Seq RClosure -> IO ()) -> (Text -> Seq RClosure) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RClosure] -> Seq RClosure
forall a. [a] -> Seq a
Sq.fromList
    ([RClosure] -> Seq RClosure)
-> (Text -> [RClosure]) -> Text -> Seq RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> RClosure) -> [Char] -> [RClosure]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Reference -> Word64 -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> GClosure comb
DataU1 Reference
Rf.charRef Word64
charTag (Int -> RClosure) -> (Char -> Int) -> Char -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum)
    ([Char] -> [RClosure]) -> (Text -> [Char]) -> Text -> [RClosure]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Util.Text.unpack
    (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
PAKB Int
i = do
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Bytes -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Bytes -> IO ()) -> ([RClosure] -> Bytes) -> [RClosure] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Bytes
By.fromWord8s ([Word8] -> Bytes)
-> ([RClosure] -> [Word8]) -> [RClosure] -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RClosure -> Word8) -> [RClosure] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RClosure -> Word8
forall {a} {comb}. (Enum a, Show comb) => GClosure comb -> a
clo2w8 ([RClosure] -> IO ()) -> [RClosure] -> IO ()
forall a b. (a -> b) -> a -> b
$ Seq RClosure -> [RClosure]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq RClosure
s
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
  where
    clo2w8 :: GClosure comb -> a
clo2w8 (DataU1 Reference
_ Word64
t Int
n) | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
natTag = Int -> a
forall a. Enum a => Int -> a
toEnum Int
n
    clo2w8 GClosure comb
c = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"pack bytes: non-natural closure: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GClosure comb -> [Char]
forall a. Show a => a -> [Char]
show GClosure comb
c
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
UPKB Int
i = do
  Bytes
b <- Stack 'BX -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk (Seq RClosure -> IO ())
-> ([Word8] -> Seq RClosure) -> [Word8] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RClosure] -> Seq RClosure
forall a. [a] -> Seq a
Sq.fromList ([RClosure] -> Seq RClosure)
-> ([Word8] -> [RClosure]) -> [Word8] -> Seq RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> RClosure) -> [Word8] -> [RClosure]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Reference -> Word64 -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> GClosure comb
DataU1 Reference
Rf.natRef Word64
natTag (Int -> RClosure) -> (Word8 -> Int) -> Word8 -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum) ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
    Bytes -> [Word8]
By.toWord8s Bytes
b
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
SIZB Int
i = do
  Bytes
b <- Stack 'BX -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ Bytes -> Int
By.size Bytes
b
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
FLTB Int
i = do
  Bytes
b <- Stack 'BX -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Bytes -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Bytes -> IO ()) -> Bytes -> IO ()
forall a b. (a -> b) -> a -> b
$ Bytes -> Bytes
By.flatten Bytes
b
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
-- impossible
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
MISS Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
CACH Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
LKUP Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
CVLD Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
TLTT Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
LOAD Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
VALU Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
DBTX Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim1 !Stack 'UN
ustk !Stack 'BX
bstk BPrim1
SDBL Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk)
{-# INLINE bprim1 #-}

bprim2 ::
  Stack 'UN ->
  Stack 'BX ->
  BPrim2 ->
  Int ->
  Int ->
  IO (Stack 'UN, Stack 'BX)
bprim2 :: Stack 'UN
-> Stack 'BX -> BPrim2 -> Int -> Int -> IO (Stack 'UN, Stack 'BX)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
EQLU Int
i Int
j = do
  RClosure
x <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  RClosure
y <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ if (Foreign -> Foreign -> Bool) -> RClosure -> RClosure -> Bool
universalEq Foreign -> Foreign -> Bool
forall a. Eq a => a -> a -> Bool
(==) RClosure
x RClosure
y then Int
Elem 'UN
1 else Int
Elem 'UN
0
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
IXOT Int
i Int
j = do
  Text
x <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  Text
y <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  case Text -> Text -> Maybe Word64
Util.Text.indexOf Text
x Text
y of
    Maybe Word64
Nothing -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
    Just Word64
i -> do
      Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
2
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
      Stack 'UN -> Int -> Word64 -> IO ()
pokeOffN Stack 'UN
ustk Int
1 Word64
i
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
IXOB Int
i Int
j = do
  Bytes
x <- Stack 'BX -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  Bytes
y <- Stack 'BX -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  case Bytes -> Bytes -> Maybe Word64
By.indexOf Bytes
x Bytes
y of
    Maybe Word64
Nothing -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
    Just Word64
i -> do
      Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'UN
ustk Int
2
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
      Stack 'UN -> Int -> Word64 -> IO ()
pokeOffN Stack 'UN
ustk Int
1 Word64
i
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
DRPT Int
i Int
j = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Text
t <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  -- Note; if n < 0, the Nat argument was greater than the maximum
  -- signed integer. As an approximation, just return the empty
  -- string, as a string larger than this would require an absurd
  -- amount of memory.
  Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Text
Util.Text.empty else Int -> Text -> Text
Util.Text.drop Int
n Text
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
CATT Int
i Int
j = do
  Text
x <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  Text
y <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y :: Util.Text.Text)
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
TAKT Int
i Int
j = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Text
t <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  -- Note: if n < 0, the Nat argument was greater than the maximum
  -- signed integer. As an approximation, we just return the original
  -- string, because it's unlikely such a large string exists.
  Stack 'BX -> Text -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Text
t else Int -> Text -> Text
Util.Text.take Int
n Text
t
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
EQLT Int
i Int
j = do
  Text
x <- forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi @Util.Text.Text Stack 'BX
bstk Int
i
  Text
y <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ if Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
y then Int
Elem 'UN
1 else Int
Elem 'UN
0
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
LEQT Int
i Int
j = do
  Text
x <- forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi @Util.Text.Text Stack 'BX
bstk Int
i
  Text
y <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ if Text
x Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
<= Text
y then Int
Elem 'UN
1 else Int
Elem 'UN
0
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
LEST Int
i Int
j = do
  Text
x <- forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi @Util.Text.Text Stack 'BX
bstk Int
i
  Text
y <- Stack 'BX -> Int -> IO Text
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ if Text
x Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
< Text
y then Int
Elem 'UN
1 else Int
Elem 'UN
0
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
DRPS Int
i Int
j = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  -- Note: if n < 0, then the Nat argument was larger than the largest
  -- signed integer. Seq actually doesn't handle this well, despite it
  -- being possible to build (lazy) sequences this large. So,
  -- approximate by yielding the empty sequence.
  Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk (Seq RClosure -> IO ()) -> Seq RClosure -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Seq RClosure
forall a. Seq a
Sq.empty else Int -> Seq RClosure -> Seq RClosure
forall a. Int -> Seq a -> Seq a
Sq.drop Int
n Seq RClosure
s
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
TAKS Int
i Int
j = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  -- Note: if n < 0, then the Nat argument was greater than the
  -- largest signed integer. It is possible to build such large
  -- sequences, but the internal size will actually be wrong then. So,
  -- we just return the original sequence as an approximation.
  Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk (Seq RClosure -> IO ()) -> Seq RClosure -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Seq RClosure
s else Int -> Seq RClosure -> Seq RClosure
forall a. Int -> Seq a -> Seq a
Sq.take Int
n Seq RClosure
s
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
CONS Int
i Int
j = do
  RClosure
x <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk (Seq RClosure -> IO ()) -> Seq RClosure -> IO ()
forall a b. (a -> b) -> a -> b
$ RClosure
x RClosure -> Seq RClosure -> Seq RClosure
forall a. a -> Seq a -> Seq a
Sq.<| Seq RClosure
s
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
SNOC Int
i Int
j = do
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i
  RClosure
x <- Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk (Seq RClosure -> IO ()) -> Seq RClosure -> IO ()
forall a b. (a -> b) -> a -> b
$ Seq RClosure
s Seq RClosure -> RClosure -> Seq RClosure
forall a. Seq a -> a -> Seq a
Sq.|> RClosure
x
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
CATS Int
i Int
j = do
  Seq RClosure
x <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
i
  Seq RClosure
y <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk (Seq RClosure -> IO ()) -> Seq RClosure -> IO ()
forall a b. (a -> b) -> a -> b
$ Seq RClosure
x Seq RClosure -> Seq RClosure -> Seq RClosure
forall a. Seq a -> Seq a -> Seq a
Sq.>< Seq RClosure
y
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
IDXS Int
i Int
j = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
j
  case Int -> Seq RClosure -> Maybe RClosure
forall a. Int -> Seq a -> Maybe a
Sq.lookup Int
n Seq RClosure
s of
    Maybe RClosure
Nothing -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
    Just RClosure
x -> do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
      Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
      Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk Elem 'BX
RClosure
x
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
SPLL Int
i Int
j = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
j
  if Seq RClosure -> Int
forall a. Seq a -> Int
Sq.length Seq RClosure
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
    then do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
    else do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
      Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'BX
bstk Int
2
      let (Seq RClosure
l, Seq RClosure
r) = Int -> Seq RClosure -> (Seq RClosure, Seq RClosure)
forall a. Int -> Seq a -> (Seq a, Seq a)
Sq.splitAt Int
n Seq RClosure
s
      Stack 'BX -> Int -> Seq RClosure -> IO ()
pokeOffS Stack 'BX
bstk Int
1 Seq RClosure
r
      Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk Seq RClosure
l
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
SPLR Int
i Int
j = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Seq RClosure
s <- Stack 'BX -> Int -> IO (Seq RClosure)
peekOffS Stack 'BX
bstk Int
j
  if Seq RClosure -> Int
forall a. Seq a -> Int
Sq.length Seq RClosure
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
    then do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
    else do
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
      Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
bumpn Stack 'BX
bstk Int
2
      let (Seq RClosure
l, Seq RClosure
r) = Int -> Seq RClosure -> (Seq RClosure, Seq RClosure)
forall a. Int -> Seq a -> (Seq a, Seq a)
Sq.splitAt (Seq RClosure -> Int
forall a. Seq a -> Int
Sq.length Seq RClosure
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Seq RClosure
s
      Stack 'BX -> Int -> Seq RClosure -> IO ()
pokeOffS Stack 'BX
bstk Int
1 Seq RClosure
r
      Stack 'BX -> Seq RClosure -> IO ()
pokeS Stack 'BX
bstk Seq RClosure
l
      pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
TAKB Int
i Int
j = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Bytes
b <- Stack 'BX -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  -- If n < 0, the Nat argument was larger than the maximum signed
  -- integer. Building a value this large would reuire an absurd
  -- amount of memory, so just assume n is larger.
  Stack 'BX -> Bytes -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Bytes -> IO ()) -> Bytes -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Bytes
b else Int -> Bytes -> Bytes
By.take Int
n Bytes
b
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
DRPB Int
i Int
j = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Bytes
b <- Stack 'BX -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  -- See above for n < 0
  Stack 'BX -> Bytes -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Bytes -> IO ()) -> Bytes -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Bytes
By.empty else Int -> Bytes -> Bytes
By.drop Int
n Bytes
b
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
IDXB Int
i Int
j = do
  Int
n <- Stack 'UN -> Int -> IO (Elem 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'UN
ustk Int
i
  Bytes
b <- Stack 'BX -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
  Stack 'UN
ustk <- case Int -> Bytes -> Maybe Word8
By.at Int
n Bytes
b of
    Maybe Word8
Nothing -> Stack 'UN
ustk Stack 'UN -> IO () -> IO (Stack 'UN)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
0
    Just Word8
x -> do
      Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk (Elem 'UN -> IO ()) -> Elem 'UN -> IO ()
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x
      Stack 'UN
ustk <- Stack 'UN -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'UN
ustk
      Stack 'UN
ustk Stack 'UN -> IO () -> IO (Stack 'UN)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack 'UN -> Elem 'UN -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'UN
ustk Int
Elem 'UN
1
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
CATB Int
i Int
j = do
  Bytes
l <- Stack 'BX -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
i
  Bytes
r <- Stack 'BX -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack 'BX -> Int -> IO b
peekOffBi Stack 'BX
bstk Int
j
  Stack 'BX
bstk <- Stack 'BX -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Stack b)
bump Stack 'BX
bstk
  Stack 'BX -> Bytes -> IO ()
forall b. BuiltinForeign b => Stack 'BX -> b -> IO ()
pokeBi Stack 'BX
bstk (Bytes
l Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> Bytes
r :: By.Bytes)
  pure (Stack 'UN
ustk, Stack 'BX
bstk)
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
THRO Int
_ Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk) -- impossible
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
TRCE Int
_ Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk) -- impossible
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
CMPU Int
_ Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk) -- impossible
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
SDBX Int
_ Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk) -- impossible
bprim2 !Stack 'UN
ustk !Stack 'BX
bstk BPrim2
SDBV Int
_ Int
_ = (Stack 'UN, Stack 'BX) -> IO (Stack 'UN, Stack 'BX)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stack 'UN
ustk, Stack 'BX
bstk) -- impossible
{-# INLINE bprim2 #-}

yield ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack 'UN ->
  Stack 'BX ->
  K ->
  IO ()
yield :: CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> IO ()
yield !CCache
env !EnumMap Word64 RClosure
denv !ActiveThreads
activeThreads !Stack 'UN
ustk !Stack 'BX
bstk !K
k = EnumMap Word64 RClosure -> K -> IO ()
leap EnumMap Word64 RClosure
denv K
k
  where
    leap :: EnumMap Word64 RClosure -> K -> IO ()
leap !EnumMap Word64 RClosure
denv0 (Mark Int
ua Int
ba EnumSet Word64
ps EnumMap Word64 RClosure
cs K
k) = do
      let denv :: EnumMap Word64 RClosure
denv = EnumMap Word64 RClosure
cs EnumMap Word64 RClosure
-> EnumMap Word64 RClosure -> EnumMap Word64 RClosure
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 RClosure
-> EnumSet Word64 -> EnumMap Word64 RClosure
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.withoutKeys EnumMap Word64 RClosure
denv0 EnumSet Word64
ps
          clo :: RClosure
clo = EnumMap Word64 RClosure
denv0 EnumMap Word64 RClosure -> Word64 -> RClosure
forall k a. EnumKey k => EnumMap k a -> k -> a
EC.! EnumSet Word64 -> Word64
forall k. EnumKey k => EnumSet k -> k
EC.findMin EnumSet Word64
ps
      Stack 'BX -> Elem 'BX -> IO ()
forall (b :: Mem). MEM b => Stack b -> Elem b -> IO ()
poke Stack 'BX
bstk (RClosure -> IO ()) -> (RClosure -> RClosure) -> RClosure -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Word64 -> RClosure -> RClosure
forall comb. Reference -> Word64 -> GClosure comb -> GClosure comb
DataB1 Reference
Rf.effectRef Word64
0 (RClosure -> IO ()) -> IO RClosure -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack 'BX -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Elem b)
peek Stack 'BX
bstk
      Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
adjustArgs Stack 'UN
ustk Int
ua
      Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
adjustArgs Stack 'BX
bstk Int
ba
      CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Bool
-> Args
-> RClosure
-> IO ()
apply CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k Bool
False (Int -> Args
BArg1 Int
0) RClosure
clo
    leap !EnumMap Word64 RClosure
denv (Push Int
ufsz Int
bfsz Int
uasz Int
basz RComb
rComb K
k) = do
      let Lam Int
_ Int
_ Int
uf Int
bf RSection
nx = RComb -> GComb RComb
unRComb RComb
rComb
      Stack 'UN
ustk <- Stack 'UN -> Int -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> Int -> IO (Stack b)
restoreFrame Stack 'UN
ustk Int
ufsz Int
uasz
      Stack 'BX
bstk <- Stack 'BX -> Int -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> Int -> IO (Stack b)
restoreFrame Stack 'BX
bstk Int
bfsz Int
basz
      Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
ensure Stack 'UN
ustk Int
uf
      Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
ensure Stack 'BX
bstk Int
bf
      CCache
-> EnumMap Word64 RClosure
-> ActiveThreads
-> Stack 'UN
-> Stack 'BX
-> K
-> Reference
-> RSection
-> IO ()
eval CCache
env EnumMap Word64 RClosure
denv ActiveThreads
activeThreads Stack 'UN
ustk Stack 'BX
bstk K
k (RComb -> Reference
rCombRef RComb
rComb) RSection
nx
    leap EnumMap Word64 RClosure
_ (CB (Hook Stack 'UN -> Stack 'BX -> IO ()
f)) = Stack 'UN -> Stack 'BX -> IO ()
f Stack 'UN
ustk Stack 'BX
bstk
    leap EnumMap Word64 RClosure
_ K
KE = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINE yield #-}

selectTextBranch ::
  Util.Text.Text -> RSection -> M.Map Util.Text.Text RSection -> RSection
selectTextBranch :: Text -> RSection -> Map Text RSection -> RSection
selectTextBranch Text
t RSection
df Map Text RSection
cs = RSection -> Text -> Map Text RSection -> RSection
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault RSection
df Text
t Map Text RSection
cs
{-# INLINE selectTextBranch #-}

selectBranch :: Tag -> RBranch -> RSection
selectBranch :: Word64 -> GBranch RComb -> RSection
selectBranch Word64
t (Test1 Word64
u RSection
y RSection
n)
  | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u = RSection
y
  | Bool
otherwise = RSection
n
selectBranch Word64
t (Test2 Word64
u RSection
cu Word64
v RSection
cv RSection
e)
  | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u = RSection
cu
  | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
v = RSection
cv
  | Bool
otherwise = RSection
e
selectBranch Word64
t (TestW RSection
df EnumMap Word64 RSection
cs) = RSection -> Word64 -> EnumMap Word64 RSection -> RSection
forall k a. EnumKey k => a -> k -> EnumMap k a -> a
lookupWithDefault RSection
df Word64
t EnumMap Word64 RSection
cs
selectBranch Word64
_ (TestT {}) = [Char] -> RSection
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
{-# INLINE selectBranch #-}

-- Splits off a portion of the continuation up to a given prompt.
--
-- The main procedure walks along the 'code' stack `k`, keeping track of how
-- many cells of the data stacks need to be captured. Then the `finish` function
-- performs the actual splitting of the data stacks together with some tweaking.
--
-- Some special attention is required for pending arguments for over-applied
-- functions. They are part of the continuation, so how many there are at the
-- time of capture is recorded in the `Captured` closure, so that information
-- can be restored later. Also, the `Mark` frame that is popped off as part of
-- this operation potentially exposes pending arguments beyond the delimited
-- region, so those are restored in the `finish` function.
splitCont ::
  DEnv ->
  Stack 'UN ->
  Stack 'BX ->
  K ->
  Word64 ->
  IO (Closure, DEnv, Stack 'UN, Stack 'BX, K)
splitCont :: EnumMap Word64 RClosure
-> Stack 'UN
-> Stack 'BX
-> K
-> Word64
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
splitCont !EnumMap Word64 RClosure
denv !Stack 'UN
ustk !Stack 'BX
bstk !K
k !Word64
p =
  EnumMap Word64 RClosure
-> Int
-> Int
-> K
-> K
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
walk EnumMap Word64 RClosure
denv Int
uasz Int
basz K
KE K
k
  where
    uasz :: Int
uasz = Stack 'UN -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'UN
ustk
    basz :: Int
basz = Stack 'BX -> Int
forall (b :: Mem). MEM b => Stack b -> Int
asize Stack 'BX
bstk
    walk :: EnumMap Word64 RClosure
-> Int
-> Int
-> K
-> K
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
walk !EnumMap Word64 RClosure
denv !Int
usz !Int
bsz !K
ck K
KE =
      [Char] -> IO Any
forall a. HasCallStack => [Char] -> IO a
die [Char]
"fell off stack" IO Any
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EnumMap Word64 RClosure
-> Int
-> Int
-> Int
-> Int
-> K
-> K
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
finish EnumMap Word64 RClosure
denv Int
usz Int
bsz Int
0 Int
0 K
ck K
KE
    walk !EnumMap Word64 RClosure
denv !Int
usz !Int
bsz !K
ck (CB Callback
_) =
      [Char] -> IO Any
forall a. HasCallStack => [Char] -> IO a
die [Char]
"fell off stack" IO Any
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EnumMap Word64 RClosure
-> Int
-> Int
-> Int
-> Int
-> K
-> K
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
finish EnumMap Word64 RClosure
denv Int
usz Int
bsz Int
0 Int
0 K
ck K
KE
    walk !EnumMap Word64 RClosure
denv !Int
usz !Int
bsz !K
ck (Mark Int
ua Int
ba EnumSet Word64
ps EnumMap Word64 RClosure
cs K
k)
      | Word64 -> EnumSet Word64 -> Bool
forall k. EnumKey k => k -> EnumSet k -> Bool
EC.member Word64
p EnumSet Word64
ps = EnumMap Word64 RClosure
-> Int
-> Int
-> Int
-> Int
-> K
-> K
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
finish EnumMap Word64 RClosure
denv' Int
usz Int
bsz Int
ua Int
ba K
ck K
k
      | Bool
otherwise = EnumMap Word64 RClosure
-> Int
-> Int
-> K
-> K
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
walk EnumMap Word64 RClosure
denv' (Int
usz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ua) (Int
bsz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ba) (Int -> Int -> EnumSet Word64 -> EnumMap Word64 RClosure -> K -> K
Mark Int
ua Int
ba EnumSet Word64
ps EnumMap Word64 RClosure
cs' K
ck) K
k
      where
        denv' :: EnumMap Word64 RClosure
denv' = EnumMap Word64 RClosure
cs EnumMap Word64 RClosure
-> EnumMap Word64 RClosure -> EnumMap Word64 RClosure
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 RClosure
-> EnumSet Word64 -> EnumMap Word64 RClosure
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.withoutKeys EnumMap Word64 RClosure
denv EnumSet Word64
ps
        cs' :: EnumMap Word64 RClosure
cs' = EnumMap Word64 RClosure
-> EnumSet Word64 -> EnumMap Word64 RClosure
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys EnumMap Word64 RClosure
denv EnumSet Word64
ps
    walk !EnumMap Word64 RClosure
denv !Int
usz !Int
bsz !K
ck (Push Int
un Int
bn Int
ua Int
ba RComb
br K
k) =
      EnumMap Word64 RClosure
-> Int
-> Int
-> K
-> K
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
walk EnumMap Word64 RClosure
denv (Int
usz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
un Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ua) (Int
bsz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ba) (Int -> Int -> Int -> Int -> RComb -> K -> K
Push Int
un Int
bn Int
ua Int
ba RComb
br K
ck) K
k

    finish :: EnumMap Word64 RClosure
-> Int
-> Int
-> Int
-> Int
-> K
-> K
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
finish !EnumMap Word64 RClosure
denv !Int
usz !Int
bsz !Int
ua !Int
ba !K
ck !K
k = do
      (ByteArray
useg, Stack 'UN
ustk) <- Stack 'UN -> Int -> IO (Seg 'UN, Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Seg b, Stack b)
grab Stack 'UN
ustk Int
usz
      (Array RClosure
bseg, Stack 'BX
bstk) <- Stack 'BX -> Int -> IO (Seg 'BX, Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Seg b, Stack b)
grab Stack 'BX
bstk Int
bsz
      Stack 'UN
ustk <- Stack 'UN -> Int -> IO (Stack 'UN)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
adjustArgs Stack 'UN
ustk Int
ua
      Stack 'BX
bstk <- Stack 'BX -> Int -> IO (Stack 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Stack b)
adjustArgs Stack 'BX
bstk Int
ba
      return (K -> Int -> Int -> Seg 'UN -> Seg 'BX -> RClosure
forall comb. K -> Int -> Int -> Seg 'UN -> Seg 'BX -> GClosure comb
Captured K
ck Int
uasz Int
basz ByteArray
Seg 'UN
useg Array RClosure
Seg 'BX
bseg, EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
{-# INLINE splitCont #-}

discardCont ::
  DEnv ->
  Stack 'UN ->
  Stack 'BX ->
  K ->
  Word64 ->
  IO (DEnv, Stack 'UN, Stack 'BX, K)
discardCont :: EnumMap Word64 RClosure
-> Stack 'UN
-> Stack 'BX
-> K
-> Word64
-> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
discardCont EnumMap Word64 RClosure
denv Stack 'UN
ustk Stack 'BX
bstk K
k Word64
p =
  EnumMap Word64 RClosure
-> Stack 'UN
-> Stack 'BX
-> K
-> Word64
-> IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
splitCont EnumMap Word64 RClosure
denv Stack 'UN
ustk Stack 'BX
bstk K
k Word64
p
    IO (RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
-> ((RClosure, EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
    -> (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K))
-> IO (EnumMap Word64 RClosure, Stack 'UN, Stack 'BX, K)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(RClosure
_, EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k) -> (EnumMap Word64 RClosure
denv, Stack 'UN
ustk, Stack 'BX
bstk, K
k)
{-# INLINE discardCont #-}

resolve :: CCache -> DEnv -> Stack 'BX -> RRef -> IO Closure
resolve :: CCache
-> EnumMap Word64 RClosure
-> Stack 'BX
-> GRef RComb
-> IO RClosure
resolve CCache
_ EnumMap Word64 RClosure
_ Stack 'BX
_ (Env RComb
rComb) = RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure) -> RClosure -> IO RClosure
forall a b. (a -> b) -> a -> b
$ RComb -> Seg 'UN -> Seg 'BX -> RClosure
forall comb. comb -> Seg 'UN -> Seg 'BX -> GClosure comb
PAp RComb
rComb Seg 'UN
unull Seg 'BX
bnull
resolve CCache
_ EnumMap Word64 RClosure
_ Stack 'BX
bstk (Stk Int
i) = Stack 'BX -> Int -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> Int -> IO (Elem b)
peekOff Stack 'BX
bstk Int
i
resolve CCache
env EnumMap Word64 RClosure
denv Stack 'BX
_ (Dyn Word64
i) = case Word64 -> EnumMap Word64 RClosure -> Maybe RClosure
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i EnumMap Word64 RClosure
denv of
  Just RClosure
clo -> RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RClosure
clo
  Maybe RClosure
Nothing -> [Char] -> CCache -> Word64 -> IO RClosure
forall a. [Char] -> CCache -> Word64 -> IO a
unhandledErr [Char]
"resolve" CCache
env Word64
i

unhandledErr :: String -> CCache -> Word64 -> IO a
unhandledErr :: forall a. [Char] -> CCache -> Word64 -> IO a
unhandledErr [Char]
fname CCache
env Word64
i =
  TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (EnumMap Word64 Reference)
tagRefs CCache
env) IO (EnumMap Word64 Reference)
-> (EnumMap Word64 Reference -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EnumMap Word64 Reference
rs -> case Word64 -> EnumMap Word64 Reference -> Maybe Reference
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i EnumMap Word64 Reference
rs of
    Just Reference
r -> [Char] -> IO a
bomb (Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r)
    Maybe Reference
Nothing -> [Char] -> IO a
bomb (Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
i)
  where
    bomb :: [Char] -> IO a
bomb [Char]
sh = [Char] -> IO a
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
fname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": unhandled ability request: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
sh

rCombSection :: EnumMap Word64 RCombs -> CombIx -> RComb
rCombSection :: EnumMap Word64 RCombs -> CombIx -> RComb
rCombSection EnumMap Word64 RCombs
combs cix :: CombIx
cix@(CIx Reference
r Word64
n Word64
i) =
  case Word64 -> EnumMap Word64 RCombs -> Maybe RCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
n EnumMap Word64 RCombs
combs of
    Just RCombs
cmbs -> case Word64 -> RCombs -> Maybe (GComb RComb)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i RCombs
cmbs of
      Just GComb RComb
cmb -> CombIx -> GComb RComb -> RComb
RComb CombIx
cix GComb RComb
cmb
      Maybe (GComb RComb)
Nothing -> [Char] -> RComb
forall a. HasCallStack => [Char] -> a
error ([Char] -> RComb) -> [Char] -> RComb
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown section `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"` of combinator `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"`. Reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r
    Maybe RCombs
Nothing -> [Char] -> RComb
forall a. HasCallStack => [Char] -> a
error ([Char] -> RComb) -> [Char] -> RComb
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown combinator `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"`. Reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

resolveSection :: CCache -> Section -> IO RSection
resolveSection :: CCache -> Section -> IO RSection
resolveSection CCache
cc Section
section = do
  EnumMap Word64 RCombs
rcombs <- TVar (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (EnumMap Word64 RCombs)
combs CCache
cc)
  pure $ EnumMap Word64 RCombs -> CombIx -> RComb
rCombSection EnumMap Word64 RCombs
rcombs (CombIx -> RComb) -> Section -> RSection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Section
section

dummyRef :: Reference
dummyRef :: Reference
dummyRef = Text -> Reference
forall t h. t -> Reference' t h
Builtin ([Char] -> Text
DTx.pack [Char]
"dummy")

reserveIds :: Word64 -> TVar Word64 -> IO Word64
reserveIds :: Word64 -> TVar Word64 -> IO Word64
reserveIds Word64
n TVar Word64
free = STM Word64 -> IO Word64
forall a. STM a -> IO a
atomically (STM Word64 -> IO Word64)
-> ((Word64 -> (Word64, Word64)) -> STM Word64)
-> (Word64 -> (Word64, Word64))
-> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Word64 -> (Word64 -> (Word64, Word64)) -> STM Word64
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar Word64
free ((Word64 -> (Word64, Word64)) -> IO Word64)
-> (Word64 -> (Word64, Word64)) -> IO Word64
forall a b. (a -> b) -> a -> b
$ \Word64
i -> (Word64
i, Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
n)

updateMap :: (Semigroup s) => s -> TVar s -> STM s
updateMap :: forall s. Semigroup s => s -> TVar s -> STM s
updateMap s
new0 TVar s
r = do
  s
new <- s -> STM s
forall a. a -> STM a
evaluateSTM s
new0
  TVar s -> (s -> (s, s)) -> STM s
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar s
r ((s -> (s, s)) -> STM s) -> (s -> (s, s)) -> STM s
forall a b. (a -> b) -> a -> b
$ \s
old ->
    let total :: s
total = s
new s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
old in (s
total, s
total)

modifyMap :: TVar s -> (s -> s) -> STM s
modifyMap :: forall s. TVar s -> (s -> s) -> STM s
modifyMap TVar s
r s -> s
f = TVar s -> (s -> (s, s)) -> STM s
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar s
r ((s -> (s, s)) -> STM s) -> (s -> (s, s)) -> STM s
forall a b. (a -> b) -> a -> b
$ \s
old -> let new :: s
new = s -> s
f s
old in (s
new, s
new)

refLookup :: String -> M.Map Reference Word64 -> Reference -> Word64
refLookup :: [Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
s Map Reference Word64
m Reference
r
  | Just Word64
w <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference Word64
m = Word64
w
  | Bool
otherwise =
      [Char] -> Word64
forall a. HasCallStack => [Char] -> a
error ([Char] -> Word64) -> [Char] -> Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"refLookup:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": unknown reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

decodeCacheArgument ::
  Sq.Seq Closure -> IO [(Reference, SuperGroup Symbol)]
decodeCacheArgument :: Seq RClosure -> IO [(Reference, SuperGroup Symbol)]
decodeCacheArgument Seq RClosure
s = [RClosure]
-> (RClosure -> IO (Reference, SuperGroup Symbol))
-> IO [(Reference, SuperGroup Symbol)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Seq RClosure -> [RClosure]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq RClosure
s) ((RClosure -> IO (Reference, SuperGroup Symbol))
 -> IO [(Reference, SuperGroup Symbol)])
-> (RClosure -> IO (Reference, SuperGroup Symbol))
-> IO [(Reference, SuperGroup Symbol)]
forall a b. (a -> b) -> a -> b
$ \case
  DataB2 Reference
_ Word64
_ (Foreign Foreign
x) (DataB2 Reference
_ Word64
_ (Foreign Foreign
y) RClosure
_) ->
    case Foreign -> Referent' Reference
forall a. Foreign -> a
unwrapForeign Foreign
x of
      Ref Reference
r -> (Reference, SuperGroup Symbol) -> IO (Reference, SuperGroup Symbol)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference
r, Foreign -> SuperGroup Symbol
forall a. Foreign -> a
unwrapForeign Foreign
y)
      Referent' Reference
_ -> [Char] -> IO (Reference, SuperGroup Symbol)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"decodeCacheArgument: Con reference"
  RClosure
_ -> [Char] -> IO (Reference, SuperGroup Symbol)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"decodeCacheArgument: unrecognized value"

decodeSandboxArgument :: Sq.Seq Closure -> IO [Reference]
decodeSandboxArgument :: Seq RClosure -> IO [Reference]
decodeSandboxArgument Seq RClosure
s = ([[Reference]] -> [Reference])
-> IO [[Reference]] -> IO [Reference]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Reference]] -> [Reference]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO [[Reference]] -> IO [Reference])
-> ((RClosure -> IO [Reference]) -> IO [[Reference]])
-> (RClosure -> IO [Reference])
-> IO [Reference]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RClosure] -> (RClosure -> IO [Reference]) -> IO [[Reference]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Seq RClosure -> [RClosure]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq RClosure
s) ((RClosure -> IO [Reference]) -> IO [Reference])
-> (RClosure -> IO [Reference]) -> IO [Reference]
forall a b. (a -> b) -> a -> b
$ \case
  Foreign Foreign
x -> case Foreign -> Referent' Reference
forall a. Foreign -> a
unwrapForeign Foreign
x of
    Ref Reference
r -> [Reference] -> IO [Reference]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Reference
r]
    Referent' Reference
_ -> [Reference] -> IO [Reference]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- constructor
  RClosure
_ -> [Char] -> IO [Reference]
forall a. HasCallStack => [Char] -> IO a
die [Char]
"decodeSandboxArgument: unrecognized value"

encodeSandboxListResult :: [Reference] -> Sq.Seq Closure
encodeSandboxListResult :: [Reference] -> Seq RClosure
encodeSandboxListResult =
  [RClosure] -> Seq RClosure
forall a. [a] -> Seq a
Sq.fromList ([RClosure] -> Seq RClosure)
-> ([Reference] -> [RClosure]) -> [Reference] -> Seq RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference -> RClosure) -> [Reference] -> [RClosure]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure)
-> (Reference -> Foreign) -> Reference -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent' Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef (Referent' Reference -> Foreign)
-> (Reference -> Referent' Reference) -> Reference -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent' Reference
Ref)

encodeSandboxResult :: Either [Reference] [Reference] -> Closure
encodeSandboxResult :: Either [Reference] [Reference] -> RClosure
encodeSandboxResult (Left [Reference]
rfs) =
  RClosure -> RClosure
encodeLeft (RClosure -> RClosure)
-> (Seq RClosure -> RClosure) -> Seq RClosure -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure)
-> (Seq RClosure -> Foreign) -> Seq RClosure -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Seq RClosure -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.listRef (Seq RClosure -> RClosure) -> Seq RClosure -> RClosure
forall a b. (a -> b) -> a -> b
$ [Reference] -> Seq RClosure
encodeSandboxListResult [Reference]
rfs
encodeSandboxResult (Right [Reference]
rfs) =
  RClosure -> RClosure
encodeRight (RClosure -> RClosure)
-> (Seq RClosure -> RClosure) -> Seq RClosure -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure)
-> (Seq RClosure -> Foreign) -> Seq RClosure -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Seq RClosure -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.listRef (Seq RClosure -> RClosure) -> Seq RClosure -> RClosure
forall a b. (a -> b) -> a -> b
$ [Reference] -> Seq RClosure
encodeSandboxListResult [Reference]
rfs

encodeLeft :: Closure -> Closure
encodeLeft :: RClosure -> RClosure
encodeLeft = Reference -> Word64 -> RClosure -> RClosure
forall comb. Reference -> Word64 -> GClosure comb -> GClosure comb
DataB1 Reference
Rf.eitherRef Word64
leftTag

encodeRight :: Closure -> Closure
encodeRight :: RClosure -> RClosure
encodeRight = Reference -> Word64 -> RClosure -> RClosure
forall comb. Reference -> Word64 -> GClosure comb -> GClosure comb
DataB1 Reference
Rf.eitherRef Word64
rightTag

addRefs ::
  TVar Word64 ->
  TVar (M.Map Reference Word64) ->
  TVar (EnumMap Word64 Reference) ->
  S.Set Reference ->
  STM (M.Map Reference Word64)
addRefs :: TVar Word64
-> TVar (Map Reference Word64)
-> TVar (EnumMap Word64 Reference)
-> Set Reference
-> STM (Map Reference Word64)
addRefs TVar Word64
vfrsh TVar (Map Reference Word64)
vfrom TVar (EnumMap Word64 Reference)
vto Set Reference
rs = do
  Map Reference Word64
from0 <- TVar (Map Reference Word64) -> STM (Map Reference Word64)
forall a. TVar a -> STM a
readTVar TVar (Map Reference Word64)
vfrom
  let new :: Set Reference
new = (Reference -> Bool) -> Set Reference -> Set Reference
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` Map Reference Word64
from0) Set Reference
rs
      sz :: Word64
sz = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Set Reference -> Int
forall a. Set a -> Int
S.size Set Reference
new
  Word64
frsh <- TVar Word64 -> (Word64 -> (Word64, Word64)) -> STM Word64
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar Word64
vfrsh ((Word64 -> (Word64, Word64)) -> STM Word64)
-> (Word64 -> (Word64, Word64)) -> STM Word64
forall a b. (a -> b) -> a -> b
$ \Word64
i -> (Word64
i, Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
sz)
  let newl :: [Reference]
newl = Set Reference -> [Reference]
forall a. Set a -> [a]
S.toList Set Reference
new
      from :: Map Reference Word64
from = [(Reference, Word64)] -> Map Reference Word64
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Reference] -> [Word64] -> [(Reference, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Reference]
newl [Word64
frsh ..]) Map Reference Word64
-> Map Reference Word64 -> Map Reference Word64
forall a. Semigroup a => a -> a -> a
<> Map Reference Word64
from0
      nto :: EnumMap Word64 Reference
nto = [(Word64, Reference)] -> EnumMap Word64 Reference
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList ([Word64] -> [Reference] -> [(Word64, Reference)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64
frsh ..] [Reference]
newl)
  TVar (Map Reference Word64) -> Map Reference Word64 -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Map Reference Word64)
vfrom Map Reference Word64
from
  TVar (EnumMap Word64 Reference)
-> (EnumMap Word64 Reference -> EnumMap Word64 Reference) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (EnumMap Word64 Reference)
vto (EnumMap Word64 Reference
nto EnumMap Word64 Reference
-> EnumMap Word64 Reference -> EnumMap Word64 Reference
forall a. Semigroup a => a -> a -> a
<>)
  pure Map Reference Word64
from

codeValidate ::
  [(Reference, SuperGroup Symbol)] ->
  CCache ->
  IO (Maybe (Failure Closure))
codeValidate :: [(Reference, SuperGroup Symbol)]
-> CCache -> IO (Maybe (Failure RClosure))
codeValidate [(Reference, SuperGroup Symbol)]
tml CCache
cc = do
  Map Reference Word64
rty0 <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTy CCache
cc)
  Word64
fty <- TVar Word64 -> IO Word64
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar Word64
freshTy CCache
cc)
  let f :: Bool -> Reference -> Set Reference
f Bool
b Reference
r
        | Bool
b, Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Reference
r Map Reference Word64
rty0 = Reference -> Set Reference
forall a. a -> Set a
S.singleton Reference
r
        | Bool
otherwise = Set Reference
forall a. Monoid a => a
mempty
      ntys0 :: Set Reference
ntys0 = (((Reference, SuperGroup Symbol) -> Set Reference)
-> [(Reference, SuperGroup Symbol)] -> Set Reference
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((Reference, SuperGroup Symbol) -> Set Reference)
 -> [(Reference, SuperGroup Symbol)] -> Set Reference)
-> ((SuperGroup Symbol -> Set Reference)
    -> (Reference, SuperGroup Symbol) -> Set Reference)
-> (SuperGroup Symbol -> Set Reference)
-> [(Reference, SuperGroup Symbol)]
-> Set Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SuperGroup Symbol -> Set Reference)
-> (Reference, SuperGroup Symbol) -> Set Reference
forall m a. Monoid m => (a -> m) -> (Reference, a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) ((Bool -> Reference -> Set Reference)
-> SuperGroup Symbol -> Set Reference
forall r v.
(Monoid r, Var v) =>
(Bool -> Reference -> r) -> SuperGroup v -> r
foldGroupLinks Bool -> Reference -> Set Reference
f) [(Reference, SuperGroup Symbol)]
tml
      ntys :: Map Reference Word64
ntys = [(Reference, Word64)] -> Map Reference Word64
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Reference, Word64)] -> Map Reference Word64)
-> [(Reference, Word64)] -> Map Reference Word64
forall a b. (a -> b) -> a -> b
$ [Reference] -> [Word64] -> [(Reference, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set Reference -> [Reference]
forall a. Set a -> [a]
S.toList Set Reference
ntys0) [Word64
fty ..]
      rty :: Map Reference Word64
rty = Map Reference Word64
ntys Map Reference Word64
-> Map Reference Word64 -> Map Reference Word64
forall a. Semigroup a => a -> a -> a
<> Map Reference Word64
rty0
  Word64
ftm <- TVar Word64 -> IO Word64
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar Word64
freshTm CCache
cc)
  Map Reference Word64
rtm0 <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTm CCache
cc)
  let rs :: [Reference]
rs = (Reference, SuperGroup Symbol) -> Reference
forall a b. (a, b) -> a
fst ((Reference, SuperGroup Symbol) -> Reference)
-> [(Reference, SuperGroup Symbol)] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, SuperGroup Symbol)]
tml
      rtm :: Map Reference Word64
rtm = Map Reference Word64
rtm0 Map Reference Word64 -> Set Reference -> Map Reference Word64
forall k a. Ord k => Map k a -> Set k -> Map k a
`M.withoutKeys` [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
S.fromList [Reference]
rs
      rns :: RefNums
rns = (Reference -> Word64) -> (Reference -> Word64) -> RefNums
RN ([Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
"ty" Map Reference Word64
rty) ([Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
"tm" Map Reference Word64
rtm)
      combinate :: (Word64, (Reference, SuperGroup Symbol))
-> IO (EnumMap Word64 Comb)
combinate (Word64
n, (Reference
r, SuperGroup Symbol
g)) = EnumMap Word64 Comb -> IO (EnumMap Word64 Comb)
forall a. a -> IO a
evaluate (EnumMap Word64 Comb -> IO (EnumMap Word64 Comb))
-> EnumMap Word64 Comb -> IO (EnumMap Word64 Comb)
forall a b. (a -> b) -> a -> b
$ RefNums
-> Reference -> Word64 -> SuperGroup Symbol -> EnumMap Word64 Comb
forall v.
Var v =>
RefNums
-> Reference -> Word64 -> SuperGroup v -> EnumMap Word64 Comb
emitCombs RefNums
rns Reference
r Word64
n SuperGroup Symbol
g
  (Maybe (Failure RClosure)
forall a. Maybe a
Nothing Maybe (Failure RClosure) -> IO () -> IO (Maybe (Failure RClosure))
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((Word64, (Reference, SuperGroup Symbol))
 -> IO (EnumMap Word64 Comb))
-> [(Word64, (Reference, SuperGroup Symbol))] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Word64, (Reference, SuperGroup Symbol))
-> IO (EnumMap Word64 Comb)
combinate ([Word64]
-> [(Reference, SuperGroup Symbol)]
-> [(Word64, (Reference, SuperGroup Symbol))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64
ftm ..] [(Reference, SuperGroup Symbol)]
tml))
    IO (Maybe (Failure RClosure))
-> (CompileExn -> IO (Maybe (Failure RClosure)))
-> IO (Maybe (Failure RClosure))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(CE CallStack
cs Pretty ColorText
perr) ->
      let msg :: Text
msg = [Char] -> Text
Util.Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Pretty ColorText -> [Char]
toPlainUnbroken Pretty ColorText
perr
          extra :: RClosure
extra = Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure) -> ([Char] -> Foreign) -> [Char] -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Text -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.textRef (Text -> Foreign) -> ([Char] -> Text) -> [Char] -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Util.Text.pack ([Char] -> RClosure) -> [Char] -> RClosure
forall a b. (a -> b) -> a -> b
$ CallStack -> [Char]
forall a. Show a => a -> [Char]
show CallStack
cs
       in Maybe (Failure RClosure) -> IO (Maybe (Failure RClosure))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Failure RClosure) -> IO (Maybe (Failure RClosure)))
-> (Failure RClosure -> Maybe (Failure RClosure))
-> Failure RClosure
-> IO (Maybe (Failure RClosure))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure RClosure -> Maybe (Failure RClosure)
forall a. a -> Maybe a
Just (Failure RClosure -> IO (Maybe (Failure RClosure)))
-> Failure RClosure -> IO (Maybe (Failure RClosure))
forall a b. (a -> b) -> a -> b
$ Reference -> Text -> RClosure -> Failure RClosure
forall a. Reference -> Text -> a -> Failure a
Failure Reference
ioFailureRef Text
msg RClosure
extra

sandboxList :: CCache -> Referent -> IO [Reference]
sandboxList :: CCache -> Referent' Reference -> IO [Reference]
sandboxList CCache
cc (Ref Reference
r) = do
  Map Reference (Set Reference)
sands <- TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a. TVar a -> IO a
readTVarIO (TVar (Map Reference (Set Reference))
 -> IO (Map Reference (Set Reference)))
-> TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (Map Reference (Set Reference))
sandbox CCache
cc
  [Reference] -> IO [Reference]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Reference] -> IO [Reference])
-> (Maybe (Set Reference) -> [Reference])
-> Maybe (Set Reference)
-> IO [Reference]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reference]
-> (Set Reference -> [Reference])
-> Maybe (Set Reference)
-> [Reference]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Set Reference -> [Reference]
forall a. Set a -> [a]
S.toList (Maybe (Set Reference) -> IO [Reference])
-> Maybe (Set Reference) -> IO [Reference]
forall a b. (a -> b) -> a -> b
$ Reference -> Map Reference (Set Reference) -> Maybe (Set Reference)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference (Set Reference)
sands
sandboxList CCache
_ Referent' Reference
_ = [Reference] -> IO [Reference]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

checkSandboxing ::
  CCache ->
  [Reference] ->
  Closure ->
  IO Bool
checkSandboxing :: CCache -> [Reference] -> RClosure -> IO Bool
checkSandboxing CCache
cc [Reference]
allowed0 RClosure
c = do
  Map Reference (Set Reference)
sands <- TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a. TVar a -> IO a
readTVarIO (TVar (Map Reference (Set Reference))
 -> IO (Map Reference (Set Reference)))
-> TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (Map Reference (Set Reference))
sandbox CCache
cc
  let f :: Reference -> Set Reference
f Reference
r
        | Just Set Reference
rs <- Reference -> Map Reference (Set Reference) -> Maybe (Set Reference)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference (Set Reference)
sands =
            Set Reference
rs Set Reference -> Set Reference -> Set Reference
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Reference
allowed
        | Bool
otherwise = Set Reference
forall a. Monoid a => a
mempty
  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Set Reference -> Bool
forall a. Set a -> Bool
S.null ((Reference -> Set Reference) -> RClosure -> Set Reference
forall m. Monoid m => (Reference -> m) -> RClosure -> m
closureTermRefs Reference -> Set Reference
f RClosure
c)
  where
    allowed :: Set Reference
allowed = [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
S.fromList [Reference]
allowed0

-- Checks a Value for sandboxing. A Left result indicates that some
-- dependencies of the Value are unknown. A Right result indicates
-- builtins transitively referenced by the Value that are disallowed.
checkValueSandboxing ::
  CCache ->
  [Reference] ->
  ANF.Value ->
  IO (Either [Reference] [Reference])
checkValueSandboxing :: CCache
-> [Reference] -> Value -> IO (Either [Reference] [Reference])
checkValueSandboxing CCache
cc [Reference]
allowed0 Value
v = do
  Map Reference (Set Reference)
sands <- TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a. TVar a -> IO a
readTVarIO (TVar (Map Reference (Set Reference))
 -> IO (Map Reference (Set Reference)))
-> TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (Map Reference (Set Reference))
sandbox CCache
cc
  Map Reference (SuperGroup Symbol)
have <- TVar (Map Reference (SuperGroup Symbol))
-> IO (Map Reference (SuperGroup Symbol))
forall a. TVar a -> IO a
readTVarIO (TVar (Map Reference (SuperGroup Symbol))
 -> IO (Map Reference (SuperGroup Symbol)))
-> TVar (Map Reference (SuperGroup Symbol))
-> IO (Map Reference (SuperGroup Symbol))
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed CCache
cc
  let f :: Bool -> Reference -> (Set Reference, Set Reference)
f Bool
False Reference
r
        | Maybe (SuperGroup Symbol)
Nothing <- Reference
-> Map Reference (SuperGroup Symbol) -> Maybe (SuperGroup Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference (SuperGroup Symbol)
have,
          Bool -> Bool
not (Reference -> Bool
isBuiltin Reference
r) =
            (Reference -> Set Reference
forall a. a -> Set a
S.singleton Reference
r, Set Reference
forall a. Monoid a => a
mempty)
        | Just Set Reference
rs <- Reference -> Map Reference (Set Reference) -> Maybe (Set Reference)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference (Set Reference)
sands =
            (Set Reference
forall a. Monoid a => a
mempty, Set Reference
rs Set Reference -> Set Reference -> Set Reference
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Reference
allowed)
      f Bool
_ Reference
_ = (Set Reference
forall a. Monoid a => a
mempty, Set Reference
forall a. Monoid a => a
mempty)
  case (Bool -> Reference -> (Set Reference, Set Reference))
-> Value -> (Set Reference, Set Reference)
forall a. Monoid a => (Bool -> Reference -> a) -> Value -> a
valueLinks Bool -> Reference -> (Set Reference, Set Reference)
f Value
v of
    (Set Reference
miss, Set Reference
sbx)
      | Set Reference -> Bool
forall a. Set a -> Bool
S.null Set Reference
miss -> Either [Reference] [Reference]
-> IO (Either [Reference] [Reference])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Reference] [Reference]
 -> IO (Either [Reference] [Reference]))
-> ([Reference] -> Either [Reference] [Reference])
-> [Reference]
-> IO (Either [Reference] [Reference])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reference] -> Either [Reference] [Reference]
forall a b. b -> Either a b
Right ([Reference] -> IO (Either [Reference] [Reference]))
-> [Reference] -> IO (Either [Reference] [Reference])
forall a b. (a -> b) -> a -> b
$ Set Reference -> [Reference]
forall a. Set a -> [a]
S.toList Set Reference
sbx
      | Bool
otherwise -> Either [Reference] [Reference]
-> IO (Either [Reference] [Reference])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Reference] [Reference]
 -> IO (Either [Reference] [Reference]))
-> ([Reference] -> Either [Reference] [Reference])
-> [Reference]
-> IO (Either [Reference] [Reference])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reference] -> Either [Reference] [Reference]
forall a b. a -> Either a b
Left ([Reference] -> IO (Either [Reference] [Reference]))
-> [Reference] -> IO (Either [Reference] [Reference])
forall a b. (a -> b) -> a -> b
$ Set Reference -> [Reference]
forall a. Set a -> [a]
S.toList Set Reference
miss
  where
    allowed :: Set Reference
allowed = [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
S.fromList [Reference]
allowed0

-- Just evaluating to force exceptions. Shouldn't actually be that
-- unsafe.
evaluateSTM :: a -> STM a
evaluateSTM :: forall a. a -> STM a
evaluateSTM a
x = IO a -> STM a
forall a. IO a -> STM a
unsafeIOToSTM (a -> IO a
forall a. a -> IO a
evaluate a
x)

cacheAdd0 ::
  S.Set Reference ->
  [(Reference, SuperGroup Symbol)] ->
  [(Reference, Set Reference)] ->
  CCache ->
  IO ()
cacheAdd0 :: Set Reference
-> [(Reference, SuperGroup Symbol)]
-> [(Reference, Set Reference)]
-> CCache
-> IO ()
cacheAdd0 Set Reference
ntys0 [(Reference, SuperGroup Symbol)]
tml [(Reference, Set Reference)]
sands CCache
cc = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Map Reference (SuperGroup Symbol)
have <- TVar (Map Reference (SuperGroup Symbol))
-> STM (Map Reference (SuperGroup Symbol))
forall a. TVar a -> STM a
readTVar (CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed CCache
cc)
  let new :: Map Reference (SuperGroup Symbol)
new = Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.difference Map Reference (SuperGroup Symbol)
toAdd Map Reference (SuperGroup Symbol)
have
      sz :: Word64
sz = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Map Reference (SuperGroup Symbol) -> Int
forall k a. Map k a -> Int
M.size Map Reference (SuperGroup Symbol)
new
      rgs :: [(Reference, SuperGroup Symbol)]
rgs = Map Reference (SuperGroup Symbol)
-> [(Reference, SuperGroup Symbol)]
forall k a. Map k a -> [(k, a)]
M.toList Map Reference (SuperGroup Symbol)
new
      rs :: [Reference]
rs = (Reference, SuperGroup Symbol) -> Reference
forall a b. (a, b) -> a
fst ((Reference, SuperGroup Symbol) -> Reference)
-> [(Reference, SuperGroup Symbol)] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, SuperGroup Symbol)]
rgs
  ()
int <- TVar (Map Reference (SuperGroup Symbol))
-> Map Reference (SuperGroup Symbol) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed CCache
cc) (Map Reference (SuperGroup Symbol)
have Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
forall a. Semigroup a => a -> a -> a
<> Map Reference (SuperGroup Symbol)
new)
  Map Reference Word64
rty <- TVar Word64
-> TVar (Map Reference Word64)
-> TVar (EnumMap Word64 Reference)
-> Set Reference
-> STM (Map Reference Word64)
addRefs (CCache -> TVar Word64
freshTy CCache
cc) (CCache -> TVar (Map Reference Word64)
refTy CCache
cc) (CCache -> TVar (EnumMap Word64 Reference)
tagRefs CCache
cc) Set Reference
ntys0
  Word64
ntm <- TVar Word64 -> (Word64 -> (Word64, Word64)) -> STM Word64
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar (CCache -> TVar Word64
freshTm CCache
cc) ((Word64 -> (Word64, Word64)) -> STM Word64)
-> (Word64 -> (Word64, Word64)) -> STM Word64
forall a b. (a -> b) -> a -> b
$ \Word64
i -> (Word64
i, Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
sz)
  Map Reference Word64
rtm <- Map Reference Word64
-> TVar (Map Reference Word64) -> STM (Map Reference Word64)
forall s. Semigroup s => s -> TVar s -> STM s
updateMap ([(Reference, Word64)] -> Map Reference Word64
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Reference, Word64)] -> Map Reference Word64)
-> [(Reference, Word64)] -> Map Reference Word64
forall a b. (a -> b) -> a -> b
$ [Reference] -> [Word64] -> [(Reference, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Reference]
rs [Word64
ntm ..]) (CCache -> TVar (Map Reference Word64)
refTm CCache
cc)
  -- check for missing references
  let rns :: RefNums
rns = (Reference -> Word64) -> (Reference -> Word64) -> RefNums
RN ([Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
"ty" Map Reference Word64
rty) ([Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
"tm" Map Reference Word64
rtm)
      combinate :: Word64 -> (Reference, SuperGroup Symbol) -> (Word64, EnumMap Word64 Comb)
      combinate :: Word64
-> (Reference, SuperGroup Symbol) -> (Word64, EnumMap Word64 Comb)
combinate Word64
n (Reference
r, SuperGroup Symbol
g) = (Word64
n, RefNums
-> Reference -> Word64 -> SuperGroup Symbol -> EnumMap Word64 Comb
forall v.
Var v =>
RefNums
-> Reference -> Word64 -> SuperGroup v -> EnumMap Word64 Comb
emitCombs RefNums
rns Reference
r Word64
n SuperGroup Symbol
g)
  EnumMap Word64 Reference
nrs <- EnumMap Word64 Reference
-> TVar (EnumMap Word64 Reference)
-> STM (EnumMap Word64 Reference)
forall s. Semigroup s => s -> TVar s -> STM s
updateMap ([(Word64, Reference)] -> EnumMap Word64 Reference
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList ([(Word64, Reference)] -> EnumMap Word64 Reference)
-> [(Word64, Reference)] -> EnumMap Word64 Reference
forall a b. (a -> b) -> a -> b
$ [Word64] -> [Reference] -> [(Word64, Reference)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64
ntm ..] [Reference]
rs) (CCache -> TVar (EnumMap Word64 Reference)
combRefs CCache
cc)
  EnumMap Word64 RCombs
ncs <- TVar (EnumMap Word64 RCombs)
-> (EnumMap Word64 RCombs -> EnumMap Word64 RCombs)
-> STM (EnumMap Word64 RCombs)
forall s. TVar s -> (s -> s) -> STM s
modifyMap (CCache -> TVar (EnumMap Word64 RCombs)
combs CCache
cc) \EnumMap Word64 RCombs
oldCombs ->
    let newCombs :: EnumMap Word64 RCombs
newCombs = Maybe (EnumMap Word64 RCombs)
-> EnumMap Word64 (EnumMap Word64 Comb) -> EnumMap Word64 RCombs
resolveCombs (EnumMap Word64 RCombs -> Maybe (EnumMap Word64 RCombs)
forall a. a -> Maybe a
Just EnumMap Word64 RCombs
oldCombs) (EnumMap Word64 (EnumMap Word64 Comb) -> EnumMap Word64 RCombs)
-> ([(Word64, EnumMap Word64 Comb)]
    -> EnumMap Word64 (EnumMap Word64 Comb))
-> [(Word64, EnumMap Word64 Comb)]
-> EnumMap Word64 RCombs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Word64, EnumMap Word64 Comb)]
-> EnumMap Word64 (EnumMap Word64 Comb)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList ([(Word64, EnumMap Word64 Comb)] -> EnumMap Word64 RCombs)
-> [(Word64, EnumMap Word64 Comb)] -> EnumMap Word64 RCombs
forall a b. (a -> b) -> a -> b
$ (Word64
 -> (Reference, SuperGroup Symbol) -> (Word64, EnumMap Word64 Comb))
-> [Word64]
-> [(Reference, SuperGroup Symbol)]
-> [(Word64, EnumMap Word64 Comb)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word64
-> (Reference, SuperGroup Symbol) -> (Word64, EnumMap Word64 Comb)
combinate [Word64
ntm ..] [(Reference, SuperGroup Symbol)]
rgs
     in EnumMap Word64 RCombs
newCombs EnumMap Word64 RCombs
-> EnumMap Word64 RCombs -> EnumMap Word64 RCombs
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 RCombs
oldCombs
  Map Reference (Set Reference)
nsn <- Map Reference (Set Reference)
-> TVar (Map Reference (Set Reference))
-> STM (Map Reference (Set Reference))
forall s. Semigroup s => s -> TVar s -> STM s
updateMap ([(Reference, Set Reference)] -> Map Reference (Set Reference)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Reference, Set Reference)]
sands) (CCache -> TVar (Map Reference (Set Reference))
sandbox CCache
cc)
  pure $ ()
int () -> () -> ()
forall a b. a -> b -> b
`seq` Map Reference Word64
rtm Map Reference Word64 -> () -> ()
forall a b. a -> b -> b
`seq` EnumMap Word64 Reference
nrs EnumMap Word64 Reference -> () -> ()
forall a b. a -> b -> b
`seq` EnumMap Word64 RCombs
ncs EnumMap Word64 RCombs -> () -> ()
forall a b. a -> b -> b
`seq` Map Reference (Set Reference)
nsn Map Reference (Set Reference) -> () -> ()
forall a b. a -> b -> b
`seq` ()
  where
    toAdd :: Map Reference (SuperGroup Symbol)
toAdd = [(Reference, SuperGroup Symbol)]
-> Map Reference (SuperGroup Symbol)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Reference, SuperGroup Symbol)]
tml

expandSandbox ::
  Map Reference (Set Reference) ->
  [(Reference, SuperGroup Symbol)] ->
  [(Reference, Set Reference)]
expandSandbox :: Map Reference (Set Reference)
-> [(Reference, SuperGroup Symbol)] -> [(Reference, Set Reference)]
expandSandbox Map Reference (Set Reference)
sand0 [(Reference, SuperGroup Symbol)]
groups = Map Reference (Set Reference) -> [(Reference, Set Reference)]
fixed Map Reference (Set Reference)
forall a. Monoid a => a
mempty
  where
    f :: Map k a -> Bool -> k -> a
f Map k a
sand Bool
False k
r = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
forall a. Monoid a => a
mempty (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
r Map k a
sand
    f Map k a
_ Bool
True k
_ = a
forall a. Monoid a => a
mempty

    h :: Map Reference (Set a) -> (a, SuperGroup v) -> Maybe (a, Set a)
h Map Reference (Set a)
sand (a
r, (Bool -> Reference -> Set a) -> SuperGroup v -> Set a
forall r v.
(Monoid r, Var v) =>
(Bool -> Reference -> r) -> SuperGroup v -> r
foldGroupLinks (Map Reference (Set a) -> Bool -> Reference -> Set a
forall {a} {k}. (Monoid a, Ord k) => Map k a -> Bool -> k -> a
f Map Reference (Set a)
sand) -> Set a
s)
      | Set a -> Bool
forall a. Set a -> Bool
S.null Set a
s = Maybe (a, Set a)
forall a. Maybe a
Nothing
      | Bool
otherwise = (a, Set a) -> Maybe (a, Set a)
forall a. a -> Maybe a
Just (a
r, Set a
s)

    fixed :: Map Reference (Set Reference) -> [(Reference, Set Reference)]
fixed Map Reference (Set Reference)
extra
      | Map Reference (Set Reference)
extra Map Reference (Set Reference)
-> Map Reference (Set Reference) -> Bool
forall a. Eq a => a -> a -> Bool
== Map Reference (Set Reference)
extra' = [(Reference, Set Reference)]
new
      | Bool
otherwise = Map Reference (Set Reference) -> [(Reference, Set Reference)]
fixed Map Reference (Set Reference)
extra'
      where
        new :: [(Reference, Set Reference)]
new = ((Reference, SuperGroup Symbol)
 -> Maybe (Reference, Set Reference))
-> [(Reference, SuperGroup Symbol)] -> [(Reference, Set Reference)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe (Map Reference (Set Reference)
-> (Reference, SuperGroup Symbol)
-> Maybe (Reference, Set Reference)
forall {v} {a} {a}.
(Var v, Ord a) =>
Map Reference (Set a) -> (a, SuperGroup v) -> Maybe (a, Set a)
h (Map Reference (Set Reference)
 -> (Reference, SuperGroup Symbol)
 -> Maybe (Reference, Set Reference))
-> Map Reference (Set Reference)
-> (Reference, SuperGroup Symbol)
-> Maybe (Reference, Set Reference)
forall a b. (a -> b) -> a -> b
$ Map Reference (Set Reference)
extra Map Reference (Set Reference)
-> Map Reference (Set Reference) -> Map Reference (Set Reference)
forall a. Semigroup a => a -> a -> a
<> Map Reference (Set Reference)
sand0) [(Reference, SuperGroup Symbol)]
groups
        extra' :: Map Reference (Set Reference)
extra' = [(Reference, Set Reference)] -> Map Reference (Set Reference)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Reference, Set Reference)]
new

cacheAdd ::
  [(Reference, SuperGroup Symbol)] ->
  CCache ->
  IO [Reference]
cacheAdd :: [(Reference, SuperGroup Symbol)] -> CCache -> IO [Reference]
cacheAdd [(Reference, SuperGroup Symbol)]
l CCache
cc = do
  Map Reference Word64
rtm <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTm CCache
cc)
  Map Reference Word64
rty <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTy CCache
cc)
  Map Reference (Set Reference)
sand <- TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference (Set Reference))
sandbox CCache
cc)
  let known :: Set Reference
known = Map Reference Word64 -> Set Reference
forall k a. Map k a -> Set k
M.keysSet Map Reference Word64
rtm Set Reference -> Set Reference -> Set Reference
forall a. Semigroup a => a -> a -> a
<> [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
S.fromList ((Reference, SuperGroup Symbol) -> Reference
forall a b. (a, b) -> a
fst ((Reference, SuperGroup Symbol) -> Reference)
-> [(Reference, SuperGroup Symbol)] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, SuperGroup Symbol)]
l)
      f :: Bool -> Reference -> Const (Set Reference, Set Reference) Any
f Bool
b Reference
r
        | Bool -> Bool
not Bool
b, Reference -> Set Reference -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember Reference
r Set Reference
known = (Set Reference, Set Reference)
-> Const (Set Reference, Set Reference) Any
forall {k} a (b :: k). a -> Const a b
Const (Reference -> Set Reference
forall a. a -> Set a
S.singleton Reference
r, Set Reference
forall a. Monoid a => a
mempty)
        | Bool
b, Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Reference
r Map Reference Word64
rty = (Set Reference, Set Reference)
-> Const (Set Reference, Set Reference) Any
forall {k} a (b :: k). a -> Const a b
Const (Set Reference
forall a. Monoid a => a
mempty, Reference -> Set Reference
forall a. a -> Set a
S.singleton Reference
r)
        | Bool
otherwise = (Set Reference, Set Reference)
-> Const (Set Reference, Set Reference) Any
forall {k} a (b :: k). a -> Const a b
Const (Set Reference
forall a. Monoid a => a
mempty, Set Reference
forall a. Monoid a => a
mempty)
      (Set Reference
missing, Set Reference
tys) = Const (Set Reference, Set Reference) Any
-> (Set Reference, Set Reference)
forall {k} a (b :: k). Const a b -> a
getConst (Const (Set Reference, Set Reference) Any
 -> (Set Reference, Set Reference))
-> Const (Set Reference, Set Reference) Any
-> (Set Reference, Set Reference)
forall a b. (a -> b) -> a -> b
$ (((Reference, SuperGroup Symbol)
 -> Const (Set Reference, Set Reference) Any)
-> [(Reference, SuperGroup Symbol)]
-> Const (Set Reference, Set Reference) Any
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((Reference, SuperGroup Symbol)
  -> Const (Set Reference, Set Reference) Any)
 -> [(Reference, SuperGroup Symbol)]
 -> Const (Set Reference, Set Reference) Any)
-> ((SuperGroup Symbol -> Const (Set Reference, Set Reference) Any)
    -> (Reference, SuperGroup Symbol)
    -> Const (Set Reference, Set Reference) Any)
-> (SuperGroup Symbol -> Const (Set Reference, Set Reference) Any)
-> [(Reference, SuperGroup Symbol)]
-> Const (Set Reference, Set Reference) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SuperGroup Symbol -> Const (Set Reference, Set Reference) Any)
-> (Reference, SuperGroup Symbol)
-> Const (Set Reference, Set Reference) Any
forall m a. Monoid m => (a -> m) -> (Reference, a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) ((Bool -> Reference -> Const (Set Reference, Set Reference) Any)
-> SuperGroup Symbol -> Const (Set Reference, Set Reference) Any
forall r v.
(Monoid r, Var v) =>
(Bool -> Reference -> r) -> SuperGroup v -> r
foldGroupLinks Bool -> Reference -> Const (Set Reference, Set Reference) Any
f) [(Reference, SuperGroup Symbol)]
l
      l' :: [(Reference, SuperGroup Symbol)]
l' = ((Reference, SuperGroup Symbol) -> Bool)
-> [(Reference, SuperGroup Symbol)]
-> [(Reference, SuperGroup Symbol)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Reference
r, SuperGroup Symbol
_) -> Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Reference
r Map Reference Word64
rtm) [(Reference, SuperGroup Symbol)]
l
  if Set Reference -> Bool
forall a. Set a -> Bool
S.null Set Reference
missing
    then [] [Reference] -> IO () -> IO [Reference]
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Set Reference
-> [(Reference, SuperGroup Symbol)]
-> [(Reference, Set Reference)]
-> CCache
-> IO ()
cacheAdd0 Set Reference
tys [(Reference, SuperGroup Symbol)]
l' (Map Reference (Set Reference)
-> [(Reference, SuperGroup Symbol)] -> [(Reference, Set Reference)]
expandSandbox Map Reference (Set Reference)
sand [(Reference, SuperGroup Symbol)]
l') CCache
cc
    else [Reference] -> IO [Reference]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Reference] -> IO [Reference]) -> [Reference] -> IO [Reference]
forall a b. (a -> b) -> a -> b
$ Set Reference -> [Reference]
forall a. Set a -> [a]
S.toList Set Reference
missing

reflectValue :: EnumMap Word64 Reference -> Closure -> IO ANF.Value
reflectValue :: EnumMap Word64 Reference -> RClosure -> IO Value
reflectValue EnumMap Word64 Reference
rty = RClosure -> IO Value
goV
  where
    err :: [Char] -> [Char]
err [Char]
s = [Char]
"reflectValue: cannot prepare value for serialization: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
    refTy :: Word64 -> IO Reference
refTy Word64
w
      | Just Reference
r <- Word64 -> EnumMap Word64 Reference -> Maybe Reference
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w EnumMap Word64 Reference
rty = Reference -> IO Reference
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Reference
r
      | Bool
otherwise =
          [Char] -> IO Reference
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Reference) -> [Char] -> IO Reference
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
err [Char]
"unknown type reference"

    goIx :: CombIx -> GroupRef
goIx (CIx Reference
r Word64
_ Word64
i) = Reference -> Word64 -> GroupRef
ANF.GR Reference
r Word64
i

    goV :: RClosure -> IO Value
goV (PApV RComb
rComb [Int]
ua [RClosure]
ba) =
      GroupRef -> [Word64] -> [Value] -> Value
ANF.Partial (CombIx -> GroupRef
goIx (CombIx -> GroupRef) -> CombIx -> GroupRef
forall a b. (a -> b) -> a -> b
$ RComb -> CombIx
rCombIx RComb
rComb) (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> [Int] -> [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
ua) ([Value] -> Value) -> IO [Value] -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RClosure -> IO Value) -> [RClosure] -> IO [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse RClosure -> IO Value
goV [RClosure]
ba
    goV (DataC Reference
_ Word64
t [Int
w] []) = BLit -> Value
ANF.BLit (BLit -> Value) -> IO BLit -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Int -> IO BLit
reflectUData Word64
t Int
w
    goV (DataC Reference
r Word64
t [Int]
us [RClosure]
bs) =
      Reference -> Word64 -> [Word64] -> [Value] -> Value
ANF.Data Reference
r (Word64 -> Word64
maskTags Word64
t) (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> [Int] -> [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
us) ([Value] -> Value) -> IO [Value] -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RClosure -> IO Value) -> [RClosure] -> IO [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse RClosure -> IO Value
goV [RClosure]
bs
    goV (CapV K
k Int
_ Int
_ [Int]
us [RClosure]
bs) =
      [Word64] -> [Value] -> Cont -> Value
ANF.Cont (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> [Int] -> [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
us) ([Value] -> Cont -> Value) -> IO [Value] -> IO (Cont -> Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RClosure -> IO Value) -> [RClosure] -> IO [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse RClosure -> IO Value
goV [RClosure]
bs IO (Cont -> Value) -> IO Cont -> IO Value
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> K -> IO Cont
goK K
k
    goV (Foreign Foreign
f) = BLit -> Value
ANF.BLit (BLit -> Value) -> IO BLit -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Foreign -> IO BLit
goF Foreign
f
    goV RClosure
BlackHole = [Char] -> IO Value
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Value) -> [Char] -> IO Value
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
err [Char]
"black hole"

    goK :: K -> IO Cont
goK (CB Callback
_) = [Char] -> IO Cont
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Cont) -> [Char] -> IO Cont
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
err [Char]
"callback continuation"
    goK K
KE = Cont -> IO Cont
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cont
ANF.KE
    goK (Mark Int
ua Int
ba EnumSet Word64
ps EnumMap Word64 RClosure
de K
k) = do
      [Reference]
ps <- (Word64 -> IO Reference) -> [Word64] -> IO [Reference]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Word64 -> IO Reference
refTy (EnumSet Word64 -> [Word64]
forall k. EnumKey k => EnumSet k -> [k]
EC.setToList EnumSet Word64
ps)
      [(Reference, Value)]
de <- ((Word64, RClosure) -> IO (Reference, Value))
-> [(Word64, RClosure)] -> IO [(Reference, Value)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(Word64
k, RClosure
v) -> (,) (Reference -> Value -> (Reference, Value))
-> IO Reference -> IO (Value -> (Reference, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> IO Reference
refTy Word64
k IO (Value -> (Reference, Value))
-> IO Value -> IO (Reference, Value)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RClosure -> IO Value
goV RClosure
v) (EnumMap Word64 RClosure -> [(Word64, RClosure)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList EnumMap Word64 RClosure
de)
      Word64
-> Word64 -> [Reference] -> Map Reference Value -> Cont -> Cont
ANF.Mark (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ua) (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ba) [Reference]
ps ([(Reference, Value)] -> Map Reference Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Reference, Value)]
de) (Cont -> Cont) -> IO Cont -> IO Cont
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K -> IO Cont
goK K
k
    goK (Push Int
uf Int
bf Int
ua Int
ba RComb
rComb K
k) =
      Word64 -> Word64 -> Word64 -> Word64 -> GroupRef -> Cont -> Cont
ANF.Push
        (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
uf)
        (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bf)
        (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ua)
        (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ba)
        (CombIx -> GroupRef
goIx (CombIx -> GroupRef) -> CombIx -> GroupRef
forall a b. (a -> b) -> a -> b
$ RComb -> CombIx
rCombIx RComb
rComb)
        (Cont -> Cont) -> IO Cont -> IO Cont
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K -> IO Cont
goK K
k

    goF :: Foreign -> IO BLit
goF Foreign
f
      | Just Text
t <- Foreign -> Maybe Text
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f =
          BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> BLit
ANF.Text Text
t)
      | Just Bytes
b <- Foreign -> Maybe Bytes
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f =
          BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> BLit
ANF.Bytes Bytes
b)
      | Just Seq RClosure
s <- Reference -> Foreign -> Maybe (Seq RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.listRef Foreign
f =
          Seq Value -> BLit
ANF.List (Seq Value -> BLit) -> IO (Seq Value) -> IO BLit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RClosure -> IO Value) -> Seq RClosure -> IO (Seq Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seq a -> f (Seq b)
traverse RClosure -> IO Value
goV Seq RClosure
s
      | Just Referent' Reference
l <- Reference -> Foreign -> Maybe (Referent' Reference)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.termLinkRef Foreign
f =
          BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referent' Reference -> BLit
ANF.TmLink Referent' Reference
l)
      | Just Reference
l <- Reference -> Foreign -> Maybe Reference
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.typeLinkRef Foreign
f =
          BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference -> BLit
ANF.TyLink Reference
l)
      | Just Value
v <- Reference -> Foreign -> Maybe Value
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.valueRef Foreign
f =
          BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> BLit
ANF.Quote Value
v)
      | Just SuperGroup Symbol
g <- Reference -> Foreign -> Maybe (SuperGroup Symbol)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.codeRef Foreign
f =
          BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SuperGroup Symbol -> BLit
ANF.Code SuperGroup Symbol
g)
      | Just ByteArray
a <- Reference -> Foreign -> Maybe ByteArray
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.ibytearrayRef Foreign
f =
          BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteArray -> BLit
ANF.BArr ByteArray
a)
      | Just Array RClosure
a <- Reference -> Foreign -> Maybe (Array RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.iarrayRef Foreign
f =
          Array Value -> BLit
ANF.Arr (Array Value -> BLit) -> IO (Array Value) -> IO BLit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RClosure -> IO Value) -> Array RClosure -> IO (Array Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Array a -> f (Array b)
traverse RClosure -> IO Value
goV Array RClosure
a
      | Bool
otherwise = [Char] -> IO BLit
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO BLit) -> [Char] -> IO BLit
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
err ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"foreign value: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (Foreign -> [Char]
forall a. Show a => a -> [Char]
show Foreign
f)

    reflectUData :: Word64 -> Int -> IO ANF.BLit
    reflectUData :: Word64 -> Int -> IO BLit
reflectUData Word64
t Int
v
      | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
natTag = BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BLit -> IO BLit) -> BLit -> IO BLit
forall a b. (a -> b) -> a -> b
$ Word64 -> BLit
ANF.Pos (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
      | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
charTag = BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BLit -> IO BLit) -> BLit -> IO BLit
forall a b. (a -> b) -> a -> b
$ Char -> BLit
ANF.Char (Int -> Char
forall a. Enum a => Int -> a
toEnum Int
v)
      | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
intTag, Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BLit -> IO BLit) -> BLit -> IO BLit
forall a b. (a -> b) -> a -> b
$ Word64 -> BLit
ANF.Pos (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
      | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
intTag, Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BLit -> IO BLit) -> BLit -> IO BLit
forall a b. (a -> b) -> a -> b
$ Word64 -> BLit
ANF.Neg (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Int
v))
      | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
floatTag = BLit -> IO BLit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BLit -> IO BLit) -> BLit -> IO BLit
forall a b. (a -> b) -> a -> b
$ Double -> BLit
ANF.Float (Int -> Double
intToDouble Int
v)
      | Bool
otherwise = [Char] -> IO BLit
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO BLit) -> ([Char] -> [Char]) -> [Char] -> IO BLit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO BLit) -> [Char] -> IO BLit
forall a b. (a -> b) -> a -> b
$ [Char]
"unboxed data: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (Word64, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Word64
t, Int
v)

reifyValue :: CCache -> ANF.Value -> IO (Either [Reference] RClosure)
reifyValue :: CCache -> Value -> IO (Either [Reference] RClosure)
reifyValue CCache
cc Value
val = do
  Either
  [Reference]
  (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
erc <-
    STM
  (Either
     [Reference]
     (EnumMap Word64 RCombs, Map Reference Word64,
      Map Reference Word64))
-> IO
     (Either
        [Reference]
        (EnumMap Word64 RCombs, Map Reference Word64,
         Map Reference Word64))
forall a. STM a -> IO a
atomically (STM
   (Either
      [Reference]
      (EnumMap Word64 RCombs, Map Reference Word64,
       Map Reference Word64))
 -> IO
      (Either
         [Reference]
         (EnumMap Word64 RCombs, Map Reference Word64,
          Map Reference Word64)))
-> STM
     (Either
        [Reference]
        (EnumMap Word64 RCombs, Map Reference Word64,
         Map Reference Word64))
-> IO
     (Either
        [Reference]
        (EnumMap Word64 RCombs, Map Reference Word64,
         Map Reference Word64))
forall a b. (a -> b) -> a -> b
$ do
      EnumMap Word64 RCombs
combs <- TVar (EnumMap Word64 RCombs) -> STM (EnumMap Word64 RCombs)
forall a. TVar a -> STM a
readTVar (CCache -> TVar (EnumMap Word64 RCombs)
combs CCache
cc)
      Map Reference Word64
rtm <- TVar (Map Reference Word64) -> STM (Map Reference Word64)
forall a. TVar a -> STM a
readTVar (CCache -> TVar (Map Reference Word64)
refTm CCache
cc)
      case Set Reference -> [Reference]
forall a. Set a -> [a]
S.toList (Set Reference -> [Reference]) -> Set Reference -> [Reference]
forall a b. (a -> b) -> a -> b
$ (Reference -> Bool) -> Set Reference -> Set Reference
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` Map Reference Word64
rtm) Set Reference
tmLinks of
        [] -> do
          Map Reference Word64
newTy <- TVar Word64
-> TVar (Map Reference Word64)
-> TVar (EnumMap Word64 Reference)
-> Set Reference
-> STM (Map Reference Word64)
addRefs (CCache -> TVar Word64
freshTy CCache
cc) (CCache -> TVar (Map Reference Word64)
refTy CCache
cc) (CCache -> TVar (EnumMap Word64 Reference)
tagRefs CCache
cc) Set Reference
tyLinks
          Either
  [Reference]
  (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 RCombs, Map Reference Word64,
         Map Reference Word64))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   [Reference]
   (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
 -> STM
      (Either
         [Reference]
         (EnumMap Word64 RCombs, Map Reference Word64,
          Map Reference Word64)))
-> ((EnumMap Word64 RCombs, Map Reference Word64,
     Map Reference Word64)
    -> Either
         [Reference]
         (EnumMap Word64 RCombs, Map Reference Word64,
          Map Reference Word64))
-> (EnumMap Word64 RCombs, Map Reference Word64,
    Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 RCombs, Map Reference Word64,
         Map Reference Word64))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
-> Either
     [Reference]
     (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
forall a b. b -> Either a b
Right ((EnumMap Word64 RCombs, Map Reference Word64,
  Map Reference Word64)
 -> STM
      (Either
         [Reference]
         (EnumMap Word64 RCombs, Map Reference Word64,
          Map Reference Word64)))
-> (EnumMap Word64 RCombs, Map Reference Word64,
    Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 RCombs, Map Reference Word64,
         Map Reference Word64))
forall a b. (a -> b) -> a -> b
$ (EnumMap Word64 RCombs
combs, Map Reference Word64
newTy, Map Reference Word64
rtm)
        [Reference]
l -> Either
  [Reference]
  (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 RCombs, Map Reference Word64,
         Map Reference Word64))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Reference]
-> Either
     [Reference]
     (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
forall a b. a -> Either a b
Left [Reference]
l)
  ((EnumMap Word64 RCombs, Map Reference Word64,
  Map Reference Word64)
 -> IO RClosure)
-> Either
     [Reference]
     (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
-> IO (Either [Reference] RClosure)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Either [Reference] a -> f (Either [Reference] b)
traverse (\(EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
rfs -> (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
-> Value -> IO RClosure
reifyValue0 (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
rfs Value
val) Either
  [Reference]
  (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
erc
  where
    f :: Bool -> a -> (Set a, Set a)
f Bool
False a
r = (Set a
forall a. Monoid a => a
mempty, a -> Set a
forall a. a -> Set a
S.singleton a
r)
    f Bool
True a
r = (a -> Set a
forall a. a -> Set a
S.singleton a
r, Set a
forall a. Monoid a => a
mempty)
    (Set Reference
tyLinks, Set Reference
tmLinks) = (Bool -> Reference -> (Set Reference, Set Reference))
-> Value -> (Set Reference, Set Reference)
forall a. Monoid a => (Bool -> Reference -> a) -> Value -> a
valueLinks Bool -> Reference -> (Set Reference, Set Reference)
forall {a}. Ord a => Bool -> a -> (Set a, Set a)
f Value
val

reifyValue0 ::
  (EnumMap Word64 RCombs, M.Map Reference Word64, M.Map Reference Word64) ->
  ANF.Value ->
  IO Closure
reifyValue0 :: (EnumMap Word64 RCombs, Map Reference Word64, Map Reference Word64)
-> Value -> IO RClosure
reifyValue0 (EnumMap Word64 RCombs
combs, Map Reference Word64
rty, Map Reference Word64
rtm) = Value -> IO RClosure
goV
  where
    err :: [Char] -> [Char]
err [Char]
s = [Char]
"reifyValue: cannot restore value: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
    refTy :: Reference -> IO Word64
refTy Reference
r
      | Just Word64
w <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference Word64
rty = Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
      | Bool
otherwise = [Char] -> IO Word64
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Word64) -> ([Char] -> [Char]) -> [Char] -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Word64) -> [Char] -> IO Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown type reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r
    refTm :: Reference -> IO Word64
refTm Reference
r
      | Just Word64
w <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference Word64
rtm = Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
      | Bool
otherwise = [Char] -> IO Word64
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Word64) -> ([Char] -> [Char]) -> [Char] -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Word64) -> [Char] -> IO Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown term reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r
    goIx :: ANF.GroupRef -> IO RComb
    goIx :: GroupRef -> IO RComb
goIx (ANF.GR Reference
r Word64
i) =
      Reference -> IO Word64
refTm Reference
r IO Word64 -> (Word64 -> RComb) -> IO RComb
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Word64
n ->
        EnumMap Word64 RCombs -> CombIx -> RComb
rCombSection EnumMap Word64 RCombs
combs (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
r Word64
n Word64
i)

    goV :: Value -> IO RClosure
goV (ANF.Partial GroupRef
gr [Word64]
ua [Value]
ba) =
      RComb -> [RClosure] -> RClosure
pap (RComb -> [RClosure] -> RClosure)
-> IO RComb -> IO ([RClosure] -> RClosure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GroupRef -> IO RComb
goIx GroupRef
gr) IO ([RClosure] -> RClosure) -> IO [RClosure] -> IO RClosure
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> IO RClosure) -> [Value] -> IO [RClosure]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Value -> IO RClosure
goV [Value]
ba
      where
        pap :: RComb -> [RClosure] -> RClosure
pap RComb
i = RComb -> [Int] -> [RClosure] -> RClosure
PApV RComb
i (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> [Word64] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word64]
ua)
    goV (ANF.Data Reference
r Word64
t0 [Word64]
us [Value]
bs) = do
      Word64
t <- (RTag -> CTag -> Word64) -> CTag -> RTag -> Word64
forall a b c. (a -> b -> c) -> b -> a -> c
flip RTag -> CTag -> Word64
packTags (Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t0) (RTag -> Word64) -> (Word64 -> RTag) -> Word64 -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> RTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word64) -> IO Word64 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> IO Word64
refTy Reference
r
      Reference -> Word64 -> [Int] -> [RClosure] -> RClosure
DataC Reference
r Word64
t (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> [Word64] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word64]
us) ([RClosure] -> RClosure) -> IO [RClosure] -> IO RClosure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> IO RClosure) -> [Value] -> IO [RClosure]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Value -> IO RClosure
goV [Value]
bs
    goV (ANF.Cont [Word64]
us [Value]
bs Cont
k) = K -> [RClosure] -> RClosure
cv (K -> [RClosure] -> RClosure)
-> IO K -> IO ([RClosure] -> RClosure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cont -> IO K
goK Cont
k IO ([RClosure] -> RClosure) -> IO [RClosure] -> IO RClosure
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> IO RClosure) -> [Value] -> IO [RClosure]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Value -> IO RClosure
goV [Value]
bs
      where
        cv :: K -> [RClosure] -> RClosure
cv K
k [RClosure]
bs = K -> Int -> Int -> [Int] -> [RClosure] -> RClosure
CapV K
k Int
ua Int
ba (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> [Word64] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word64]
us) [RClosure]
bs
          where
            (Int
uksz, Int
bksz) = K -> (Int, Int)
frameDataSize K
k
            ua :: Int
ua = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Word64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word64]
us Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
uksz
            ba :: Int
ba = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [RClosure] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RClosure]
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bksz
    goV (ANF.BLit BLit
l) = BLit -> IO RClosure
goL BLit
l

    goK :: Cont -> IO K
goK Cont
ANF.KE = K -> IO K
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure K
KE
    goK (ANF.Mark Word64
ua Word64
ba [Reference]
ps Map Reference Value
de Cont
k) =
      [Word64] -> [(Word64, RClosure)] -> K -> K
mrk
        ([Word64] -> [(Word64, RClosure)] -> K -> K)
-> IO [Word64] -> IO ([(Word64, RClosure)] -> K -> K)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Reference -> IO Word64) -> [Reference] -> IO [Word64]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Reference -> IO Word64
refTy [Reference]
ps
        IO ([(Word64, RClosure)] -> K -> K)
-> IO [(Word64, RClosure)] -> IO (K -> K)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Reference, Value) -> IO (Word64, RClosure))
-> [(Reference, Value)] -> IO [(Word64, RClosure)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(Reference
k, Value
v) -> (,) (Word64 -> RClosure -> (Word64, RClosure))
-> IO Word64 -> IO (RClosure -> (Word64, RClosure))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> IO Word64
refTy Reference
k IO (RClosure -> (Word64, RClosure))
-> IO RClosure -> IO (Word64, RClosure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> IO RClosure
goV Value
v) (Map Reference Value -> [(Reference, Value)]
forall k a. Map k a -> [(k, a)]
M.toList Map Reference Value
de)
        IO (K -> K) -> IO K -> IO K
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cont -> IO K
goK Cont
k
      where
        mrk :: [Word64] -> [(Word64, RClosure)] -> K -> K
mrk [Word64]
ps [(Word64, RClosure)]
de K
k =
          Int -> Int -> EnumSet Word64 -> EnumMap Word64 RClosure -> K -> K
Mark (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ua) (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ba) ([Word64] -> EnumSet Word64
forall k. EnumKey k => [k] -> EnumSet k
setFromList [Word64]
ps) ([(Word64, RClosure)] -> EnumMap Word64 RClosure
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList [(Word64, RClosure)]
de) K
k
    goK (ANF.Push Word64
uf Word64
bf Word64
ua Word64
ba GroupRef
gr Cont
k) =
      Int -> Int -> Int -> Int -> RComb -> K -> K
Push
        (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
uf)
        (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
bf)
        (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ua)
        (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ba)
        (RComb -> K -> K) -> IO RComb -> IO (K -> K)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GroupRef -> IO RComb
goIx GroupRef
gr)
        IO (K -> K) -> IO K -> IO K
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cont -> IO K
goK Cont
k

    goL :: BLit -> IO RClosure
goL (ANF.Text Text
t) = RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure)
-> (Foreign -> RClosure) -> Foreign -> IO RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> IO RClosure) -> Foreign -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Text -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.textRef Text
t
    goL (ANF.List Seq Value
l) = Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure)
-> (Seq RClosure -> Foreign) -> Seq RClosure -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Seq RClosure -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.listRef (Seq RClosure -> RClosure) -> IO (Seq RClosure) -> IO RClosure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> IO RClosure) -> Seq Value -> IO (Seq RClosure)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seq a -> f (Seq b)
traverse Value -> IO RClosure
goV Seq Value
l
    goL (ANF.TmLink Referent' Reference
r) = RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure)
-> (Foreign -> RClosure) -> Foreign -> IO RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> IO RClosure) -> Foreign -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Referent' Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef Referent' Reference
r
    goL (ANF.TyLink Reference
r) = RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure)
-> (Foreign -> RClosure) -> Foreign -> IO RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> IO RClosure) -> Foreign -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.typeLinkRef Reference
r
    goL (ANF.Bytes Bytes
b) = RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure)
-> (Foreign -> RClosure) -> Foreign -> IO RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> IO RClosure) -> Foreign -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Bytes -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.bytesRef Bytes
b
    goL (ANF.Quote Value
v) = RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure)
-> (Foreign -> RClosure) -> Foreign -> IO RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> IO RClosure) -> Foreign -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Value -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.valueRef Value
v
    goL (ANF.Code SuperGroup Symbol
g) = RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure)
-> (Foreign -> RClosure) -> Foreign -> IO RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> IO RClosure) -> Foreign -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> SuperGroup Symbol -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.codeRef SuperGroup Symbol
g
    goL (ANF.BArr ByteArray
a) = RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure)
-> (Foreign -> RClosure) -> Foreign -> IO RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> IO RClosure) -> Foreign -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> ByteArray -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.ibytearrayRef ByteArray
a
    goL (ANF.Char Char
c) = RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure) -> RClosure -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Word64 -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> GClosure comb
DataU1 Reference
Rf.charRef Word64
charTag (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c)
    goL (ANF.Pos Word64
w) =
      RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure) -> RClosure -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Word64 -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> GClosure comb
DataU1 Reference
Rf.natRef Word64
natTag (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w)
    goL (ANF.Neg Word64
w) =
      RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure) -> RClosure -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Word64 -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> GClosure comb
DataU1 Reference
Rf.intRef Word64
intTag (-Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w)
    goL (ANF.Float Double
d) =
      RClosure -> IO RClosure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RClosure -> IO RClosure) -> RClosure -> IO RClosure
forall a b. (a -> b) -> a -> b
$ Reference -> Word64 -> Int -> RClosure
forall comb. Reference -> Word64 -> Int -> GClosure comb
DataU1 Reference
Rf.floatRef Word64
floatTag (Double -> Int
doubleToInt Double
d)
    goL (ANF.Arr Array Value
a) = Foreign -> RClosure
forall comb. Foreign -> GClosure comb
Foreign (Foreign -> RClosure)
-> (Array RClosure -> Foreign) -> Array RClosure -> RClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Array RClosure -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.iarrayRef (Array RClosure -> RClosure) -> IO (Array RClosure) -> IO RClosure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> IO RClosure) -> Array Value -> IO (Array RClosure)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Array a -> f (Array b)
traverse Value -> IO RClosure
goV Array Value
a

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

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

-- Universal comparison functions

closureNum :: Closure -> Int
closureNum :: RClosure -> Int
closureNum PAp {} = Int
0
closureNum DataC {} = Int
1
closureNum Captured {} = Int
2
closureNum Foreign {} = Int
3
closureNum BlackHole {} = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"BlackHole"

universalEq ::
  (Foreign -> Foreign -> Bool) ->
  Closure ->
  Closure ->
  Bool
universalEq :: (Foreign -> Foreign -> Bool) -> RClosure -> RClosure -> Bool
universalEq Foreign -> Foreign -> Bool
frn = RClosure -> RClosure -> Bool
eqc
  where
    eql :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eql a -> b -> Bool
cm [a]
l [b]
r = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
r Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((a -> b -> Bool) -> [a] -> [b] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> Bool
cm [a]
l [b]
r)
    eqc :: RClosure -> RClosure -> Bool
eqc (DataC Reference
_ Word64
ct1 [Int
w1] []) (DataC Reference
_ Word64
ct2 [Int
w2] []) =
      Word64 -> Word64 -> Bool
matchTags Word64
ct1 Word64
ct2 Bool -> Bool -> Bool
&& Int
w1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
w2
    eqc (DataC Reference
_ Word64
ct1 [Int]
us1 [RClosure]
bs1) (DataC Reference
_ Word64
ct2 [Int]
us2 [RClosure]
bs2) =
      Word64
ct1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
ct2
        Bool -> Bool -> Bool
&& (Int -> Int -> Bool) -> [Int] -> [Int] -> Bool
forall {a} {b}. (a -> b -> Bool) -> [a] -> [b] -> Bool
eql Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Int]
us1 [Int]
us2
        Bool -> Bool -> Bool
&& (RClosure -> RClosure -> Bool) -> [RClosure] -> [RClosure] -> Bool
forall {a} {b}. (a -> b -> Bool) -> [a] -> [b] -> Bool
eql RClosure -> RClosure -> Bool
eqc [RClosure]
bs1 [RClosure]
bs2
    eqc (PApV RComb
i1 [Int]
us1 [RClosure]
bs1) (PApV RComb
i2 [Int]
us2 [RClosure]
bs2) =
      RComb
i1 RComb -> RComb -> Bool
forall a. Eq a => a -> a -> Bool
== RComb
i2
        Bool -> Bool -> Bool
&& (Int -> Int -> Bool) -> [Int] -> [Int] -> Bool
forall {a} {b}. (a -> b -> Bool) -> [a] -> [b] -> Bool
eql Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Int]
us1 [Int]
us2
        Bool -> Bool -> Bool
&& (RClosure -> RClosure -> Bool) -> [RClosure] -> [RClosure] -> Bool
forall {a} {b}. (a -> b -> Bool) -> [a] -> [b] -> Bool
eql RClosure -> RClosure -> Bool
eqc [RClosure]
bs1 [RClosure]
bs2
    eqc (CapV K
k1 Int
ua1 Int
ba1 [Int]
us1 [RClosure]
bs1) (CapV K
k2 Int
ua2 Int
ba2 [Int]
us2 [RClosure]
bs2) =
      K
k1 K -> K -> Bool
forall a. Eq a => a -> a -> Bool
== K
k2
        Bool -> Bool -> Bool
&& Int
ua1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ua2
        Bool -> Bool -> Bool
&& Int
ba1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ba2
        Bool -> Bool -> Bool
&& (Int -> Int -> Bool) -> [Int] -> [Int] -> Bool
forall {a} {b}. (a -> b -> Bool) -> [a] -> [b] -> Bool
eql Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Int]
us1 [Int]
us2
        Bool -> Bool -> Bool
&& (RClosure -> RClosure -> Bool) -> [RClosure] -> [RClosure] -> Bool
forall {a} {b}. (a -> b -> Bool) -> [a] -> [b] -> Bool
eql RClosure -> RClosure -> Bool
eqc [RClosure]
bs1 [RClosure]
bs2
    eqc (Foreign Foreign
fl) (Foreign Foreign
fr)
      | Just Array RClosure
al <- Reference -> Foreign -> Maybe (Array RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.iarrayRef Foreign
fl,
        Just Array RClosure
ar <- Reference -> Foreign -> Maybe (Array RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.iarrayRef Foreign
fr =
          (RClosure -> RClosure -> Bool)
-> Array RClosure -> Array RClosure -> Bool
arrayEq RClosure -> RClosure -> Bool
eqc Array RClosure
al Array RClosure
ar
      | Just Seq RClosure
sl <- Reference -> Foreign -> Maybe (Seq RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.listRef Foreign
fl,
        Just Seq RClosure
sr <- Reference -> Foreign -> Maybe (Seq RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.listRef Foreign
fr =
          Seq RClosure -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq RClosure
sl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Seq RClosure -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq RClosure
sr Bool -> Bool -> Bool
&& Seq Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((RClosure -> RClosure -> Bool)
-> Seq RClosure -> Seq RClosure -> Seq Bool
forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Sq.zipWith RClosure -> RClosure -> Bool
eqc Seq RClosure
sl Seq RClosure
sr)
      | Bool
otherwise = Foreign -> Foreign -> Bool
frn Foreign
fl Foreign
fr
    eqc RClosure
c RClosure
d = RClosure -> Int
closureNum RClosure
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RClosure -> Int
closureNum RClosure
d

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

arrayEq :: (Closure -> Closure -> Bool) -> PA.Array Closure -> PA.Array Closure -> Bool
arrayEq :: (RClosure -> RClosure -> Bool)
-> Array RClosure -> Array RClosure -> Bool
arrayEq RClosure -> RClosure -> Bool
eqc Array RClosure
l Array RClosure
r
  | Array RClosure -> Int
forall a. Array a -> Int
PA.sizeofArray Array RClosure
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Array RClosure -> Int
forall a. Array a -> Int
PA.sizeofArray Array RClosure
r = Bool
False
  | Bool
otherwise = Int -> Bool
go (Array RClosure -> Int
forall a. Array a -> Int
PA.sizeofArray Array RClosure
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  where
    go :: Int -> Bool
go Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Bool
True
      | Bool
otherwise = RClosure -> RClosure -> Bool
eqc (Array RClosure -> Int -> RClosure
forall a. Array a -> Int -> a
PA.indexArray Array RClosure
l Int
i) (Array RClosure -> Int -> RClosure
forall a. Array a -> Int -> a
PA.indexArray Array RClosure
r Int
i) Bool -> Bool -> Bool
&& Int -> Bool
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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

compareAsNat :: Int -> Int -> Ordering
compareAsNat :: Int -> Int -> Ordering
compareAsNat Int
i Int
j = Word -> Word -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word
ni Word
nj
  where
    ni, nj :: Word
    ni :: Word
ni = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
    nj :: Word
nj = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j

floatTag :: Word64
floatTag :: Word64
floatTag
  | Just Word64
n <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
Rf.floatRef Map Reference Word64
builtinTypeNumbering,
    RTag
rt <- Int -> RTag
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) =
      RTag -> CTag -> Word64
packTags RTag
rt CTag
0
  | Bool
otherwise = [Char] -> Word64
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: floatTag"

natTag :: Word64
natTag :: Word64
natTag
  | Just Word64
n <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
Rf.natRef Map Reference Word64
builtinTypeNumbering,
    RTag
rt <- Int -> RTag
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) =
      RTag -> CTag -> Word64
packTags RTag
rt CTag
0
  | Bool
otherwise = [Char] -> Word64
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: natTag"

intTag :: Word64
intTag :: Word64
intTag
  | Just Word64
n <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
Rf.intRef Map Reference Word64
builtinTypeNumbering,
    RTag
rt <- Int -> RTag
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) =
      RTag -> CTag -> Word64
packTags RTag
rt CTag
0
  | Bool
otherwise = [Char] -> Word64
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: intTag"

charTag :: Word64
charTag :: Word64
charTag
  | Just Word64
n <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
Rf.charRef Map Reference Word64
builtinTypeNumbering,
    RTag
rt <- Int -> RTag
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) =
      RTag -> CTag -> Word64
packTags RTag
rt CTag
0
  | Bool
otherwise = [Char] -> Word64
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: charTag"

unitTag :: Word64
unitTag :: Word64
unitTag
  | Just Word64
n <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
Rf.unitRef Map Reference Word64
builtinTypeNumbering,
    RTag
rt <- Int -> RTag
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) =
      RTag -> CTag -> Word64
packTags RTag
rt CTag
0
  | Bool
otherwise = [Char] -> Word64
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: unitTag"

leftTag, rightTag :: Word64
(Word64
leftTag, Word64
rightTag)
  | Just Word64
n <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
Rf.eitherRef Map Reference Word64
builtinTypeNumbering,
    RTag
et <- Int -> RTag
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n),
    CTag
lt <- Int -> CTag
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
Rf.eitherLeftId),
    CTag
rt <- Int -> CTag
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
Rf.eitherRightId) =
      (RTag -> CTag -> Word64
packTags RTag
et CTag
lt, RTag -> CTag -> Word64
packTags RTag
et CTag
rt)
  | Bool
otherwise = [Char] -> (Word64, Word64)
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: either tags"

universalCompare ::
  (Foreign -> Foreign -> Ordering) ->
  Closure ->
  Closure ->
  Ordering
universalCompare :: (Foreign -> Foreign -> Ordering)
-> RClosure -> RClosure -> Ordering
universalCompare Foreign -> Foreign -> Ordering
frn = Bool -> RClosure -> RClosure -> Ordering
cmpc Bool
False
  where
    cmpl :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering
cmpl a -> b -> Ordering
cm [a]
l [b]
r =
      Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l) ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
r) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> [Ordering] -> Ordering
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ((a -> b -> Ordering) -> [a] -> [b] -> [Ordering]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> Ordering
cm [a]
l [b]
r)
    cmpc :: Bool -> RClosure -> RClosure -> Ordering
cmpc Bool
_ (DataC Reference
_ Word64
ct1 [Int
i] []) (DataC Reference
_ Word64
ct2 [Int
j] [])
      | Word64
ct1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
floatTag, Word64
ct2 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
floatTag = Int -> Int -> Ordering
compareAsFloat Int
i Int
j
      | Word64
ct1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
natTag, Word64
ct2 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
natTag = Int -> Int -> Ordering
compareAsNat Int
i Int
j
      | Word64
ct1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
intTag, Word64
ct2 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
natTag = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
i Int
j
      | Word64
ct1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
natTag, Word64
ct2 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
intTag = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
i Int
j
    cmpc Bool
tyEq (DataC Reference
rf1 Word64
ct1 [Int]
us1 [RClosure]
bs1) (DataC Reference
rf2 Word64
ct2 [Int]
us2 [RClosure]
bs2) =
      (if Bool
tyEq Bool -> Bool -> Bool
&& Word64
ct1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
ct2 then Reference -> Reference -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Reference
rf1 Reference
rf2 else Ordering
EQ)
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word64 -> Word64
maskTags Word64
ct1) (Word64 -> Word64
maskTags Word64
ct2)
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (Int -> Int -> Ordering) -> [Int] -> [Int] -> Ordering
forall {a} {b}. (a -> b -> Ordering) -> [a] -> [b] -> Ordering
cmpl Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Int]
us1 [Int]
us2
        -- when comparing corresponding `Any` values, which have
        -- existentials inside check that type references match
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (RClosure -> RClosure -> Ordering)
-> [RClosure] -> [RClosure] -> Ordering
forall {a} {b}. (a -> b -> Ordering) -> [a] -> [b] -> Ordering
cmpl (Bool -> RClosure -> RClosure -> Ordering
cmpc (Bool -> RClosure -> RClosure -> Ordering)
-> Bool -> RClosure -> RClosure -> Ordering
forall a b. (a -> b) -> a -> b
$ Bool
tyEq Bool -> Bool -> Bool
|| Reference
rf1 Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Rf.anyRef) [RClosure]
bs1 [RClosure]
bs2
    cmpc Bool
tyEq (PApV RComb
i1 [Int]
us1 [RClosure]
bs1) (PApV RComb
i2 [Int]
us2 [RClosure]
bs2) =
      RComb -> RComb -> Ordering
forall a. Ord a => a -> a -> Ordering
compare RComb
i1 RComb
i2
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (Int -> Int -> Ordering) -> [Int] -> [Int] -> Ordering
forall {a} {b}. (a -> b -> Ordering) -> [a] -> [b] -> Ordering
cmpl Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Int]
us1 [Int]
us2
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (RClosure -> RClosure -> Ordering)
-> [RClosure] -> [RClosure] -> Ordering
forall {a} {b}. (a -> b -> Ordering) -> [a] -> [b] -> Ordering
cmpl (Bool -> RClosure -> RClosure -> Ordering
cmpc Bool
tyEq) [RClosure]
bs1 [RClosure]
bs2
    cmpc Bool
_ (CapV K
k1 Int
ua1 Int
ba1 [Int]
us1 [RClosure]
bs1) (CapV K
k2 Int
ua2 Int
ba2 [Int]
us2 [RClosure]
bs2) =
      K -> K -> Ordering
forall a. Ord a => a -> a -> Ordering
compare K
k1 K
k2
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
ua1 Int
ua2
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
ba1 Int
ba2
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (Int -> Int -> Ordering) -> [Int] -> [Int] -> Ordering
forall {a} {b}. (a -> b -> Ordering) -> [a] -> [b] -> Ordering
cmpl Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Int]
us1 [Int]
us2
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (RClosure -> RClosure -> Ordering)
-> [RClosure] -> [RClosure] -> Ordering
forall {a} {b}. (a -> b -> Ordering) -> [a] -> [b] -> Ordering
cmpl (Bool -> RClosure -> RClosure -> Ordering
cmpc Bool
True) [RClosure]
bs1 [RClosure]
bs2
    cmpc Bool
tyEq (Foreign Foreign
fl) (Foreign Foreign
fr)
      | Just Seq RClosure
sl <- Reference -> Foreign -> Maybe (Seq RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.listRef Foreign
fl,
        Just Seq RClosure
sr <- Reference -> Foreign -> Maybe (Seq RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.listRef Foreign
fr =
          Seq Ordering -> Ordering
forall m. Monoid m => Seq m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ((RClosure -> RClosure -> Ordering)
-> Seq RClosure -> Seq RClosure -> Seq Ordering
forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Sq.zipWith (Bool -> RClosure -> RClosure -> Ordering
cmpc Bool
tyEq) Seq RClosure
sl Seq RClosure
sr)
            Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Seq RClosure -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq RClosure
sl) (Seq RClosure -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq RClosure
sr)
      | Just Array RClosure
al <- Reference -> Foreign -> Maybe (Array RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.iarrayRef Foreign
fl,
        Just Array RClosure
ar <- Reference -> Foreign -> Maybe (Array RClosure)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.iarrayRef Foreign
fr =
          (RClosure -> RClosure -> Ordering)
-> Array RClosure -> Array RClosure -> Ordering
arrayCmp (Bool -> RClosure -> RClosure -> Ordering
cmpc Bool
tyEq) Array RClosure
al Array RClosure
ar
      | Bool
otherwise = Foreign -> Foreign -> Ordering
frn Foreign
fl Foreign
fr
    cmpc Bool
_ RClosure
c RClosure
d = (RClosure -> Int) -> RClosure -> RClosure -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing RClosure -> Int
closureNum RClosure
c RClosure
d

arrayCmp ::
  (Closure -> Closure -> Ordering) ->
  PA.Array Closure ->
  PA.Array Closure ->
  Ordering
arrayCmp :: (RClosure -> RClosure -> Ordering)
-> Array RClosure -> Array RClosure -> Ordering
arrayCmp RClosure -> RClosure -> Ordering
cmpc Array RClosure
l Array RClosure
r =
  (Array RClosure -> Int)
-> Array RClosure -> Array RClosure -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Array RClosure -> Int
forall a. Array a -> Int
PA.sizeofArray Array RClosure
l Array RClosure
r Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Ordering
go (Array RClosure -> Int
forall a. Array a -> Int
PA.sizeofArray Array RClosure
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  where
    go :: Int -> Ordering
go Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Ordering
EQ
      | Bool
otherwise = RClosure -> RClosure -> Ordering
cmpc (Array RClosure -> Int -> RClosure
forall a. Array a -> Int -> a
PA.indexArray Array RClosure
l Int
i) (Array RClosure -> Int -> RClosure
forall a. Array a -> Int -> a
PA.indexArray Array RClosure
r Int
i) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Ordering
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)