{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}

module Unison.Runtime.Machine
  ( ActiveThreads,
    CCache (..),
    Combs,
    Tracer (..),
    apply0,
    baseCCache,
    cacheAdd,
    cacheAdd0,
    eval0,
    expandSandbox,
    preEvalTopLevelConstants,
    refLookup,
    refNumTm,
    refNumsTm,
    refNumsTy,
    reifyValue,
    resolveSection,
  )
where

import Control.Concurrent (ThreadId)
import Control.Concurrent.STM as STM
import Control.Exception
import Control.Lens
import Data.Atomics qualified as Atomic
import Data.Bits
import Data.Functor.Classes (Eq1 (..), Ord1 (..))
import Data.List qualified as List
import Data.IORef (IORef)
import Data.IORef qualified as IORef
import Data.Map.Strict qualified as M
import Data.Ord (comparing)
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 GHC.Stack
import Unison.Builtin.Decls (exceptionRef, ioFailureRef)
import Unison.Builtin.Decls qualified as Rf
import Unison.Builtin.Decls qualified as Ty
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
  ( Cacheability (..),
    Code (..),
    CompileExn (..),
    PackedTag (..),
    SuperGroup,
    codeGroup,
    foldGroup,
    foldGroupLinks,
    maskTags,
    packTags,
    valueLinks,
  )
import Unison.Runtime.ANF qualified as ANF
import Unison.Runtime.Array as PA
import Unison.Runtime.Builtin hiding (unitValue)
import Unison.Runtime.Exception hiding (die)
import Unison.Runtime.Foreign
import Unison.Runtime.Foreign.Function (foreignCall)
import Unison.Runtime.MCode
import Unison.Runtime.Stack
import Unison.Runtime.TypeTags qualified as TT
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.Monoid qualified as Monoid
import Unison.Util.Pretty (toPlainUnbroken)
import Unison.Util.Pretty qualified as P
import Unison.Util.Text qualified as Util.Text
import UnliftIO qualified
import UnliftIO.Concurrent qualified as UnliftIO

{- ORMOLU_DISABLE -}
#ifdef STACK_CHECK
import Unison.Debug qualified as Debug
import System.IO.Unsafe (unsafePerformIO)
#endif

#ifdef OPT_CHECK
import Test.Inspection qualified as TI
#endif
{- ORMOLU_ENABLE -}

-- | 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, in one-off environments 'Nothing' is used and we don't bother tracking forked threads since they'll be
-- cleaned up automatically on process termination.
type ActiveThreads = Maybe (IORef (Set ThreadId))

type Tag = Word64

-- dynamic environment
type DEnv = EnumMap Word64 Val

type MCombs = RCombs Val

type Combs = GCombs Void CombIx

type MSection = RSection Val

type MBranch = RBranch Val

type MInstr = RInstr Val

type MComb = RComb Val

type MRef = RRef Val

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

-- code caching environment
data CCache = CCache
  { CCache -> Bool
sandboxed :: Bool,
    CCache -> Bool -> Val -> Tracer
tracer :: Bool -> Val -> Tracer,
    -- Combinators in their original form, where they're easier to serialize into SCache
    CCache -> TVar (EnumMap Word64 (GCombs Void CombIx))
srcCombs :: TVar (EnumMap Word64 Combs),
    CCache -> TVar (EnumMap Word64 MCombs)
combs :: TVar (EnumMap Word64 MCombs),
    CCache -> TVar (EnumMap Word64 Reference)
combRefs :: TVar (EnumMap Word64 Reference),
    -- Combs which we're allowed to cache after evaluating
    CCache -> TVar (EnumSet Word64)
cacheableCombs :: TVar (EnumSet Word64),
    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

baseCCache :: Bool -> IO CCache
baseCCache :: Bool -> IO CCache
baseCCache Bool
sandboxed = do
  Bool
-> (Bool -> Val -> Tracer)
-> TVar (EnumMap Word64 (GCombs Void CombIx))
-> TVar (EnumMap Word64 MCombs)
-> TVar (EnumMap Word64 Reference)
-> TVar (EnumSet Word64)
-> 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 Bool
sandboxed Bool -> Val -> Tracer
forall {p} {p}. p -> p -> Tracer
noTrace
    (TVar (EnumMap Word64 (GCombs Void CombIx))
 -> TVar (EnumMap Word64 MCombs)
 -> TVar (EnumMap Word64 Reference)
 -> TVar (EnumSet Word64)
 -> 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 (GCombs Void CombIx)))
-> IO
     (TVar (EnumMap Word64 MCombs)
      -> TVar (EnumMap Word64 Reference)
      -> TVar (EnumSet Word64)
      -> 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 (GCombs Void CombIx)
-> IO (TVar (EnumMap Word64 (GCombs Void CombIx)))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 (GCombs Void CombIx)
srcCombs
    IO
  (TVar (EnumMap Word64 MCombs)
   -> TVar (EnumMap Word64 Reference)
   -> TVar (EnumSet Word64)
   -> 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 MCombs))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar (EnumSet Word64)
      -> 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 MCombs -> IO (TVar (EnumMap Word64 MCombs))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 MCombs
combs
    IO
  (TVar (EnumMap Word64 Reference)
   -> TVar (EnumSet Word64)
   -> 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 (EnumSet Word64)
      -> 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 (EnumSet Word64)
   -> 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 (EnumSet Word64))
-> 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
<*> EnumSet Word64 -> IO (TVar (EnumSet Word64))
forall a. a -> IO (TVar a)
newTVarIO EnumSet Word64
cacheableCombs
    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
    cacheableCombs :: EnumSet Word64
cacheableCombs = EnumSet Word64
forall a. Monoid a => a
mempty
    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}

    srcCombs :: EnumMap Word64 Combs
    srcCombs :: EnumMap Word64 (GCombs Void CombIx)
srcCombs =
      EnumMap Word64 (SuperNormal Symbol)
numberedTermLookup
        EnumMap Word64 (SuperNormal Symbol)
-> (EnumMap Word64 (SuperNormal Symbol)
    -> EnumMap Word64 (GCombs Void CombIx))
-> EnumMap Word64 (GCombs Void CombIx)
forall a b. a -> (a -> b) -> b
& (Word64 -> SuperNormal Symbol -> GCombs Void CombIx)
-> EnumMap Word64 (SuperNormal Symbol)
-> EnumMap Word64 (GCombs Void CombIx)
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)
-> GCombs Void CombIx
emitComb @Symbol RefNums
rns Reference
r Word64
k RCtx Symbol
forall a. Monoid a => a
mempty (Word64
0, SuperNormal Symbol
v))
    combs :: EnumMap Word64 MCombs
    combs :: EnumMap Word64 MCombs
combs =
      EnumMap Word64 (GCombs Void CombIx)
srcCombs
        EnumMap Word64 (GCombs Void CombIx)
-> (EnumMap Word64 (GCombs Void CombIx)
    -> EnumMap Word64 (GCombs Void CombIx))
-> EnumMap Word64 (GCombs Void CombIx)
forall a b. a -> (a -> b) -> b
& Bool
-> Set ForeignFunc
-> EnumMap Word64 (GCombs Void CombIx)
-> EnumMap Word64 (GCombs Void CombIx)
sanitizeCombsOfForeignFuncs Bool
sandboxed Set ForeignFunc
sandboxedForeignFuncs
        EnumMap Word64 (GCombs Void CombIx)
-> (EnumMap Word64 (GCombs Void CombIx)
    -> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall a b. a -> (a -> b) -> b
& EnumMap Word64 (GCombs Void CombIx)
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall cix any.
EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
absurdCombs
        EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
    -> EnumMap Word64 MCombs)
-> EnumMap Word64 MCombs
forall a b. a -> (a -> b) -> b
& Maybe (EnumMap Word64 MCombs)
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> EnumMap Word64 MCombs
forall val.
Maybe (EnumMap Word64 (RCombs val))
-> EnumMap Word64 (GCombs val CombIx)
-> EnumMap Word64 (RCombs val)
resolveCombs Maybe (EnumMap Word64 MCombs)
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

-- Entry point for evaluating a section
eval0 :: CCache -> ActiveThreads -> MSection -> IO ()
eval0 :: CCache -> ActiveThreads -> MSection -> IO ()
eval0 CCache
env !ActiveThreads
activeThreads !MSection
co = do
  Stack
stk <- IO Stack
alloc
  EnumMap Word64 MCombs
cmbs <- TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs)
forall a. TVar a -> IO a
readTVarIO (TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs))
-> TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs)
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (EnumMap Word64 MCombs)
combs CCache
env
  (EnumMap Word64 Val
denv, K -> K
k) <-
    EnumMap Word64 MCombs
-> Map Reference Word64
-> Map Reference Word64
-> (EnumMap Word64 Val, K -> K)
topDEnv EnumMap Word64 MCombs
cmbs (Map Reference Word64
 -> Map Reference Word64 -> (EnumMap Word64 Val, K -> K))
-> IO (Map Reference Word64)
-> IO (Map Reference Word64 -> (EnumMap Word64 Val, 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 Val, K -> K))
-> IO (Map Reference Word64) -> IO (EnumMap Word64 Val, 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 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk (K -> K
k K
KE) Reference
dummyRef MSection
co

mCombVal :: CombIx -> MComb -> Val
mCombVal :: CombIx -> MComb -> Val
mCombVal CombIx
cix (RComb (Comb GCombInfo MComb
comb)) =
  Closure -> Val
BoxedVal (CombIx -> GCombInfo MComb -> Seg -> Closure
PAp CombIx
cix GCombInfo MComb
comb Seg
nullSeg)
mCombVal CombIx
_ (RComb (CachedVal Word64
_ Val
clo)) = Val
clo

topDEnv ::
  EnumMap Word64 MCombs ->
  M.Map Reference Word64 ->
  M.Map Reference Word64 ->
  (DEnv, K -> K)
topDEnv :: EnumMap Word64 MCombs
-> Map Reference Word64
-> Map Reference Word64
-> (EnumMap Word64 Val, K -> K)
topDEnv EnumMap Word64 MCombs
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,
    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,
    CombIx
cix <- Reference -> Word64 -> Word64 -> CombIx
CIx Reference
rcrf Word64
j Word64
0,
    Val
clo <- CombIx -> MComb -> Val
mCombVal CombIx
cix (MComb -> Val) -> MComb -> Val
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 MCombs -> CombIx -> MComb
rCombSection EnumMap Word64 MCombs
combs CombIx
cix =
      ( Word64 -> Val -> EnumMap Word64 Val
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
n Val
clo,
        Int -> EnumSet Word64 -> EnumMap Word64 Val -> K -> K
Mark Int
0 (Word64 -> EnumSet Word64
forall k. EnumKey k => k -> EnumSet k
EC.setSingleton Word64
n) EnumMap Word64 Val
forall a. Monoid a => a
mempty
      )
topDEnv EnumMap Word64 MCombs
_ Map Reference Word64
_ Map Reference Word64
_ = (EnumMap Word64 Val
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 (XStack -> IO ()) ->
  CCache ->
  ActiveThreads ->
  Word64 ->
  IO ()
apply0 :: Maybe (XStack -> IO ())
-> CCache -> ActiveThreads -> Word64 -> IO ()
apply0 !Maybe (XStack -> IO ())
callback CCache
env !ActiveThreads
threadTracker !Word64
i = do
  Stack
stk <- IO Stack
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 MCombs
cmbs <- TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs)
forall a. TVar a -> IO a
readTVarIO (TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs))
-> TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs)
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (EnumMap Word64 MCombs)
combs CCache
env
  (EnumMap Word64 Val
denv, K -> K
kf) <-
    EnumMap Word64 MCombs
-> Map Reference Word64
-> Map Reference Word64
-> (EnumMap Word64 Val, K -> K)
topDEnv EnumMap Word64 MCombs
cmbs (Map Reference Word64
 -> Map Reference Word64 -> (EnumMap Word64 Val, K -> K))
-> IO (Map Reference Word64)
-> IO (Map Reference Word64 -> (EnumMap Word64 Val, 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 Val, K -> K))
-> IO (Map Reference Word64) -> IO (EnumMap Word64 Val, 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 entryCix :: CombIx
entryCix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
r Word64
i Word64
0)
  case MComb -> GComb Val MComb
forall val. RComb val -> GComb val (RComb val)
unRComb (MComb -> GComb Val MComb) -> MComb -> GComb Val MComb
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 MCombs -> CombIx -> MComb
rCombSection EnumMap Word64 MCombs
cmbs CombIx
entryCix of
    Comb GCombInfo MComb
entryComb -> do
      CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env EnumMap Word64 Val
denv ActiveThreads
threadTracker Stack
stk (K -> K
kf K
k0) Bool
True Args
ZArgs (Val -> IO ()) -> (Closure -> Val) -> Closure -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
BoxedVal (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$
        CombIx -> GCombInfo MComb -> Seg -> Closure
PAp CombIx
entryCix GCombInfo MComb
entryComb Seg
nullSeg
    -- if it's cached, we can just finish
    CachedVal Word64
_ Val
val -> Stack -> IO Stack
bump Stack
stk IO Stack -> (Stack -> 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
>>= \Stack
stk -> (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
val
  where
    k0 :: K
k0 = K -> Maybe K -> K
forall a. a -> Maybe a -> a
fromMaybe K
KE (Maybe
  ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
      MutableArray# RealWorld Closure #)
   -> IO ())
Maybe (XStack -> IO ())
callback Maybe
  ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
      MutableArray# RealWorld Closure #)
   -> IO ())
-> (((# Int#, Int#, Int#, MutableByteArray# RealWorld,
        MutableArray# RealWorld Closure #)
     -> IO ())
    -> K)
-> Maybe K
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
-> IO ()
cb -> Callback -> K
CB (Callback -> K)
-> (((# Int#, Int#, Int#, MutableByteArray# RealWorld,
        MutableArray# RealWorld Closure #)
     -> IO ())
    -> Callback)
-> ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
       MutableArray# RealWorld Closure #)
    -> IO ())
-> K
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
    MutableArray# RealWorld Closure #)
 -> IO ())
-> Callback
(XStack -> IO ()) -> Callback
Hook (((# Int#, Int#, Int#, MutableByteArray# RealWorld,
     MutableArray# RealWorld Closure #)
  -> IO ())
 -> K)
-> ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
       MutableArray# RealWorld Closure #)
    -> IO ())
-> K
forall a b. (a -> b) -> a -> b
$ \(# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
stk -> (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
-> IO ()
cb (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
stk)

-- Apply helper currently used for forking. Creates the new stacks
-- necessary to evaluate a closure with the provided information.
apply1 ::
  (Stack -> IO ()) ->
  CCache ->
  ActiveThreads ->
  Val ->
  IO ()
apply1 :: (Stack -> IO ()) -> CCache -> ActiveThreads -> Val -> IO ()
apply1 Stack -> IO ()
callback CCache
env ActiveThreads
threadTracker Val
clo = do
  Stack
stk <- IO Stack
alloc
  CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env EnumMap Word64 Val
forall a. Monoid a => a
mempty ActiveThreads
threadTracker Stack
stk K
k0 Bool
True Args
ZArgs (Val -> IO ()) -> Val -> IO ()
forall a b. (a -> b) -> a -> b
$ Val
clo
  where
    k0 :: K
k0 = Callback -> K
CB (Callback -> K) -> Callback -> K
forall a b. (a -> b) -> a -> b
$ (XStack -> IO ()) -> Callback
Hook (\XStack
stk -> Stack -> IO ()
callback (Stack -> IO ()) -> Stack -> IO ()
forall a b. (a -> b) -> a -> b
$ XStack -> Stack
packXStack XStack
stk)

unitValue :: Val
unitValue :: Val
unitValue = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Closure
unitClosure
{-# NOINLINE unitValue #-}

unitClosure :: Closure
unitClosure :: Closure
unitClosure = Reference -> PackedTag -> Closure
Enum Reference
Ty.unitRef PackedTag
TT.unitTag
{-# NOINLINE unitClosure #-}

litToVal :: MLit -> Val
litToVal :: MLit -> Val
litToVal = \case
  MT Text
t -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (Reference -> Text -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.textRef Text
t)
  MM Referent' Reference
r -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (Reference -> Referent' Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef Referent' Reference
r)
  MY Reference
r -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.typeLinkRef Reference
r)
  MI Int
i -> Int -> Val
IntVal Int
i
  MN Word64
n -> Word64 -> Val
NatVal Word64
n
  MC Char
c -> Char -> Val
CharVal Char
c
  MD Double
d -> Double -> Val
DoubleVal Double
d
{-# INLINE litToVal #-}

{- ORMOLU_DISABLE -}
#ifdef STACK_CHECK
debugger :: (Show a) => Stack -> String -> a -> Bool
debugger stk msg a = unsafePerformIO $ do
  dumpStack stk
  Debug.debugLogM Debug.Interpreter (msg ++ ": " ++ show a)
  pure False

dumpStack :: Stack -> IO ()
dumpStack stk@(Stack ap fp sp _ustk _bstk)
  | sp - fp < 0 = Debug.debugLogM Debug.Interpreter "Stack before 👇: Empty"
  | otherwise = do
      stkLocals <- for [0 .. ((sp - fp) - 1)] $ \i -> do
        peekOff stk i
      Debug.debugM Debug.Interpreter "Stack frame locals 👇:" stkLocals
      stkArgs <- for [0 .. ((fp - ap) - 1)] $ \i -> do
        peekOff stk (i + (sp - fp))
      Debug.debugM Debug.Interpreter "Stack args 👇:" stkArgs
#endif
{- ORMOLU_ENABLE -}

-- | Execute an instruction
exec ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Reference ->
  MInstr ->
  IO (Bool, DEnv, Stack, K)
{- ORMOLU_DISABLE -}
#ifdef STACK_CHECK
exec _ !_ !_ !stk !_ !_ instr
  | debugger stk "exec" instr = undefined
#endif
{- ORMOLU_ENABLE -}
exec :: CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MInstr
-> IO (Bool, EnumMap Word64 Val, Stack, K)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Info [Char]
tx) = do
  [Char] -> Stack -> IO ()
forall a. Show a => [Char] -> a -> IO ()
info [Char]
tx Stack
stk
  [Char] -> K -> IO ()
forall a. Show a => [Char] -> a -> IO ()
info [Char]
tx K
k
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Name GRef MComb
r Args
args) = do
  Val
v <- CCache -> EnumMap Word64 Val -> Stack -> GRef MComb -> IO Val
resolve CCache
env EnumMap Word64 Val
denv Stack
stk GRef MComb
r
  Stack
stk <- Stack -> Args -> Val -> IO Stack
name Stack
stk Args
args Val
v
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (SetDyn Word64
p Int
i) = do
  Val
val <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  pure (Bool
False, Word64 -> Val -> EnumMap Word64 Val -> EnumMap Word64 Val
forall k a. EnumKey k => k -> a -> EnumMap k a -> EnumMap k a
EC.mapInsert Word64
p Val
val EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Capture Word64
p) = do
  (Val
cap, EnumMap Word64 Val
denv, Stack
stk, K
k) <- EnumMap Word64 Val
-> Stack -> K -> Word64 -> IO (Val, EnumMap Word64 Val, Stack, K)
splitCont EnumMap Word64 Val
denv Stack
stk K
k Word64
p
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
cap
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (UPrim1 UPrim1
op Int
i) = do
  Stack
stk <- Stack -> UPrim1 -> Int -> IO Stack
uprim1 Stack
stk UPrim1
op Int
i
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (UPrim2 UPrim2
op Int
i Int
j) = do
  Stack
stk <- Stack -> UPrim2 -> Int -> Int -> IO Stack
uprim2 Stack
stk UPrim2
op Int
i Int
j
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim1 BPrim1
MISS Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: isMissing"
  | Bool
otherwise = do
      Closure
clink <- (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i
      let link :: Reference
link = case Foreign -> Referent' Reference
forall a. Foreign -> a
unwrapForeign (Foreign -> Referent' Reference) -> Foreign -> Referent' Reference
forall a b. (a -> b) -> a -> b
$ HasCallStack => Closure -> Foreign
Closure -> Foreign
marshalToForeign Closure
clink of
            Ref Reference
r -> Reference
r
            Referent' Reference
_ -> [Char] -> Reference
forall a. HasCallStack => [Char] -> a
error [Char]
"exec:BPrim1:MISS: Expected Ref"
      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
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (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)
      pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim1 BPrim1
CACH Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: cache"
  | Bool
otherwise = do
      USeq
arg <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i
      [(Reference, Code)]
news <- USeq -> IO [(Reference, Code)]
decodeCacheArgument USeq
arg
      [Reference]
unknown <- [(Reference, Code)] -> CCache -> IO [Reference]
cacheAdd [(Reference, Code)]
news CCache
env
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack -> USeq -> IO ()
pokeS
        Stack
stk
        ([Val] -> USeq
forall a. [a] -> Seq a
Sq.fromList ([Val] -> USeq) -> [Val] -> USeq
forall a b. (a -> b) -> a -> b
$ Closure -> Val
boxedVal (Closure -> Val) -> (Reference -> Closure) -> Reference -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure)
-> (Reference -> Foreign) -> Reference -> Closure
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 -> Val) -> [Reference] -> [Val]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Reference]
unknown)
      pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim1 BPrim1
CVLD Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: validate"
  | Bool
otherwise = do
      USeq
arg <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i
      [(Reference, Code)]
news <- USeq -> IO [(Reference, Code)]
decodeCacheArgument USeq
arg
      [(Reference, SuperGroup Symbol)]
-> CCache -> IO (Maybe (Failure Closure))
codeValidate ((Code -> SuperGroup Symbol)
-> (Reference, Code) -> (Reference, SuperGroup Symbol)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Code -> SuperGroup Symbol
codeGroup ((Reference, Code) -> (Reference, SuperGroup Symbol))
-> [(Reference, Code)] -> [(Reference, SuperGroup Symbol)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, Code)]
news) CCache
env IO (Maybe (Failure Closure))
-> (Maybe (Failure Closure)
    -> IO (Bool, EnumMap Word64 Val, Stack, K))
-> IO (Bool, EnumMap Word64 Val, Stack, 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 Closure)
Nothing -> do
          Stack
stk <- Stack -> IO Stack
bump Stack
stk
          (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
          pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
        Just (Failure Reference
ref Text
msg Closure
clo) -> do
          Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
3
          (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Foreign -> Closure
Foreign (Foreign -> Closure) -> Foreign -> Closure
forall a b. (a -> b) -> a -> b
$ Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.typeLinkRef Reference
ref)
          Stack -> Int -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> Int -> b -> IO ()
pokeOffBi Stack
stk Int
1 Text
msg
          (() :: Constraint) => Stack -> Int -> Closure -> IO ()
Stack -> Int -> Closure -> IO ()
bpokeOff Stack
stk Int
2 Closure
clo
          Stack
stk <- Stack -> IO Stack
bump Stack
stk
          (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
          pure (Bool
False,  EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim1 BPrim1
LKUP Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: lookup"
  | Bool
otherwise = do
      Closure
clink <- (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i
      let link :: Reference
link = case Foreign -> Referent' Reference
forall a. Foreign -> a
unwrapForeign (Foreign -> Referent' Reference) -> Foreign -> Referent' Reference
forall a b. (a -> b) -> a -> b
$ HasCallStack => Closure -> Foreign
Closure -> Foreign
marshalToForeign Closure
clink of
            Ref Reference
r -> Reference
r
            Referent' Reference
_ -> [Char] -> Reference
forall a. HasCallStack => [Char] -> a
error [Char]
"exec:BPrim1:LKUP: Expected Ref"
      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)
      Map Reference Word64
rfn <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTm CCache
env)
      EnumSet Word64
cach <- TVar (EnumSet Word64) -> IO (EnumSet Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (EnumSet Word64)
cacheableCombs CCache
env)
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack
stk <- 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 -> Code -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (SuperGroup Symbol -> Cacheability -> Code
CodeRep ([(Symbol, SuperNormal Symbol)]
-> SuperNormal Symbol -> SuperGroup Symbol
forall v. [(v, SuperNormal v)] -> SuperNormal v -> SuperGroup v
ANF.Rec [] SuperNormal Symbol
sn) Cacheability
Uncacheable)
              Stack
stk <- Stack -> IO Stack
bump Stack
stk
              Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
          | Bool
otherwise -> Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
        Just SuperGroup Symbol
sg -> do
          let ch :: Cacheability
ch
                | Just Word64
n <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
link Map Reference Word64
rfn,
                  Word64 -> EnumSet Word64 -> Bool
forall k. EnumKey k => k -> EnumSet k -> Bool
EC.member Word64
n EnumSet Word64
cach =
                    Cacheability
Cacheable
                | Bool
otherwise = Cacheability
Uncacheable
          Stack -> Code -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (SuperGroup Symbol -> Cacheability -> Code
CodeRep SuperGroup Symbol
sg Cacheability
ch)
          Stack
stk <- Stack -> IO Stack
bump Stack
stk
          Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
      pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim1 BPrim1
TLTT Int
i) = do
  Closure
clink <- (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk 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 => Closure -> Foreign
Closure -> Foreign
marshalToForeign Closure
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
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk Text
sh
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim1 BPrim1
LOAD Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: load"
  | Bool
otherwise = do
      Value
v <- Stack -> Int -> IO Value
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
      CCache -> Value -> IO (Either [Reference] Val)
reifyValue CCache
env Value
v IO (Either [Reference] Val)
-> (Either [Reference] Val -> 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 -> Int -> USeq -> IO ()
pokeOffS Stack
stk Int
1 (USeq -> IO ()) -> USeq -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Val] -> USeq
forall a. [a] -> Seq a
Sq.fromList ([Val] -> USeq) -> [Val] -> USeq
forall a b. (a -> b) -> a -> b
$
              Closure -> Val
boxedVal (Closure -> Val) -> (Reference -> Closure) -> Reference -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure)
-> (Reference -> Foreign) -> Reference -> Closure
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 -> Val) -> [Reference] -> [Val]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Reference]
miss
          (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
        Right Val
x -> do
          (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
x
          (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
      pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !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)
  Val
c <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Value -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (Value -> IO ()) -> IO Value -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EnumMap Word64 Reference -> Val -> IO Value
reflectValue EnumMap Word64 Reference
m Val
c
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim1 BPrim1
DBTX Int
i)
  | CCache -> Bool
sandboxed CCache
env =
      [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: Debug.toText"
  | Bool
otherwise = do
      Val
val <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack
stk <- case CCache -> Bool -> Val -> Tracer
tracer CCache
env Bool
False Val
val of
        Tracer
NoTrace -> Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
        MsgTrace [Char]
_ [Char]
_ [Char]
tx -> do
          Stack -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk ([Char] -> Text
Util.Text.pack [Char]
tx)
          Stack
stk <- Stack -> IO Stack
bump Stack
stk
          Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
        SimpleTrace [Char]
tx -> do
          Stack -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk ([Char] -> Text
Util.Text.pack [Char]
tx)
          Stack
stk <- Stack -> IO Stack
bump Stack
stk
          Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
2
      pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim1 BPrim1
SDBL Int
i)
  | CCache -> Bool
sandboxed CCache
env =
      [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: sandboxLinks"
  | Bool
otherwise = do
      Referent' Reference
tl <- Stack -> Int -> IO (Referent' Reference)
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack -> USeq -> IO ()
pokeS Stack
stk (USeq -> IO ()) -> ([Reference] -> USeq) -> [Reference] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reference] -> USeq
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 (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim1 BPrim1
op Int
i) = do
  Stack
stk <- CCache -> Stack -> BPrim1 -> Int -> IO Stack
bprim1 CCache
env Stack
stk BPrim1
op Int
i
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim2 BPrim2
SDBX Int
i Int
j) = do
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i
  Closure
c <- (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
j
  [Reference]
l <- USeq -> IO [Reference]
decodeSandboxArgument USeq
s
  Bool
b <- CCache -> [Reference] -> Closure -> IO Bool
checkSandboxing CCache
env [Reference]
l Closure
c
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool
b
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim2 BPrim2
SDBV Int
i Int
j)
  | CCache -> Bool
sandboxed CCache
env =
      [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: Value.validateSandboxed"
  | Bool
otherwise = do
      USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i
      Value
v <- Stack -> Int -> IO Value
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
      [Reference]
l <- USeq -> IO [Reference]
decodeSandboxArgument USeq
s
      Either [Reference] [Reference]
res <- CCache
-> [Reference] -> Value -> IO (Either [Reference] [Reference])
checkValueSandboxing CCache
env [Reference]
l Value
v
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Either [Reference] [Reference] -> Closure
encodeSandboxResult Either [Reference] [Reference]
res
      pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim2 BPrim2
EQLU Int
i Int
j) = do
  Val
x <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Val
y <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Foreign -> Foreign -> Bool) -> Val -> Val -> Bool
universalEq Foreign -> Foreign -> Bool
forall a. Eq a => a -> a -> Bool
(==) Val
x Val
y
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim2 BPrim2
LEQU Int
i Int
j) = do
  Val
x <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Val
y <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Foreign -> Foreign -> Ordering) -> Val -> Val -> Ordering
universalCompare Foreign -> Foreign -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Val
x Val
y) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim2 BPrim2
LESU Int
i Int
j) = do
  Val
x <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Val
y <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Foreign -> Foreign -> Ordering) -> Val -> Val -> Ordering
universalCompare Foreign -> Foreign -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Val
x Val
y) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim2 BPrim2
CMPU Int
i Int
j) = do
  Val
x <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Val
y <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int -> IO ()) -> (Ordering -> Int) -> Ordering -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> (Ordering -> Int) -> Ordering -> Int
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) -> Val -> Val -> Ordering
universalCompare Foreign -> Foreign -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Val
x Val
y
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
_ !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
r (BPrim2 BPrim2
THRO Int
i Int
j) = do
  Text
name <- forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi @Util.Text.Text Stack
stk Int
i
  Val
x <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  () <- RuntimeExn -> IO ()
forall e a. Exception e => e -> IO a
throwIO ([(Reference, Int)] -> Text -> Val -> RuntimeExn
BU (Reference -> K -> [(Reference, Int)]
traceK Reference
r K
k) (Text -> Text
Util.Text.toText Text
name) Val
x)
  [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> a
error [Char]
"throwIO should never return"
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (BPrim2 BPrim2
TRCE Int
i Int
j)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: trace"
  | Bool
otherwise = do
      Text
tx <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
      Val
clo <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
      case CCache -> Bool -> Val -> Tracer
tracer CCache
env Bool
True Val
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 (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_trackThreads !Stack
stk !K
k Reference
_ (BPrim2 BPrim2
op Int
i Int
j) = do
  Stack
stk <- Stack -> BPrim2 -> Int -> Int -> IO Stack
bprim2 Stack
stk BPrim2
op Int
i Int
j
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (RefCAS Int
refI Int
ticketI Int
valI)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: Ref.cas"
  | Bool
otherwise = do
      (IORef Val
ref :: IORef Val) <- Stack -> Int -> IO (IORef Val)
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
refI
      -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it
      -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal
      -- forcing of the values and tickets.
      !(Ticket Val
ticket :: Atomic.Ticket Val) <- Stack -> Int -> IO (Ticket Val)
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
ticketI
      Val
v <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
valI
      (Bool
r, Ticket Val
_) <- IORef Val -> Ticket Val -> Val -> IO (Bool, Ticket Val)
forall a. IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
Atomic.casIORef IORef Val
ref Ticket Val
ticket Val
v
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk Bool
r
      pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Pack Reference
r PackedTag
t Args
args) = do
  Closure
clo <- Stack -> Reference -> PackedTag -> Args -> IO Closure
buildData Stack
stk Reference
r PackedTag
t Args
args
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk Closure
clo
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Print Int
i) = do
  Text
t <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Text -> IO ()
Tx.putStrLn (Text -> Text
Util.Text.toText Text
t)
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Lit MLit
ml) = do
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk (Val -> IO ()) -> Val -> IO ()
forall a b. (a -> b) -> a -> b
$ MLit -> Val
litToVal MLit
ml
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Reset EnumSet Word64
ps) = do
  (Stack
stk, Int
a) <- Stack -> IO (Stack, Int)
saveArgs Stack
stk
  (Bool, EnumMap Word64 Val, Stack, K)
-> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, Int -> EnumSet Word64 -> EnumMap Word64 Val -> K -> K
Mark Int
a EnumSet Word64
ps EnumMap Word64 Val
clos K
k)
  where
    clos :: EnumMap Word64 Val
clos = EnumMap Word64 Val -> EnumSet Word64 -> EnumMap Word64 Val
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys EnumMap Word64 Val
denv EnumSet Word64
ps
exec CCache
_ !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Seq Args
as) = do
  [Val]
l <- Stack -> Args -> IO [Val]
closureArgs Stack
stk Args
as
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> USeq -> IO ()
pokeS Stack
stk (USeq -> IO ()) -> USeq -> IO ()
forall a b. (a -> b) -> a -> b
$ [Val] -> USeq
forall a. [a] -> Seq a
Sq.fromList [Val]
l
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (ForeignCall Bool
_ ForeignFunc
func Args
args) = do
  (Bool
b, Stack
stk) <- IOEXStack -> IO (Bool, Stack)
exStackIOToIO (IOEXStack -> IO (Bool, Stack)) -> IOEXStack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ ForeignFunc -> Args -> XStack -> IOEXStack
foreignCall ForeignFunc
func Args
args (Stack -> XStack
unpackXStack Stack
stk)
  (Bool, EnumMap Word64 Val, Stack, K)
-> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
b, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (Fork Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: fork"
  | Bool
otherwise = do
      ThreadId
tid <- CCache -> ActiveThreads -> Val -> IO ThreadId
forkEval CCache
env ActiveThreads
activeThreads (Val -> IO ThreadId) -> IO Val -> IO ThreadId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> (ThreadId -> Closure) -> ThreadId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure)
-> (ThreadId -> Foreign) -> ThreadId -> Closure
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 (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (Atomically Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (Bool, EnumMap Word64 Val, Stack, K))
-> [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a b. (a -> b) -> a -> b
$ [Char]
"attempted to use sandboxed operation: atomically"
  | Bool
otherwise = do
      Val
v <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      CCache -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
atomicEval CCache
env ActiveThreads
activeThreads ((() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk) Val
v
      pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (TryForce Int
i)
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (Bool, EnumMap Word64 Val, Stack, K))
-> [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a b. (a -> b) -> a -> b
$ [Char]
"attempted to use sandboxed operation: tryForce"
  | Bool
otherwise = do
      Val
v <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
      Stack
stk <- Stack -> IO Stack
bump Stack
stk -- Bump the boxed stack to make a slot for the result, which will be written in the callback if we succeed.
      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 -> (Val -> IO ()) -> Val -> IO ()
nestEval CCache
env ActiveThreads
activeThreads ((() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk) Val
v
      Stack
stk <- Stack -> Either SomeException () -> IO Stack
encodeExn Stack
stk Either SomeException ()
ev
      pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec !CCache
_ !EnumMap Word64 Val
_ !ActiveThreads
_ !Stack
_ !K
_ Reference
_ (SandboxingFailure Text
t) = do
  [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (Bool, EnumMap Word64 Val, Stack, K))
-> [Char] -> IO (Bool, EnumMap Word64 Val, Stack, K)
forall a b. (a -> b) -> a -> b
$ [Char]
"Attempted to use disallowed builtin in sandboxed environment: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
DTx.unpack Text
t
{-# INLINE exec #-}

encodeExn ::
  Stack ->
  Either SomeException () ->
  IO Stack
encodeExn :: Stack -> Either SomeException () -> IO Stack
encodeExn Stack
stk Either SomeException ()
exc = do
  case Either SomeException ()
exc of
    Right () -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
    Left SomeException
exn -> do
      -- If we hit an exception, we have one unused slot on the stack
      -- from where the result _would_ have been placed.
      -- So here we bump one less than it looks like we should, and re-use
      -- that slot.
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
3
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      (() :: Constraint) => Stack -> Int -> Closure -> IO ()
Stack -> Int -> Closure -> IO ()
bpokeOff Stack
stk Int
1 (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.typeLinkRef Reference
link)
      Stack -> Int -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> Int -> b -> IO ()
pokeOffBi Stack
stk Int
2 Text
msg
      Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
3 Val
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, Val
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, Val
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, Val
unitValue)
              BU [(Reference, Int)]
_ Text
tx Val
val -> (Reference
Rf.runtimeFailureRef, Text -> Text
Util.Text.fromText Text
tx, Val
val)
          | 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, Val
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, Val
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, Val
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, Val
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, Val
unitValue)
          | Bool
otherwise = (Reference
Rf.miscFailureRef, SomeException -> Text
forall {a}. Show a => a -> Text
disp SomeException
exn, Val
unitValue)

-- | Evaluate a section
eval ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Reference ->
  MSection ->
  IO ()
{- ORMOLU_DISABLE -}
#ifdef STACK_CHECK
eval _ !_ !_ !stk !_ !_ section
  | debugger stk "eval" section = undefined
#endif
{- ORMOLU_ENABLE -}
eval :: CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
r (Match Int
i (TestT MSection
df Map Text MSection
cs)) = do
  Text
t <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
r (MSection -> IO ()) -> MSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> MSection -> Map Text MSection -> MSection
selectTextBranch Text
t MSection
df Map Text MSection
cs
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
r (Match Int
i GBranch MComb
br) = do
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
r (MSection -> IO ()) -> MSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> GBranch MComb -> MSection
selectBranch Word64
n GBranch MComb
br
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
r (DMatch Maybe Reference
mr Int
i GBranch MComb
br) = do
  (MSection
nx, Stack
stk) <- Maybe Reference
-> Stack -> GBranch MComb -> Closure -> IO (MSection, Stack)
dataBranch Maybe Reference
mr Stack
stk GBranch MComb
br (Closure -> IO (MSection, Stack))
-> IO Closure -> IO (MSection, Stack)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i
  CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
r MSection
nx
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
r (NMatch Maybe Reference
_mr Int
i GBranch MComb
br) = do
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
r (MSection -> IO ()) -> MSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> GBranch MComb -> MSection
selectBranch Word64
n GBranch MComb
br
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
r (RMatch Int
i MSection
pu EnumMap Word64 (GBranch MComb)
br) = do
  (PackedTag
t, Stack
stk) <- Stack -> Val -> IO (PackedTag, Stack)
dumpDataValNoTag Stack
stk (Val -> IO (PackedTag, Stack)) -> IO Val -> IO (PackedTag, Stack)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  if PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.pureEffectTag
    then CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
r MSection
pu
    else case PackedTag -> (RTag, CTag)
ANF.unpackTags PackedTag
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 MComb
ebs <- Word64 -> EnumMap Word64 (GBranch MComb) -> Maybe (GBranch MComb)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
e EnumMap Word64 (GBranch MComb)
br ->
            CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
r (MSection -> IO ()) -> MSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> GBranch MComb -> MSection
selectBranch Word64
t GBranch MComb
ebs
        | Bool
otherwise -> IO ()
forall a. HasCallStack => IO a
unhandledAbilityRequest
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (Yield Args
args)
  | Stack -> Int
asize Stack
stk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0,
    VArg1 Int
i <- Args
args =
      (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i IO Val -> (Val -> 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 Val
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Bool
False Args
ZArgs
  | Bool
otherwise = do
      Stack
stk <- Stack -> Args -> IO Stack
moveArgs Stack
stk Args
args
      Stack
stk <- Stack -> IO Stack
frameArgs Stack
stk
      CCache
-> EnumMap Word64 Val -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (App Bool
ck GRef MComb
r Args
args) =
  CCache -> EnumMap Word64 Val -> Stack -> GRef MComb -> IO Val
resolve CCache
env EnumMap Word64 Val
denv Stack
stk GRef MComb
r
    IO Val -> (Val -> 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 Val
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Bool
ck Args
args
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (Call Bool
ck CombIx
combIx MComb
rcomb Args
args) =
  CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> Bool
-> Args
-> MComb
-> IO ()
enter CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k (CombIx -> Reference
combRef CombIx
combIx) Bool
ck Args
args MComb
rcomb
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (Jump Int
i Args
args) =
  (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> 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 Val
-> ActiveThreads
-> Stack
-> K
-> Args
-> Closure
-> IO ()
jump CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Args
args
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
r (Let MSection
nw CombIx
cix Int
f MSection
sect) = do
  (Stack
stk, Int
fsz, Int
asz) <- Stack -> IO (Stack, Int, Int)
saveFrame Stack
stk
  CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval
    CCache
env
    EnumMap Word64 Val
denv
    ActiveThreads
activeThreads
    Stack
stk
    (Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push Int
fsz Int
asz CombIx
cix Int
f MSection
sect K
k)
    Reference
r
    MSection
nw
eval CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
r (Ins MInstr
i MSection
nx) = do
  CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MInstr
-> IO (Bool, EnumMap Word64 Val, Stack, K)
exec CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
r MInstr
i IO (Bool, EnumMap Word64 Val, Stack, K)
-> ((Bool, EnumMap Word64 Val, Stack, K) -> 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
    (Bool
exception, EnumMap Word64 Val
denv, Stack
stk, K
k)
      -- In this case, the instruction indicated an exception to
      -- be handled by the current {Exception} handler. The stack
      -- currently points to an appropriate `Failure` value, and
      -- we must handle the rest.
      | Bool
exception -> case Word64 -> EnumMap Word64 Val -> Maybe Val
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
TT.exceptionTag EnumMap Word64 Val
denv of
        Just Val
eh -> do
          -- wrap the failure in an exception raise box
          Val
fv <- (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek Stack
stk
          (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Reference -> PackedTag -> Val -> Closure
Data1 Reference
exceptionRef PackedTag
TT.exceptionRaiseTag Val
fv
          (Stack
stk, Int
fsz, Int
asz) <- Stack -> IO (Stack, Int, Int)
saveFrame Stack
stk
          let kk :: K
kk = Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push Int
fsz Int
asz CombIx
fakeCix Int
10 MSection
nx K
k
          CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
kk Bool
False (Int -> Args
VArg1 Int
0) Val
eh
        Maybe Val
Nothing -> -- should be impossible
          IO ()
forall a. HasCallStack => IO a
unhandledAbilityRequest
      | Bool
otherwise -> CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
r MSection
nx
eval CCache
_ !EnumMap Word64 Val
_ !ActiveThreads
_ !Stack
_activeThreads !K
_ Reference
_ MSection
Exit = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
eval CCache
_ !EnumMap Word64 Val
_ !ActiveThreads
_ !Stack
_activeThreads !K
_ Reference
_ (Die [Char]
s) = [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
die [Char]
s
{-# NOINLINE eval #-}

fakeCix :: CombIx
fakeCix :: CombIx
fakeCix = Reference -> Word64 -> Word64 -> CombIx
CIx Reference
exceptionRef Word64
forall a. Bounded a => a
maxBound Word64
forall a. Bounded a => a
maxBound

unhandledAbilityRequest :: (HasCallStack) => IO a
unhandledAbilityRequest :: forall a. HasCallStack => IO a
unhandledAbilityRequest = [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO a) -> ([Char] -> [Char]) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuntimeExn -> [Char]
forall a. Show a => a -> [Char]
show (RuntimeExn -> [Char])
-> ([Char] -> RuntimeExn) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> Pretty ColorText -> RuntimeExn
PE CallStack
HasCallStack => CallStack
callStack (Pretty ColorText -> RuntimeExn)
-> ([Char] -> Pretty ColorText) -> [Char] -> RuntimeExn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorText -> Pretty ColorText
forall s. (IsString s, ListLike s Char) => s -> Pretty s
P.lit (ColorText -> Pretty ColorText)
-> ([Char] -> ColorText) -> [Char] -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ColorText
forall a. IsString a => [Char] -> a
fromString ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
"eval: unhandled ability request"

forkEval :: CCache -> ActiveThreads -> Val -> IO ThreadId
forkEval :: CCache -> ActiveThreads -> Val -> IO ThreadId
forkEval CCache
env ActiveThreads
activeThreads Val
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 -> IO ()) -> CCache -> ActiveThreads -> Val -> IO ()
apply1 Stack -> IO ()
err CCache
env ActiveThreads
activeThreads Val
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 -> IO ()
    err :: Stack -> IO ()
err Stack
_ = () -> 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 -> (Val -> IO ()) -> Val -> IO ()
nestEval :: CCache -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
nestEval CCache
env ActiveThreads
activeThreads Val -> IO ()
write Val
val = (Stack -> IO ()) -> CCache -> ActiveThreads -> Val -> IO ()
apply1 Stack -> IO ()
readBack CCache
env ActiveThreads
activeThreads Val
val
  where
    readBack :: Stack -> IO ()
readBack Stack
stk = (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek Stack
stk IO Val -> (Val -> 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
>>= Val -> IO ()
write
{-# INLINE nestEval #-}

atomicEval :: CCache -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
atomicEval :: CCache -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
atomicEval CCache
env ActiveThreads
activeThreads Val -> IO ()
write Val
val =
  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 -> (Val -> IO ()) -> Val -> IO ()
nestEval CCache
env ActiveThreads
activeThreads Val -> IO ()
write Val
val
{-# INLINE atomicEval #-}

-- fast path application
enter ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Reference ->
  Bool ->
  Args ->
  MComb ->
  IO ()
enter :: CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> Bool
-> Args
-> MComb
-> IO ()
enter CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k !Reference
cref !Bool
sck !Args
args = \case
  (RComb (Lam Int
a Int
f MSection
entry)) -> do
    -- check for stack check _skip_
    Stack
stk <- if Bool
sck then Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk else Stack -> Int -> IO Stack
ensure Stack
stk Int
f
    Stack
stk <- Stack -> Args -> IO Stack
moveArgs Stack
stk Args
args
    Stack
stk <- Stack -> Int -> IO Stack
acceptArgs Stack
stk Int
a
    CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
cref MSection
entry
  (RComb (CachedVal Word64
_ Val
val)) -> do
    Stack
stk <- Stack -> IO Stack
discardFrame Stack
stk
    Stack
stk <- Stack -> IO Stack
bump Stack
stk
    (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
val
    CCache
-> EnumMap Word64 Val -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k
{-# INLINE enter #-}

-- fast path by-name delaying
name :: Stack -> Args -> Val -> IO Stack
name :: Stack -> Args -> Val -> IO Stack
name !Stack
stk !Args
args = \case
  BoxedVal (PAp CombIx
cix GCombInfo MComb
comb Seg
seg) -> do
    Seg
seg <- Augment -> Stack -> Seg -> Args -> IO Seg
closeArgs Augment
I Stack
stk Seg
seg Args
args
    Stack
stk <- Stack -> IO Stack
bump Stack
stk
    (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ CombIx -> GCombInfo MComb -> Seg -> Closure
PAp CombIx
cix GCombInfo MComb
comb Seg
seg
    pure Stack
stk
  Val
v -> [Char] -> IO Stack
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Stack) -> [Char] -> IO Stack
forall a b. (a -> b) -> a -> b
$ [Char]
"naming non-function: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v
{-# INLINE name #-}

-- slow path application
apply ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Bool ->
  Args ->
  Val ->
  IO ()
{- ORMOLU_DISABLE -}
#ifdef STACK_CHECK
apply _env !_denv !_activeThreads !stk !_k !_ck !args !val
  | debugger stk "apply" (args, val) = undefined
#endif
{- ORMOLU_ENABLE -}
apply :: CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k !Bool
ck !Args
args !Val
val =
  case Val
val of
    BoxedVal (PAp cix :: CombIx
cix@(CIx Reference
combRef Word64
_ Word64
_) GCombInfo MComb
comb Seg
seg) ->
      case GCombInfo MComb
comb of
        LamI Int
a Int
f MSection
entry
          | Bool
ck Bool -> Bool -> Bool
|| Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
ac -> do
              Stack
stk <- Stack -> Int -> IO Stack
ensure Stack
stk Int
f
              Stack
stk <- Stack -> Args -> IO Stack
moveArgs Stack
stk Args
args
              Stack
stk <- Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
A
              Stack
stk <- Stack -> Int -> IO Stack
acceptArgs Stack
stk Int
a
              CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
combRef MSection
entry
          | Bool
otherwise -> do
              Seg
seg <- Augment -> Stack -> Seg -> Args -> IO Seg
closeArgs Augment
C Stack
stk Seg
seg Args
args
              Stack
stk <- Stack -> IO Stack
discardFrame (Stack -> IO Stack) -> IO Stack -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack -> IO Stack
frameArgs Stack
stk
              Stack
stk <- Stack -> IO Stack
bump Stack
stk
              (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ CombIx -> GCombInfo MComb -> Seg -> Closure
PAp CombIx
cix GCombInfo MComb
comb Seg
seg
              CCache
-> EnumMap Word64 Val -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k
      where
        ac :: Int
ac = Stack -> Int
asize Stack
stk Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Args -> Int
countArgs Args
args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Seg -> Int
scount Seg
seg
    Val
v -> Val -> IO ()
zeroArgClosure Val
v
  where
    zeroArgClosure :: Val -> IO ()
    zeroArgClosure :: Val -> IO ()
zeroArgClosure Val
v
      | Args
ZArgs <- Args
args,
        Stack -> Int
asize Stack
stk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = do
          Stack
stk <- Stack -> IO Stack
discardFrame Stack
stk
          Stack
stk <- Stack -> IO Stack
bump Stack
stk
          (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
v
          CCache
-> EnumMap Word64 Val -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk 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]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v
{-# INLINE apply #-}

jump ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Args ->
  Closure ->
  IO ()
jump :: CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Args
-> Closure
-> IO ()
jump CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k !Args
args Closure
clo = case Closure
clo of
  Captured K
sk0 Int
a Seg
seg -> do
    let (Int
p, K
sk) = K -> (Int, K)
adjust K
sk0
    Seg
seg <- Augment -> Stack -> Seg -> Args -> IO Seg
closeArgs Augment
K Stack
stk Seg
seg Args
args
    Stack
stk <- Stack -> IO Stack
discardFrame Stack
stk
    Stack
stk <- Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg (Dump -> IO Stack) -> Dump -> IO Stack
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Dump
F (Args -> Int
countArgs Args
args) Int
a
    Stack
stk <- Stack -> Int -> IO Stack
adjustArgs Stack
stk Int
p
    CCache
-> ActiveThreads -> Stack -> EnumMap Word64 Val -> K -> K -> IO ()
repush CCache
env ActiveThreads
activeThreads Stack
stk EnumMap Word64 Val
denv K
sk K
k
  Closure
_ -> [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.
    adjust :: K -> (SZ, K)
    adjust :: K -> (Int, K)
adjust (Mark Int
a EnumSet Word64
rs EnumMap Word64 Val
denv K
k) =
      (Int
0, Int -> EnumSet Word64 -> EnumMap Word64 Val -> K -> K
Mark (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Stack -> Int
asize Stack
stk) EnumSet Word64
rs EnumMap Word64 Val
denv K
k)
    adjust (Push Int
n Int
a CombIx
cix Int
f MSection
rsect K
k) =
      (Int
0, Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push Int
n (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Stack -> Int
asize Stack
stk) CombIx
cix Int
f MSection
rsect K
k)
    adjust K
k = (Stack -> Int
asize Stack
stk, K
k)
{-# INLINE jump #-}

repush ::
  CCache ->
  ActiveThreads ->
  Stack ->
  DEnv ->
  K ->
  K ->
  IO ()
repush :: CCache
-> ActiveThreads -> Stack -> EnumMap Word64 Val -> K -> K -> IO ()
repush CCache
env !ActiveThreads
activeThreads !Stack
stk = EnumMap Word64 Val -> K -> K -> IO ()
go
  where
    go :: EnumMap Word64 Val -> K -> K -> IO ()
go !EnumMap Word64 Val
denv K
KE !K
k = CCache
-> EnumMap Word64 Val -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k
    go !EnumMap Word64 Val
denv (Mark Int
a EnumSet Word64
ps EnumMap Word64 Val
cs K
sk) !K
k = EnumMap Word64 Val -> K -> K -> IO ()
go EnumMap Word64 Val
denv' K
sk (K -> IO ()) -> K -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> EnumSet Word64 -> EnumMap Word64 Val -> K -> K
Mark Int
a EnumSet Word64
ps EnumMap Word64 Val
cs' K
k
      where
        denv' :: EnumMap Word64 Val
denv' = EnumMap Word64 Val
cs EnumMap Word64 Val -> EnumMap Word64 Val -> EnumMap Word64 Val
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Val -> EnumSet Word64 -> EnumMap Word64 Val
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.withoutKeys EnumMap Word64 Val
denv EnumSet Word64
ps
        cs' :: EnumMap Word64 Val
cs' = EnumMap Word64 Val -> EnumSet Word64 -> EnumMap Word64 Val
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys EnumMap Word64 Val
denv EnumSet Word64
ps
    go !EnumMap Word64 Val
denv (Push Int
n Int
a CombIx
cix Int
f MSection
rsect K
sk) !K
k =
      EnumMap Word64 Val -> K -> K -> IO ()
go EnumMap Word64 Val
denv K
sk (K -> IO ()) -> K -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push Int
n Int
a CombIx
cix Int
f MSection
rsect K
k
    go !EnumMap Word64 Val
_ (CB Callback
_) !K
_ = [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
die [Char]
"repush: impossible"
{-# INLINE repush #-}

moveArgs ::
  Stack ->
  Args ->
  IO Stack
moveArgs :: Stack -> Args -> IO Stack
moveArgs !Stack
stk Args
ZArgs = do
  Stack
stk <- Stack -> IO Stack
discardFrame Stack
stk
  pure Stack
stk
moveArgs !Stack
stk (VArg1 Int
i) = do
  Stack
stk <- Stack -> Args' -> IO Stack
prepareArgs Stack
stk (Int -> Args'
Arg1 Int
i)
  pure Stack
stk
moveArgs !Stack
stk (VArg2 Int
i Int
j) = do
  Stack
stk <- Stack -> Args' -> IO Stack
prepareArgs Stack
stk (Int -> Int -> Args'
Arg2 Int
i Int
j)
  pure Stack
stk
moveArgs !Stack
stk (VArgR Int
i Int
l) = do
  Stack
stk <- Stack -> Args' -> IO Stack
prepareArgs Stack
stk (Int -> Int -> Args'
ArgR Int
i Int
l)
  pure Stack
stk
moveArgs !Stack
stk (VArgN PrimArray Int
as) = do
  Stack
stk <- Stack -> Args' -> IO Stack
prepareArgs Stack
stk (PrimArray Int -> Args'
ArgN PrimArray Int
as)
  pure Stack
stk
moveArgs !Stack
stk (VArgV Int
i) = do
  Stack
stk <-
    if Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then Stack -> Args' -> IO Stack
prepareArgs Stack
stk (Int -> Int -> Args'
ArgR Int
0 Int
l)
      else Stack -> IO Stack
discardFrame Stack
stk
  pure Stack
stk
  where
    l :: Int
l = Stack -> Int
fsize Stack
stk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i
{-# INLINE moveArgs #-}

closureArgs :: Stack -> Args -> IO [Val]
closureArgs :: Stack -> Args -> IO [Val]
closureArgs !Stack
_ Args
ZArgs = [Val] -> IO [Val]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
closureArgs !Stack
stk (VArg1 Int
i) = do
  Val
x <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  pure [Val
x]
closureArgs !Stack
stk (VArg2 Int
i Int
j) = do
  Val
x <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Val
y <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  pure [Val
x, Val
y]
closureArgs !Stack
stk (VArgR Int
i Int
l) =
  [Int] -> (Int -> IO Val) -> IO [Val]
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 ..]) ((() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk)
closureArgs !Stack
stk (VArgN PrimArray Int
bs) =
  [Int] -> (Int -> IO Val) -> IO [Val]
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) ((() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk)
closureArgs !Stack
_ Args
_ =
  [Char] -> IO [Val]
forall a. HasCallStack => [Char] -> a
error [Char]
"closure arguments can only be boxed."
{-# INLINE closureArgs #-}

-- | Pack some number of args into a data type of the provided ref/tag type.
buildData ::
  Stack -> Reference -> PackedTag -> Args -> IO Closure
buildData :: Stack -> Reference -> PackedTag -> Args -> IO Closure
buildData !Stack
_ !Reference
r !PackedTag
t Args
ZArgs = Closure -> IO Closure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ Reference -> PackedTag -> Closure
Enum Reference
r PackedTag
t
buildData !Stack
stk !Reference
r !PackedTag
t (VArg1 Int
i) = do
  Val
v <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  pure $ Reference -> PackedTag -> Val -> Closure
Data1 Reference
r PackedTag
t Val
v
buildData !Stack
stk !Reference
r !PackedTag
t (VArg2 Int
i Int
j) = do
  Val
v1 <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Val
v2 <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  pure $ Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
r PackedTag
t Val
v1 Val
v2
buildData !Stack
stk !Reference
r !PackedTag
t (VArgR Int
i Int
l) = do
  Seg
seg <- Augment -> Stack -> Seg -> Maybe Args' -> IO Seg
augSeg Augment
I Stack
stk Seg
nullSeg (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 -> PackedTag -> Seg -> Closure
DataG Reference
r PackedTag
t Seg
seg
buildData !Stack
stk !Reference
r !PackedTag
t (VArgN PrimArray Int
as) = do
  Seg
seg <- Augment -> Stack -> Seg -> Maybe Args' -> IO Seg
augSeg Augment
I Stack
stk Seg
nullSeg (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 -> PackedTag -> Seg -> Closure
DataG Reference
r PackedTag
t Seg
seg
buildData !Stack
stk !Reference
r !PackedTag
t (VArgV Int
i) = do
  Seg
seg <-
    if Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then Augment -> Stack -> Seg -> Maybe Args' -> IO Seg
augSeg Augment
I Stack
stk Seg
nullSeg (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
l)
      else Seg -> IO Seg
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seg
nullSeg
  pure $ Reference -> PackedTag -> Seg -> Closure
DataG Reference
r PackedTag
t Seg
seg
  where
    l :: Int
l = Stack -> Int
fsize Stack
stk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i
{-# INLINE buildData #-}

dumpDataValNoTag ::
  Stack ->
  Val ->
  IO (PackedTag, Stack)
dumpDataValNoTag :: Stack -> Val -> IO (PackedTag, Stack)
dumpDataValNoTag Stack
stk (BoxedVal Closure
c) =
  (Closure -> PackedTag
closureTag Closure
c,) (Stack -> (PackedTag, Stack)) -> IO Stack -> IO (PackedTag, Stack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Reference -> Stack -> Closure -> IO Stack
dumpDataNoTag Maybe Reference
forall a. Maybe a
Nothing Stack
stk Closure
c
dumpDataValNoTag Stack
_ Val
v =
  [Char] -> IO (PackedTag, Stack)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (PackedTag, Stack))
-> [Char] -> IO (PackedTag, Stack)
forall a b. (a -> b) -> a -> b
$ [Char]
"dumpDataValNoTag: unboxed val: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v
{-# inline dumpDataValNoTag #-}

-- 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 ->
  Closure ->
  IO Stack
dumpDataNoTag :: Maybe Reference -> Stack -> Closure -> IO Stack
dumpDataNoTag !Maybe Reference
mr !Stack
stk = \case
  -- Normally we want to avoid dumping unboxed values since it's unnecessary, but sometimes we don't know the type of
  -- the incoming value and end up dumping unboxed values, so we just push them back to the stack as-is. e.g. in type-casts/coercions
  Enum Reference
_ PackedTag
_ -> Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
  Data1 Reference
_ PackedTag
_ Val
x -> do
    Stack
stk <- Stack -> IO Stack
bump Stack
stk
    (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
    pure Stack
stk
  Data2 Reference
_ PackedTag
_ Val
x Val
y -> do
    Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
    (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
y
    Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
  DataG Reference
_ PackedTag
_ Seg
seg -> Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
S
  Closure
clo ->
    [Char] -> IO Stack
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Stack) -> [Char] -> IO Stack
forall a b. (a -> b) -> a -> b
$
      [Char]
"dumpDataNoTag: bad closure: "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
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 #-}

-- 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 ->
  Seg ->
  Args ->
  IO Seg
closeArgs :: Augment -> Stack -> Seg -> Args -> IO Seg
closeArgs Augment
mode !Stack
stk !Seg
seg Args
args = Augment -> Stack -> Seg -> Maybe Args' -> IO Seg
augSeg Augment
mode Stack
stk Seg
seg Maybe Args'
as
  where
    as :: Maybe Args'
as = case Args
args of
      Args
ZArgs -> Maybe Args'
forall a. Maybe a
Nothing
      VArg1 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
      VArg2 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
      VArgR 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
      VArgN 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
      VArgV Int
i -> Maybe Args'
a
        where
          a :: Maybe Args'
a
            | Int
l 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
l
            | Bool
otherwise = Maybe Args'
forall a. Maybe a
Nothing
          l :: Int
l = Stack -> Int
fsize Stack
stk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i

uprim1 :: Stack -> UPrim1 -> Int -> IO Stack
uprim1 :: Stack -> UPrim1 -> Int -> IO Stack
uprim1 !Stack
stk UPrim1
DECI !Int
i = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
DECN !Int
i = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
m Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
INCI !Int
i = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
INCN !Int
i = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
m Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
TRNC !Int
i = do
  Int
v <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
unsafePokeIasN Stack
stk (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
v)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
NEGI !Int
i = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (-Int
m)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
SGNI !Int
i = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int -> Int
forall a. Num a => a -> a
signum Int
m)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
ABSF !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Num a => a -> a
abs Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
CEIL !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
FLOR !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
TRNF !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
RNDF !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
EXPF !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
exp Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
LOGF !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
log Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
SQRT !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
sqrt Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
COSF !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
cos Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
SINF !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
sin Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
TANF !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
tan Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
COSH !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
cosh Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
SINH !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
sinh Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
TANH !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
tanh Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
ACOS !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
acos Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
ASIN !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
asin Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
ATAN !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
atan Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
ASNH !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
asinh Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
ACSH !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
acosh Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
ATNH !Int
i = do
  Double
d <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double
forall a. Floating a => a -> a
atanh Double
d)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
ITOF !Int
i = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
NTOF !Int
i = do
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
LZRO !Int
i = do
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
unsafePokeIasN Stack
stk (Word64 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros Word64
n)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
TZRO !Int
i = do
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
unsafePokeIasN Stack
stk (Word64 -> Int
forall b. FiniteBits b => b -> Int
countTrailingZeros Word64
n)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
POPC !Int
i = do
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
unsafePokeIasN Stack
stk (Word64 -> Int
forall a. Bits a => a -> Int
popCount Word64
n)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
COMN !Int
i = do
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64 -> Word64
forall a. Bits a => a -> a
complement Word64
n)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
COMI !Int
i = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int -> Int
forall a. Bits a => a -> a
complement Int
n)
  pure Stack
stk
uprim1 !Stack
stk UPrim1
NOTB !Int
i = do
  Bool
b <- Stack -> Int -> IO Bool
peekOffBool Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> Bool
not Bool
b)
  pure Stack
stk
{-# INLINE uprim1 #-}

uprim2 :: Stack -> UPrim2 -> Int -> Int -> IO Stack
uprim2 :: Stack -> UPrim2 -> Int -> Int -> IO Stack
uprim2 !Stack
stk UPrim2
ADDI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
ADDN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
m Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
SUBI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
DRPN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  let r :: Word64
r = if Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
m then Word64
0 else Word64
m Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
n
  Stack -> Word64 -> IO ()
pokeN Stack
stk Word64
r
  pure Stack
stk
uprim2 !Stack
stk UPrim2
SUBN !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
MULI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
MULN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
m Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
DIVI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
MODI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
SHLI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
SHLN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
m Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
SHRI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
SHRN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
m Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
POWI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
m Int -> Word64 -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Word64
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
POWN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
m Word64 -> Word64 -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ Word64
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
EQLI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
  pure Stack
stk
uprim2 !Stack
stk UPrim2
NEQI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n
  pure Stack
stk
uprim2 !Stack
stk UPrim2
EQLN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64
m Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
n
  pure Stack
stk
uprim2 !Stack
stk UPrim2
NEQN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64
m Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
n
  pure Stack
stk
uprim2 !Stack
stk UPrim2
LEQI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n
  pure Stack
stk
uprim2 !Stack
stk UPrim2
LEQN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64
m Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
n
  pure Stack
stk
uprim2 !Stack
stk UPrim2
LESI !Int
i !Int
j = do
  Int
m <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
  pure Stack
stk
uprim2 !Stack
stk UPrim2
LESN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64
m Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
n
  pure Stack
stk
uprim2 !Stack
stk UPrim2
DIVN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
m Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
MODN !Int
i !Int
j = do
  Word64
m <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
m Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
n)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
ADDF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
SUBF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
MULF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
DIVF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
LOGB !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
x Double
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
POWF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double
x Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
MAXF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
x Double
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
MINF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
x Double
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
EQLF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
y
  pure Stack
stk
uprim2 !Stack
stk UPrim2
NEQF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
y
  pure Stack
stk
uprim2 !Stack
stk UPrim2
LEQF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
y
  pure Stack
stk
uprim2 !Stack
stk UPrim2
LESF !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
y
  pure Stack
stk
uprim2 !Stack
stk UPrim2
ATN2 !Int
i !Int
j = do
  Double
x <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Double
y <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Double -> IO ()
pokeD Stack
stk (Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 Double
x Double
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
ANDN !Int
i !Int
j = do
  Word64
x <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
y <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
ANDI !Int
i !Int
j = do
  Int
x <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
i
  Int
y <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
IORN !Int
i !Int
j = do
  Word64
x <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
y <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
IORI !Int
i !Int
j = do
  Int
x <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
i
  Int
y <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
XORN !Int
i !Int
j = do
  Word64
x <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Word64
y <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
xor Word64
x Word64
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
XORI !Int
i !Int
j = do
  Int
x <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
i
  Int
y <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Int -> IO ()
pokeI Stack
stk (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
x Int
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
CAST !Int
vi !Int
ti = do
  Int
newTypeTag <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
ti
  Int
v <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
vi
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk (Val -> IO ()) -> Val -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> UnboxedTypeTag -> Val
UnboxedVal Int
v (HasCallStack => Int -> UnboxedTypeTag
Int -> UnboxedTypeTag
unboxedTypeTagFromInt Int
newTypeTag)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
ANDB !Int
i !Int
j = do
  Bool
x <- Stack -> Int -> IO Bool
peekOffBool Stack
stk Int
i
  Bool
y <- Stack -> Int -> IO Bool
peekOffBool Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool
x Bool -> Bool -> Bool
&& Bool
y)
  pure Stack
stk
uprim2 !Stack
stk UPrim2
IORB !Int
i !Int
j = do
  Bool
x <- Stack -> Int -> IO Bool
peekOffBool Stack
stk Int
i
  Bool
y <- Stack -> Int -> IO Bool
peekOffBool Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool
x Bool -> Bool -> Bool
|| Bool
y)
  pure Stack
stk
{-# INLINE uprim2 #-}

bprim1 ::
  CCache ->
  Stack ->
  BPrim1 ->
  Int ->
  IO Stack
bprim1 :: CCache -> Stack -> BPrim1 -> Int -> IO Stack
bprim1 !CCache
_env !Stack
stk BPrim1
SIZT Int
i = do
  Text
t <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
unsafePokeIasN Stack
stk (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Int
Util.Text.size Text
t
  pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
SIZS Int
i = do
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
unsafePokeIasN Stack
stk (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ USeq -> Int
forall a. Seq a -> Int
Sq.length USeq
s
  pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
ITOT Int
i = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (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
stk
bprim1 !CCache
_env !Stack
stk BPrim1
NTOT Int
i = do
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (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
stk
bprim1 !CCache
_env !Stack
stk BPrim1
FTOT Int
i = do
  Double
f <- Stack -> Int -> IO Double
peekOffD Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (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
stk
bprim1 !CCache
_env !Stack
stk BPrim1
USNC Int
i =
  Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i IO Text -> (Text -> IO Stack) -> IO Stack
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
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      pure Stack
stk
    Just (Text
t, Char
c) -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
3
      Stack -> Int -> Char -> IO ()
pokeOffC Stack
stk Int
2 (Char -> IO ()) -> Char -> IO ()
forall a b. (a -> b) -> a -> b
$ Char
c -- char value
      Stack -> Int -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> Int -> b -> IO ()
pokeOffBi Stack
stk Int
1 Text
t -- remaining text
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1 -- 'Just' tag
      pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
UCNS Int
i =
  Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i IO Text -> (Text -> IO Stack) -> IO Stack
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
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      pure Stack
stk
    Just (Char
c, Text
t) -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
3
      Stack -> Int -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> Int -> b -> IO ()
pokeOffBi Stack
stk Int
2 Text
t -- remaining text
      Stack -> Int -> Char -> IO ()
pokeOffC Stack
stk Int
1 (Char -> IO ()) -> Char -> IO ()
forall a b. (a -> b) -> a -> b
$ Char
c -- char value
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1 -- 'Just' tag
      pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
TTOI Int
i =
  Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i IO Text -> (Text -> IO Stack) -> IO Stack
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
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
          (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
          Stack -> Int -> Int -> IO ()
pokeOffI Stack
stk Int
1 (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
          pure Stack
stk
    Maybe Integer
_ -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      pure Stack
stk
  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 !CCache
_env !Stack
stk BPrim1
TTON Int
i =
  Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i IO Text -> (Text -> IO Stack) -> IO Stack
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
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
          (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
          Stack -> Int -> Word64 -> IO ()
pokeOffN Stack
stk Int
1 (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
n)
          pure Stack
stk
    Maybe Integer
_ -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
TTOF Int
i =
  Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i IO Text -> (Text -> IO Stack) -> IO Stack
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
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      pure Stack
stk
    Just Double
f -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
      Stack -> Int -> Double -> IO ()
pokeOffD Stack
stk Int
1 Double
f
      pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
VWLS Int
i =
  Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i IO USeq -> (USeq -> IO Stack) -> IO Stack
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    USeq
Sq.Empty -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0 -- 'Empty' tag
      pure Stack
stk
    Val
x Sq.:<| USeq
xs -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
3
      Stack -> Int -> USeq -> IO ()
pokeOffS Stack
stk Int
2 USeq
xs -- remaining seq
      (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
x -- head
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1 -- ':<|' tag
      pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
VWRS Int
i =
  Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i IO USeq -> (USeq -> IO Stack) -> IO Stack
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    USeq
Sq.Empty -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0 -- 'Empty' tag
      pure Stack
stk
    USeq
xs Sq.:|> Val
x -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
3
      (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
2 Val
x -- last
      Stack -> Int -> USeq -> IO ()
pokeOffS Stack
stk Int
1 USeq
xs -- remaining seq
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1 -- ':|>' tag
      pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
PAKT Int
i = do
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (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
$ Val -> Char
val2char (Val -> Char) -> USeq -> Seq Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> USeq
s
  pure Stack
stk
  where
    val2char :: Val -> Char
    val2char :: Val -> Char
val2char (CharVal Char
c) = Char
c
    val2char Val
c = [Char] -> Char
forall a. HasCallStack => [Char] -> a
error ([Char] -> Char) -> [Char] -> Char
forall a b. (a -> b) -> a -> b
$ [Char]
"pack text: non-character closure: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
c
bprim1 !CCache
_env !Stack
stk BPrim1
UPKT Int
i = do
  Text
t <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> USeq -> IO ()
pokeS Stack
stk
    (USeq -> IO ()) -> (Text -> USeq) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> USeq
forall a. [a] -> Seq a
Sq.fromList
    ([Val] -> USeq) -> (Text -> [Val]) -> Text -> USeq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Val) -> [Char] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Val
CharVal
    ([Char] -> [Val]) -> (Text -> [Char]) -> Text -> [Val]
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
stk
bprim1 !CCache
_env !Stack
stk BPrim1
PAKB Int
i = do
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Bytes -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (Bytes -> IO ()) -> ([Val] -> Bytes) -> [Val] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Bytes
By.fromWord8s ([Word8] -> Bytes) -> ([Val] -> [Word8]) -> [Val] -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Val -> Word8) -> [Val] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Val -> Word8
val2w8 ([Val] -> IO ()) -> [Val] -> IO ()
forall a b. (a -> b) -> a -> b
$ USeq -> [Val]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList USeq
s
  pure Stack
stk
  where
    -- TODO: Should we have a tag for bytes specifically?
    val2w8 :: Val -> Word8
    val2w8 :: Val -> Word8
val2w8 (NatVal Word64
n) = Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> (Word64 -> Int) -> Word64 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int
forall a. Enum a => a -> Int
fromEnum (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
n
    val2w8 Val
c = [Char] -> Word8
forall a. HasCallStack => [Char] -> a
error ([Char] -> Word8) -> [Char] -> Word8
forall a b. (a -> b) -> a -> b
$ [Char]
"pack bytes: non-natural closure: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
c
bprim1 !CCache
_env !Stack
stk BPrim1
UPKB Int
i = do
  Bytes
b <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> USeq -> IO ()
pokeS Stack
stk (USeq -> IO ()) -> ([Word8] -> USeq) -> [Word8] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> USeq
forall a. [a] -> Seq a
Sq.fromList ([Val] -> USeq) -> ([Word8] -> [Val]) -> [Word8] -> USeq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Val) -> [Word8] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> Val
NatVal (Word64 -> Val) -> (Word8 -> Word64) -> Word8 -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => Int -> a
toEnum @Word64 (Int -> Word64) -> (Word8 -> Int) -> Word8 -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum @Word8) ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
    Bytes -> [Word8]
By.toWord8s Bytes
b
  pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
SIZB Int
i = do
  Bytes
b <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
unsafePokeIasN Stack
stk (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Bytes -> Int
By.size Bytes
b
  pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
FLTB Int
i = do
  Bytes
b <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Bytes -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (Bytes -> IO ()) -> Bytes -> IO ()
forall a b. (a -> b) -> a -> b
$ Bytes -> Bytes
By.flatten Bytes
b
  pure Stack
stk

-- The docs for IORef state that IORef operations can be observed
-- out of order ([1]) but actually GHC does emit the appropriate
-- load and store barriers nowadays ([2], [3]).
--
-- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2
-- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286
-- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298
bprim1 !CCache
_env !Stack
stk BPrim1
REFR Int
i = do
  (IORef Val
ref :: IORef Val) <- Stack -> Int -> IO (IORef Val)
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Val
v <- IORef Val -> IO Val
forall a. IORef a -> IO a
IORef.readIORef IORef Val
ref
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
v
  pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
REFN Int
i = do
  -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it
  -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal
  -- forcing of the values and tickets.
  !Val
v <- Val -> IO Val
forall a. a -> IO a
evaluate (Val -> IO Val) -> IO Val -> IO Val
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  IORef Val
ref <- Val -> IO (IORef Val)
forall a. a -> IO (IORef a)
IORef.newIORef Val
v
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> IORef Val -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk IORef Val
ref
  pure Stack
stk
bprim1 !CCache
env !Stack
stk BPrim1
RRFC Int
i
  | CCache -> Bool
sandboxed CCache
env = [Char] -> IO Stack
forall a. HasCallStack => [Char] -> IO a
die [Char]
"attempted to use sandboxed operation: Ref.readForCAS"
  | Bool
otherwise = do
      (IORef Val
ref :: IORef Val) <- Stack -> Int -> IO (IORef Val)
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
      Ticket Val
ticket <- IORef Val -> IO (Ticket Val)
forall a. IORef a -> IO (Ticket a)
Atomic.readForCAS IORef Val
ref
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack -> Ticket Val -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk Ticket Val
ticket
      pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
TIKR Int
i = do
  (Ticket Val
t :: Atomic.Ticket Val) <- Stack -> Int -> IO (Ticket Val)
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  let v :: Val
v = Ticket Val -> Val
forall a. Ticket a -> a
Atomic.peekTicket Ticket Val
t
  (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
v
  pure Stack
stk

-- impossible
bprim1 !CCache
_env !Stack
stk BPrim1
MISS Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
CACH Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
LKUP Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
CVLD Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
TLTT Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
LOAD Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
VALU Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
DBTX Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
bprim1 !CCache
_env !Stack
stk BPrim1
SDBL Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
{-# INLINE bprim1 #-}

bprim2 ::
  Stack ->
  BPrim2 ->
  Int ->
  Int ->
  IO Stack
bprim2 :: Stack -> BPrim2 -> Int -> Int -> IO Stack
bprim2 !Stack
stk BPrim2
IXOT Int
i Int
j = do
  Text
x <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Text
y <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  case Text -> Text -> Maybe Word64
Util.Text.indexOf Text
x Text
y of
    Maybe Word64
Nothing -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      pure Stack
stk
    Just Word64
i -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
      Stack -> Int -> Word64 -> IO ()
pokeOffN Stack
stk Int
1 Word64
i
      pure Stack
stk
bprim2 !Stack
stk BPrim2
IXOB Int
i Int
j = do
  Bytes
x <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Bytes
y <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  case Bytes -> Bytes -> Maybe Word64
By.indexOf Bytes
x Bytes
y of
    Maybe Word64
Nothing -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      pure Stack
stk
    Just Word64
i -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
      Stack -> Int -> Word64 -> IO ()
pokeOffN Stack
stk Int
1 Word64
i
      pure Stack
stk
bprim2 !Stack
stk BPrim2
DRPT Int
i Int
j = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Text
t <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  -- 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 -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (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
stk
bprim2 !Stack
stk BPrim2
CATT Int
i Int
j = do
  Text
x <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Text
y <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (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
stk
bprim2 !Stack
stk BPrim2
TAKT Int
i Int
j = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Text
t <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  -- 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 -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (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
stk
bprim2 !Stack
stk BPrim2
EQLT Int
i Int
j = do
  Text
x <- forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi @Util.Text.Text Stack
stk Int
i
  Text
y <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
y
  pure Stack
stk
bprim2 !Stack
stk BPrim2
LEQT Int
i Int
j = do
  Text
x <- forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi @Util.Text.Text Stack
stk Int
i
  Text
y <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
x Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
<= Text
y
  pure Stack
stk
bprim2 !Stack
stk BPrim2
LEST Int
i Int
j = do
  Text
x <- forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi @Util.Text.Text Stack
stk Int
i
  Text
y <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
x Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
< Text
y
  pure Stack
stk
bprim2 !Stack
stk BPrim2
DRPS Int
i Int
j = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  -- 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 -> USeq -> IO ()
pokeS Stack
stk (USeq -> IO ()) -> USeq -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then USeq
forall a. Seq a
Sq.empty else Int -> USeq -> USeq
forall a. Int -> Seq a -> Seq a
Sq.drop Int
n USeq
s
  pure Stack
stk
bprim2 !Stack
stk BPrim2
TAKS Int
i Int
j = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  -- 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 -> USeq -> IO ()
pokeS Stack
stk (USeq -> IO ()) -> USeq -> IO ()
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then USeq
s else Int -> USeq -> USeq
forall a. Int -> Seq a -> Seq a
Sq.take Int
n USeq
s
  pure Stack
stk
bprim2 !Stack
stk BPrim2
CONS Int
i Int
j = do
  Val
x <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> USeq -> IO ()
pokeS Stack
stk (USeq -> IO ()) -> USeq -> IO ()
forall a b. (a -> b) -> a -> b
$ Val
x Val -> USeq -> USeq
forall a. a -> Seq a -> Seq a
Sq.<| USeq
s
  pure Stack
stk
bprim2 !Stack
stk BPrim2
SNOC Int
i Int
j = do
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i
  Val
x <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> USeq -> IO ()
pokeS Stack
stk (USeq -> IO ()) -> USeq -> IO ()
forall a b. (a -> b) -> a -> b
$ USeq
s USeq -> Val -> USeq
forall a. Seq a -> a -> Seq a
Sq.|> Val
x
  pure Stack
stk
bprim2 !Stack
stk BPrim2
CATS Int
i Int
j = do
  USeq
x <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i
  USeq
y <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> USeq -> IO ()
pokeS Stack
stk (USeq -> IO ()) -> USeq -> IO ()
forall a b. (a -> b) -> a -> b
$ USeq
x USeq -> USeq -> USeq
forall a. Seq a -> Seq a -> Seq a
Sq.>< USeq
y
  pure Stack
stk
bprim2 !Stack
stk BPrim2
IDXS Int
i Int
j = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
j
  case Int -> USeq -> Maybe Val
forall a. Int -> Seq a -> Maybe a
Sq.lookup Int
n USeq
s of
    Maybe Val
Nothing -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      pure Stack
stk
    Just Val
x -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
      pure Stack
stk
bprim2 !Stack
stk BPrim2
SPLL Int
i Int
j = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
j
  if USeq -> Int
forall a. Seq a -> Int
Sq.length USeq
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
    then do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      pure Stack
stk
    else do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
      let (USeq
l, USeq
r) = Int -> USeq -> (USeq, USeq)
forall a. Int -> Seq a -> (Seq a, Seq a)
Sq.splitAt Int
n USeq
s
      Stack -> Int -> USeq -> IO ()
pokeOffS Stack
stk Int
1 USeq
r
      Stack -> USeq -> IO ()
pokeS Stack
stk USeq
l
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
      pure Stack
stk
bprim2 !Stack
stk BPrim2
SPLR Int
i Int
j = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  USeq
s <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
j
  if USeq -> Int
forall a. Seq a -> Int
Sq.length USeq
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
    then do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      pure Stack
stk
    else do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
      let (USeq
l, USeq
r) = Int -> USeq -> (USeq, USeq)
forall a. Int -> Seq a -> (Seq a, Seq a)
Sq.splitAt (USeq -> Int
forall a. Seq a -> Int
Sq.length USeq
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) USeq
s
      Stack -> Int -> USeq -> IO ()
pokeOffS Stack
stk Int
1 USeq
r
      Stack -> USeq -> IO ()
pokeS Stack
stk USeq
l
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
      pure Stack
stk
bprim2 !Stack
stk BPrim2
TAKB Int
i Int
j = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Bytes
b <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  -- 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 -> Bytes -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (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
stk
bprim2 !Stack
stk BPrim2
DRPB Int
i Int
j = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Bytes
b <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  -- See above for n < 0
  Stack -> Bytes -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (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
stk
bprim2 !Stack
stk BPrim2
IDXB Int
i Int
j = do
  Int
n <- (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  Bytes
b <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack
stk <- case Int -> Bytes -> Maybe Word8
By.at Int
n Bytes
b of
    Maybe Word8
Nothing -> Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
    Just Word8
x -> do
      Stack -> Word8 -> IO ()
pokeByte Stack
stk Word8
x
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
  pure Stack
stk
bprim2 !Stack
stk BPrim2
CATB Int
i Int
j = do
  Bytes
l <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Bytes
r <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Bytes -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (Bytes
l Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> Bytes
r :: By.Bytes)
  pure Stack
stk
bprim2 !Stack
stk BPrim2
REFW Int
i Int
j = do
  (IORef Val
ref :: IORef Val) <- Stack -> Int -> IO (IORef Val)
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Val
v <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  IORef Val -> Val -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef Val
ref Val
v
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk Closure
unitClosure
  pure Stack
stk
bprim2 !Stack
stk BPrim2
THRO Int
_ Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk -- impossible
bprim2 !Stack
stk BPrim2
TRCE Int
_ Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk -- impossible
bprim2 !Stack
stk BPrim2
EQLU Int
_ Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk -- impossible
bprim2 !Stack
stk BPrim2
LEQU Int
_ Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk -- impossible
bprim2 !Stack
stk BPrim2
LESU Int
_ Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk -- impossible
bprim2 !Stack
stk BPrim2
CMPU Int
_ Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk -- impossible
bprim2 !Stack
stk BPrim2
SDBX Int
_ Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk -- impossible
bprim2 !Stack
stk BPrim2
SDBV Int
_ Int
_ = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk -- impossible
{-# INLINE bprim2 #-}

yield ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  IO ()
yield :: CCache
-> EnumMap Word64 Val -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env !EnumMap Word64 Val
denv !ActiveThreads
activeThreads !Stack
stk !K
k = EnumMap Word64 Val -> K -> IO ()
leap EnumMap Word64 Val
denv K
k
  where
    leap :: EnumMap Word64 Val -> K -> IO ()
leap !EnumMap Word64 Val
denv0 (Mark Int
a EnumSet Word64
ps EnumMap Word64 Val
cs K
k) = do
      let denv :: EnumMap Word64 Val
denv = EnumMap Word64 Val
cs EnumMap Word64 Val -> EnumMap Word64 Val -> EnumMap Word64 Val
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Val -> EnumSet Word64 -> EnumMap Word64 Val
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.withoutKeys EnumMap Word64 Val
denv0 EnumSet Word64
ps
          val :: Val
val = EnumMap Word64 Val
denv0 EnumMap Word64 Val -> Word64 -> Val
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
      Val
v <- (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek Stack
stk
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Reference -> PackedTag -> Val -> Closure
Data1 Reference
Rf.effectRef (Word64 -> PackedTag
PackedTag Word64
0) Val
v
      Stack
stk <- Stack -> Int -> IO Stack
adjustArgs Stack
stk Int
a
      CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Bool
False (Int -> Args
VArg1 Int
0) Val
val
    leap !EnumMap Word64 Val
denv (Push Int
fsz Int
asz (CIx Reference
ref Word64
_ Word64
_) Int
f MSection
nx K
k) = do
      Stack
stk <- Stack -> Int -> Int -> IO Stack
restoreFrame Stack
stk Int
fsz Int
asz
      Stack
stk <- Stack -> Int -> IO Stack
ensure Stack
stk Int
f
      CCache
-> EnumMap Word64 Val
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env EnumMap Word64 Val
denv ActiveThreads
activeThreads Stack
stk K
k Reference
ref MSection
nx
    leap EnumMap Word64 Val
_ (CB (Hook XStack -> IO ()
f)) = XStack -> IO ()
f (Stack -> XStack
unpackXStack Stack
stk)
    leap EnumMap Word64 Val
_ K
KE = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINE yield #-}

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

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

-- Combined branch selection and field dumping function for data types.
-- Fields should only be dumped on _matches_, not default cases, because
-- default cases potentially cover many constructors which could result
-- in a variable number of values being put on the stack. Default cases
-- uniformly expect _no_ values to be added to the stack.
dataBranch
  :: Maybe Reference -> Stack -> MBranch -> Closure -> IO (MSection, Stack)
dataBranch :: Maybe Reference
-> Stack -> GBranch MComb -> Closure -> IO (MSection, Stack)
dataBranch Maybe Reference
mrf Stack
stk (Test1 Word64
u MSection
cu MSection
df) = \case
  Enum Reference
_ PackedTag
t
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
cu, Stack
stk)
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  Data1 Reference
_ PackedTag
t Val
x
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (MSection
cu, Stack
stk) (MSection, Stack) -> IO () -> IO (MSection, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  Data2 Reference
_ PackedTag
t Val
x Val
y
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
      (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
y
      (MSection
cu, Stack
stk) (MSection, Stack) -> IO () -> IO (MSection, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  DataG Reference
_ PackedTag
t Seg
seg
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u -> (MSection
cu,) (Stack -> (MSection, Stack)) -> IO Stack -> IO (MSection, Stack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
S
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  Closure
clo -> Maybe Reference -> Closure -> IO (MSection, Stack)
forall a. Maybe Reference -> Closure -> IO a
dataBranchClosureError Maybe Reference
mrf Closure
clo
dataBranch Maybe Reference
mrf Stack
stk (Test2 Word64
u MSection
cu Word64
v MSection
cv MSection
df) = \case
  Enum Reference
_ PackedTag
t
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
cu, Stack
stk)
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
v -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
cv, Stack
stk)
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  Data1 Reference
_ PackedTag
t Val
x
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (MSection
cu, Stack
stk) (MSection, Stack) -> IO () -> IO (MSection, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
v -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (MSection
cv, Stack
stk) (MSection, Stack) -> IO () -> IO (MSection, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  Data2 Reference
_ PackedTag
t Val
x Val
y
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
      (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
y
      (MSection
cu, Stack
stk) (MSection, Stack) -> IO () -> IO (MSection, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
v -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
      (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
y
      (MSection
cv, Stack
stk) (MSection, Stack) -> IO () -> IO (MSection, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  DataG Reference
_ PackedTag
t Seg
seg
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u -> (MSection
cu,) (Stack -> (MSection, Stack)) -> IO Stack -> IO (MSection, Stack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
S
    | PackedTag -> Word64
maskTags PackedTag
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
v -> (MSection
cv,) (Stack -> (MSection, Stack)) -> IO Stack -> IO (MSection, Stack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
S
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  Closure
clo -> Maybe Reference -> Closure -> IO (MSection, Stack)
forall a. Maybe Reference -> Closure -> IO a
dataBranchClosureError Maybe Reference
mrf Closure
clo
dataBranch Maybe Reference
mrf Stack
stk (TestW MSection
df EnumMap Word64 MSection
bs) = \case
  Enum Reference
_ PackedTag
t
    | Just MSection
ca <- Word64 -> EnumMap Word64 MSection -> Maybe MSection
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup (PackedTag -> Word64
maskTags PackedTag
t) EnumMap Word64 MSection
bs -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
ca, Stack
stk)
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  Data1 Reference
_ PackedTag
t Val
x
    | Just MSection
ca <- Word64 -> EnumMap Word64 MSection -> Maybe MSection
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup (PackedTag -> Word64
maskTags PackedTag
t) EnumMap Word64 MSection
bs -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (MSection
ca, Stack
stk) (MSection, Stack) -> IO () -> IO (MSection, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  Data2 Reference
_ PackedTag
t Val
x Val
y
    | Just MSection
ca <- Word64 -> EnumMap Word64 MSection -> Maybe MSection
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup (PackedTag -> Word64
maskTags PackedTag
t) EnumMap Word64 MSection
bs -> do
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
      (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
y
      (MSection
ca, Stack
stk) (MSection, Stack) -> IO () -> IO (MSection, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  DataG Reference
_ PackedTag
t Seg
seg
    | Just MSection
ca <- Word64 -> EnumMap Word64 MSection -> Maybe MSection
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup (PackedTag -> Word64
maskTags PackedTag
t) EnumMap Word64 MSection
bs ->
      (MSection
ca,) (Stack -> (MSection, Stack)) -> IO Stack -> IO (MSection, Stack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
S
    | Bool
otherwise -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
df, Stack
stk)
  Closure
clo -> Maybe Reference -> Closure -> IO (MSection, Stack)
forall a. Maybe Reference -> Closure -> IO a
dataBranchClosureError Maybe Reference
mrf Closure
clo
dataBranch Maybe Reference
_ Stack
_ GBranch MComb
br = \Closure
_ ->
  GBranch MComb -> IO (MSection, Stack)
forall a. GBranch MComb -> IO a
dataBranchBranchError GBranch MComb
br
{-# inline dataBranch #-}

dataBranchClosureError :: Maybe Reference -> Closure -> IO a
dataBranchClosureError :: forall a. Maybe Reference -> Closure -> IO a
dataBranchClosureError Maybe Reference
mrf Closure
clo =
  [Char] -> IO a
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
"dataBranch: bad closure: "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
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
mrf

dataBranchBranchError :: MBranch -> IO a
dataBranchBranchError :: forall a. GBranch MComb -> IO a
dataBranchBranchError GBranch MComb
br =
  [Char] -> IO a
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
"dataBranch: unexpected branch: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GBranch MComb -> [Char]
forall a. Show a => a -> [Char]
show GBranch MComb
br

-- 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 ->
  K ->
  Word64 ->
  IO (Val, DEnv, Stack, K)
splitCont :: EnumMap Word64 Val
-> Stack -> K -> Word64 -> IO (Val, EnumMap Word64 Val, Stack, K)
splitCont !EnumMap Word64 Val
denv !Stack
stk !K
k !Word64
p =
  EnumMap Word64 Val
-> Int -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K)
walk EnumMap Word64 Val
denv Int
asz K
KE K
k
  where
    asz :: Int
asz = Stack -> Int
asize Stack
stk
    walk :: EnumMap Word64 Val -> SZ -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K)
    walk :: EnumMap Word64 Val
-> Int -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K)
walk !EnumMap Word64 Val
denv !Int
sz !K
ck K
KE =
      [Char] -> IO Any
forall a. HasCallStack => [Char] -> IO a
die [Char]
"fell off stack" IO Any
-> IO (Val, EnumMap Word64 Val, Stack, K)
-> IO (Val, EnumMap Word64 Val, Stack, K)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EnumMap Word64 Val
-> Int -> Int -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K)
finish EnumMap Word64 Val
denv Int
sz Int
0 K
ck K
KE
    walk !EnumMap Word64 Val
denv !Int
sz !K
ck (CB Callback
_) =
      [Char] -> IO Any
forall a. HasCallStack => [Char] -> IO a
die [Char]
"fell off stack" IO Any
-> IO (Val, EnumMap Word64 Val, Stack, K)
-> IO (Val, EnumMap Word64 Val, Stack, K)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EnumMap Word64 Val
-> Int -> Int -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K)
finish EnumMap Word64 Val
denv Int
sz Int
0 K
ck K
KE
    walk !EnumMap Word64 Val
denv !Int
sz !K
ck (Mark Int
a EnumSet Word64
ps EnumMap Word64 Val
cs K
k)
      | Word64 -> EnumSet Word64 -> Bool
forall k. EnumKey k => k -> EnumSet k -> Bool
EC.member Word64
p EnumSet Word64
ps = EnumMap Word64 Val
-> Int -> Int -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K)
finish EnumMap Word64 Val
denv' Int
sz Int
a K
ck K
k
      | Bool
otherwise = EnumMap Word64 Val
-> Int -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K)
walk EnumMap Word64 Val
denv' (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a) (Int -> EnumSet Word64 -> EnumMap Word64 Val -> K -> K
Mark Int
a EnumSet Word64
ps EnumMap Word64 Val
cs' K
ck) K
k
      where
        denv' :: EnumMap Word64 Val
denv' = EnumMap Word64 Val
cs EnumMap Word64 Val -> EnumMap Word64 Val -> EnumMap Word64 Val
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Val -> EnumSet Word64 -> EnumMap Word64 Val
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.withoutKeys EnumMap Word64 Val
denv EnumSet Word64
ps
        cs' :: EnumMap Word64 Val
cs' = EnumMap Word64 Val -> EnumSet Word64 -> EnumMap Word64 Val
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys EnumMap Word64 Val
denv EnumSet Word64
ps
    walk !EnumMap Word64 Val
denv !Int
sz !K
ck (Push Int
n Int
a CombIx
br Int
p MSection
brSect K
k) =
      EnumMap Word64 Val
-> Int -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K)
walk
        EnumMap Word64 Val
denv
        (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a)
        (Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push Int
n Int
a CombIx
br Int
p MSection
brSect K
ck)
        K
k

    finish :: EnumMap Word64 Val -> SZ -> SZ -> K -> K -> (IO (Val, EnumMap Word64 Val, Stack, K))
    finish :: EnumMap Word64 Val
-> Int -> Int -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K)
finish !EnumMap Word64 Val
denv !Int
sz !Int
a !K
ck !K
k = do
      (Seg
seg, Stack
stk) <- Stack -> Int -> IO (Seg, Stack)
grab Stack
stk Int
sz
      Stack
stk <- Stack -> Int -> IO Stack
adjustArgs Stack
stk Int
a
      return (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ K -> Int -> Seg -> Closure
Captured K
ck Int
asz Seg
seg, EnumMap Word64 Val
denv, Stack
stk, K
k)
{-# INLINE splitCont #-}

resolve :: CCache -> DEnv -> Stack -> MRef -> IO Val
resolve :: CCache -> EnumMap Word64 Val -> Stack -> GRef MComb -> IO Val
resolve CCache
_ EnumMap Word64 Val
_ Stack
_ (Env CombIx
cix MComb
mcomb) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ CombIx -> MComb -> Val
mCombVal CombIx
cix MComb
mcomb
resolve CCache
_ EnumMap Word64 Val
_ Stack
stk (Stk Int
i) = (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
resolve CCache
env EnumMap Word64 Val
denv Stack
_ (Dyn Word64
i) = case Word64 -> EnumMap Word64 Val -> Maybe Val
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i EnumMap Word64 Val
denv of
  Just Val
val -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
val
  Maybe Val
Nothing -> [Char] -> CCache -> Word64 -> IO Val
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 MCombs -> CombIx -> MComb
rCombSection :: EnumMap Word64 MCombs -> CombIx -> MComb
rCombSection EnumMap Word64 MCombs
combs (CIx Reference
r Word64
n Word64
i) =
  case Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
n EnumMap Word64 MCombs
combs of
    Just MCombs
cmbs -> case Word64 -> MCombs -> Maybe (GComb Val MComb)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i MCombs
cmbs of
      Just GComb Val MComb
cmb -> GComb Val MComb -> MComb
forall val. GComb val (RComb val) -> RComb val
RComb GComb Val MComb
cmb
      Maybe (GComb Val MComb)
Nothing -> [Char] -> MComb
forall a. HasCallStack => [Char] -> a
error ([Char] -> MComb) -> [Char] -> MComb
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 MCombs
Nothing -> [Char] -> MComb
forall a. HasCallStack => [Char] -> a
error ([Char] -> MComb) -> [Char] -> MComb
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 MSection
resolveSection :: CCache -> Section -> IO MSection
resolveSection CCache
cc Section
section = do
  EnumMap Word64 MCombs
rcombs <- TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (EnumMap Word64 MCombs)
combs CCache
cc)
  pure $ EnumMap Word64 MCombs -> CombIx -> MComb
rCombSection EnumMap Word64 MCombs
rcombs (CombIx -> MComb) -> Section -> MSection
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")

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)

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 ::
  USeq -> IO [(Reference, Code)]
decodeCacheArgument :: USeq -> IO [(Reference, Code)]
decodeCacheArgument USeq
s = [Val] -> (Val -> IO (Reference, Code)) -> IO [(Reference, Code)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (USeq -> [Val]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList USeq
s) ((Val -> IO (Reference, Code)) -> IO [(Reference, Code)])
-> (Val -> IO (Reference, Code)) -> IO [(Reference, Code)]
forall a b. (a -> b) -> a -> b
$ \case
  (Val Int
_unboxed (Data2 Reference
_ PackedTag
_ (BoxedVal (Foreign Foreign
x)) (BoxedVal (Data2 Reference
_ PackedTag
_ (BoxedVal (Foreign Foreign
y)) Val
_)))) ->
    case Foreign -> Referent' Reference
forall a. Foreign -> a
unwrapForeign Foreign
x of
      Ref Reference
r -> (Reference, Code) -> IO (Reference, Code)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference
r, Foreign -> Code
forall a. Foreign -> a
unwrapForeign Foreign
y)
      Referent' Reference
_ -> [Char] -> IO (Reference, Code)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"decodeCacheArgument: Con reference"
  Val
_ -> [Char] -> IO (Reference, Code)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"decodeCacheArgument: unrecognized value"

decodeSandboxArgument :: USeq -> IO [Reference]
decodeSandboxArgument :: USeq -> IO [Reference]
decodeSandboxArgument USeq
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])
-> ((Val -> IO [Reference]) -> IO [[Reference]])
-> (Val -> IO [Reference])
-> IO [Reference]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> (Val -> IO [Reference]) -> IO [[Reference]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (USeq -> [Val]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList USeq
s) ((Val -> IO [Reference]) -> IO [Reference])
-> (Val -> IO [Reference]) -> IO [Reference]
forall a b. (a -> b) -> a -> b
$ \case
  Val Int
_ (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
  Val
_ -> [Char] -> IO [Reference]
forall a. HasCallStack => [Char] -> IO a
die [Char]
"decodeSandboxArgument: unrecognized value"

encodeSandboxListResult :: [Reference] -> Sq.Seq Val
encodeSandboxListResult :: [Reference] -> USeq
encodeSandboxListResult =
  [Val] -> USeq
forall a. [a] -> Seq a
Sq.fromList ([Val] -> USeq) -> ([Reference] -> [Val]) -> [Reference] -> USeq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference -> Val) -> [Reference] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Closure -> Val
boxedVal (Closure -> Val) -> (Reference -> Closure) -> Reference -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure)
-> (Reference -> Foreign) -> Reference -> Closure
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] -> Closure
encodeSandboxResult (Left [Reference]
rfs) =
  Val -> Closure
encodeLeft (Val -> Closure) -> (USeq -> Val) -> USeq -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (USeq -> Closure) -> USeq -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure) -> (USeq -> Foreign) -> USeq -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> USeq -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.listRef (USeq -> Closure) -> USeq -> Closure
forall a b. (a -> b) -> a -> b
$ [Reference] -> USeq
encodeSandboxListResult [Reference]
rfs
encodeSandboxResult (Right [Reference]
rfs) =
  Val -> Closure
encodeRight (Val -> Closure) -> (USeq -> Val) -> USeq -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (USeq -> Closure) -> USeq -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure) -> (USeq -> Foreign) -> USeq -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> USeq -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.listRef (USeq -> Closure) -> USeq -> Closure
forall a b. (a -> b) -> a -> b
$ [Reference] -> USeq
encodeSandboxListResult [Reference]
rfs

encodeLeft :: Val -> Closure
encodeLeft :: Val -> Closure
encodeLeft = Reference -> PackedTag -> Val -> Closure
Data1 Reference
Rf.eitherRef PackedTag
TT.leftTag

encodeRight :: Val -> Closure
encodeRight :: Val -> Closure
encodeRight = Reference -> PackedTag -> Val -> Closure
Data1 Reference
Rf.eitherRef PackedTag
TT.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 Closure))
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
-> Map Reference Word64 -> Map Reference Word64
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` [(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]
rs [Word64
ftm ..])
      rns :: RefNums
rns = (Reference -> Word64)
-> (Reference -> Word64) -> (Reference -> Maybe Int) -> 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) (Maybe Int -> Reference -> Maybe Int
forall a b. a -> b -> a
const Maybe Int
forall a. Maybe a
Nothing)
      combinate :: (Word64, (Reference, SuperGroup Symbol)) -> IO (GCombs Void CombIx)
combinate (Word64
n, (Reference
r, SuperGroup Symbol
g)) = GCombs Void CombIx -> IO (GCombs Void CombIx)
forall a. a -> IO a
evaluate (GCombs Void CombIx -> IO (GCombs Void CombIx))
-> GCombs Void CombIx -> IO (GCombs Void CombIx)
forall a b. (a -> b) -> a -> b
$ RefNums
-> Reference -> Word64 -> SuperGroup Symbol -> GCombs Void CombIx
forall v.
Var v =>
RefNums
-> Reference -> Word64 -> SuperGroup v -> GCombs Void CombIx
emitCombs RefNums
rns Reference
r Word64
n SuperGroup Symbol
g
  (Maybe (Failure Closure)
forall a. Maybe a
Nothing Maybe (Failure Closure) -> IO () -> IO (Maybe (Failure Closure))
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((Word64, (Reference, SuperGroup Symbol))
 -> IO (GCombs Void CombIx))
-> [(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 (GCombs Void CombIx)
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 Closure))
-> (CompileExn -> IO (Maybe (Failure Closure)))
-> IO (Maybe (Failure Closure))
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 :: Closure
extra = Foreign -> Closure
Foreign (Foreign -> Closure) -> ([Char] -> Foreign) -> [Char] -> Closure
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] -> Closure) -> [Char] -> Closure
forall a b. (a -> b) -> a -> b
$ CallStack -> [Char]
forall a. Show a => a -> [Char]
show CallStack
cs
       in Maybe (Failure Closure) -> IO (Maybe (Failure Closure))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Failure Closure) -> IO (Maybe (Failure Closure)))
-> (Failure Closure -> Maybe (Failure Closure))
-> Failure Closure
-> IO (Maybe (Failure Closure))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure Closure -> Maybe (Failure Closure)
forall a. a -> Maybe a
Just (Failure Closure -> IO (Maybe (Failure Closure)))
-> Failure Closure -> IO (Maybe (Failure Closure))
forall a b. (a -> b) -> a -> b
$ Reference -> Text -> Closure -> Failure Closure
forall a. Reference -> Text -> a -> Failure a
Failure Reference
ioFailureRef Text
msg Closure
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] -> Closure -> IO Bool
checkSandboxing CCache
cc [Reference]
allowed0 Closure
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) -> Closure -> Set Reference
forall m. Monoid m => (Reference -> m) -> Closure -> m
closureTermRefs Reference -> Set Reference
f Closure
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, Code)] ->
  [(Reference, Set Reference)] ->
  CCache ->
  IO ()
cacheAdd0 :: Set Reference
-> [(Reference, Code)]
-> [(Reference, Set Reference)]
-> CCache
-> IO ()
cacheAdd0 Set Reference
ntys0 [(Reference, Code)]
termSuperGroups [(Reference, Set Reference)]
sands CCache
cc = do
  let 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, Code)]
termSuperGroups [(Reference, Code)]
-> ((Reference, Code) -> (Reference, SuperGroup Symbol))
-> [(Reference, SuperGroup Symbol)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Code -> SuperGroup Symbol)
-> (Reference, Code) -> (Reference, SuperGroup Symbol)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Code -> SuperGroup Symbol
codeGroup)
  (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedCacheableCombs, EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedNonCacheableCombs) <- STM
  (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
   EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> IO
     (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
      EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall a. STM a -> IO a
atomically (STM
   (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
 -> IO
      (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
       EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))))
-> STM
     (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
      EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> IO
     (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
      EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
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
    let 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
    let 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
    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)]
rgs
    Map Reference (SuperGroup Symbol)
int <- Map Reference (SuperGroup Symbol)
-> TVar (Map Reference (SuperGroup Symbol))
-> STM (Map Reference (SuperGroup Symbol))
forall s. Semigroup s => s -> TVar s -> STM s
updateMap Map Reference (SuperGroup Symbol)
new (CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed CCache
cc)
    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 arities :: Map Reference Int
arities = (SuperGroup Symbol -> Int)
-> Map Reference (SuperGroup Symbol) -> Map Reference Int
forall a b. (a -> b) -> Map Reference a -> Map Reference b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Int] -> Int
forall a. HasCallStack => [a] -> a
head ([Int] -> Int)
-> (SuperGroup Symbol -> [Int]) -> SuperGroup Symbol -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuperGroup Symbol -> [Int]
forall v. SuperGroup v -> [Int]
ANF.arities) Map Reference (SuperGroup Symbol)
int Map Reference Int -> Map Reference Int -> Map Reference Int
forall a. Semigroup a => a -> a -> a
<> Map Reference Int
builtinArities
        inlinfo :: Map Reference (Int, ANormal Symbol)
inlinfo = Map Reference (SuperGroup Symbol)
-> Map Reference (Int, ANormal Symbol)
forall v.
Var v =>
Map Reference (SuperGroup v) -> Map Reference (Int, ANormal v)
ANF.buildInlineMap Map Reference (SuperGroup Symbol)
int Map Reference (Int, ANormal Symbol)
-> Map Reference (Int, ANormal Symbol)
-> Map Reference (Int, ANormal Symbol)
forall a. Semigroup a => a -> a -> a
<> Map Reference (Int, ANormal Symbol)
builtinInlineInfo
        rns :: RefNums
rns = (Reference -> Word64)
-> (Reference -> Word64) -> (Reference -> Maybe Int) -> 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) ((Reference -> Map Reference Int -> Maybe Int)
-> Map Reference Int -> Reference -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference -> Map Reference Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map Reference Int
arities)
        combinate :: Word64 -> (Reference, SuperGroup Symbol) -> (Word64, EnumMap Word64 Comb)
        combinate :: Word64
-> (Reference, SuperGroup Symbol) -> (Word64, GCombs Void CombIx)
combinate Word64
n (Reference
r, SuperGroup Symbol
g) =
          (Word64
n, RefNums
-> Reference -> Word64 -> SuperGroup Symbol -> GCombs Void CombIx
forall v.
Var v =>
RefNums
-> Reference -> Word64 -> SuperGroup v -> GCombs Void CombIx
emitCombs RefNums
rns Reference
r Word64
n (SuperGroup Symbol -> GCombs Void CombIx)
-> SuperGroup Symbol -> GCombs Void CombIx
forall a b. (a -> b) -> a -> b
$ Map Reference (Int, ANormal Symbol)
-> SuperGroup Symbol -> SuperGroup Symbol
forall v.
Var v =>
Map Reference (Int, ANormal v) -> SuperGroup v -> SuperGroup v
ANF.inline Map Reference (Int, ANormal Symbol)
inlinfo SuperGroup Symbol
g)
    let combRefUpdates :: EnumMap Word64 Reference
combRefUpdates = ([(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)
    let combIdFromRefMap :: Map Reference Word64
combIdFromRefMap = ([(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 ..])
    let newCacheableCombs :: EnumSet Word64
newCacheableCombs =
          [(Reference, Code)]
termSuperGroups
            [(Reference, Code)]
-> ([(Reference, Code)] -> [Word64]) -> [Word64]
forall a b. a -> (a -> b) -> b
& ((Reference, Code) -> Maybe Word64)
-> [(Reference, Code)] -> [Word64]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe
              ( \case
                  (Reference
ref, CodeRep SuperGroup Symbol
_ Cacheability
Cacheable) ->
                    Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
ref Map Reference Word64
combIdFromRefMap
                  (Reference, Code)
_ -> Maybe Word64
forall a. Maybe a
Nothing
              )
            [Word64] -> ([Word64] -> EnumSet Word64) -> EnumSet Word64
forall a b. a -> (a -> b) -> b
& [Word64] -> EnumSet Word64
forall k. EnumKey k => [k] -> EnumSet k
EC.setFromList
    EnumMap Word64 Reference
newCombRefs <- EnumMap Word64 Reference
-> TVar (EnumMap Word64 Reference)
-> STM (EnumMap Word64 Reference)
forall s. Semigroup s => s -> TVar s -> STM s
updateMap EnumMap Word64 Reference
combRefUpdates (CCache -> TVar (EnumMap Word64 Reference)
combRefs CCache
cc)
    (EnumMap Word64 (GCombs Void CombIx)
unresolvedNewCombs, EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedCacheableCombs, EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedNonCacheableCombs, EnumMap Word64 MCombs
updatedCombs) <- TVar (EnumMap Word64 MCombs)
-> (EnumMap Word64 MCombs
    -> ((EnumMap Word64 (GCombs Void CombIx),
         EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
         EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
         EnumMap Word64 MCombs),
        EnumMap Word64 MCombs))
-> STM
     (EnumMap Word64 (GCombs Void CombIx),
      EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
      EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
      EnumMap Word64 MCombs)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar (CCache -> TVar (EnumMap Word64 MCombs)
combs CCache
cc) \EnumMap Word64 MCombs
oldCombs ->
      let unresolvedNewCombs :: EnumMap Word64 (GCombs any CombIx)
          unresolvedNewCombs :: forall any. EnumMap Word64 (GCombs any CombIx)
unresolvedNewCombs =
            EnumMap Word64 (GCombs Void CombIx)
-> EnumMap Word64 (GCombs any CombIx)
forall cix any.
EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
absurdCombs (EnumMap Word64 (GCombs Void CombIx)
 -> EnumMap Word64 (GCombs any CombIx))
-> ([(Word64, GCombs Void CombIx)]
    -> EnumMap Word64 (GCombs Void CombIx))
-> [(Word64, GCombs Void CombIx)]
-> EnumMap Word64 (GCombs any CombIx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Set ForeignFunc
-> EnumMap Word64 (GCombs Void CombIx)
-> EnumMap Word64 (GCombs Void CombIx)
sanitizeCombsOfForeignFuncs (CCache -> Bool
sandboxed CCache
cc) Set ForeignFunc
sandboxedForeignFuncs (EnumMap Word64 (GCombs Void CombIx)
 -> EnumMap Word64 (GCombs Void CombIx))
-> ([(Word64, GCombs Void CombIx)]
    -> EnumMap Word64 (GCombs Void CombIx))
-> [(Word64, GCombs Void CombIx)]
-> EnumMap Word64 (GCombs Void CombIx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Word64, GCombs Void CombIx)]
-> EnumMap Word64 (GCombs Void CombIx)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList ([(Word64, GCombs Void CombIx)]
 -> EnumMap Word64 (GCombs any CombIx))
-> [(Word64, GCombs Void CombIx)]
-> EnumMap Word64 (GCombs any CombIx)
forall a b. (a -> b) -> a -> b
$ (Word64
 -> (Reference, SuperGroup Symbol) -> (Word64, GCombs Void CombIx))
-> [Word64]
-> [(Reference, SuperGroup Symbol)]
-> [(Word64, GCombs Void CombIx)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word64
-> (Reference, SuperGroup Symbol) -> (Word64, GCombs Void CombIx)
combinate [Word64
ntm ..] [(Reference, SuperGroup Symbol)]
rgs
          (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedCacheableCombs, EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedNonCacheableCombs) =
            EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> [(Word64, EnumMap Word64 (GComb Val CombIx))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall any. EnumMap Word64 (GCombs any CombIx)
unresolvedNewCombs [(Word64, EnumMap Word64 (GComb Val CombIx))]
-> ([(Word64, EnumMap Word64 (GComb Val CombIx))]
    -> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
        EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))))
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall a b. a -> (a -> b) -> b
& ((Word64, EnumMap Word64 (GComb Val CombIx))
 -> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
     EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))))
-> [(Word64, EnumMap Word64 (GComb Val CombIx))]
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \(Word64
w, EnumMap Word64 (GComb Val CombIx)
gcombs) ->
              if Word64 -> EnumSet Word64 -> Bool
forall k. EnumKey k => k -> EnumSet k -> Bool
EC.member Word64
w EnumSet Word64
newCacheableCombs
                then (Word64
-> EnumMap Word64 (GComb Val CombIx)
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
w EnumMap Word64 (GComb Val CombIx)
gcombs, EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall a. Monoid a => a
mempty)
                else (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall a. Monoid a => a
mempty, Word64
-> EnumMap Word64 (GComb Val CombIx)
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
w EnumMap Word64 (GComb Val CombIx)
gcombs)
          newCombs :: EnumMap Word64 MCombs
          newCombs :: EnumMap Word64 MCombs
newCombs = Maybe (EnumMap Word64 MCombs)
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> EnumMap Word64 MCombs
forall val.
Maybe (EnumMap Word64 (RCombs val))
-> EnumMap Word64 (GCombs val CombIx)
-> EnumMap Word64 (RCombs val)
resolveCombs (EnumMap Word64 MCombs -> Maybe (EnumMap Word64 MCombs)
forall a. a -> Maybe a
Just EnumMap Word64 MCombs
oldCombs) (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
 -> EnumMap Word64 MCombs)
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> EnumMap Word64 MCombs
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall any. EnumMap Word64 (GCombs any CombIx)
unresolvedNewCombs
          updatedCombs :: EnumMap Word64 MCombs
updatedCombs = EnumMap Word64 MCombs
newCombs EnumMap Word64 MCombs
-> EnumMap Word64 MCombs -> EnumMap Word64 MCombs
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 MCombs
oldCombs
       in ((EnumMap Word64 (GCombs Void CombIx)
forall any. EnumMap Word64 (GCombs any CombIx)
unresolvedNewCombs, EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedCacheableCombs, EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedNonCacheableCombs, EnumMap Word64 MCombs
updatedCombs), EnumMap Word64 MCombs
updatedCombs)
    EnumMap Word64 (GCombs Void CombIx)
nsc <- EnumMap Word64 (GCombs Void CombIx)
-> TVar (EnumMap Word64 (GCombs Void CombIx))
-> STM (EnumMap Word64 (GCombs Void CombIx))
forall s. Semigroup s => s -> TVar s -> STM s
updateMap EnumMap Word64 (GCombs Void CombIx)
unresolvedNewCombs (CCache -> TVar (EnumMap Word64 (GCombs Void CombIx))
srcCombs CCache
cc)
    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)
    EnumSet Word64
ncc <- EnumSet Word64 -> TVar (EnumSet Word64) -> STM (EnumSet Word64)
forall s. Semigroup s => s -> TVar s -> STM s
updateMap EnumSet Word64
newCacheableCombs (CCache -> TVar (EnumSet Word64)
cacheableCombs CCache
cc)
    -- Now that the code cache is primed with everything we need,
    -- we can pre-evaluate the top-level constants.
    pure $ Map Reference (SuperGroup Symbol)
int Map Reference (SuperGroup Symbol)
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall a b. a -> b -> b
`seq` Map Reference Word64
rtm Map Reference Word64
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall a b. a -> b -> b
`seq` EnumMap Word64 Reference
newCombRefs EnumMap Word64 Reference
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall a b. a -> b -> b
`seq` EnumMap Word64 MCombs
updatedCombs EnumMap Word64 MCombs
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall a b. a -> b -> b
`seq` Map Reference (Set Reference)
nsn Map Reference (Set Reference)
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall a b. a -> b -> b
`seq` EnumSet Word64
ncc EnumSet Word64
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall a b. a -> b -> b
`seq` EnumMap Word64 (GCombs Void CombIx)
nsc EnumMap Word64 (GCombs Void CombIx)
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)),
    EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall a b. a -> b -> b
`seq` (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedCacheableCombs, EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedNonCacheableCombs)
  EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> CCache
-> IO ()
preEvalTopLevelConstants EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedCacheableCombs EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
unresolvedNonCacheableCombs CCache
cc

preEvalTopLevelConstants :: (EnumMap Word64 (GCombs Val CombIx)) -> (EnumMap Word64 (GCombs Val CombIx)) -> CCache -> IO ()
preEvalTopLevelConstants :: EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> CCache
-> IO ()
preEvalTopLevelConstants EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
cacheableCombs EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
newCombs CCache
cc = do
  ActiveThreads
activeThreads <- IORef (Set ThreadId) -> ActiveThreads
forall a. a -> Maybe a
Just (IORef (Set ThreadId) -> ActiveThreads)
-> IO (IORef (Set ThreadId)) -> IO ActiveThreads
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set ThreadId -> IO (IORef (Set ThreadId))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
UnliftIO.newIORef Set ThreadId
forall a. Monoid a => a
mempty
  TVar (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
evaluatedCacheableCombsVar <- EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> IO (TVar (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall a. Monoid a => a
mempty
  [(Word64, EnumMap Word64 (GComb Val CombIx))]
-> ((Word64, EnumMap Word64 (GComb Val CombIx)) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> [(Word64, EnumMap Word64 (GComb Val CombIx))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
cacheableCombs) \(Word64
w, EnumMap Word64 (GComb Val CombIx)
_) -> do
    let hook :: (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
-> IO ()
hook (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
xstk = do
          Val
val <- (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek (XStack -> Stack
packXStack (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
XStack
xstk)
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            TVar (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
    -> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
evaluatedCacheableCombsVar ((EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
  -> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
 -> STM ())
-> (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
    -> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> STM ()
forall a b. (a -> b) -> a -> b
$ Word64
-> EnumMap Word64 (GComb Val CombIx)
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall k a. EnumKey k => k -> a -> EnumMap k a -> EnumMap k a
EC.mapInsert Word64
w (Word64 -> GComb Val CombIx -> EnumMap Word64 (GComb Val CombIx)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
0 (GComb Val CombIx -> EnumMap Word64 (GComb Val CombIx))
-> GComb Val CombIx -> EnumMap Word64 (GComb Val CombIx)
forall a b. (a -> b) -> a -> b
$ Word64 -> Val -> GComb Val CombIx
forall val comb. Word64 -> val -> GComb val comb
CachedVal Word64
w Val
val)
    Maybe (XStack -> IO ())
-> CCache -> ActiveThreads -> Word64 -> IO ()
apply0 (((# Int#, Int#, Int#, MutableByteArray# RealWorld,
    MutableArray# RealWorld Closure #)
 -> IO ())
-> Maybe
     ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
         MutableArray# RealWorld Closure #)
      -> IO ())
forall a. a -> Maybe a
Just (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
-> IO ()
hook) CCache
cc ActiveThreads
activeThreads Word64
w
      IO () -> (RuntimeExn -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \RuntimeExn
e ->
        -- ignore sandboxing exceptions during pre-eval, in case they
        -- don't matter for the final result.
        if RuntimeExn -> Bool
isSandboxingException RuntimeExn
e
          then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          else RuntimeExn -> IO ()
forall e a. Exception e => e -> IO a
throwIO RuntimeExn
e

  EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
evaluatedCacheableCombs <- TVar (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
-> IO (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
forall a. TVar a -> IO a
readTVarIO TVar (EnumMap Word64 (EnumMap Word64 (GComb Val CombIx)))
evaluatedCacheableCombsVar
  let allNew :: EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
allNew = EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
evaluatedCacheableCombs EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
newCombs
  -- Rewrite all the inlined combinator references to point to the
  -- new cached versions.
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (EnumMap Word64 MCombs)
-> (EnumMap Word64 MCombs -> EnumMap Word64 MCombs) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (CCache -> TVar (EnumMap Word64 MCombs)
combs CCache
cc) (\EnumMap Word64 MCombs
existingCombs -> (Maybe (EnumMap Word64 MCombs)
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> EnumMap Word64 MCombs
forall val.
Maybe (EnumMap Word64 (RCombs val))
-> EnumMap Word64 (GCombs val CombIx)
-> EnumMap Word64 (RCombs val)
resolveCombs (EnumMap Word64 MCombs -> Maybe (EnumMap Word64 MCombs)
forall a. a -> Maybe a
Just (EnumMap Word64 MCombs -> Maybe (EnumMap Word64 MCombs))
-> EnumMap Word64 MCombs -> Maybe (EnumMap Word64 MCombs)
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 MCombs
-> EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
-> EnumMap Word64 MCombs
forall k a b.
EnumKey k =>
EnumMap k a -> EnumMap k b -> EnumMap k a
EC.mapDifference EnumMap Word64 MCombs
existingCombs EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
allNew) EnumMap Word64 (EnumMap Word64 (GComb Val CombIx))
allNew) EnumMap Word64 MCombs
-> EnumMap Word64 MCombs -> EnumMap Word64 MCombs
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 MCombs
existingCombs)

-- Checks if a runtime exception is due to sandboxing.
--
-- This is used above during pre-evaluation, to ignore sandboxing
-- exceptions for top-level constant dependencies of docs and such, in
-- case the docs don't actually evaluate them.
isSandboxingException :: RuntimeExn -> Bool
isSandboxingException :: RuntimeExn -> Bool
isSandboxingException (PE CallStack
_ (Pretty ColorText -> [Char]
P.toPlainUnbroken -> [Char]
msg)) =
  [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf [Char]
sdbx1 [Char]
msg Bool -> Bool -> Bool
|| [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf [Char]
sdbx2 [Char]
msg
  where
    sdbx1 :: [Char]
sdbx1 = [Char]
"attempted to use sandboxed operation"
    sdbx2 :: [Char]
sdbx2 = [Char]
"Attempted to use disallowed builtin in sandboxed"
isSandboxingException RuntimeExn
_ = Bool
False

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, Code)] ->
  CCache ->
  IO [Reference]
cacheAdd :: [(Reference, Code)] -> CCache -> IO [Reference]
cacheAdd [(Reference, Code)]
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 (Getting Reference (Reference, Code) Reference
-> (Reference, Code) -> Reference
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Reference (Reference, Code) Reference
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Reference, Code) (Reference, Code) Reference Reference
_1 ((Reference, Code) -> Reference)
-> [(Reference, Code)] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, Code)]
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, Code) -> Const (Set Reference, Set Reference) Any)
-> [(Reference, Code)] -> 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, Code) -> Const (Set Reference, Set Reference) Any)
 -> [(Reference, Code)] -> Const (Set Reference, Set Reference) Any)
-> ((SuperGroup Symbol -> Const (Set Reference, Set Reference) Any)
    -> (Reference, Code) -> Const (Set Reference, Set Reference) Any)
-> (SuperGroup Symbol -> Const (Set Reference, Set Reference) Any)
-> [(Reference, Code)]
-> Const (Set Reference, Set Reference) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Code -> Const (Set Reference, Set Reference) Any)
-> (Reference, Code) -> 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 ((Code -> Const (Set Reference, Set Reference) Any)
 -> (Reference, Code) -> Const (Set Reference, Set Reference) Any)
-> ((SuperGroup Symbol -> Const (Set Reference, Set Reference) Any)
    -> Code -> Const (Set Reference, Set Reference) Any)
-> (SuperGroup Symbol -> Const (Set Reference, Set Reference) Any)
-> (Reference, Code)
-> Const (Set Reference, Set Reference) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SuperGroup Symbol -> Const (Set Reference, Set Reference) Any)
-> Code -> Const (Set Reference, Set Reference) Any
forall m. Monoid m => (SuperGroup Symbol -> m) -> Code -> m
foldGroup) ((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, Code)]
l
      l'' :: [(Reference, Code)]
l'' = ((Reference, Code) -> Bool)
-> [(Reference, Code)] -> [(Reference, Code)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Reference
r, Code
_) -> Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Reference
r Map Reference Word64
rtm) [(Reference, Code)]
l
      l' :: [(Reference, SuperGroup Symbol)]
l' = ((Reference, Code) -> (Reference, SuperGroup Symbol))
-> [(Reference, Code)] -> [(Reference, SuperGroup Symbol)]
forall a b. (a -> b) -> [a] -> [b]
map ((Code -> SuperGroup Symbol)
-> (Reference, Code) -> (Reference, SuperGroup Symbol)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Code -> SuperGroup Symbol
codeGroup) [(Reference, Code)]
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, Code)]
-> [(Reference, Set Reference)]
-> CCache
-> IO ()
cacheAdd0 Set Reference
tys [(Reference, Code)]
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 -> Val -> IO ANF.Value
reflectValue :: EnumMap Word64 Reference -> Val -> IO Value
reflectValue EnumMap Word64 Reference
rty = Val -> 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 :: Val -> IO ANF.Value
    goV :: Val -> IO Value
goV = \case
      -- For back-compatibility we reflect all Unboxed values into boxed literals, we could change this in the future,
      -- but there's not much of a big reason to.

      NatVal Word64
n -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> IO Value) -> (BLit -> Value) -> BLit -> IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> IO Value) -> BLit -> IO Value
forall a b. (a -> b) -> a -> b
$ Word64 -> BLit
ANF.Pos Word64
n
      IntVal Int
n
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> IO Value) -> (BLit -> Value) -> BLit -> IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> IO Value) -> BLit -> IO Value
forall a b. (a -> b) -> a -> b
$ Word64 -> BLit
ANF.Pos (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
        | Bool
otherwise -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> IO Value) -> (BLit -> Value) -> BLit -> IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> IO Value) -> BLit -> IO Value
forall a b. (a -> b) -> a -> b
$ Word64 -> BLit
ANF.Neg (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int
forall a. Num a => a -> a
abs Int
n))
      DoubleVal Double
f -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> IO Value) -> (BLit -> Value) -> BLit -> IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> IO Value) -> BLit -> IO Value
forall a b. (a -> b) -> a -> b
$ Double -> BLit
ANF.Float Double
f
      CharVal Char
c -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> IO Value) -> (BLit -> Value) -> BLit -> IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> IO Value) -> BLit -> IO Value
forall a b. (a -> b) -> a -> b
$ Char -> BLit
ANF.Char Char
c
      val :: Val
val@(Val Int
_ Closure
clos) ->
        case Closure
clos of
          (PApV CombIx
cix GCombInfo MComb
_rComb [Val]
args) ->
            GroupRef -> ValList -> Value
ANF.Partial (CombIx -> GroupRef
goIx CombIx
cix) (ValList -> Value) -> IO ValList -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> IO Value) -> [Val] -> IO ValList
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 Val -> IO Value
goV [Val]
args
          (DataC Reference
r PackedTag
t [Val]
segs) ->
            Reference -> Word64 -> ValList -> Value
ANF.Data Reference
r (PackedTag -> Word64
maskTags PackedTag
t) (ValList -> Value) -> IO ValList -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> IO Value) -> [Val] -> IO ValList
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 Val -> IO Value
goV [Val]
segs
          (CapV K
k Int
_ [Val]
segs) ->
            ValList -> Cont -> Value
ANF.Cont (ValList -> Cont -> Value) -> IO ValList -> IO (Cont -> Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> IO Value) -> [Val] -> IO ValList
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 Val -> IO Value
goV [Val]
segs 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
          (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
          Closure
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"
          UnboxedTypeTag {} -> [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] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown unboxed value" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Val -> [Char]
forall a. Show a => a -> [Char]
show Val
val

    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
a EnumSet Word64
ps EnumMap Word64 Val
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, Val) -> IO (Reference, Value))
-> [(Word64, Val)] -> 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, Val
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
<*> Val -> IO Value
goV Val
v) (EnumMap Word64 Val -> [(Word64, Val)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList EnumMap Word64 Val
de)
      Word64 -> [Reference] -> Map Reference Value -> Cont -> Cont
ANF.Mark (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a) [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
f Int
a CombIx
cix Int
_ MSection
_rsect K
k) =
      Word64 -> Word64 -> GroupRef -> Cont -> Cont
ANF.Push
        (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
f)
        (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a)
        (CombIx -> GroupRef
goIx CombIx
cix)
        (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 USeq
s <- Reference -> Foreign -> Maybe USeq
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
<$> (Val -> IO Value) -> USeq -> 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 Val -> IO Value
goV USeq
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 Code
g <- Reference -> Foreign -> Maybe Code
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 (Code -> BLit
ANF.Code Code
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 Val
a <- Reference -> Foreign -> Maybe (Array Val)
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
<$> (Val -> IO Value) -> Array Val -> 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 Val -> IO Value
goV Array Val
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)

reifyValue :: CCache -> ANF.Value -> IO (Either [Reference] Val)
reifyValue :: CCache -> Value -> IO (Either [Reference] Val)
reifyValue CCache
cc Value
val = do
  Either
  [Reference]
  (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
erc <-
    STM
  (Either
     [Reference]
     (EnumMap Word64 MCombs, Map Reference Word64,
      Map Reference Word64))
-> IO
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall a. STM a -> IO a
atomically (STM
   (Either
      [Reference]
      (EnumMap Word64 MCombs, Map Reference Word64,
       Map Reference Word64))
 -> IO
      (Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64,
          Map Reference Word64)))
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
-> IO
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall a b. (a -> b) -> a -> b
$ do
      EnumMap Word64 MCombs
combs <- TVar (EnumMap Word64 MCombs) -> STM (EnumMap Word64 MCombs)
forall a. TVar a -> STM a
readTVar (CCache -> TVar (EnumMap Word64 MCombs)
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 MCombs, Map Reference Word64, Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   [Reference]
   (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
 -> STM
      (Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64,
          Map Reference Word64)))
-> ((EnumMap Word64 MCombs, Map Reference Word64,
     Map Reference Word64)
    -> Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64,
          Map Reference Word64))
-> (EnumMap Word64 MCombs, Map Reference Word64,
    Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> Either
     [Reference]
     (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
forall a b. b -> Either a b
Right ((EnumMap Word64 MCombs, Map Reference Word64,
  Map Reference Word64)
 -> STM
      (Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64,
          Map Reference Word64)))
-> (EnumMap Word64 MCombs, Map Reference Word64,
    Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall a b. (a -> b) -> a -> b
$ (EnumMap Word64 MCombs
combs, Map Reference Word64
newTy, Map Reference Word64
rtm)
        [Reference]
l -> Either
  [Reference]
  (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, 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 MCombs, Map Reference Word64, Map Reference Word64)
forall a b. a -> Either a b
Left [Reference]
l)
  ((EnumMap Word64 MCombs, Map Reference Word64,
  Map Reference Word64)
 -> IO Val)
-> Either
     [Reference]
     (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> IO (Either [Reference] Val)
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 MCombs, Map Reference Word64, Map Reference Word64)
rfs -> (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> Value -> IO Val
reifyValue0 (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
rfs Value
val) Either
  [Reference]
  (EnumMap Word64 MCombs, 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 MCombs, M.Map Reference Word64, M.Map Reference Word64) ->
  ANF.Value ->
  IO Val
reifyValue0 :: (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> Value -> IO Val
reifyValue0 (EnumMap Word64 MCombs
combs, Map Reference Word64
rty, Map Reference Word64
rtm) = Value -> IO Val
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 (CombIx, MComb)
    goIx :: GroupRef -> IO (CombIx, MComb)
goIx (ANF.GR Reference
r Word64
i) =
      Reference -> IO Word64
refTm Reference
r IO Word64 -> (Word64 -> (CombIx, MComb)) -> IO (CombIx, MComb)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Word64
n ->
        let cix :: CombIx
cix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
r Word64
n Word64
i)
         in (CombIx
cix, EnumMap Word64 MCombs -> CombIx -> MComb
rCombSection EnumMap Word64 MCombs
combs CombIx
cix)

    goV :: ANF.Value -> IO Val
    goV :: Value -> IO Val
goV (ANF.Partial GroupRef
gr ValList
vs) =
      GroupRef -> IO (CombIx, MComb)
goIx GroupRef
gr IO (CombIx, MComb) -> ((CombIx, MComb) -> IO Val) -> IO Val
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (CombIx
cix, RComb (Comb GCombInfo MComb
rcomb)) -> Closure -> Val
boxedVal (Closure -> Val) -> ([Val] -> Closure) -> [Val] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CombIx -> GCombInfo MComb -> [Val] -> Closure
PApV CombIx
cix GCombInfo MComb
rcomb ([Val] -> Val) -> IO [Val] -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> IO Val) -> ValList -> IO [Val]
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 Val
goV ValList
vs
        (CombIx
_, RComb (CachedVal Word64
_ Val
val))
          | [] <- ValList
vs -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
val
          | Bool
otherwise -> [Char] -> IO Val
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO Val) -> ([Char] -> [Char]) -> [Char] -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Val) -> [Char] -> IO Val
forall a b. (a -> b) -> a -> b
$ [Char]
msg
          where
            msg :: [Char]
msg = [Char]
"reifyValue0: non-trivial partial application to cached value"
    goV (ANF.Data Reference
r Word64
t0 ValList
vs) = do
      PackedTag
t <- (RTag -> CTag -> PackedTag) -> CTag -> RTag -> PackedTag
forall a b c. (a -> b -> c) -> b -> a -> c
flip RTag -> CTag -> PackedTag
packTags (Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t0) (RTag -> PackedTag) -> (Word64 -> RTag) -> Word64 -> PackedTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> RTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> PackedTag) -> IO Word64 -> IO PackedTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> IO Word64
refTy Reference
r
      Closure -> Val
boxedVal (Closure -> Val) -> ([Val] -> Closure) -> [Val] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> [Val] -> Closure
DataC Reference
r PackedTag
t ([Val] -> Val) -> IO [Val] -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> IO Val) -> ValList -> IO [Val]
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 Val
goV ValList
vs
    goV (ANF.Cont ValList
vs Cont
k) = do
      K
k' <- Cont -> IO K
goK Cont
k
      [Val]
vs' <- (Value -> IO Val) -> ValList -> IO [Val]
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 Val
goV ValList
vs
      Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (Closure -> Val) -> Closure -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> IO Val) -> Closure -> IO Val
forall a b. (a -> b) -> a -> b
$ K -> [Val] -> Closure
cv K
k' [Val]
vs'
      where
        cv :: K -> [Val] -> Closure
cv K
k [Val]
s = K -> Int -> [Val] -> Closure
CapV K
k Int
a [Val]
s
          where
            ksz :: Int
ksz = K -> Int
frameDataSize K
k
            a :: Int
a = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Val] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Val]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ksz
    goV (ANF.BLit BLit
l) = BLit -> IO Val
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
a [Reference]
ps Map Reference Value
de Cont
k) =
      [Word64] -> [(Word64, Val)] -> K -> K
mrk
        ([Word64] -> [(Word64, Val)] -> K -> K)
-> IO [Word64] -> IO ([(Word64, Val)] -> 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, Val)] -> K -> K) -> IO [(Word64, Val)] -> 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, Val))
-> [(Reference, Value)] -> IO [(Word64, Val)]
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 -> Val -> (Word64, Val))
-> IO Word64 -> IO (Val -> (Word64, Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> IO Word64
refTy Reference
k IO (Val -> (Word64, Val)) -> IO Val -> IO (Word64, Val)
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 Val
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, Val)] -> K -> K
mrk [Word64]
ps [(Word64, Val)]
de K
k =
          Int -> EnumSet Word64 -> EnumMap Word64 Val -> K -> K
Mark (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a) ([Word64] -> EnumSet Word64
forall k. EnumKey k => [k] -> EnumSet k
setFromList [Word64]
ps) ([(Word64, Val)] -> EnumMap Word64 Val
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList [(Word64, Val)]
de) K
k
    goK (ANF.Push Word64
f Word64
a GroupRef
gr Cont
k) =
      GroupRef -> IO (CombIx, MComb)
goIx GroupRef
gr IO (CombIx, MComb) -> ((CombIx, MComb) -> IO K) -> IO 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
        (CombIx
cix, RComb (Lam Int
_ Int
fr MSection
sect)) ->
          Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push
            (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
f)
            (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a)
            CombIx
cix
            Int
fr
            MSection
sect
            (K -> K) -> IO K -> IO K
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cont -> IO K
goK Cont
k
        (CIx Reference
r Word64
_ Word64
_, MComb
_) ->
          [Char] -> IO K
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO K) -> ([Char] -> [Char]) -> [Char] -> IO K
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO K) -> [Char] -> IO K
forall a b. (a -> b) -> a -> b
$
            [Char]
"tried to reify a continuation with a cached value resumption"
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

    goL :: ANF.BLit -> IO Val
    goL :: BLit -> IO Val
goL (ANF.Text Text
t) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (Foreign -> Val) -> Foreign -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (Foreign -> Closure) -> Foreign -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> IO Val) -> Foreign -> IO Val
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) = Closure -> Val
boxedVal (Closure -> Val) -> (USeq -> Closure) -> USeq -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure) -> (USeq -> Foreign) -> USeq -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> USeq -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.listRef (USeq -> Val) -> IO USeq -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> IO Val) -> Seq Value -> IO USeq
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 Val
goV Seq Value
l
    goL (ANF.TmLink Referent' Reference
r) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (Foreign -> Val) -> Foreign -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (Foreign -> Closure) -> Foreign -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> IO Val) -> Foreign -> IO Val
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) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (Foreign -> Val) -> Foreign -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (Foreign -> Closure) -> Foreign -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> IO Val) -> Foreign -> IO Val
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) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (Foreign -> Val) -> Foreign -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (Foreign -> Closure) -> Foreign -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> IO Val) -> Foreign -> IO Val
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) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (Foreign -> Val) -> Foreign -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (Foreign -> Closure) -> Foreign -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> IO Val) -> Foreign -> IO Val
forall a b. (a -> b) -> a -> b
$ Reference -> Value -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.valueRef Value
v
    goL (ANF.Code Code
g) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (Foreign -> Val) -> Foreign -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (Foreign -> Closure) -> Foreign -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> IO Val) -> Foreign -> IO Val
forall a b. (a -> b) -> a -> b
$ Reference -> Code -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.codeRef Code
g
    goL (ANF.BArr ByteArray
a) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (Foreign -> Val) -> Foreign -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (Foreign -> Closure) -> Foreign -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> IO Val) -> Foreign -> IO Val
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) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Char -> Val
CharVal Char
c
    goL (ANF.Pos Word64
w) =
      -- TODO: Should this be a Nat or an Int?
      Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Word64 -> Val
NatVal Word64
w
    goL (ANF.Neg Word64
w) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Int -> Val
IntVal (Int -> Int
forall a. Num a => a -> a
negate (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w :: Int))
    goL (ANF.Float Double
d) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Double -> Val
DoubleVal Double
d
    goL (ANF.Arr Array Value
a) = Closure -> Val
boxedVal (Closure -> Val) -> (Array Val -> Closure) -> Array Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure)
-> (Array Val -> Foreign) -> Array Val -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Array Val -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.iarrayRef (Array Val -> Val) -> IO (Array Val) -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> IO Val) -> Array Value -> IO (Array Val)
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 Val
goV Array Value
a

-- Universal comparison functions

closureNum :: Closure -> Int
closureNum :: Closure -> Int
closureNum PAp {} = Int
0
closureNum DataC {} = Int
1
closureNum Captured {} = Int
2
closureNum Foreign {} = Int
3
closureNum UnboxedTypeTag {} = Int
4
closureNum BlackHole {} = Int
5

universalEq ::
  (Foreign -> Foreign -> Bool) ->
  Val ->
  Val ->
  Bool
universalEq :: (Foreign -> Foreign -> Bool) -> Val -> Val -> Bool
universalEq Foreign -> Foreign -> Bool
frn = Val -> Val -> Bool
eqVal
  where
    eql :: (a -> b -> Bool) -> [a] -> [b] -> Bool
    eql :: forall a b. (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)
    eqVal :: Val -> Val -> Bool
    eqVal :: Val -> Val -> Bool
eqVal (UnboxedVal Int
v1 UnboxedTypeTag
t1) (UnboxedVal Int
v2 UnboxedTypeTag
t2) = UnboxedTypeTag -> UnboxedTypeTag -> Bool
matchUnboxedTypes UnboxedTypeTag
t1 UnboxedTypeTag
t2 Bool -> Bool -> Bool
&& Int
v1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v2
    eqVal (BoxedVal Closure
x) (BoxedVal Closure
y) = Closure -> Closure -> Bool
eqc Closure
x Closure
y
    eqVal Val
_ Val
_ = Bool
False
    eqc :: Closure -> Closure -> Bool
    eqc :: Closure -> Closure -> Bool
eqc (DataC Reference
_ PackedTag
ct1 [Val
w1]) (DataC Reference
_ PackedTag
ct2 [Val
w2]) =
      PackedTag -> PackedTag -> Bool
matchTags PackedTag
ct1 PackedTag
ct2 Bool -> Bool -> Bool
&& Val -> Val -> Bool
eqVal Val
w1 Val
w2
    eqc (DataC Reference
_ PackedTag
ct1 [Val]
vs1) (DataC Reference
_ PackedTag
ct2 [Val]
vs2) =
      PackedTag
ct1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
ct2
        Bool -> Bool -> Bool
&& [Val] -> [Val] -> Bool
eqValList [Val]
vs1 [Val]
vs2
    eqc (PApV CombIx
cix1 GCombInfo MComb
_ [Val]
segs1) (PApV CombIx
cix2 GCombInfo MComb
_ [Val]
segs2) =
      CombIx
cix1 CombIx -> CombIx -> Bool
forall a. Eq a => a -> a -> Bool
== CombIx
cix2
        Bool -> Bool -> Bool
&& [Val] -> [Val] -> Bool
eqValList [Val]
segs1 [Val]
segs2
    eqc (CapV K
k1 Int
a1 [Val]
vs1) (CapV K
k2 Int
a2 [Val]
vs2) =
      K -> K -> Bool
eqK K
k1 K
k2
        Bool -> Bool -> Bool
&& Int
a1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
a2
        Bool -> Bool -> Bool
&& [Val] -> [Val] -> Bool
eqValList [Val]
vs1 [Val]
vs2
    eqc (Foreign Foreign
fl) (Foreign Foreign
fr)
      | Just Array Val
al <- forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign @(PA.Array Val) Reference
Rf.iarrayRef Foreign
fl,
        Just Array Val
ar <- forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign @(PA.Array Val) Reference
Rf.iarrayRef Foreign
fr =
          (Val -> Val -> Bool) -> Array Val -> Array Val -> Bool
forall a. (a -> a -> Bool) -> Array a -> Array a -> Bool
arrayEq Val -> Val -> Bool
eqVal Array Val
al Array Val
ar
      | Just USeq
sl <- forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign @(Seq Val) Reference
Rf.listRef Foreign
fl,
        Just USeq
sr <- forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign @(Seq Val) Reference
Rf.listRef Foreign
fr =
          USeq -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length USeq
sl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== USeq -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length USeq
sr Bool -> Bool -> Bool
&& Seq Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Val -> Val -> Bool) -> USeq -> USeq -> Seq Bool
forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Sq.zipWith Val -> Val -> Bool
eqVal USeq
sl USeq
sr)
      | Bool
otherwise = Foreign -> Foreign -> Bool
frn Foreign
fl Foreign
fr
    eqc Closure
c Closure
d = Closure -> Int
closureNum Closure
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Closure -> Int
closureNum Closure
d

    eqValList :: [Val] -> [Val] -> Bool
    eqValList :: [Val] -> [Val] -> Bool
eqValList [Val]
vs1 [Val]
vs2 = (Val -> Val -> Bool) -> [Val] -> [Val] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
eql Val -> Val -> Bool
eqVal [Val]
vs1 [Val]
vs2

    eqK :: K -> K -> Bool
    eqK :: K -> K -> Bool
eqK K
KE K
KE = Bool
True
    eqK (CB Callback
cb) (CB Callback
cb') = Callback
cb Callback -> Callback -> Bool
forall a. Eq a => a -> a -> Bool
== Callback
cb'
    eqK (Mark Int
a EnumSet Word64
ps EnumMap Word64 Val
m K
k) (Mark Int
a' EnumSet Word64
ps' EnumMap Word64 Val
m' K
k') =
      Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
a' Bool -> Bool -> Bool
&& EnumSet Word64
ps EnumSet Word64 -> EnumSet Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== EnumSet Word64
ps' Bool -> Bool -> Bool
&& (Val -> Val -> Bool)
-> EnumMap Word64 Val -> EnumMap Word64 Val -> Bool
forall a b.
(a -> b -> Bool) -> EnumMap Word64 a -> EnumMap Word64 b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq Val -> Val -> Bool
eqVal EnumMap Word64 Val
m EnumMap Word64 Val
m' Bool -> Bool -> Bool
&& K -> K -> Bool
eqK K
k K
k'
    eqK (Push Int
f Int
a CombIx
ci Int
_ MSection
_sect K
k) (Push Int
f' Int
a' CombIx
ci' Int
_ MSection
_sect' K
k') =
      Int
f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
f' Bool -> Bool -> Bool
&& Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
a' Bool -> Bool -> Bool
&& CombIx
ci CombIx -> CombIx -> Bool
forall a. Eq a => a -> a -> Bool
== CombIx
ci' Bool -> Bool -> Bool
&& K -> K -> Bool
eqK K
k K
k'
    eqK K
_ K
_ = Bool
False

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

-- serialization doesn't necessarily preserve Int tags, so be
-- more accepting for those.
matchUnboxedTypes :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
matchUnboxedTypes :: UnboxedTypeTag -> UnboxedTypeTag -> Bool
matchUnboxedTypes UnboxedTypeTag
ct1 UnboxedTypeTag
ct2 =
  UnboxedTypeTag
ct1 UnboxedTypeTag -> UnboxedTypeTag -> Bool
forall a. Eq a => a -> a -> Bool
== UnboxedTypeTag
ct2
    Bool -> Bool -> Bool
|| (UnboxedTypeTag
ct1 UnboxedTypeTag -> UnboxedTypeTag -> Bool
forall a. Eq a => a -> a -> Bool
== UnboxedTypeTag
IntTag Bool -> Bool -> Bool
&& UnboxedTypeTag
ct2 UnboxedTypeTag -> UnboxedTypeTag -> Bool
forall a. Eq a => a -> a -> Bool
== UnboxedTypeTag
NatTag)
    Bool -> Bool -> Bool
|| (UnboxedTypeTag
ct1 UnboxedTypeTag -> UnboxedTypeTag -> Bool
forall a. Eq a => a -> a -> Bool
== UnboxedTypeTag
NatTag Bool -> Bool -> Bool
&& UnboxedTypeTag
ct2 UnboxedTypeTag -> UnboxedTypeTag -> Bool
forall a. Eq a => a -> a -> Bool
== UnboxedTypeTag
IntTag)

arrayEq :: (a -> a -> Bool) -> PA.Array a -> PA.Array a -> Bool
arrayEq :: forall a. (a -> a -> Bool) -> Array a -> Array a -> Bool
arrayEq a -> a -> Bool
eqc Array a
l Array a
r
  | Array a -> Int
forall a. Array a -> Int
PA.sizeofArray Array a
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Array a -> Int
forall a. Array a -> Int
PA.sizeofArray Array a
r = Bool
False
  | Bool
otherwise = Int -> Bool
go (Array a -> Int
forall a. Array a -> Int
PA.sizeofArray Array a
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 = a -> a -> Bool
eqc (Array a -> Int -> a
forall a. Array a -> Int -> a
PA.indexArray Array a
l Int
i) (Array a -> Int -> a
forall a. Array a -> Int -> a
PA.indexArray Array a
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

universalCompare ::
  (Foreign -> Foreign -> Ordering) ->
  Val ->
  Val ->
  Ordering
universalCompare :: (Foreign -> Foreign -> Ordering) -> Val -> Val -> Ordering
universalCompare Foreign -> Foreign -> Ordering
frn = Bool -> Val -> Val -> Ordering
cmpVal Bool
False
  where
    cmpVal :: Bool -> Val -> Val -> Ordering
    cmpVal :: Bool -> Val -> Val -> Ordering
cmpVal Bool
tyEq = \cases
      (BoxedVal Closure
c1) (BoxedVal Closure
c2) -> Bool -> Closure -> Closure -> Ordering
cmpc Bool
tyEq Closure
c1 Closure
c2
      (UnboxedVal {}) (BoxedVal {}) -> Ordering
LT
      (BoxedVal {}) (UnboxedVal {}) -> Ordering
GT
      (NatVal Word64
i) (NatVal Word64
j) -> Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
i Word64
j
      (UnboxedVal Int
v1 UnboxedTypeTag
t1) (UnboxedVal Int
v2 UnboxedTypeTag
t2) -> Bool -> (UnboxedTypeTag, Int) -> (UnboxedTypeTag, Int) -> Ordering
cmpUnboxed Bool
tyEq (UnboxedTypeTag
t1, Int
v1) (UnboxedTypeTag
t2, Int
v2)
    cmpl :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering
    cmpl :: forall a b. (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 -> Closure -> Closure -> Ordering
    cmpc :: Bool -> Closure -> Closure -> Ordering
cmpc Bool
tyEq = \cases
      (DataC Reference
rf1 PackedTag
ct1 [Val]
vs1) (DataC Reference
rf2 PackedTag
ct2 [Val]
vs2) ->
        (if Bool
tyEq Bool -> Bool -> Bool
&& PackedTag
ct1 PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
/= PackedTag
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 (PackedTag -> Word64
maskTags PackedTag
ct1) (PackedTag -> Word64
maskTags PackedTag
ct2)
          -- when comparing corresponding `Any` values, which have
          -- existentials inside check that type references match
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> [Val] -> [Val] -> Ordering
cmpValList (Bool
tyEq Bool -> Bool -> Bool
|| Reference
rf1 Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Rf.anyRef) [Val]
vs1 [Val]
vs2
      (PApV CombIx
cix1 GCombInfo MComb
_ [Val]
segs1) (PApV CombIx
cix2 GCombInfo MComb
_ [Val]
segs2) ->
        CombIx -> CombIx -> Ordering
forall a. Ord a => a -> a -> Ordering
compare CombIx
cix1 CombIx
cix2
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> [Val] -> [Val] -> Ordering
cmpValList Bool
tyEq [Val]
segs1 [Val]
segs2
      (CapV K
k1 Int
a1 [Val]
vs1) (CapV K
k2 Int
a2 [Val]
vs2) ->
        Bool -> K -> K -> Ordering
cmpK Bool
tyEq 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
a1 Int
a2
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> [Val] -> [Val] -> Ordering
cmpValList Bool
True [Val]
vs1 [Val]
vs2
      (Foreign Foreign
fl) (Foreign Foreign
fr)
        | Just USeq
sl <- forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign @(Seq Val) Reference
Rf.listRef Foreign
fl,
          Just USeq
sr <- forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign @(Seq Val) 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 ((Val -> Val -> Ordering) -> USeq -> USeq -> Seq Ordering
forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Sq.zipWith (Bool -> Val -> Val -> Ordering
cmpVal Bool
tyEq) USeq
sl USeq
sr)
              Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (USeq -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length USeq
sl) (USeq -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length USeq
sr)
        | Just Array Val
al <- forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign @(PA.Array Val) Reference
Rf.iarrayRef Foreign
fl,
          Just Array Val
ar <- forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign @(PA.Array Val) Reference
Rf.iarrayRef Foreign
fr ->
            (Val -> Val -> Ordering) -> Array Val -> Array Val -> Ordering
forall a. (a -> a -> Ordering) -> Array a -> Array a -> Ordering
arrayCmp (Bool -> Val -> Val -> Ordering
cmpVal Bool
tyEq) Array Val
al Array Val
ar
        | Bool
otherwise -> Foreign -> Foreign -> Ordering
frn Foreign
fl Foreign
fr
      (UnboxedTypeTag UnboxedTypeTag
t1) (UnboxedTypeTag UnboxedTypeTag
t2) -> UnboxedTypeTag -> UnboxedTypeTag -> Ordering
forall a. Ord a => a -> a -> Ordering
compare UnboxedTypeTag
t1 UnboxedTypeTag
t2
      (Closure
BlackHole) (Closure
BlackHole) -> Ordering
EQ
      Closure
c Closure
d -> (Closure -> Int) -> Closure -> Closure -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Closure -> Int
closureNum Closure
c Closure
d

    cmpUnboxed :: Bool -> (UnboxedTypeTag, Int) -> (UnboxedTypeTag, Int) -> Ordering
    cmpUnboxed :: Bool -> (UnboxedTypeTag, Int) -> (UnboxedTypeTag, Int) -> Ordering
cmpUnboxed Bool
tyEq = \cases
      -- Need to cast to Nat or else maxNat == -1 and it flips comparisons of large Nats.
      -- TODO: Investigate whether bit-twiddling is faster than using Haskell's fromIntegral.
      (UnboxedTypeTag
IntTag, Int
n1) (UnboxedTypeTag
IntTag, Int
n2) -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
n1 Int
n2
      (UnboxedTypeTag
NatTag, Int
n1) (UnboxedTypeTag
NatTag, Int
n2) -> Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n1 :: Word64) (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n2 :: Word64)
      (UnboxedTypeTag
NatTag, Int
n1) (UnboxedTypeTag
IntTag, Int
n2)
        | Int
n2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> Ordering
GT
        | Bool
otherwise -> Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n1 :: Word64) (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n2 :: Word64)
      (UnboxedTypeTag
IntTag, Int
n1) (UnboxedTypeTag
NatTag, Int
n2)
        | Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> Ordering
LT
        | Bool
otherwise -> Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n1 :: Word64) (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n2 :: Word64)
      (UnboxedTypeTag
FloatTag, Int
n1) (UnboxedTypeTag
FloatTag, Int
n2) -> Int -> Int -> Ordering
compareAsFloat Int
n1 Int
n2
      (UnboxedTypeTag
t1, Int
v1) (UnboxedTypeTag
t2, Int
v2) ->
        Bool -> Ordering -> Ordering
forall a. Monoid a => Bool -> a -> a
Monoid.whenM Bool
tyEq (UnboxedTypeTag -> UnboxedTypeTag -> Ordering
forall a. Ord a => a -> a -> Ordering
compare UnboxedTypeTag
t1 UnboxedTypeTag
t2)
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
v1 Int
v2

    cmpValList :: Bool -> [Val] -> [Val] -> Ordering
    cmpValList :: Bool -> [Val] -> [Val] -> Ordering
cmpValList Bool
tyEq [Val]
vs1 [Val]
vs2 = (Val -> Val -> Ordering) -> [Val] -> [Val] -> Ordering
forall a b. (a -> b -> Ordering) -> [a] -> [b] -> Ordering
cmpl (Bool -> Val -> Val -> Ordering
cmpVal Bool
tyEq) [Val]
vs1 [Val]
vs2

    cmpK :: Bool -> K -> K -> Ordering
    cmpK :: Bool -> K -> K -> Ordering
cmpK Bool
tyEq = \cases
      K
KE K
KE -> Ordering
EQ
      (CB Callback
cb) (CB Callback
cb') -> Callback -> Callback -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Callback
cb Callback
cb'
      (Mark Int
a EnumSet Word64
ps EnumMap Word64 Val
m K
k) (Mark Int
a' EnumSet Word64
ps' EnumMap Word64 Val
m' K
k') ->
        Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
a Int
a'
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> EnumSet Word64 -> EnumSet Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare EnumSet Word64
ps EnumSet Word64
ps'
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (Val -> Val -> Ordering)
-> EnumMap Word64 Val -> EnumMap Word64 Val -> Ordering
forall a b.
(a -> b -> Ordering)
-> EnumMap Word64 a -> EnumMap Word64 b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (Bool -> Val -> Val -> Ordering
cmpVal Bool
tyEq) EnumMap Word64 Val
m EnumMap Word64 Val
m'
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> K -> K -> Ordering
cmpK Bool
tyEq K
k K
k'
      (Push Int
f Int
a CombIx
ci Int
_ MSection
_sect K
k) (Push Int
f' Int
a' CombIx
ci' Int
_ MSection
_sect' K
k') ->
        Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
f Int
f'
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
a Int
a'
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> CombIx -> CombIx -> Ordering
forall a. Ord a => a -> a -> Ordering
compare CombIx
ci CombIx
ci'
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> K -> K -> Ordering
cmpK Bool
tyEq K
k K
k'
      K
KE K
_ -> Ordering
LT
      K
_ K
KE -> Ordering
GT
      (CB {}) K
_ -> Ordering
LT
      K
_ (CB {}) -> Ordering
GT
      (Mark {}) K
_ -> Ordering
LT
      K
_ (Mark {}) -> Ordering
GT

arrayCmp ::
  (a -> a -> Ordering) ->
  PA.Array a ->
  PA.Array a ->
  Ordering
arrayCmp :: forall a. (a -> a -> Ordering) -> Array a -> Array a -> Ordering
arrayCmp a -> a -> Ordering
cmpVal Array a
l Array a
r =
  (Array a -> Int) -> Array a -> Array a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Array a -> Int
forall a. Array a -> Int
PA.sizeofArray Array a
l Array a
r Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Ordering
go (Array a -> Int
forall a. Array a -> Int
PA.sizeofArray Array a
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 = a -> a -> Ordering
cmpVal (Array a -> Int -> a
forall a. Array a -> Int -> a
PA.indexArray Array a
l Int
i) (Array a -> Int -> a
forall a. Array a -> Int -> a
PA.indexArray Array a
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)

die :: (HasCallStack) => String -> IO a
die :: forall a. HasCallStack => [Char] -> IO a
die [Char]
s = do
  IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> ([Char] -> IO Any) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuntimeExn -> IO Any
forall e a. Exception e => e -> IO a
throwIO (RuntimeExn -> IO Any)
-> ([Char] -> RuntimeExn) -> [Char] -> IO Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> Pretty ColorText -> RuntimeExn
PE CallStack
HasCallStack => CallStack
callStack (Pretty ColorText -> RuntimeExn)
-> ([Char] -> Pretty ColorText) -> [Char] -> RuntimeExn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorText -> Pretty ColorText
forall s. (IsString s, ListLike s Char) => s -> Pretty s
P.lit (ColorText -> Pretty ColorText)
-> ([Char] -> ColorText) -> [Char] -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ColorText
forall a. IsString a => [Char] -> a
fromString ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
s
  -- This is unreachable, but we need it to fix some quirks in GHC's
  -- worker/wrapper optimization, specifically, it seems that when throwIO's polymorphic return
  -- value is specialized to a type like 'Stack' which we want GHC to unbox, it will sometimes
  -- fail to unbox it, possibly because it can't unbox it when it's strictly a type application.
  -- For whatever reason, this seems to fix it while still allowing us to throw exceptions in IO
  -- like we prefer.
  [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"
{-# INLINE die #-}

{- ORMOLU_DISABLE -}
#ifdef OPT_CHECK
-- Assert that we don't allocate any 'Stack' objects in 'eval', since we expect GHC to always
-- trigger the worker/wrapper optimization and unbox it fully, and if it fails to do so, we want to
-- know about it.
--
-- Note: this must remain in this module, it can't be moved to a testing module, this is a requirement of the inspection
-- testing library.
--
-- Note: We _must_ check 'eval0' instead of 'eval' here because if you simply check 'eval', you'll be
-- testing the 'wrapper' part of the worker/wrapper, which will always mention the 'Stack' object as part of its
-- unwrapping, and since there's  no way to refer to the generated wrapper directly, we instead refer to 'eval0'
-- which allocates its own stack to pass in, meaning it's one level above the wrapper, and GHC should always detect that
-- it can call the worker directly without using the wrapper.
-- See: https://github.com/nomeata/inspection-testing/issues/50 for more information.
--
-- If this test starts failing, here are some things you can check.
--
-- 1. Are 'Stack's being passed to dynamic functions? If so, try changing those functions to take an 'XStack' instead,
--    and manually unpack/pack the 'Stack' where necessary.
-- 2. Are there calls to 'die' or 'throwIO' or something similar in which a fully polymorphic type variable is being
--    specialized to 'Stack'? Sometimes this trips up the optimization, you can try using an 'error' instead, or even
--    following the 'throwIO' with a useless call to @error "unreachable"@, this seems to help for some reason.
--    See this page for more info on precise exceptions: https://gitlab.haskell.org/ghc/ghc/-/wikis/exceptions/precise-exceptions
--
-- Best of luck!
TI.inspect $ 'eval0 `TI.hasNoType` ''Stack
#endif
{- ORMOLU_ENABLE -}