{-# 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.IORef (IORef)
import Data.List qualified as List
import Data.Map.Strict qualified as M
import Data.Map.Strict.Internal qualified as M
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)
import Unison.Builtin.Decls qualified as Rf
import Unison.Prelude hiding (Text)
import Unison.Reference
  ( Reference,
    Reference' (Builtin),
  )
import Unison.Referent (pattern Ref)
import Unison.Runtime.ANF as ANF
  ( Cacheability (..),
    Code (..),
    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,
    functionReplacements,
    functionUnreplacements,
    pseudoConstructors,
  )
import Unison.Runtime.MCode
import Unison.Runtime.Machine.Primops
import Unison.Runtime.Machine.Types
import Unison.Runtime.Stack
import Unison.Runtime.TypeTags qualified as TT
import Unison.Symbol (Symbol)
import Unison.Type qualified as Rf
import Unison.Util.EnumContainers as EC
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

#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

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)
{-# INLINE apply1 #-}

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

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
r -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (Reference -> Referent -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef Referent
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 #-}

#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

-- | Execute an instruction
exec ::
  CCache ->
  DEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Reference ->
  MInstr ->
  IO (Bool, DEnv, Stack, K)
#ifdef STACK_CHECK
exec _ !_ !_ !stk !_ !_ instr
  | debugger stk "exec" instr = undefined
#endif
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
env !EnumMap Word64 Val
denv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Prim1 Prim1
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 -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef (Referent -> Foreign)
-> (Reference -> Referent) -> Reference -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent
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
_ (Prim1 Prim1
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 -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef (Referent -> Foreign)
-> (Reference -> Referent) -> Reference -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent
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
_ (Prim1 Prim1
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
_ (Prim1 Prim1
op Int
i) = do
  Stack
stk <- CCache -> Stack -> Prim1 -> Int -> IO Stack
prim1 CCache
env Stack
stk Prim1
op Int
i
  pure (Bool
False, EnumMap Word64 Val
denv, Stack
stk, K
k)
exec CCache
_ !EnumMap Word64 Val
_ !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
r (Prim2 Prim2
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
_ (Prim2 Prim2
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
env !EnumMap Word64 Val
denv !ActiveThreads
_trackThreads !Stack
stk !K
k Reference
_ (Prim2 Prim2
op Int
i Int
j) = do
  Stack
stk <- CCache -> Stack -> Prim2 -> Int -> Int -> IO Stack
primxx CCache
env Stack
stk Prim2
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 ()
#ifdef STACK_CHECK
eval _ !_ !_ !stk !_ !_ section
  | debugger stk "eval" section = undefined
#endif
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 ()
#ifdef STACK_CHECK
apply _env !_denv !_activeThreads !stk !_k !_ck !args !val
  | debugger stk "apply" (args, val) = undefined
#endif
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

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)
  Foreign Foreign
f
    | Just Map Val Val
m <- Reference -> Foreign -> Maybe (Map Val Val)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.hmapRef Foreign
f -> case Map Val Val
m of
        M.Bin Int
sz Val
k Val
e Map Val Val
l Map Val Val
r
          | Word64
u Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
Rf.mapBin -> (MSection
cu,) (Stack -> (MSection, Stack)) -> IO Stack -> IO (MSection, Stack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Val -> Val -> Map Val Val -> Map Val Val -> Stack -> IO Stack
dumpBin Int
sz Val
k Val
e Map Val Val
l Map Val Val
r Stack
stk
        Map Val Val
M.Tip
          | Word64
u Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
Rf.mapTip -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
cu, Stack
stk)
        Map Val Val
_ -> (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)
  Foreign Foreign
f
    | Just Map Val Val
m <- Reference -> Foreign -> Maybe (Map Val Val)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.hmapRef Foreign
f -> case Map Val Val
m of
        M.Bin Int
sz Val
k Val
e Map Val Val
l Map Val Val
r
          | Word64
u Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
Rf.mapBin -> (MSection
cu,) (Stack -> (MSection, Stack)) -> IO Stack -> IO (MSection, Stack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Val -> Val -> Map Val Val -> Map Val Val -> Stack -> IO Stack
dumpBin Int
sz Val
k Val
e Map Val Val
l Map Val Val
r Stack
stk
          | Word64
v Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
Rf.mapBin -> (MSection
cv,) (Stack -> (MSection, Stack)) -> IO Stack -> IO (MSection, Stack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Val -> Val -> Map Val Val -> Map Val Val -> Stack -> IO Stack
dumpBin Int
sz Val
k Val
e Map Val Val
l Map Val Val
r Stack
stk
        Map Val Val
M.Tip
          | Word64
u Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
Rf.mapTip -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
cu, Stack
stk)
          | Word64
v Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
Rf.mapTip -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSection
cv, Stack
stk)
        Map Val Val
_ -> (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)
  Foreign Foreign
f
    | Just Map Val Val
m <- Reference -> Foreign -> Maybe (Map Val Val)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.hmapRef Foreign
f -> case Map Val Val
m of
        M.Bin Int
sz Val
k Val
e Map Val Val
l Map Val Val
r
          | Just MSection
ca <- Word64 -> EnumMap Word64 MSection -> Maybe MSection
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
Rf.mapBin 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
<$> Int
-> Val -> Val -> Map Val Val -> Map Val Val -> Stack -> IO Stack
dumpBin Int
sz Val
k Val
e Map Val Val
l Map Val Val
r Stack
stk
        Map Val Val
M.Tip
          | Just MSection
ca <- Word64 -> EnumMap Word64 MSection -> Maybe MSection
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
Rf.mapTip 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)
        Map Val Val
_ -> (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 #-}

dumpBin :: Int -> Val -> Val -> Map Val Val -> Map Val Val -> Stack -> IO Stack
dumpBin :: Int
-> Val -> Val -> Map Val Val -> Map Val Val -> Stack -> IO Stack
dumpBin Int
sz Val
k Val
e Map Val Val
l Map Val Val
r Stack
stk = do
  Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
5
  (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
unsafePokeIasN Stack
stk Int
sz
  (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
k
  (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
2 Val
e
  Stack -> Int -> Map Val Val -> IO ()
forall b. BuiltinForeign b => Stack -> Int -> b -> IO ()
pokeOffBi Stack
stk Int
3 Map Val Val
l
  Stack -> Int -> Map Val Val -> IO ()
forall b. BuiltinForeign b => Stack -> Int -> b -> IO ()
pokeOffBi Stack
stk Int
4 Map Val Val
r
  pure Stack
stk
{-# INLINE dumpBin #-}

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)

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
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
_ -> [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"

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

-- 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 ((SuperGroup Symbol -> SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
forall a b. (a -> b) -> Map Reference a -> Map Reference b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SuperGroup Symbol -> SuperGroup Symbol
replace 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)
        replace :: SuperGroup Symbol -> SuperGroup Symbol
replace =
          Map Reference (Map CTag ForeignFunc)
-> SuperGroup Symbol -> SuperGroup Symbol
forall v.
Var v =>
Map Reference (Map CTag ForeignFunc)
-> SuperGroup v -> SuperGroup v
ANF.replaceConstructors Map Reference (Map CTag ForeignFunc)
pseudoConstructors
            (SuperGroup Symbol -> SuperGroup Symbol)
-> (SuperGroup Symbol -> SuperGroup Symbol)
-> SuperGroup Symbol
-> SuperGroup Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Reference Reference -> SuperGroup Symbol -> SuperGroup Symbol
forall v.
Var v =>
Map Reference Reference -> SuperGroup v -> SuperGroup v
ANF.replaceFunctions Map Reference Reference
functionReplacements
        optimize :: SuperGroup Symbol -> SuperGroup Symbol
optimize = 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 -> SuperGroup Symbol)
-> (SuperGroup Symbol -> SuperGroup Symbol)
-> SuperGroup Symbol
-> SuperGroup Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuperGroup Symbol -> SuperGroup Symbol
replace
        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
$ SuperGroup Symbol -> SuperGroup Symbol
optimize 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
r0 Word64
_ Word64
i) = Reference -> Word64 -> GroupRef
ANF.GR Reference
r Word64
i
      where
        r :: Reference
r = Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Reference
r0 Reference
r0 Map Reference Reference
functionUnreplacements

    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)
            | Just Map Val Val
m <- Reference -> Foreign -> Maybe (Map Val Val)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.hmapRef Foreign
f ->
                Val -> IO Value
goV (Val -> IO Value) -> (Closure -> Val) -> Closure -> IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
BoxedVal (Closure -> IO Value) -> Closure -> IO Value
forall a b. (a -> b) -> a -> b
$ Map Val Val -> Closure
inflateMap Map Val Val
m
            | Bool
otherwise -> 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
l <- Reference -> Foreign -> Maybe Referent
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 -> BLit
ANF.TmLink Referent
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
r0 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)
      where
        r :: Reference
r = Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Reference
r0 Reference
r0 Map Reference Reference
functionReplacements

    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
formDataReplaced 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
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 -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef Referent
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
#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