{-# 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, newIORef, readIORef, writeIORef)
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.ANF.Optimize qualified as ANF
#ifdef CODE_SERIAL_CHECK
import Unison.Runtime.ANF.Serialize (serializeCode, deserializeCode)
#endif
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 => String -> a -> IO ()
info String
ctx a
x = String -> String -> IO ()
infos String
ctx (a -> String
forall a. Show a => a -> String
show a
x)

infos :: String -> String -> IO ()
infos :: String -> String -> IO ()
infos String
ctx String
s = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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
  (HEnv
henv, K -> K
k) <- do
    Map Reference Word64
rfTy <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTy CCache
env)
    Map Reference Word64
rfTm <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTm CCache
env)
    EnumMap Word64 MCombs
-> Map Reference Word64
-> Map Reference Word64
-> IO (HEnv, K -> K)
topHEnv EnumMap Word64 MCombs
cmbs Map Reference Word64
rfTy Map Reference Word64
rfTm
  CCache
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv 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

topAEnv ::
  EnumMap Word64 MCombs ->
  M.Map Reference Word64 ->
  M.Map Reference Word64 ->
  IO (AEnv, K -> K)
topAEnv :: EnumMap Word64 MCombs
-> Map Reference Word64
-> Map Reference Word64
-> IO (AEnv, K -> K)
topAEnv 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 (String -> Text
DTx.pack String
"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 = do
      IORef Closure
r <- Closure -> IO (IORef Closure)
forall a. a -> IO (IORef a)
newIORef Closure
BlackHole
      let ar :: AffineRef
ar = IORef Closure -> AffineRef
ARef IORef Closure
r
      Closure
ahv <- Val -> Val -> IO Closure
extendPAp Val
clo (Val -> IO Closure) -> (Closure -> Val) -> Closure -> IO Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
BoxedVal (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ EnumSet Word64 -> AEnv -> AffineRef -> Closure
Affine (Word64 -> EnumSet Word64
forall k. EnumKey k => k -> EnumSet k
setSingleton Word64
n) AEnv
forall a. Monoid a => a
mempty AffineRef
ar
      IORef Closure -> Closure -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Closure
r Closure
ahv
      pure (Word64 -> AffineRef -> AEnv
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
n AffineRef
ar, Int -> AEnv -> AffineRef -> K -> K
AMark Int
0 AEnv
forall a. Monoid a => a
mempty AffineRef
ar)
topAEnv EnumMap Word64 MCombs
_ Map Reference Word64
_ Map Reference Word64
_ = (AEnv, K -> K) -> IO (AEnv, K -> K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AEnv
forall a. Monoid a => a
mempty, K -> K
forall a. a -> a
id)

topHEnv ::
  EnumMap Word64 MCombs ->
  M.Map Reference Word64 ->
  M.Map Reference Word64 ->
  IO (HEnv, K -> K)
topHEnv :: EnumMap Word64 MCombs
-> Map Reference Word64
-> Map Reference Word64
-> IO (HEnv, K -> K)
topHEnv EnumMap Word64 MCombs
combs Map Reference Word64
rfTy Map Reference Word64
rfTm =
  (AEnv -> HEnv) -> (AEnv, K -> K) -> (HEnv, K -> K)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((AEnv -> DEnv -> HEnv) -> DEnv -> AEnv -> HEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip AEnv -> DEnv -> HEnv
HEnv DEnv
forall a. Monoid a => a
mempty) ((AEnv, K -> K) -> (HEnv, K -> K))
-> IO (AEnv, K -> K) -> IO (HEnv, K -> K)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumMap Word64 MCombs
-> Map Reference Word64
-> Map Reference Word64
-> IO (AEnv, K -> K)
topAEnv EnumMap Word64 MCombs
combs Map Reference Word64
rfTy Map Reference Word64
rfTm

-- 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
  (HEnv
henv, K -> K
kf) <- do
    Map Reference Word64
rfTy <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTy CCache
env)
    Map Reference Word64
rfTm <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTm CCache
env)
    EnumMap Word64 MCombs
-> Map Reference Word64
-> Map Reference Word64
-> IO (HEnv, K -> K)
topHEnv EnumMap Word64 MCombs
cmbs Map Reference Word64
rfTy Map Reference Word64
rfTm
  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 -> String -> IO Reference
forall a. HasCallStack => String -> IO a
die String
"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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env HEnv
henv 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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env HEnv
forall a. Monoid a => a
mempty ActiveThreads
threadTracker Stack
stk K
k0 Bool
True Args
ZArgs 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
--
-- Note: both `env` and `henv` are intentionally not strict arguments.
-- It seems to be slower to unpack them into many arguments. `env` is
-- never modified, so this is no worry. `henv` is modified, but it is
-- immediately evaluated when created to avoid thunks building up, so
-- that it doesn't need to be a strict argument.
exec ::
  CCache ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Reference ->
  MInstr ->
  IO (Bool, HEnv, Stack, K)
#ifdef STACK_CHECK
exec _ _ !_ !stk !_ !_ instr
  | debugger stk "exec" instr = undefined
#endif
exec :: CCache
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MInstr
-> IO (Bool, HEnv, Stack, K)
exec CCache
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Info String
tx) = do
  String -> Stack -> IO ()
forall a. Show a => String -> a -> IO ()
info String
tx Stack
stk
  String -> K -> IO ()
forall a. Show a => String -> a -> IO ()
info String
tx K
k
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Name GRef MComb
r Args
args) = do
  Val
v <- CCache -> HEnv -> Stack -> GRef MComb -> IO Val
resolve CCache
env HEnv
henv Stack
stk GRef MComb
r
  Stack
stk <- Stack -> Args -> Val -> IO Stack
name Stack
stk Args
args Val
v
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (SetAff Bool
u Int
i Int
j) =
  (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure
-> (Closure -> IO (Bool, HEnv, Stack, K))
-> IO (Bool, HEnv, Stack, K)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Affine EnumSet Word64
ps AEnv
_ ar :: AffineRef
ar@(ARef IORef Closure
r) -> do
      (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
j 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
>>= IORef Closure -> Closure -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Closure
r
      HEnv
henv <-
        if Bool
u
          then do
            AEnv
aenv <-
              AEnv -> IO AEnv
forall a. a -> IO a
evaluate (AEnv -> IO AEnv) -> AEnv -> IO AEnv
forall a b. (a -> b) -> a -> b
$ (AffineRef -> AffineRef -> AffineRef) -> AEnv -> AEnv -> AEnv
forall k a.
EnumKey k =>
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EC.unionWith AffineRef -> AffineRef -> AffineRef
forall a b. a -> b -> a
const (EnumSet Word64 -> AffineRef -> AEnv
forall k a. EnumKey k => EnumSet k -> a -> EnumMap k a
mapFromSet EnumSet Word64
ps AffineRef
ar) (HEnv -> AEnv
aenv HEnv
henv)
            HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ HEnv
henv {aenv = aenv}
          else HEnv -> IO HEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HEnv
henv
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
    Closure
_ -> String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die String
"SetAff called with bad handler reference"
exec CCache
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Capture Word64
p) = do
  (Val
cap, DEnv
denv, Stack
stk, K
k) <- DEnv -> Stack -> K -> Word64 -> IO (Val, DEnv, Stack, K)
splitCont (HEnv -> DEnv
denv HEnv
henv) 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
  HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ HEnv
henv {denv = denv}
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache
_ HEnv
_henv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Discard Int
i) = do
  (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure
-> (Closure -> IO (Bool, HEnv, Stack, K))
-> IO (Bool, HEnv, Stack, K)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Affine EnumSet Word64
_ AEnv
_ AffineRef
r -> do
      (AEnv
aenv, Stack
stk, K
k) <- Stack -> K -> AffineRef -> IO (AEnv, Stack, K)
abortCont Stack
stk K
k AffineRef
r
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ AEnv -> DEnv -> HEnv
HEnv AEnv
aenv DEnv
forall a. Monoid a => a
mempty
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
    Closure
_ -> String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die String
"Discard called with bad handler reference"
exec CCache
_env HEnv
henv0 !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (InLocal Int
i) = do
  (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure
-> (Closure -> IO (Bool, HEnv, Stack, K))
-> IO (Bool, HEnv, Stack, K)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Affine EnumSet Word64
_ AEnv
aenv AffineRef
_ -> do
      (Stack
stk, Int
a) <- Stack -> IO (Stack, Int)
saveArgs Stack
stk
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ AEnv -> DEnv -> HEnv
HEnv AEnv
aenv DEnv
forall a. Monoid a => a
mempty
      pure (Bool
False, HEnv
henv, Stack
stk, HEnv -> Int -> K -> K
Local HEnv
henv0 Int
a K
k)
    Closure
v -> String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die (String -> IO (Bool, HEnv, Stack, K))
-> String -> IO (Bool, HEnv, Stack, K)
forall a b. (a -> b) -> a -> b
$ String
"InLocal called with bad handler reference\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Closure -> String
forall a. Show a => a -> String
show Closure
v
exec CCache
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Prim1 Prim1
CACH Int
i)
  | CCache -> Bool
sandboxed CCache
env = String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die String
"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, HEnv
henv, Stack
stk, K
k)
exec CCache
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Prim1 Prim1
LOAD Int
i)
  | CCache -> Bool
sandboxed CCache
env = String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die String
"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, HEnv
henv, Stack
stk, K
k)
exec CCache
env HEnv
henv !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
=<< CCache -> EnumMap Word64 Reference -> Val -> IO Value
reflectValue CCache
env EnumMap Word64 Reference
m Val
c
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache
env HEnv
henv !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, HEnv
henv, Stack
stk, K
k)
exec CCache
_ HEnv
_ !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)
  String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> a
error String
"throwIO should never return"
exec CCache
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Prim2 Prim2
TRCE Int
i Int
j)
  | CCache -> Bool
sandboxed CCache
env = String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die String
"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 String
str -> do
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"trace: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Util.Text.unpack Text
tx
          String -> IO ()
putStrLn String
str
        MsgTrace String
msg String
ugl String
pre -> do
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"trace: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Util.Text.unpack Text
tx
          String -> IO ()
putStrLn String
""
          String -> IO ()
putStrLn String
msg
          String -> IO ()
putStrLn String
"\nraw structure:\n"
          String -> IO ()
putStrLn String
ugl
          String -> IO ()
putStrLn String
"partial decompilation:\n"
          String -> IO ()
putStrLn String
pre
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache
env HEnv
henv !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, HEnv
henv, Stack
stk, K
k)
exec CCache
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (RefCAS Int
refI Int
ticketI Int
valI)
  | CCache -> Bool
sandboxed CCache
env = String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die String
"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, HEnv
henv, Stack
stk, K
k)
exec CCache
_ HEnv
henv !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, HEnv
henv, Stack
stk, K
k)
exec CCache
_ HEnv
henv !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, HEnv
henv, Stack
stk, K
k)
exec CCache
_ HEnv
henv !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, HEnv
henv, Stack
stk, K
k)
exec CCache
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k Reference
_ (Reset EnumSet Word64
ps Int
nhi Maybe Int
mah)
  -- if denv is null, and there's an affine handler, use it
  | HEnv AEnv
aenv0 DEnv
denv0 <- HEnv
henv,
    DEnv -> Bool
forall a. EnumMap Word64 a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null DEnv
denv0,
    Just Int
ahi <- Maybe Int
mah = do
      (Stack
stk, Int
a) <- Stack -> IO (Stack, Int)
saveArgs Stack
stk
      Val
ahv0 <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
ahi
      IORef Closure
r <- Closure -> IO (IORef Closure)
forall a. a -> IO (IORef a)
newIORef Closure
BlackHole
      let ar :: AffineRef
ar = IORef Closure -> AffineRef
ARef IORef Closure
r
      Closure
ahv <- Val -> Val -> IO Closure
extendPAp Val
ahv0 (Val -> IO Closure) -> (Closure -> Val) -> Closure -> IO Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
BoxedVal (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ EnumSet Word64 -> AEnv -> AffineRef -> Closure
Affine EnumSet Word64
ps AEnv
aenv0 AffineRef
ar
      IORef Closure -> Closure -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Closure
r Closure
ahv
      AEnv
aenv <- AEnv -> IO AEnv
forall a. a -> IO a
evaluate (AEnv -> IO AEnv) -> AEnv -> IO AEnv
forall a b. (a -> b) -> a -> b
$ (AffineRef -> AffineRef -> AffineRef) -> AEnv -> AEnv -> AEnv
forall k a.
EnumKey k =>
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EC.unionWith AffineRef -> AffineRef -> AffineRef
forall a b. a -> b -> a
const (EnumSet Word64 -> AffineRef -> AEnv
forall k a. EnumKey k => EnumSet k -> a -> EnumMap k a
mapFromSet EnumSet Word64
ps AffineRef
ar) AEnv
aenv0
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ HEnv
henv {aenv = aenv}
      pure (Bool
False, HEnv
henv, Stack
stk, Int -> AEnv -> AffineRef -> K -> K
AMark Int
a AEnv
aenv0 AffineRef
ar K
k)
  | HEnv AEnv
aenv0 DEnv
denv0 <- HEnv
henv = do
      (Stack
stk, Int
a) <- Stack -> IO (Stack, Int)
saveArgs Stack
stk
      Val
nh <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
nhi
      DEnv
denv <- DEnv -> IO DEnv
forall a. a -> IO a
evaluate (DEnv -> IO DEnv) -> DEnv -> IO DEnv
forall a b. (a -> b) -> a -> b
$ (Val -> Val -> Val) -> DEnv -> DEnv -> DEnv
forall k a.
EnumKey k =>
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EC.unionWith Val -> Val -> Val
forall a b. a -> b -> a
const (EnumSet Word64 -> Val -> DEnv
forall k a. EnumKey k => EnumSet k -> a -> EnumMap k a
mapFromSet EnumSet Word64
ps Val
nh) DEnv
denv0
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ AEnv -> DEnv -> HEnv
HEnv AEnv
aenv0 DEnv
denv
      DEnv
clos <- DEnv -> IO DEnv
forall a. a -> IO a
evaluate (DEnv -> IO DEnv) -> DEnv -> IO DEnv
forall a b. (a -> b) -> a -> b
$ DEnv -> EnumSet Word64 -> DEnv
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys DEnv
denv0 EnumSet Word64
ps
      pure (Bool
False, HEnv
henv, Stack
stk, Int -> EnumSet Word64 -> DEnv -> K -> K
Mark Int
a EnumSet Word64
ps DEnv
clos K
k)
exec CCache
_ HEnv
henv !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, HEnv
henv, Stack
stk, K
k)
exec CCache
_env HEnv
henv !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, HEnv, Stack, K) -> IO (Bool, HEnv, Stack, K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
b, HEnv
henv, Stack
stk, K
k)
exec CCache
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (Fork Int
i)
  | CCache -> Bool
sandboxed CCache
env = String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die String
"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, HEnv
henv, Stack
stk, K
k)
exec CCache
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (Atomically Int
i)
  | CCache -> Bool
sandboxed CCache
env = String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die (String -> IO (Bool, HEnv, Stack, K))
-> String -> IO (Bool, HEnv, Stack, K)
forall a b. (a -> b) -> a -> b
$ String
"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, HEnv
henv, Stack
stk, K
k)
exec CCache
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (TryForce Int
i)
  | CCache -> Bool
sandboxed CCache
env = String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die (String -> IO (Bool, HEnv, Stack, K))
-> String -> IO (Bool, HEnv, Stack, K)
forall a b. (a -> b) -> a -> b
$ String
"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, HEnv
henv, Stack
stk, K
k)
exec CCache
_ HEnv
_ !ActiveThreads
_ !Stack
_ !K
_ Reference
_ (SandboxingFailure Text
t) = do
  String -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die (String -> IO (Bool, HEnv, Stack, K))
-> String -> IO (Bool, HEnv, Stack, K)
forall a b. (a -> b) -> a -> b
$ String
"Attempted to use disallowed builtin in sandboxed environment: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
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 = String -> Text
Util.Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
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, String -> Text
Util.Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Pretty ColorText -> String
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)
          | Just (Panic String
msg Maybe Val
v) <- SomeException -> Maybe RuntimePanic
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn,
            Text
msg <- String -> Text
Util.Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"panic: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg =
              (Reference
Rf.miscFailureRef, Text
msg, Val -> Maybe Val -> Val
forall a. a -> Maybe a -> a
fromMaybe Val
unitValue Maybe Val
v)
          | Bool
otherwise = (Reference
Rf.miscFailureRef, SomeException -> Text
forall {a}. Show a => a -> Text
disp SomeException
exn, Val
unitValue)

-- | Evaluate a section
--
-- Note: both `env` and `henv` are intentionally not strict arguments.
-- It seems to be slower to unpack them into many arguments. `env` is
-- never modified, so this is no worry. `henv` is modified, but it is
-- immediately evaluated when created to avoid thunks building up, so
-- that it doesn't need to be a strict argument.
eval ::
  CCache ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Reference ->
  MSection ->
  IO ()
#ifdef STACK_CHECK
eval _ _ !_ !stk !_ !_ section
  | debugger stk "eval" section = undefined
#endif
eval :: CCache
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv !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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv 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 HEnv
henv !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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv 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 HEnv
henv !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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Reference
r MSection
nx
eval CCache
env HEnv
henv !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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv 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 HEnv
henv !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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv 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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv 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 HEnv
henv !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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env HEnv
henv 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 -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k
eval CCache
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (App Bool
ck GRef MComb
r Args
args) =
  CCache -> HEnv -> Stack -> GRef MComb -> IO Val
resolve CCache
env HEnv
henv 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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Bool
ck Args
args
eval CCache
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
_ (Call Bool
ck CombIx
combIx MComb
rcomb Args
args) =
  CCache
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> Bool
-> Args
-> MComb
-> IO ()
enter CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k (CombIx -> Reference
combRef CombIx
combIx) Bool
ck Args
args MComb
rcomb
eval CCache
env HEnv
henv !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
-> HEnv -> ActiveThreads -> Stack -> K -> Args -> Closure -> IO ()
jump CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Args
args
eval CCache
env HEnv
henv !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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval
    CCache
env
    HEnv
henv
    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 HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k Reference
r (Ins MInstr
i MSection
nx) = do
  CCache
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MInstr
-> IO (Bool, HEnv, Stack, K)
exec CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Reference
r MInstr
i IO (Bool, HEnv, Stack, K)
-> ((Bool, HEnv, 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, HEnv
henv, !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 -> do
          Val
eh <- HEnv -> IO Val
resolveExceptionHandler HEnv
henv
          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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
kk Bool
False (Int -> Args
VArg1 Int
0) Val
eh
      | Bool
otherwise -> CCache
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Reference
r MSection
nx
eval CCache
_ HEnv
_ !ActiveThreads
_ !Stack
_activeThreads !K
_ Reference
_ MSection
Exit = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
eval CCache
_ HEnv
_ !ActiveThreads
_ !Stack
_activeThreads !K
_ Reference
_ (Die String
s) = String -> IO ()
forall a. HasCallStack => String -> IO a
die String
s
{-# NOINLINE eval #-}

-- Note: denv shadows aenv always
resolveExceptionHandler :: HEnv -> IO Val
resolveExceptionHandler :: HEnv -> IO Val
resolveExceptionHandler (HEnv AEnv
aenv DEnv
denv)
  | Just Val
eh <- Word64 -> DEnv -> Maybe Val
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
TT.exceptionTag DEnv
denv = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
eh
  | Just (ARef IORef Closure
r) <- Word64 -> AEnv -> Maybe AffineRef
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
TT.exceptionTag AEnv
aenv =
      Closure -> Val
BoxedVal (Closure -> Val) -> IO Closure -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Closure -> IO Closure
forall a. IORef a -> IO a
readIORef IORef Closure
r
  -- should be impossible
  | Bool
otherwise = IO Val
forall a. HasCallStack => IO a
unhandledAbilityRequest
{-# INLINE resolveExceptionHandler #-}

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 = String -> IO a
forall a. HasCallStack => String -> a
error (String -> IO a) -> (String -> String) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuntimeExn -> String
forall a. Show a => a -> String
show (RuntimeExn -> String)
-> (String -> RuntimeExn) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> Pretty ColorText -> RuntimeExn
PE CallStack
HasCallStack => CallStack
callStack (Pretty ColorText -> RuntimeExn)
-> (String -> Pretty ColorText) -> String -> 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)
-> (String -> ColorText) -> String -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ColorText
forall a. IsString a => String -> a
fromString (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"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 ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Reference ->
  Bool ->
  Args ->
  MComb ->
  IO ()
enter :: CCache
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> Bool
-> Args
-> MComb
-> IO ()
enter CCache
env HEnv
henv !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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv 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 -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env HEnv
henv 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 -> String -> IO Stack
forall a. HasCallStack => String -> IO a
die (String -> IO Stack) -> String -> IO Stack
forall a b. (a -> b) -> a -> b
$ String
"naming non-function: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v
{-# INLINE name #-}

extendPAp :: Val -> Val -> IO Closure
extendPAp :: Val -> Val -> IO Closure
extendPAp (BoxedVal (PAp CombIx
cix GCombInfo MComb
comb (USeg
useg0, BSeg
bseg0))) Val
new = do
  MutableByteArray RealWorld
ucop <- Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray (Int -> IO (MutableByteArray (PrimState IO)))
-> Int -> IO (MutableByteArray (PrimState IO))
forall a b. (a -> b) -> a -> b
$ Int
ussz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8
  MutableByteArray (PrimState IO)
-> Int -> USeg -> Int -> Int -> IO ()
forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> USeg -> Int -> Int -> m ()
copyByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
ucop Int
8 USeg
useg0 Int
0 Int
ussz
  MutableByteArray (PrimState IO) -> Int -> Int -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
ucop Int
0 (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Val -> Int
getUnboxedVal Val
new
  USeg
useg <- MutableByteArray (PrimState IO) -> IO USeg
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m USeg
unsafeFreezeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
ucop

  MutableArray RealWorld Closure
bcop <- Int -> Closure -> IO (MutableArray (PrimState IO) Closure)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray (Int
bssz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Closure
BlackHole
  MutableArray (PrimState IO) Closure
-> Int -> BSeg -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> Array a -> Int -> Int -> m ()
copyArray MutableArray RealWorld Closure
MutableArray (PrimState IO) Closure
bcop Int
1 BSeg
bseg0 Int
0 Int
bssz
  MutableArray (PrimState IO) Closure -> Int -> Closure -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Closure
MutableArray (PrimState IO) Closure
bcop Int
0 (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Val -> Closure
getBoxedVal Val
new
  BSeg
bseg <- MutableArray (PrimState IO) Closure -> IO BSeg
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
unsafeFreezeArray MutableArray RealWorld Closure
MutableArray (PrimState IO) Closure
bcop

  pure $ CombIx -> GCombInfo MComb -> Seg -> Closure
PAp CombIx
cix GCombInfo MComb
comb (USeg
useg, BSeg
bseg)
  where
    ussz :: Int
ussz = USeg -> Int
sizeofByteArray USeg
useg0
    bssz :: Int
bssz = BSeg -> Int
forall a. Array a -> Int
sizeofArray BSeg
bseg0
extendPAp Val
v Val
_ =
  String -> IO Closure
forall a. HasCallStack => String -> IO a
die (String -> IO Closure) -> String -> IO Closure
forall a b. (a -> b) -> a -> b
$ String
"extendPAp: non partial application" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v
{-# INLINE extendPAp #-}

-- slow path application
apply ::
  CCache ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Bool ->
  Args ->
  Val ->
  IO ()
#ifdef STACK_CHECK
apply _env _henv !_activeThreads !stk !_k !_ck !args !val
  | debugger stk "apply" (args, val) = undefined
#endif
apply :: CCache
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env HEnv
henv !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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv 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 -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env HEnv
henv 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 -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k
      | Bool
otherwise = String -> IO ()
forall a. HasCallStack => String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"applying non-function: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v
{-# INLINE apply #-}

jump ::
  CCache ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Args ->
  Closure ->
  IO ()
jump :: CCache
-> HEnv -> ActiveThreads -> Stack -> K -> Args -> Closure -> IO ()
jump CCache
env HEnv
henv !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 -> HEnv -> K -> K -> IO ()
repush CCache
env ActiveThreads
activeThreads Stack
stk HEnv
henv K
sk K
k
  Closure
_ -> String -> IO ()
forall a. HasCallStack => String -> IO a
die String
"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 DEnv
denv K
k) =
      (Int
0, Int -> EnumSet Word64 -> DEnv -> K -> K
Mark (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Stack -> Int
asize Stack
stk) EnumSet Word64
rs DEnv
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 ->
  HEnv ->
  K ->
  K ->
  IO ()
repush :: CCache -> ActiveThreads -> Stack -> HEnv -> K -> K -> IO ()
repush CCache
env !ActiveThreads
activeThreads !Stack
stk (HEnv AEnv
aenv DEnv
denv0) = DEnv -> K -> K -> IO ()
go DEnv
denv0
  where
    go :: DEnv -> K -> K -> IO ()
go !DEnv
denv K
KE !K
k = CCache -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env (AEnv -> DEnv -> HEnv
HEnv AEnv
aenv DEnv
denv) ActiveThreads
activeThreads Stack
stk K
k
    go !DEnv
denv (Mark Int
a EnumSet Word64
ps DEnv
cs K
sk) !K
k = DEnv -> K -> K -> IO ()
go DEnv
denv' K
sk (K -> IO ()) -> K -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> EnumSet Word64 -> DEnv -> K -> K
Mark Int
a EnumSet Word64
ps DEnv
cs' K
k
      where
        denv' :: DEnv
denv' = DEnv
cs DEnv -> DEnv -> DEnv
forall a. Semigroup a => a -> a -> a
<> DEnv -> EnumSet Word64 -> DEnv
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.withoutKeys DEnv
denv EnumSet Word64
ps
        cs' :: DEnv
cs' = DEnv -> EnumSet Word64 -> DEnv
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys DEnv
denv EnumSet Word64
ps
    go !DEnv
denv (Push Int
n Int
a CombIx
cix Int
f MSection
rsect K
sk) !K
k =
      DEnv -> K -> K -> IO ()
go DEnv
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 !DEnv
_ (Local {}) !K
_ = String -> IO ()
forall a. HasCallStack => String -> IO a
die String
"repush: captured Local frame"
    go !DEnv
_ (AMark {}) !K
_ = String -> IO ()
forall a. HasCallStack => String -> IO a
die String
"repush: captured AMark frame"
    go !DEnv
_ (CB Callback
_) !K
_ = String -> IO ()
forall a. HasCallStack => String -> IO a
die String
"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
_ =
  String -> IO [Val]
forall a. HasCallStack => String -> a
error String
"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 =
  String -> IO (PackedTag, Stack)
forall a. HasCallStack => String -> IO a
die (String -> IO (PackedTag, Stack))
-> String -> IO (PackedTag, Stack)
forall a b. (a -> b) -> a -> b
$ String
"dumpDataValNoTag: unboxed val: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
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 ->
    String -> IO Stack
forall a. HasCallStack => String -> IO a
die (String -> IO Stack) -> String -> IO Stack
forall a b. (a -> b) -> a -> b
$
      String
"dumpDataNoTag: bad closure: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Closure -> String
forall a. Show a => a -> String
show Closure
clo
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Reference -> String) -> Maybe Reference -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Reference
r -> String
"\nexpected type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reference -> String
forall a. Show a => a -> String
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 ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  IO ()
yield :: CCache -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env HEnv
henv0 !ActiveThreads
activeThreads !Stack
stk = K -> IO ()
leap
  where
    leap :: K -> IO ()
leap (Mark Int
a EnumSet Word64
ps DEnv
cs K
k) | HEnv AEnv
aenv0 DEnv
denv0 <- HEnv
henv0 = do
      DEnv
denv <- DEnv -> IO DEnv
forall a. a -> IO a
evaluate (DEnv -> IO DEnv) -> DEnv -> IO DEnv
forall a b. (a -> b) -> a -> b
$ DEnv
cs DEnv -> DEnv -> DEnv
forall a. Semigroup a => a -> a -> a
<> DEnv -> EnumSet Word64 -> DEnv
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.withoutKeys DEnv
denv0 EnumSet Word64
ps
      let h :: Val
h = DEnv
denv0 DEnv -> 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
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ AEnv -> DEnv -> HEnv
HEnv AEnv
aenv0 DEnv
denv
      CCache
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Bool
False (Int -> Args
VArg1 Int
0) Val
h
    leap (AMark Int
a AEnv
aenv (ARef IORef Closure
r) K
k) = do
      Val
v <- (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek Stack
stk
      Val
h <- Closure -> Val
BoxedVal (Closure -> Val) -> IO Closure -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Closure -> IO Closure
forall a. IORef a -> IO a
readIORef IORef Closure
r
      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
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ AEnv -> DEnv -> HEnv
HEnv AEnv
aenv DEnv
forall a. Monoid a => a
mempty
      CCache
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Bool
False (Int -> Args
VArg1 Int
0) Val
h
    leap (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
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Reference
-> MSection
-> IO ()
eval CCache
env HEnv
henv0 ActiveThreads
activeThreads Stack
stk K
k Reference
ref MSection
nx
    leap (Local HEnv
henv Int
asz K
k) = do
      Stack
stk <- Stack -> Int -> Int -> IO Stack
restoreFrame Stack
stk Int
0 Int
asz
      CCache -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield CCache
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k
    leap (CB (Hook XStack -> IO ()
f)) = XStack -> IO ()
f (Stack -> XStack
unpackXStack Stack
stk)
    leap 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 {}) = String -> MSection
forall a. HasCallStack => String -> a
error String
"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 =
  String -> IO a
forall a. HasCallStack => String -> IO a
die (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$
    String
"dataBranch: bad closure: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Closure -> String
forall a. Show a => a -> String
show Closure
clo
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Reference -> String) -> Maybe Reference -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Reference
r -> String
"\nexpected type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reference -> String
forall a. Show a => a -> String
show Reference
r) Maybe Reference
mrf

dataBranchBranchError :: MBranch -> IO a
dataBranchBranchError :: forall a. GBranch MComb -> IO a
dataBranchBranchError GBranch MComb
br =
  String -> IO a
forall a. HasCallStack => String -> IO a
die (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"dataBranch: unexpected branch: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GBranch MComb -> String
forall a. Show a => a -> String
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 :: DEnv -> Stack -> K -> Word64 -> IO (Val, DEnv, Stack, K)
splitCont !DEnv
denv !Stack
stk !K
k !Word64
p =
  DEnv -> Int -> K -> K -> IO (Val, DEnv, Stack, K)
walk DEnv
denv Int
asz K
KE K
k
  where
    asz :: Int
asz = Stack -> Int
asize Stack
stk
    walk :: DEnv -> SZ -> K -> K -> IO (Val, DEnv, Stack, K)
    walk :: DEnv -> Int -> K -> K -> IO (Val, DEnv, Stack, K)
walk !DEnv
denv !Int
sz !K
ck K
KE =
      String -> IO Any
forall a. HasCallStack => String -> IO a
die String
"fell off stack" IO Any -> IO (Val, DEnv, Stack, K) -> IO (Val, DEnv, Stack, K)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DEnv -> Int -> Int -> K -> K -> IO (Val, DEnv, Stack, K)
finish DEnv
denv Int
sz Int
0 K
ck K
KE
    walk !DEnv
denv !Int
sz !K
ck (CB Callback
_) =
      String -> IO Any
forall a. HasCallStack => String -> IO a
die String
"fell off stack" IO Any -> IO (Val, DEnv, Stack, K) -> IO (Val, DEnv, Stack, K)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DEnv -> Int -> Int -> K -> K -> IO (Val, DEnv, Stack, K)
finish DEnv
denv Int
sz Int
0 K
ck K
KE
    walk !DEnv
denv !Int
sz !K
ck (Local {}) =
      String -> IO Any
forall a. HasCallStack => String -> IO a
die String
"splitCont: Local frame" IO Any -> IO (Val, DEnv, Stack, K) -> IO (Val, DEnv, Stack, K)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DEnv -> Int -> Int -> K -> K -> IO (Val, DEnv, Stack, K)
finish DEnv
denv Int
sz Int
0 K
ck K
KE
    walk !DEnv
denv !Int
sz !K
ck (AMark {}) =
      String -> IO Any
forall a. HasCallStack => String -> IO a
die String
"splitCont: AMark frame" IO Any -> IO (Val, DEnv, Stack, K) -> IO (Val, DEnv, Stack, K)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DEnv -> Int -> Int -> K -> K -> IO (Val, DEnv, Stack, K)
finish DEnv
denv Int
sz Int
0 K
ck K
KE
    walk !DEnv
denv !Int
sz !K
ck (Mark Int
a EnumSet Word64
ps DEnv
cs K
k)
      | Word64 -> EnumSet Word64 -> Bool
forall k. EnumKey k => k -> EnumSet k -> Bool
EC.member Word64
p EnumSet Word64
ps = DEnv -> Int -> Int -> K -> K -> IO (Val, DEnv, Stack, K)
finish DEnv
denv' Int
sz Int
a K
ck K
k
      | Bool
otherwise = DEnv -> Int -> K -> K -> IO (Val, DEnv, Stack, K)
walk DEnv
denv' (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a) (Int -> EnumSet Word64 -> DEnv -> K -> K
Mark Int
a EnumSet Word64
ps DEnv
cs' K
ck) K
k
      where
        denv' :: DEnv
denv' = DEnv
cs DEnv -> DEnv -> DEnv
forall a. Semigroup a => a -> a -> a
<> DEnv -> EnumSet Word64 -> DEnv
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.withoutKeys DEnv
denv EnumSet Word64
ps
        cs' :: DEnv
cs' = DEnv -> EnumSet Word64 -> DEnv
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys DEnv
denv EnumSet Word64
ps
    walk !DEnv
denv !Int
sz !K
ck (Push Int
n Int
a CombIx
br Int
p MSection
brSect K
k) =
      DEnv -> Int -> K -> K -> IO (Val, DEnv, Stack, K)
walk
        DEnv
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 :: DEnv -> SZ -> SZ -> K -> K -> IO (Val, DEnv, Stack, K)
    finish :: DEnv -> Int -> Int -> K -> K -> IO (Val, DEnv, Stack, K)
finish !DEnv
denv !Int
sz !Int
a !K
ck !K
k = do
      (Seg
seg, Stack
stk) <- Stack -> Int -> IO (Seg, Stack)
grabSeg 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, DEnv
denv, Stack
stk, K
k)
{-# INLINE splitCont #-}

abortCont ::
  Stack ->
  K ->
  AffineRef ->
  IO (AEnv, Stack, K)
abortCont :: Stack -> K -> AffineRef -> IO (AEnv, Stack, K)
abortCont !Stack
stk !K
k !AffineRef
r = Int -> K -> IO (AEnv, Stack, K)
walk (Stack -> Int
asize Stack
stk) K
k
  where
    walk :: SZ -> K -> IO (AEnv, Stack, K)
    walk :: Int -> K -> IO (AEnv, Stack, K)
walk !Int
sz = \case
      K
KE -> String -> IO (AEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die String
"abortCont: fell off stack"
      (CB Callback
_) -> String -> IO (AEnv, Stack, K)
forall a. HasCallStack => String -> IO a
die String
"abortCont: fell off stack"
      (Local HEnv
_ Int
a K
k) -> Int -> K -> IO (AEnv, Stack, K)
walk (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a) K
k
      (Push Int
n Int
a CombIx
_ Int
_ MSection
_ K
k) -> Int -> K -> IO (AEnv, Stack, K)
walk (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) K
k
      -- dynamic mark cannot match
      (Mark Int
a EnumSet Word64
_ DEnv
_ K
k) -> Int -> K -> IO (AEnv, Stack, K)
walk (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a) K
k
      (AMark Int
a AEnv
aenv AffineRef
s K
k)
        | AffineRef
r AffineRef -> AffineRef -> Bool
forall a. Eq a => a -> a -> Bool
== AffineRef
s -> AEnv -> Int -> Int -> K -> IO (AEnv, Stack, K)
finish AEnv
aenv Int
sz Int
a K
k
        | Bool
otherwise -> Int -> K -> IO (AEnv, Stack, K)
walk (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a) K
k

    finish :: AEnv -> SZ -> SZ -> K -> IO (AEnv, Stack, K)
    finish :: AEnv -> Int -> Int -> K -> IO (AEnv, Stack, K)
finish !AEnv
aenv !Int
sz !Int
a !K
k = do
      Stack
stk <- Stack -> Int -> IO Stack
truncateSeg Stack
stk Int
sz
      Stack
stk <- Stack -> Int -> IO Stack
adjustArgs Stack
stk Int
a
      pure (AEnv
aenv, Stack
stk, K
k)
{-# INLINE abortCont #-}

resolve :: CCache -> HEnv -> Stack -> MRef -> IO Val
resolve :: CCache -> HEnv -> Stack -> GRef MComb -> IO Val
resolve CCache
_ HEnv
_ Stack
_ (Env CombIx
cix MComb
mcomb) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CombIx -> MComb -> Val
mCombVal CombIx
cix MComb
mcomb)
resolve CCache
_ HEnv
_ Stack
stk (Stk Int
i) = (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
resolve CCache
env (HEnv AEnv
aenv DEnv
denv) Stack
_ (Dyn Word64
i)
  | Just Val
v <- Word64 -> DEnv -> Maybe Val
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i DEnv
denv = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
v
  | Just (ARef IORef Closure
r) <- Word64 -> AEnv -> Maybe AffineRef
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i AEnv
aenv = Closure -> Val
BoxedVal (Closure -> Val) -> IO Closure -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Closure -> IO Closure
forall a. IORef a -> IO a
readIORef IORef Closure
r
  | Bool
otherwise = String -> CCache -> Word64 -> IO Val
forall a. String -> CCache -> Word64 -> IO a
unhandledErr String
"resolve" CCache
env Word64
i
{-# INLINE resolve #-}

unhandledErr :: String -> CCache -> Word64 -> IO a
unhandledErr :: forall a. String -> CCache -> Word64 -> IO a
unhandledErr String
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 -> String -> IO a
bomb (Reference -> String
forall a. Show a => a -> String
show Reference
r)
    Maybe Reference
Nothing -> String -> IO a
bomb (Word64 -> String
forall a. Show a => a -> String
show Word64
i)
  where
    bomb :: String -> IO a
bomb String
sh = String -> IO a
forall a. HasCallStack => String -> IO a
die (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": unhandled ability request: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 -> String -> MComb
forall a. HasCallStack => String -> a
error (String -> MComb) -> String -> MComb
forall a b. (a -> b) -> a -> b
$ String
"unknown section `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` of combinator `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`. Reference: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reference -> String
forall a. Show a => a -> String
show Reference
r
    Maybe MCombs
Nothing -> String -> MComb
forall a. HasCallStack => String -> a
error (String -> MComb) -> String -> MComb
forall a b. (a -> b) -> a -> b
$ String
"unknown combinator `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`. Reference: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reference -> String
forall a. Show a => a -> String
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 (String -> Text
DTx.pack String
"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
_ -> String -> IO (Reference, Code)
forall a. HasCallStack => String -> IO a
die String
"decodeCacheArgument: Con reference"
  Val
_ -> String -> IO (Reference, Code)
forall a. HasCallStack => String -> IO a
die String
"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)

-- If this flag is set, all code is run through serialization before
-- loading. This renames variables, and it's possible a problem would
-- only be visible with the renamed variables. This allows testing
-- these cases just by rebuilding ucm, rather than actually concocting
-- a test that involves remote code loading.
#if defined(CODE_SERIAL_CHECK)

normalizeCode :: Code -> Code
normalizeCode co = case deserializeCode (serializeCode False co) of
  Left _ -> error "normalizeCode: impossible"
  Right co -> co

normalizeCodes :: [(Reference, Code)] -> [(Reference, Code)]
normalizeCodes = fmap $ second normalizeCode

#else

normalizeCodes :: [(Reference, Code)] -> [(Reference, Code)]
normalizeCodes :: [(Reference, Code)] -> [(Reference, Code)]
normalizeCodes = [(Reference, Code)] -> [(Reference, Code)]
forall a. a -> a
id

#endif

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)] -> [(Reference, Code)]
normalizeCodes -> [(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 rs :: [Reference]
rs = Map Reference (SuperGroup Symbol) -> [Reference]
forall k a. Map k a -> [k]
M.keys Map Reference (SuperGroup Symbol)
new
    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)
    let 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
        haff :: (Map Reference (SuperGroup v), OptInfos v)
-> (Map Reference (SuperGroup v), OptInfos v)
haff (Map Reference (SuperGroup v)
cmbs, OptInfos v
opts) =
          ((Reference -> SuperGroup v -> SuperGroup v)
-> Map Reference (SuperGroup v) -> Map Reference (SuperGroup v)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey (OptInfos v -> Reference -> SuperGroup v -> SuperGroup v
forall v.
Var v =>
OptInfos v -> Reference -> SuperGroup v -> SuperGroup v
ANF.optimizeHandler OptInfos v
opts) Map Reference (SuperGroup v)
cmbs, OptInfos v
opts)
    Map Reference (SuperGroup Symbol)
opt <-
      TVar (OptInfos Symbol)
-> (OptInfos Symbol
    -> (Map Reference (SuperGroup Symbol), OptInfos Symbol))
-> STM (Map Reference (SuperGroup Symbol))
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar (CCache -> TVar (OptInfos Symbol)
optInfos CCache
cc) ((OptInfos Symbol
  -> (Map Reference (SuperGroup Symbol), OptInfos Symbol))
 -> STM (Map Reference (SuperGroup Symbol)))
-> (OptInfos Symbol
    -> (Map Reference (SuperGroup Symbol), OptInfos Symbol))
-> STM (Map Reference (SuperGroup Symbol))
forall a b. (a -> b) -> a -> b
$ (Map Reference (SuperGroup Symbol), OptInfos Symbol)
-> (Map Reference (SuperGroup Symbol), OptInfos Symbol)
forall {v}.
Var v =>
(Map Reference (SuperGroup v), OptInfos v)
-> (Map Reference (SuperGroup v), OptInfos v)
haff ((Map Reference (SuperGroup Symbol), OptInfos Symbol)
 -> (Map Reference (SuperGroup Symbol), OptInfos Symbol))
-> (OptInfos Symbol
    -> (Map Reference (SuperGroup Symbol), OptInfos Symbol))
-> OptInfos Symbol
-> (Map Reference (SuperGroup Symbol), OptInfos Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Reference (SuperGroup Symbol)
-> OptInfos Symbol
-> (Map Reference (SuperGroup Symbol), OptInfos Symbol)
forall v.
Var v =>
Map Reference (SuperGroup v)
-> OptInfos v -> (Map Reference (SuperGroup v), OptInfos v)
ANF.optimize ((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)
new)
    Map Reference Word64
rty <- TVar Word64
-> TVar (Map Reference Word64)
-> TVar (EnumMap Word64 Reference)
-> Set Reference
-> STM (Map Reference Word64)
addRefs (CCache -> TVar Word64
freshTy CCache
cc) (CCache -> TVar (Map Reference Word64)
refTy CCache
cc) (CCache -> TVar (EnumMap Word64 Reference)
tagRefs CCache
cc) Set Reference
ntys0
    Word64
ntm <- TVar Word64 -> (Word64 -> (Word64, Word64)) -> STM Word64
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar (CCache -> TVar Word64
freshTm CCache
cc) ((Word64 -> (Word64, Word64)) -> STM Word64)
-> (Word64 -> (Word64, Word64)) -> STM Word64
forall a b. (a -> b) -> a -> b
$ \Word64
i -> (Word64
i, Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
sz)
    Map Reference Word64
rtm <- Map Reference Word64
-> TVar (Map Reference Word64) -> STM (Map Reference Word64)
forall s. Semigroup s => s -> TVar s -> STM s
updateMap ([(Reference, Word64)] -> Map Reference Word64
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Reference, Word64)] -> Map Reference Word64)
-> [(Reference, Word64)] -> Map Reference Word64
forall a b. (a -> b) -> a -> b
$ [Reference] -> [Word64] -> [(Reference, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Reference]
rs [Word64
ntm ..]) (CCache -> TVar (Map Reference Word64)
refTm CCache
cc)
    -- check for missing references
    let 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
        rns :: RefNums
rns = (Reference -> Word64)
-> (Reference -> Word64) -> (Reference -> Maybe Int) -> RefNums
RN (String -> Map Reference Word64 -> Reference -> Word64
refLookup String
"ty" Map Reference Word64
rty) (String -> Map Reference Word64 -> Reference -> Word64
refLookup String
"tm" Map Reference Word64
rtm) ((Reference -> Map Reference Int -> Maybe Int)
-> Map Reference Int -> Reference -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference -> Map Reference Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map Reference Int
arities)
        combinate :: Word64 -> (Reference, SuperGroup Symbol) -> (Word64, EnumMap Word64 Comb)
        combinate :: Word64
-> (Reference, SuperGroup Symbol) -> (Word64, GCombs Void CombIx)
combinate Word64
n (Reference
r, SuperGroup Symbol
g) = (Word64
n, RefNums
-> Reference -> Word64 -> SuperGroup Symbol -> GCombs Void CombIx
forall v.
Var v =>
RefNums
-> Reference -> Word64 -> SuperGroup v -> GCombs Void CombIx
emitCombs RefNums
rns Reference
r Word64
n SuperGroup Symbol
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 ..] (Map Reference (SuperGroup Symbol)
-> [(Reference, SuperGroup Symbol)]
forall k a. Map k a -> [(k, a)]
M.toList Map Reference (SuperGroup Symbol)
opt)
          (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 -> String
P.toPlainUnbroken -> String
msg)) =
  String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
sdbx1 String
msg Bool -> Bool -> Bool
|| String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
sdbx2 String
msg
  where
    sdbx1 :: String
sdbx1 = String
"attempted to use sandboxed operation"
    sdbx2 :: String
sdbx2 = String
"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 ::
  CCache -> EnumMap Word64 Reference -> Val -> IO ANF.Value
reflectValue :: CCache -> EnumMap Word64 Reference -> Val -> IO Value
reflectValue CCache
env EnumMap Word64 Reference
rty = Val -> IO Value
goV0
  where
    err :: String -> String -> String
err String
s String
v =
      String
"reflectValue: cannot prepare value for serialization: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\nSerialized value:\n\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v

    refTy :: Word64 -> Either String 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 -> Either String Reference
forall a b. b -> Either a b
Right Reference
r
      | Bool
otherwise = String -> Either String Reference
forall a b. a -> Either a b
Left String
"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

    goV0 :: Val -> IO ANF.Value
    goV0 :: Val -> IO Value
goV0 Val
v = case Val -> Either String Value
goV Val
v of
      Right Value
rv -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
rv
      Left String
problem -> String -> IO Value
forall a. HasCallStack => String -> IO a
die (String -> IO Value) -> String -> IO Value
forall a b. (a -> b) -> a -> b
$ String -> String -> String
err String
problem String
rendered
      where
        rendered :: String
rendered = case CCache -> Bool -> Val -> Tracer
tracer CCache
env Bool
False Val
v of
          Tracer
NoTrace -> Val -> String
forall a. Show a => a -> String
show Val
v
          MsgTrace String
_ String
_ String
pre -> String
pre
          SimpleTrace String
ugl -> String
ugl

    goV :: Val -> Either String ANF.Value
    goV :: Val -> Either String 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 -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (BLit -> Value) -> BLit -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> Either String Value) -> BLit -> Either String 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 -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (BLit -> Value) -> BLit -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> Either String Value) -> BLit -> Either String 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 -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (BLit -> Value) -> BLit -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> Either String Value) -> BLit -> Either String 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 -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (BLit -> Value) -> BLit -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> Either String Value) -> BLit -> Either String Value
forall a b. (a -> b) -> a -> b
$ Double -> BLit
ANF.Float Double
f
      CharVal Char
c -> Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (BLit -> Value) -> BLit -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> Either String Value) -> BLit -> Either String Value
forall a b. (a -> b) -> a -> b
$ Char -> BLit
ANF.Char Char
c
      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) -> Either String ValList -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> Either String Value) -> [Val] -> Either String 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 -> Either String 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) -> Either String ValList -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> Either String Value) -> [Val] -> Either String 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 -> Either String Value
goV [Val]
segs
          (CapV K
k Int
_ [Val]
segs) ->
            ValList -> Cont -> Value
ANF.Cont (ValList -> Cont -> Value)
-> Either String ValList -> Either String (Cont -> Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> Either String Value) -> [Val] -> Either String 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 -> Either String Value
goV [Val]
segs Either String (Cont -> Value)
-> Either String Cont -> Either String Value
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> K -> Either String 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 -> Either String Value
goV (Val -> Either String Value)
-> (Closure -> Val) -> Closure -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
BoxedVal (Closure -> Either String Value) -> Closure -> Either String 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) -> Either String BLit -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Foreign -> Either String BLit
goF Foreign
f
          Closure
BlackHole -> String -> Either String Value
forall a b. a -> Either a b
Left String
"black hole"
          UnboxedTypeTag {} -> String -> Either String Value
forall a b. a -> Either a b
Left String
"unknown unboxed value"
          Affine {} -> String -> Either String Value
forall a b. a -> Either a b
Left String
"affine info"

    goK :: K -> Either String Cont
goK (CB Callback
_) = String -> Either String Cont
forall a b. a -> Either a b
Left String
"callback continuation"
    goK (Local {}) = String -> Either String Cont
forall a b. a -> Either a b
Left String
"captured Local frame"
    goK (AMark {}) = String -> Either String Cont
forall a b. a -> Either a b
Left String
"captured AMark frame"
    goK K
KE = Cont -> Either String Cont
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cont
ANF.KE
    goK (Mark Int
a EnumSet Word64
ps DEnv
de K
k) = do
      [Reference]
ps <- (Word64 -> Either String Reference)
-> [Word64] -> Either String [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 -> Either String Reference
refTy (EnumSet Word64 -> [Word64]
forall k. EnumKey k => EnumSet k -> [k]
EC.setToList EnumSet Word64
ps)
      [(Reference, Value)]
de <- ((Word64, Val) -> Either String (Reference, Value))
-> [(Word64, Val)] -> Either String [(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))
-> Either String Reference
-> Either String (Value -> (Reference, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Either String Reference
refTy Word64
k Either String (Value -> (Reference, Value))
-> Either String Value -> Either String (Reference, Value)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> Either String Value
goV Val
v) (DEnv -> [(Word64, Val)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList DEnv
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) -> Either String Cont -> Either String Cont
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K -> Either String 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) -> Either String Cont -> Either String Cont
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K -> Either String Cont
goK K
k

    goF :: Foreign -> Either String BLit
goF Foreign
f
      | Just Text
t <- Foreign -> Maybe Text
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f =
          BLit -> Either String BLit
forall a. a -> Either String 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 -> Either String BLit
forall a. a -> Either String 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)
-> Either String (Seq Value) -> Either String BLit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> Either String Value) -> USeq -> Either String (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 -> Either String Value
goV USeq
s
      | Just Referent
l <- Reference -> Foreign -> Maybe Referent
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.termLinkRef Foreign
f =
          BLit -> Either String BLit
forall a. a -> Either String 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 -> Either String BLit
forall a. a -> Either String 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 -> Either String BLit
forall a. a -> Either String 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 -> Either String BLit
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code -> BLit
ANF.Code Code
g)
      | Just USeg
a <- Reference -> Foreign -> Maybe USeg
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.ibytearrayRef Foreign
f =
          BLit -> Either String BLit
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (USeg -> BLit
ANF.BArr USeg
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)
-> Either String (Array Value) -> Either String BLit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> Either String Value)
-> Array Val -> Either String (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 -> Either String Value
goV Array Val
a
      | Bool
otherwise = String -> Either String BLit
forall a b. a -> Either a b
Left String
"foreign value"

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 :: String -> String
err String
s = String
"reifyValue: cannot restore value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 = String -> IO Word64
forall a. HasCallStack => String -> IO a
die (String -> IO Word64) -> (String -> String) -> String -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
err (String -> IO Word64) -> String -> IO Word64
forall a b. (a -> b) -> a -> b
$ String
"unknown type reference: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reference -> String
forall a. Show a => a -> String
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 = String -> IO Word64
forall a. HasCallStack => String -> IO a
die (String -> IO Word64) -> (String -> String) -> String -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
err (String -> IO Word64) -> String -> IO Word64
forall a b. (a -> b) -> a -> b
$ String
"unknown term reference: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reference -> String
forall a. Show a => a -> String
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 -> String -> IO Val
forall a. HasCallStack => String -> IO a
die (String -> IO Val) -> (String -> String) -> String -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
err (String -> IO Val) -> String -> IO Val
forall a b. (a -> b) -> a -> b
$ String
msg
          where
            msg :: String
msg = String
"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 -> DEnv -> 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)] -> DEnv
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
_) ->
          String -> IO K
forall a. HasCallStack => String -> IO a
die (String -> IO K) -> (String -> String) -> String -> IO K
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
err (String -> IO K) -> String -> IO K
forall a b. (a -> b) -> a -> b
$
            String
"tried to reify a continuation with a cached value resumption"
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reference -> String
forall a. Show a => a -> String
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 USeg
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 -> USeg -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.ibytearrayRef USeg
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