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

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

import Control.Concurrent (ThreadId)
import Control.Concurrent qualified as Conc
import Control.Concurrent.STM as STM
import Control.Exception
import Control.Lens
import Control.Monad.State.Strict
import Data.Atomics qualified as Atomic
import Data.HashMap.Lazy qualified as HM
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Map.Strict qualified as M
import Data.Map.Strict.Internal qualified as M
import Data.Sequence qualified as Seq
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 Foreign.Concurrent qualified as CFPtr
import Foreign.LibFFI.Internal
import Foreign.Marshal (alloca)
import Foreign.Marshal.Array (allocaArray)
import Foreign.Ptr
import Foreign.Storable qualified as Store
import GHC.Conc as STM (unsafeIOToSTM)
import GHC.Float (double2Float, float2Double)
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),
    showShort,
  )
import Unison.Referent (Referent, pattern Ref)
import Unison.ReferentPrime (Referent' (..))
import Unison.Runtime.ANF as ANF
  ( Cacheability (..),
    Code (..),
    PackedTag (..),
    SuperGroup,
    codeGroup,
    collectValueLinks,
    foldGroup,
    foldGroupLinks,
    maskTags,
    packTags,
  )
import Unison.Runtime.ANF qualified as ANF
import Unison.Runtime.ANF.Optimize qualified as ANF
import Unison.Runtime.JIT (initialNativeCount, jitCompileGroup, jitConfig, jitExits, jitFrames, jitPool, jitRequestCell, jitRequestGroup, jitStats, jitTracing, noteAdHocExit, noteOutput, printJITStats, registerTypeNumbers, stackSlots)
import Unison.Runtime.JIT.Config qualified as JIT
import Unison.Runtime.JIT.Exits
import Unison.Runtime.JIT.Frames
import Unison.Runtime.JIT.Native
import Unison.Runtime.JIT.Pool (currentPool)
import Unison.Util.Deque qualified as Sq
import Unsafe.Coerce (unsafeCoerce)
#ifdef CODE_SERIAL_CHECK
import Unison.Runtime.ANF.Serialize (serializeCode, deserializeCode)
#endif
import Data.Text qualified as Text
import Data.Vector qualified as V
import Unison.Runtime.Array as PA
import Unison.Runtime.Builtin hiding (unitValue)
import Unison.Runtime.Exception (RuntimeExn (BU, PE), die, exn)
import Unison.Runtime.Foreign.Callback qualified as Callback
import Unison.Runtime.Foreign.Dynamic qualified as DLL
import Unison.Runtime.Foreign.Function
  ( decodeVal,
    encodeVal,
    foreignCall,
    functionReplacements,
    functionUnreplacements,
    pseudoConstructors,
    writeBack,
  )
import Unison.Runtime.MCode
import Unison.Runtime.Machine.Primops
import Unison.Runtime.Machine.Types
import Unison.Runtime.Profiling
import Unison.Runtime.Referenced
import Unison.Runtime.Stack
import Unison.Runtime.TypeTags qualified as TT
import Unison.Symbol (Symbol)
import Unison.Type qualified as Rf
import Unison.Util.BiMap qualified as BM
import Unison.Util.Bytes qualified as Bytes
import Unison.Util.EnumContainers as EC
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
#endif

#ifdef OPT_CHECK
import Test.Inspection qualified as TI
#endif

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

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

-- Entry point for evaluating a section
eval0 ::
  (RuntimeProfiler p) => CCache p -> ActiveThreads -> MSection -> IO ()
eval0 :: forall p.
RuntimeProfiler p =>
CCache p -> ActiveThreads -> MSection -> IO ()
eval0 CCache p
env !ActiveThreads
activeThreads !MSection
co = do
  Stack
stk <- Int -> IO Stack
alloc (JIT -> Int
stackSlots (CCache p -> JIT
forall prof. CCache prof -> JIT
jit CCache p
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 p -> TVar (EnumMap Word64 MCombs)
forall prof. CCache prof -> TVar (EnumMap Word64 MCombs)
combs CCache p
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 p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTy CCache p
env)
    Map Reference Word64
rfTm <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache p
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
  (Ticker p
tick, IO ()
cancelTicks) <- p -> IO (Ticker p, IO ())
forall prof.
RuntimeProfiler prof =>
prof -> IO (Ticker prof, IO ())
startTicker (p -> IO (Ticker p, IO ())) -> p -> IO (Ticker p, IO ())
forall a b. (a -> b) -> a -> b
$ CCache p -> p
forall prof. CCache prof -> prof
profiler CCache p
env
  Ticker p
-> CCache p
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker p
tick CCache p
env HEnv
henv ActiveThreads
activeThreads Stack
stk (K -> K
k K
KE) (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
dummyRef Word64
0 Word64
0) MSection
co
    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
cancelTicks
{-# SPECIALIZE eval0 ::
  CCache () -> ActiveThreads -> MSection -> IO ()
  #-}
{-# SPECIALIZE eval0 ::
  CCache ProfileComm -> ActiveThreads -> MSection -> IO ()
  #-}

mCombVal :: CombIx -> MComb -> Val
mCombVal :: CombIx -> RComb Val -> Val
mCombVal CombIx
cix (RComb (Comb GCombInfo (RComb Val)
comb)) =
  Closure -> Val
BoxedVal (CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp CombIx
cix GCombInfo (RComb Val)
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 <- FieldName -> Reference
forall t h. t -> Reference' t h
Builtin ([Char] -> FieldName
DTx.pack [Char]
"raise"),
    Just Word64
j <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
rcrf Map Reference Word64
rfTm,
    CombIx
cix <- Reference -> Word64 -> Word64 -> CombIx
CIx Reference
rcrf Word64
j Word64
0,
    Val
clo <- CombIx -> RComb Val -> Val
mCombVal CombIx
cix (RComb Val -> Val) -> RComb Val -> Val
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 MCombs -> CombIx -> RComb Val
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
emptyAEnv, 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
emptyDEnv) ((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 ::
  (RuntimeProfiler p) =>
  Maybe (XStack -> IO ()) ->
  CCache p ->
  ActiveThreads ->
  Word64 ->
  IO ()
apply0 :: forall p.
RuntimeProfiler p =>
Maybe (XStack -> IO ())
-> CCache p -> ActiveThreads -> Word64 -> IO ()
apply0 !Maybe (XStack -> IO ())
callback CCache p
env !ActiveThreads
threadTracker !Word64
i = do
  Stack
stk <- Int -> IO Stack
alloc (JIT -> Int
stackSlots (CCache p -> JIT
forall prof. CCache prof -> JIT
jit CCache p
env))
  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 p -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
combRefs CCache p
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 p -> TVar (EnumMap Word64 MCombs)
forall prof. CCache prof -> TVar (EnumMap Word64 MCombs)
combs CCache p
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 p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTy CCache p
env)
    Map Reference Word64
rfTm <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache p
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 -> [Word] -> [Char] -> IO Reference
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"apply0: missing reference to entry point"
  let entryCix :: CombIx
entryCix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
r Word64
i Word64
0)
  case RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb (RComb Val -> GComb Val (RComb Val))
-> RComb Val -> GComb Val (RComb Val)
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 MCombs -> CombIx -> RComb Val
rCombSection EnumMap Word64 MCombs
cmbs CombIx
entryCix of
    Comb GCombInfo (RComb Val)
entryComb -> do
      (Ticker p
tick, IO ()
cancelTicks) <- p -> IO (Ticker p, IO ())
forall prof.
RuntimeProfiler prof =>
prof -> IO (Ticker prof, IO ())
startTicker (p -> IO (Ticker p, IO ())) -> p -> IO (Ticker p, IO ())
forall a b. (a -> b) -> a -> b
$ CCache p -> p
forall prof. CCache prof -> prof
profiler CCache p
env
      Ticker p
-> CCache p
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply
        Ticker p
tick
        CCache p
env
        HEnv
henv
        ActiveThreads
threadTracker
        Stack
stk
        (K -> K
kf K
k0)
        Bool
True
        Args
ZArgs
        (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp CombIx
entryCix GCombInfo (RComb Val)
entryComb Seg
nullSeg)
        IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
cancelTicks
    -- 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 -> DebugCallStack => 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)
{-# SPECIALIZE apply0 ::
  Maybe (XStack -> IO ()) ->
  CCache () ->
  ActiveThreads ->
  Word64 ->
  IO ()
  #-}
{-# SPECIALIZE apply0 ::
  Maybe (XStack -> IO ()) ->
  CCache ProfileComm ->
  ActiveThreads ->
  Word64 ->
  IO ()
  #-}

-- Apply helper currently used for forking. Creates the new stacks
-- necessary to evaluate a closure with the provided information.
apply1 ::
  (RuntimeProfiler p) =>
  (Stack -> IO ()) ->
  CCache p ->
  ActiveThreads ->
  Val ->
  IO ()
apply1 :: forall p.
RuntimeProfiler p =>
(Stack -> IO ()) -> CCache p -> ActiveThreads -> Val -> IO ()
apply1 Stack -> IO ()
callback CCache p
env ActiveThreads
threadTracker Val
clo = do
  Stack
stk <- Int -> IO Stack
alloc (JIT -> Int
stackSlots (CCache p -> JIT
forall prof. CCache prof -> JIT
jit CCache p
env))
  (Ticker p
tick, IO ()
cancelTicks) <- p -> IO (Ticker p, IO ())
forall prof.
RuntimeProfiler prof =>
prof -> IO (Ticker prof, IO ())
startTicker (p -> IO (Ticker p, IO ())) -> p -> IO (Ticker p, IO ())
forall a b. (a -> b) -> a -> b
$ CCache p -> p
forall prof. CCache prof -> prof
profiler CCache p
env
  Ticker p
-> CCache p
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply Ticker p
tick CCache p
env (AEnv -> DEnv -> HEnv
HEnv AEnv
emptyAEnv DEnv
emptyDEnv) ActiveThreads
threadTracker Stack
stk K
k0 Bool
True Args
ZArgs Val
clo
    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
cancelTicks
  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
$ Text -> Closure
TextC Text
t
  MM Referent
r -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (Referent -> Foreign
WrapReferent Referent
r)
  MY Reference
r -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (Reference -> Foreign
WrapReference 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 ::
  (RuntimeProfiler prof) =>
  CCache prof ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  CombIx ->
  MInstr ->
  IO (Bool, HEnv, Stack, K)
#ifdef STACK_CHECK
exec _ _ !_ !stk !_ !_ instr
  | debugger stk "exec" instr = undefined
#endif
exec :: forall prof.
RuntimeProfiler prof =>
CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MInstr
-> IO (Bool, HEnv, Stack, K)
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Info [Char]
tx) = do
  [Char] -> Stack -> IO ()
forall a. Show a => [Char] -> a -> IO ()
info [Char]
tx Stack
stk
  [Char] -> K -> IO ()
forall a. Show a => [Char] -> a -> IO ()
info [Char]
tx K
k
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Name GRef (RComb Val)
r Args
args) = do
  Val
v <- CCache prof -> HEnv -> Stack -> GRef (RComb Val) -> IO Val
forall p. CCache p -> HEnv -> Stack -> GRef (RComb Val) -> IO Val
resolve CCache prof
env HEnv
henv Stack
stk GRef (RComb Val)
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 prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (SetAff Bool
u Int
i Int
j) =
  DebugCallStack => 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
      DebugCallStack => 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
_ -> [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"SetAff called with bad handler reference"
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (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
  DebugCallStack => 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 prof
_ HEnv
_henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Discard Int
i) = do
  DebugCallStack => 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
emptyDEnv
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
    Closure
_ -> [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"Discard called with bad handler reference"
exec CCache prof
_env HEnv
henv0 !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (InLocal Int
i) = do
  DebugCallStack => 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
emptyDEnv
      pure (Bool
False, HEnv
henv, Stack
stk, HEnv -> Int -> K -> K
Local HEnv
henv0 Int
a K
k)
    Closure
v -> [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (Bool, HEnv, Stack, K))
-> [Char] -> IO (Bool, HEnv, Stack, K)
forall a b. (a -> b) -> a -> b
$ [Char]
"InLocal called with bad handler reference\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
v
exec CCache prof
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Prim1 Prim1
CACH Int
i)
  | CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env = [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"attempted to use sandboxed operation: cache"
  | Bool
otherwise = do
      USeq
arg <- Stack -> Int -> IO USeq
peekOffS Stack
stk Int
i
      [(Reference, Code Reference)]
news <- USeq -> IO [(Reference, Code Reference)]
decodeCacheArgument USeq
arg
      [Reference]
unknown <- [(Reference, Code Reference)] -> CCache prof -> IO [Reference]
forall p.
RuntimeProfiler p =>
[(Reference, Code Reference)] -> CCache p -> IO [Reference]
cacheAdd [(Reference, Code Reference)]
news CCache prof
env
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack -> USeq -> IO ()
pokeS
        Stack
stk
        ([Val] -> USeq
forall a. [a] -> Deque a
Sq.fromList ([Val] -> USeq) -> [Val] -> USeq
forall a b. (a -> b) -> a -> b
$ Referent -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Referent -> Val) -> (Reference -> Referent) -> Reference -> Val
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 prof
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Prim1 Prim1
LOAD Int
i)
  | CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env = [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"attempted to use sandboxed operation: load"
  | Bool
otherwise = do
      Referenced Value
v <- Stack -> Int -> IO (Referenced 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 prof -> Referenced Value -> IO (Either [Reference] Val)
forall p.
CCache p -> Referenced Value -> IO (Either [Reference] Val)
reifyValue CCache prof
env Referenced 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] -> Deque a
Sq.fromList ([Val] -> USeq) -> [Val] -> USeq
forall a b. (a -> b) -> a -> b
$
              Referent -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Referent -> Val) -> (Reference -> Referent) -> Reference -> Val
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
          DebugCallStack => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
        Right Val
x -> do
          DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
x
          DebugCallStack => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Prim1 Prim1
VALU Int
i) = do
  Val
c <- DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> Referenced Value -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk (Referenced Value -> IO ()) -> IO (Referenced Value) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CCache prof -> Val -> IO (Referenced Value)
forall p. CCache p -> Val -> IO (Referenced Value)
reflectValue CCache prof
env Val
c
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Prim1 Prim1
op Int
i) = do
  Stack
stk <- CCache prof -> Stack -> Prim1 -> Int -> IO Stack
forall p. CCache p -> Stack -> Prim1 -> Int -> IO Stack
prim1 CCache prof
env Stack
stk Prim1
op Int
i
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
_ !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
cix (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 <- DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  () <- RuntimeExn -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (RuntimeExn -> IO ()) -> RuntimeExn -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Reference, Int)] -> FieldName -> Val -> RuntimeExn
BU (Reference -> K -> [(Reference, Int)]
traceK Reference
r K
k) (Text -> FieldName
Util.Text.toText Text
name) Val
x
  [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Char] -> a
error [Char]
"throwIO should never return"
  where
    r :: Reference
r = CombIx -> Reference
combRef CombIx
cix
exec CCache prof
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Prim2 Prim2
TRCE Int
i Int
j)
  | CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env = (Bool, HEnv, Stack, K) -> IO (Bool, HEnv, Stack, K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, HEnv
henv, Stack
stk, K
k)
  | Bool
otherwise = do
      Text
tx <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
      Val
clo <- DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
      case CCache prof -> Bool -> Val -> Tracer
forall prof. CCache prof -> Bool -> Val -> Tracer
tracer CCache prof
env Bool
True Val
clo of
        Tracer
NoTrace -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        SimpleTrace [Char]
str -> do
          [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"trace: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Util.Text.unpack Text
tx
          [Char] -> IO ()
putStrLn [Char]
str
        MsgTrace [Char]
msg [Char]
ugl [Char]
pre -> do
          [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"trace: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Util.Text.unpack Text
tx
          [Char] -> IO ()
putStrLn [Char]
""
          [Char] -> IO ()
putStrLn [Char]
msg
          [Char] -> IO ()
putStrLn [Char]
"\nraw structure:\n"
          [Char] -> IO ()
putStrLn [Char]
ugl
          [Char] -> IO ()
putStrLn [Char]
"partial decompilation:\n"
          [Char] -> IO ()
putStrLn [Char]
pre
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
_trackThreads !Stack
stk !K
k CombIx
_ (Prim2 Prim2
op Int
i Int
j) = do
  Stack
stk <- CCache prof -> Stack -> Prim2 -> Int -> Int -> IO Stack
forall p. CCache p -> Stack -> Prim2 -> Int -> Int -> IO Stack
primxx CCache prof
env Stack
stk Prim2
op Int
i Int
j
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (RefCAS Int
refI Int
ticketI Int
valI)
  | CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env = [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"attempted to use sandboxed operation: Ref.cas"
  | Bool
otherwise = do
      (IORef Val
ref :: IORef Val) <- Stack -> Int -> IO (IORef Val)
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
refI
      -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it
      -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal
      -- forcing of the values and tickets.
      !(Ticket Val
ticket :: Atomic.Ticket Val) <- Stack -> Int -> IO (Ticket Val)
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
ticketI
      Val
v <- DebugCallStack => 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
      DebugCallStack => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk Bool
r
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (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
  DebugCallStack => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk Closure
clo
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (RecPack RecordShape
shape Args
args) = do
  Closure
clo <- Stack -> RecordShape -> Args -> IO Closure
buildRec Stack
stk RecordShape
shape Args
args
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  DebugCallStack => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk Closure
clo
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (RecUnpack Vector FieldRef
desiredFields Int
recIndex) = do
  DebugCallStack => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
recIndex 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
    RecordG RecordShape
shape RecordVals
vals -> do
      -- The slot a field sits in depends on the *value's* shape, not the
      -- pattern's: one pattern matches records of several shapes, in which a
      -- given field may sit at a different slot.
      let seg :: Seg
seg =
            Vector FieldRef -> [FieldRef]
forall a. Vector a -> [a]
V.toList Vector FieldRef
desiredFields
              [FieldRef] -> (FieldRef -> Val) -> [Val]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\FieldRef
f -> RecordVals
vals RecordVals -> Int -> Val
forall a. Vector a -> Int -> a
V.! RecordShape -> FieldRef -> Int
shapeSlot RecordShape
shape FieldRef
f)
              [Val] -> ([Val] -> Seg) -> Seg
forall a b. a -> (a -> b) -> b
& [Val] -> Seg
segFromList
      Stack
stk' <- Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
S
      pure (Bool
False, HEnv
henv, Stack
stk', K
k)
    Closure
_ -> [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"RecUnpack called on non-record value"
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (RecSet FieldRef
field Args
args) = do
  case Args
args of
    VArg2 Int
recI Int
valI -> do
      Closure
rv <- DebugCallStack => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
recI
      Val
nv <- DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
valI
      case Closure
rv of
        RecordG RecordShape
shape RecordVals
vals -> do
          -- The value's own shape says which slot the field sits in.
          let pos :: Int
pos = RecordShape -> FieldRef -> Int
shapeSlot RecordShape
shape FieldRef
field
          Stack
stk <- Stack -> IO Stack
bump Stack
stk
          DebugCallStack => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ())
-> (RecordVals -> Closure) -> RecordVals -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordShape -> RecordVals -> Closure
RecordG RecordShape
shape (RecordVals -> IO ()) -> RecordVals -> IO ()
forall a b. (a -> b) -> a -> b
$ RecordVals
vals RecordVals -> [(Int, Val)] -> RecordVals
forall a. Vector a -> [(Int, a)] -> Vector a
V.// [(Int
pos, Val
nv)]
          pure (Bool
False, HEnv
henv, Stack
stk, K
k)
        Closure
_ -> [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"RecSet called on non-record value"
    Args
_ -> [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"RecSet called with unexpected arguments"
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Print Int
i) = do
  Text
t <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  FieldName -> IO ()
Tx.putStrLn (Text -> FieldName
Util.Text.toText Text
t)
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Lit MLit
ml) = do
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  DebugCallStack => 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 prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (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 <- DebugCallStack => 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
          -- evaluated: the JIT's handler code reads it from the stack
          !aff :: Closure
aff = EnumSet Word64 -> AEnv -> AffineRef -> Closure
Affine EnumSet Word64
ps AEnv
aenv0 AffineRef
ar
      Closure
ahv <- Val -> Val -> IO Closure
extendPAp Val
ahv0 (Closure -> Val
BoxedVal Closure
aff)
      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 <- DebugCallStack => 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 prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (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] -> Deque a
Sq.fromList [Val]
l
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (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)
  -- for the JIT's per-output statistics; nothing unless they are on
  JIT -> ForeignFunc -> IO ()
noteOutput (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env) ForeignFunc
func
  pure (Bool
b, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
_ (Fork Int
i)
  | CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env = [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"attempted to use sandboxed operation: fork"
  | Bool
otherwise = do
      ThreadId
tid <- CCache prof -> ActiveThreads -> Val -> IO ThreadId
forall prof.
RuntimeProfiler prof =>
CCache prof -> ActiveThreads -> Val -> IO ThreadId
forkEval CCache prof
env ActiveThreads
activeThreads (Val -> IO ThreadId) -> IO Val -> IO ThreadId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      DebugCallStack => 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
. ThreadId -> Foreign
WrapThreadId (ThreadId -> IO ()) -> ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId
tid
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
_ (Atomically Int
i)
  | CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env = [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (Bool, HEnv, Stack, K))
-> [Char] -> IO (Bool, HEnv, Stack, K)
forall a b. (a -> b) -> a -> b
$ [Char]
"attempted to use sandboxed operation: atomically"
  | Bool
otherwise = do
      Val
v <- DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      CCache prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
forall prof.
RuntimeProfiler prof =>
CCache prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
atomicEval CCache prof
env ActiveThreads
activeThreads (DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk) Val
v
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
_ (TryForce Int
i)
  | CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env = [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (Bool, HEnv, Stack, K))
-> [Char] -> IO (Bool, HEnv, Stack, K)
forall a b. (a -> b) -> a -> b
$ [Char]
"attempted to use sandboxed operation: tryForce"
  | Bool
otherwise = do
      Val
v <- DebugCallStack => 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 prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
forall prof.
RuntimeProfiler prof =>
CCache prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
nestEval CCache prof
env ActiveThreads
activeThreads (DebugCallStack => 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 prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
_ (NewForeignPtr Int
i Int
j)
  | CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env =
      [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"attempted to use sandboxed operation: ForeignPtr.new"
  | Bool
otherwise = do
      Val
fin <- DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
      Ptr (ZonkAny 8)
p <- Stack -> Int -> IO (Ptr (ZonkAny 8))
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
j
      let thunk :: IO ()
thunk = CCache prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
forall prof.
RuntimeProfiler prof =>
CCache prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
nestEval CCache prof
env ActiveThreads
activeThreads (IO () -> Val -> IO ()
forall a b. a -> b -> a
const (IO () -> Val -> IO ()) -> IO () -> Val -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Val
fin
      ForeignPtr (ZonkAny 8)
fp <- Ptr (ZonkAny 8) -> IO () -> IO (ForeignPtr (ZonkAny 8))
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
CFPtr.newForeignPtr Ptr (ZonkAny 8)
p IO ()
thunk
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack -> ForeignPtr (ZonkAny 8) -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk ForeignPtr (ZonkAny 8)
fp
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
_ (AddFinalizer Int
i Int
j)
  | CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env =
      [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"attempted to use sandboxed operation: ForeignPtr.addFinalizer"
  | Bool
otherwise = do
      ForeignPtr (ZonkAny 9)
fp <- Stack -> Int -> IO (ForeignPtr (ZonkAny 9))
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
      Val
fin <- DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
      ForeignPtr (ZonkAny 9) -> IO () -> IO ()
forall a. ForeignPtr a -> IO () -> IO ()
CFPtr.addForeignPtrFinalizer ForeignPtr (ZonkAny 9)
fp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        CCache prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
forall prof.
RuntimeProfiler prof =>
CCache prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
nestEval CCache prof
env ActiveThreads
activeThreads (IO () -> Val -> IO ()
forall a b. a -> b -> a
const (IO () -> Val -> IO ()) -> IO () -> Val -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Val
fin
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
_ (MkCallback Int
i Int
j)
  | CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env =
      [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"attempted to use sandboxed operation: FFI.newCallback"
  | Bool
otherwise = do
      FFSpec
spec <- Stack -> Int -> IO FFSpec
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
      Val
fn <- DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
      -- The C side calls this later with its own arguments (decoded directly
      -- onto a stack); running the Unison function needs the live code
      -- environment, which only exists here.
      let run :: Stack -> (Stack -> IO ()) -> IO ()
run = CCache prof
-> ActiveThreads -> Val -> Stack -> (Stack -> IO ()) -> IO ()
forall prof.
RuntimeProfiler prof =>
CCache prof
-> ActiveThreads -> Val -> Stack -> (Stack -> IO ()) -> IO ()
applyToStackArgs CCache prof
env ActiveThreads
activeThreads Val
fn
      CDynFunc
cb <- FFSpec -> (Stack -> (Stack -> IO ()) -> IO ()) -> IO CDynFunc
Callback.mkCallback FFSpec
spec Stack -> (Stack -> IO ()) -> IO ()
run
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack -> CDynFunc -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk CDynFunc
cb
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ MInstr
DLLCall = do
  CDynFunc
cf <- Stack -> IO CDynFunc
forall b. BuiltinForeign b => Stack -> IO b
peekBi Stack
stk
  let n :: Int
n = CSpec -> Int
DLL.numArgs (CSpec -> Int) -> CSpec -> Int
forall a b. (a -> b) -> a -> b
$ CDynFunc -> CSpec
DLL.cSpec CDynFunc
cf
  -- Note: pre-bump, because you can't pass stk out of these blocks
  -- without boxing (or customizing allocaArray).
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Int -> (Ptr Int -> IO ()) -> IO ()
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
n \Ptr Int
storage ->
    Int -> (Ptr (Ptr CValue) -> IO ()) -> IO ()
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
n \Ptr (Ptr CValue)
cArgs ->
      (Ptr Int -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \(Ptr Int
cRet :: Ptr Int) -> do
        Stack -> [FFType] -> Ptr Int -> Ptr (Ptr CValue) -> IO () -> IO ()
copyArgs Stack
stk (CDynFunc -> [FFType]
DLL.cffArgs CDynFunc
cf) Ptr Int
storage Ptr (Ptr CValue)
cArgs do
          CDynFunc -> Ptr (Ptr CValue) -> Ptr Int -> IO ()
forall a r. CDynFunc -> Ptr (Ptr a) -> Ptr r -> IO ()
DLL.callForeign CDynFunc
cf Ptr (Ptr CValue)
cArgs Ptr Int
cRet
          case CDynFunc -> FFType
DLL.cffResult CDynFunc
cf of
            FFType
DLL.I8 -> Ptr Int8 -> IO Int8
forall a. Storable a => Ptr a -> IO a
Store.peek (Ptr Int -> Ptr Int8
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
cRet) IO Int8 -> (Int8 -> 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 -> Int -> IO ()
pokeI Stack
stk (Int -> IO ()) -> (Int8 -> Int) -> Int8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Int
fi8
            FFType
DLL.I16 -> Ptr Int16 -> IO Int16
forall a. Storable a => Ptr a -> IO a
Store.peek (Ptr Int -> Ptr Int16
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
cRet) IO Int16 -> (Int16 -> 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 -> Int -> IO ()
pokeI Stack
stk (Int -> IO ()) -> (Int16 -> Int) -> Int16 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Int
fi16
            FFType
DLL.I32 -> Ptr Int32 -> IO Int32
forall a. Storable a => Ptr a -> IO a
Store.peek (Ptr Int -> Ptr Int32
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
cRet) IO Int32 -> (Int32 -> 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 -> Int -> IO ()
pokeI Stack
stk (Int -> IO ()) -> (Int32 -> Int) -> Int32 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
fi32
            FFType
DLL.I64 -> Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
Store.peek Ptr Int
cRet IO Int -> (Int -> 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 -> Int -> IO ()
pokeI Stack
stk
            FFType
DLL.U8 -> Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
Store.peek (Ptr Int -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
cRet) IO Word8 -> (Word8 -> 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 -> Word64 -> IO ()
pokeN Stack
stk (Word64 -> IO ()) -> (Word8 -> Word64) -> Word8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word64
fu8
            FFType
DLL.U16 -> Ptr Word16 -> IO Word16
forall a. Storable a => Ptr a -> IO a
Store.peek (Ptr Int -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
cRet) IO Word16 -> (Word16 -> 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 -> Word64 -> IO ()
pokeN Stack
stk (Word64 -> IO ()) -> (Word16 -> Word64) -> Word16 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Word64
fu16
            FFType
DLL.U32 -> Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
Store.peek (Ptr Int -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
cRet) IO Word32 -> (Word32 -> 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 -> Word64 -> IO ()
pokeN Stack
stk (Word64 -> IO ()) -> (Word32 -> Word64) -> Word32 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word64
fu32
            FFType
DLL.U64 -> Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
Store.peek (Ptr Int -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
cRet) IO Word64 -> (Word64 -> 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 -> Word64 -> IO ()
pokeN Stack
stk
            FFType
DLL.F32 -> Ptr Float -> IO Float
forall a. Storable a => Ptr a -> IO a
Store.peek (Ptr Int -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
cRet) IO Float -> (Float -> 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 -> Double -> IO ()
pokeD Stack
stk (Double -> IO ()) -> (Float -> Double) -> Float -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Double
ff32
            FFType
DLL.D64 -> Ptr Double -> IO Double
forall a. Storable a => Ptr a -> IO a
Store.peek (Ptr Int -> Ptr Double
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
cRet) IO Double -> (Double -> 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 -> Double -> IO ()
pokeD Stack
stk
            FFType
DLL.Void -> DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
unitValue
            FFType
DLL.Ptr ->
              Ptr (Ptr ()) -> IO (Ptr ())
forall a. Storable a => Ptr a -> IO a
Store.peek (Ptr Int -> Ptr (Ptr ())
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
cRet) IO (Ptr ()) -> (Ptr () -> 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
>>= forall a. ForeignConvention a => Stack -> a -> IO ()
writeBack @(Ptr ()) Stack
stk
            FFType
DLL.MBArr ->
              [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected array result from DLL function"
            FFType
DLL.Fun ->
              [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected function-pointer result from DLL function"
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (KeepAlive Int
i) = do
  Closure
x <- DebugCallStack => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i
  (Stack
stk, Int
a) <- Stack -> IO (Stack, Int)
saveArgs Stack
stk
  pure (Bool
False, HEnv
henv, Stack
stk, Closure -> Int -> K -> K
forall a. a -> Int -> K -> K
Keep Closure
x Int
a K
k)
exec CCache prof
_ HEnv
_ !ActiveThreads
_ !Stack
_ !K
_ CombIx
_ (SandboxingFailure FieldName
t) = do
  [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (Bool, HEnv, Stack, K))
-> [Char] -> IO (Bool, HEnv, Stack, K)
forall a b. (a -> b) -> a -> b
$ [Char]
"Attempted to use disallowed builtin in sandboxed environment: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> FieldName -> [Char]
DTx.unpack FieldName
t
{-# INLINE exec #-}

fi8 :: Int8 -> Int
fi8 :: Int8 -> Int
fi8 = Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

ti8 :: Int -> Int8
ti8 :: Int -> Int8
ti8 = Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral

fu8 :: Word8 -> Word64
fu8 :: Word8 -> Word64
fu8 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

tu8 :: Word64 -> Word8
tu8 :: Word64 -> Word8
tu8 = Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral

fi16 :: Int16 -> Int
fi16 :: Int16 -> Int
fi16 = Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

ti16 :: Int -> Int16
ti16 :: Int -> Int16
ti16 = Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral

fi32 :: Int32 -> Int
fi32 :: Int32 -> Int
fi32 = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

ti32 :: Int -> Int32
ti32 :: Int -> Int32
ti32 = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

fu32 :: Word32 -> Word64
fu32 :: Word32 -> Word64
fu32 = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

tu32 :: Word64 -> Word32
tu32 :: Word64 -> Word32
tu32 = Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

fu16 :: Word16 -> Word64
fu16 :: Word16 -> Word64
fu16 = Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

tu16 :: Word64 -> Word16
tu16 :: Word64 -> Word16
tu16 = Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral

tf32 :: Double -> Float
tf32 :: Double -> Float
tf32 = Double -> Float
double2Float

ff32 :: Float -> Double
ff32 :: Float -> Double
ff32 = Float -> Double
float2Double

-- Copies unison stack values into temporary space appropriate for
-- calling libffi. The latter takes all arguments as pointers, so we
-- need to copy the arguments to pinned memory to have a stable
-- location. All our FFI arguments are 64-bit or smaller, though, so
-- we can just use a contiguous array with as many 8 byte slots as
-- there are arguments, possibly using only portions of some slots.
copyArgs ::
  Stack -> [DLL.FFType] -> Ptr Int -> Ptr (Ptr CValue) -> IO () -> IO ()
copyArgs :: Stack -> [FFType] -> Ptr Int -> Ptr (Ptr CValue) -> IO () -> IO ()
copyArgs !Stack
stk [FFType]
tys Ptr Int
p0 Ptr (Ptr CValue)
h0 IO ()
next = Int -> [FFType] -> Ptr Int -> Ptr (Ptr CValue) -> IO ()
go Int
2 [FFType]
tys Ptr Int
p0 Ptr (Ptr CValue)
h0
  where
    go :: Int -> [FFType] -> Ptr Int -> Ptr (Ptr CValue) -> IO ()
go !Int
i (FFType
a : [FFType]
as) !Ptr Int
p !Ptr (Ptr CValue)
h = FFType -> Int -> Ptr Int -> IO () -> IO ()
store FFType
a Int
i Ptr Int
p do
      Ptr (Ptr CValue) -> Ptr CValue -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke Ptr (Ptr CValue)
h (Ptr Int -> Ptr CValue
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p)
      Int -> [FFType] -> Ptr Int -> Ptr (Ptr CValue) -> IO ()
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [FFType]
as (Ptr Int -> Int -> Ptr Int
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Int
p Int
szp) (Ptr (Ptr CValue) -> Int -> Ptr (Ptr CValue)
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr (Ptr CValue)
h Int
szh)
    go Int
_ [FFType]
_ Ptr Int
_ Ptr (Ptr CValue)
_ = IO ()
next

    -- special case non-64-bit values for conversions, otherwise just
    -- copy bytes.
    store :: FFType -> Int -> Ptr Int -> IO () -> IO ()
store FFType
DLL.I32 Int
i Ptr Int
p IO ()
nx =
      DebugCallStack => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i IO Int -> (Int -> 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
>>= Ptr Int32 -> Int32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke (Ptr Int -> Ptr Int32
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) (Int32 -> IO ()) -> (Int -> Int32) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int32
ti32 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    store FFType
DLL.U32 Int
i Ptr Int
p IO ()
nx =
      Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i IO Word64 -> (Word64 -> 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
>>= Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke (Ptr Int -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) (Word32 -> IO ()) -> (Word64 -> Word32) -> Word64 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word32
tu32 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    store FFType
DLL.I16 Int
i Ptr Int
p IO ()
nx =
      DebugCallStack => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i IO Int -> (Int -> 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
>>= Ptr Int16 -> Int16 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke (Ptr Int -> Ptr Int16
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) (Int16 -> IO ()) -> (Int -> Int16) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int16
ti16 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    store FFType
DLL.U16 Int
i Ptr Int
p IO ()
nx =
      Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i IO Word64 -> (Word64 -> 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
>>= Ptr Word16 -> Word16 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke (Ptr Int -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) (Word16 -> IO ()) -> (Word64 -> Word16) -> Word64 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word16
tu16 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    store FFType
DLL.I8 Int
i Ptr Int
p IO ()
nx =
      DebugCallStack => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i IO Int -> (Int -> 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
>>= Ptr Int8 -> Int8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke (Ptr Int -> Ptr Int8
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) (Int8 -> IO ()) -> (Int -> Int8) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int8
ti8 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    store FFType
DLL.U8 Int
i Ptr Int
p IO ()
nx =
      Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i IO Word64 -> (Word64 -> 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
>>= Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke (Ptr Int -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) (Word8 -> IO ()) -> (Word64 -> Word8) -> Word64 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word8
tu8 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    store FFType
DLL.F32 Int
i Ptr Int
p IO ()
nx =
      Stack -> Int -> IO Double
peekOffD Stack
stk Int
i IO Double -> (Double -> 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
>>= Ptr Float -> Float -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke (Ptr Int -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) (Float -> IO ()) -> (Double -> Float) -> Double -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Float
tf32 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    store FFType
DLL.MBArr Int
i Ptr Int
p IO ()
nx = do
      MutableByteArray RealWorld
mb <- Stack -> Int -> IO (MutableByteArray RealWorld)
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
      MutableByteArray (PrimState IO) -> (Ptr Word8 -> IO ()) -> IO ()
forall (m :: * -> *) a.
PrimBase m =>
MutableByteArray (PrimState m) -> (Ptr Word8 -> m a) -> m a
withMutableByteArrayContents MutableByteArray RealWorld
MutableByteArray (PrimState IO)
mb \Ptr Word8
ptr ->
        Ptr (Ptr Word8) -> Ptr Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke (Ptr Int -> Ptr (Ptr Word8)
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) Ptr Word8
ptr IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    store FFType
DLL.Ptr Int
i Ptr Int
p IO ()
nx = do
      forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi @(Ptr ()) Stack
stk Int
i IO (Ptr ()) -> (Ptr () -> 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
>>= Ptr (Ptr ()) -> Ptr () -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke (Ptr Int -> Ptr (Ptr ())
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    store FFType
DLL.Fun Int
i Ptr Int
p IO ()
nx = do
      CDynFunc
cf <- forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi @DLL.CDynFunc Stack
stk Int
i
      case CDynFunc
cf of
        DLL.CDynFunc [Char]
_ CSpec
_ FunPtr a
f IO ()
_ ->
          Ptr (FunPtr ()) -> FunPtr () -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke (Ptr Int -> Ptr (FunPtr ())
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) (FunPtr a -> FunPtr ()
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr a
f :: FunPtr ()) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    store FFType
_ Int
i Ptr Int
p IO ()
nx =
      DebugCallStack => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i IO Int -> (Int -> 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
>>= Ptr Int -> Int -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Store.poke Ptr Int
p IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
nx
    {-# INLINE store #-}

    szp :: Int
szp = Int -> Int
forall a. Storable a => a -> Int
Store.sizeOf (Int
0 :: Int)
    szh :: Int
szh = Ptr CValue -> Int
forall a. Storable a => a -> Int
Store.sizeOf (Ptr CValue
forall a. HasCallStack => a
undefined :: Ptr CValue)
{-# INLINE copyArgs #-}

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
<$ DebugCallStack => 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
      DebugCallStack => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      DebugCallStack => 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 -> Foreign
WrapReference 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
<$ DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
3 Val
extra
      where
        disp :: (Exception e) => e -> Util.Text.Text
        disp :: forall e. Exception e => e -> Text
disp = [Char] -> Text
Util.Text.pack ([Char] -> Text) -> (e -> [Char]) -> e -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> [Char]
forall a. Show a => a -> [Char]
show
        (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 e. Exception e => e -> 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 [Word]
_issues Pretty ColorText
msg ->
                (Reference
Rf.runtimeFailureRef, FieldName -> Text
Util.Text.fromText (FieldName -> Text) -> FieldName -> Text
forall a b. (a -> b) -> a -> b
$ Width -> Pretty ColorText -> FieldName
P.toPlain Width
0 Pretty ColorText
msg, Val
unitValue)
              BU [(Reference, Int)]
_ FieldName
tx Val
val -> (Reference
Rf.runtimeFailureRef, FieldName -> Text
Util.Text.fromText FieldName
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 e. Exception e => e -> 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 e. Exception e => e -> 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 e. Exception e => e -> 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 e. Exception e => e -> 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 e. Exception e => e -> Text
disp AsyncException
ie, Val
unitValue)
          | Just (AsyncCancelled
ie :: UnliftIO.AsyncCancelled) <- SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn =
              (Reference
Rf.asyncCancelledFailureRef, AsyncCancelled -> Text
forall e. Exception e => e -> Text
disp AsyncCancelled
ie, Val
unitValue)
          | Just (Panic [Char]
msg Maybe Val
v) <- SomeException -> Maybe RuntimePanic
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn,
            Text
msg <- [Char] -> Text
Util.Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"panic: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 e. Exception e => e -> 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' ::
  (RuntimeProfiler prof) =>
  Ticker prof ->
  CCache prof ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  CombIx ->
  MSection ->
  IO ()
#ifdef STACK_CHECK
eval' !_ _ _ !_ !stk !_ !_ section
  | debugger stk "eval" section = undefined
#endif
eval' :: forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
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
  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
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' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
r (Match Int
i (TestY MSection
df Map Bytes MSection
cs)) = do
  Bytes
b <- Stack -> Int -> IO Bytes
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
r (MSection -> IO ()) -> MSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Bytes -> MSection -> Map Bytes MSection -> MSection
selectBytesBranch Bytes
b MSection
df Map Bytes MSection
cs
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
r (Match Int
i MBranch
br) = do
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
r (MSection -> IO ()) -> MSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> MBranch -> MSection
selectBranch Word64
n MBranch
br
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
r (DMatch Maybe Reference
mr Int
i MBranch
br) = do
  (MSection
nx, Stack
stk) <- Maybe Reference
-> Stack -> MBranch -> Closure -> IO (MSection, Stack)
dataBranch Maybe Reference
mr Stack
stk MBranch
br (Closure -> IO (MSection, Stack))
-> IO Closure -> IO (MSection, Stack)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DebugCallStack => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i
  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
r MSection
nx
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
r (NMatch Maybe Reference
_mr Int
i MBranch
br) = do
  Word64
n <- Stack -> Int -> IO Word64
peekOffN Stack
stk Int
i
  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
r (MSection -> IO ()) -> MSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> MBranch -> MSection
selectBranch Word64
n MBranch
br
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
r (RMatch Int
i MSection
pu EnumMap Word64 MBranch
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
=<< DebugCallStack => 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 Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
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 MBranch
ebs <- Word64 -> EnumMap Word64 MBranch -> Maybe MBranch
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
e EnumMap Word64 MBranch
br ->
            Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
r (MSection -> IO ()) -> MSection -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> MBranch -> MSection
selectBranch Word64
t MBranch
ebs
        | Bool
otherwise -> IO ()
forall a. HasCallStack => IO a
unhandledAbilityRequest
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
here (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 = do
      Ticker prof -> CombIx -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof -> CombIx -> K -> IO ()
checkTicker Ticker prof
yld CombIx
here K
k
      DebugCallStack => 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
>>= Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Bool
False Args
ZArgs
  | Bool
otherwise = do
      Ticker prof -> CombIx -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof -> CombIx -> K -> IO ()
checkTicker Ticker prof
yld CombIx
here K
k
      Stack
stk <- Stack -> Args -> IO Stack
moveArgs Stack
stk Args
args
      Stack
stk <- Stack -> IO Stack
frameArgs Stack
stk
      Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
here (App Bool
ck GRef (RComb Val)
r Args
args) = do
  Ticker prof -> CombIx -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof -> CombIx -> K -> IO ()
checkTicker Ticker prof
yld CombIx
here K
k
  CCache prof -> HEnv -> Stack -> GRef (RComb Val) -> IO Val
forall p. CCache p -> HEnv -> Stack -> GRef (RComb Val) -> IO Val
resolve CCache prof
env HEnv
henv Stack
stk GRef (RComb Val)
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
>>= Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Bool
ck Args
args
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
here (Call Bool
ck CombIx
combIx RComb Val
rcomb Args
args) = do
  Ticker prof -> CombIx -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof -> CombIx -> K -> IO ()
checkTicker Ticker prof
yld CombIx
here K
k
  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> Bool
-> Args
-> RComb Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> Bool
-> Args
-> RComb Val
-> IO ()
enter Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
combIx Bool
ck Args
args RComb Val
rcomb
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
_ (Jump Int
i Args
args) =
  DebugCallStack => 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
>>= Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Args
-> Closure
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Args
-> Closure
-> IO ()
jump Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Args
args
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
r (Let MSection
nw CombIx
cix Int
f MSection
sect Ptr NativeCell
cell) = do
  (Stack
stk, Int
fsz, Int
asz) <- Stack -> IO (Stack, Int, Int)
saveFrame Stack
stk
  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval
    Ticker prof
yld
    CCache prof
env
    HEnv
henv
    ActiveThreads
activeThreads
    Stack
stk
    (Int -> Int -> CombIx -> Int -> MSection -> Ptr NativeCell -> K -> K
Push Int
fsz Int
asz CombIx
cix Int
f MSection
sect Ptr NativeCell
cell K
k)
    CombIx
r
    MSection
nw
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
r (Ins MInstr
i MSection
nx) = do
  CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MInstr
-> IO (Bool, HEnv, Stack, K)
forall prof.
RuntimeProfiler prof =>
CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MInstr
-> IO (Bool, HEnv, Stack, K)
exec CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
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 <- DebugCallStack => Stack -> IO Val
Stack -> IO Val
peek Stack
stk
          DebugCallStack => 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 -> Ptr NativeCell -> K -> K
Push Int
fsz Int
asz CombIx
fakeCix Int
10 MSection
nx Ptr NativeCell
noNativeCell K
k
          Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
kk Bool
False (Int -> Args
VArg1 Int
0) Val
eh
      | Bool
otherwise -> Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
r MSection
nx
eval' !Ticker prof
_ CCache prof
_ HEnv
_ !ActiveThreads
_ !Stack
_activeThreads !K
_ CombIx
_ MSection
Exit = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
eval' !Ticker prof
_ CCache prof
_ HEnv
_ !ActiveThreads
_ !Stack
_activeThreads !K
_ CombIx
_ (Die [Char]
s) = [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
s
{-# INLINE eval' #-}

eval ::
  (RuntimeProfiler prof) =>
  Ticker prof ->
  CCache prof ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  CombIx ->
  MSection ->
  IO ()
eval :: forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
here MSection
sect = do
  Ticker prof -> CombIx -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof -> CombIx -> K -> IO ()
checkTicker Ticker prof
yld CombIx
here K
k
  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval' Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
here MSection
sect
{-# SPECIALIZE eval ::
  Ticker () ->
  CCache () ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  CombIx ->
  MSection ->
  IO ()
  #-}
{-# SPECIALIZE eval ::
  Ticker ProfileComm ->
  CCache ProfileComm ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  CombIx ->
  MSection ->
  IO ()
  #-}

-- 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 = [Word] -> [Char] -> IO a
forall a. HasCallStack => [Word] -> [Char] -> a
exn [Word
2922, Word
5400] [Char]
"eval: unhandled ability request"

forkEval ::
  (RuntimeProfiler prof) =>
  CCache prof ->
  ActiveThreads ->
  Val ->
  IO ThreadId
forkEval :: forall prof.
RuntimeProfiler prof =>
CCache prof -> ActiveThreads -> Val -> IO ThreadId
forkEval CCache prof
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 prof -> ActiveThreads -> Val -> IO ()
forall p.
RuntimeProfiler p =>
(Stack -> IO ()) -> CCache p -> ActiveThreads -> Val -> IO ()
apply1 Stack -> IO ()
err CCache prof
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 ::
  (RuntimeProfiler prof) =>
  CCache prof ->
  ActiveThreads ->
  (Val -> IO ()) ->
  Val ->
  IO ()
nestEval :: forall prof.
RuntimeProfiler prof =>
CCache prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
nestEval CCache prof
env ActiveThreads
activeThreads Val -> IO ()
write Val
val = (Stack -> IO ()) -> CCache prof -> ActiveThreads -> Val -> IO ()
forall p.
RuntimeProfiler p =>
(Stack -> IO ()) -> CCache p -> ActiveThreads -> Val -> IO ()
apply1 Stack -> IO ()
readBack CCache prof
env ActiveThreads
activeThreads Val
val
  where
    readBack :: Stack -> IO ()
readBack Stack
stk = DebugCallStack => 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 #-}

-- | Apply a function value to the arguments already pushed on the given stack
-- (the count taken from the stack's frame size), running to a result that is
-- handed, on the stack, to the continuation (result on top).
--
-- This is the re-entrant entry point used to run a Unison function from a C
-- callback, which decodes its arguments directly onto the stack rather than
-- through an intermediate list.
applyToStackArgs ::
  (RuntimeProfiler prof) =>
  CCache prof ->
  ActiveThreads ->
  Val ->
  Stack ->
  (Stack -> IO ()) ->
  IO ()
applyToStackArgs :: forall prof.
RuntimeProfiler prof =>
CCache prof
-> ActiveThreads -> Val -> Stack -> (Stack -> IO ()) -> IO ()
applyToStackArgs CCache prof
env ActiveThreads
activeThreads Val
clo Stack
stk Stack -> IO ()
k = do
  (Ticker prof
tick, IO ()
cancelTicks) <- prof -> IO (Ticker prof, IO ())
forall prof.
RuntimeProfiler prof =>
prof -> IO (Ticker prof, IO ())
startTicker (prof -> IO (Ticker prof, IO ()))
-> prof -> IO (Ticker prof, IO ())
forall a b. (a -> b) -> a -> b
$ CCache prof -> prof
forall prof. CCache prof -> prof
profiler CCache prof
env
  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply Ticker prof
tick CCache prof
env HEnv
forall a. Monoid a => a
mempty ActiveThreads
activeThreads Stack
stk K
k0 Bool
True Args
args Val
clo
    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
cancelTicks
  where
    k0 :: K
k0 = Callback -> K
CB (Callback -> K) -> Callback -> K
forall a b. (a -> b) -> a -> b
$ (XStack -> IO ()) -> Callback
Hook (\XStack
res -> Stack -> IO ()
k (XStack -> Stack
packXStack XStack
res))
    -- The callback pushed arguments left-to-right, so the k-th argument sits
    -- at offset @n - 1 - k@ from the top. Name those offsets in parameter
    -- order, mirroring 'demuxArgs'.
    args :: Args
args = case [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0 .. Stack -> Int
fsize Stack
stk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] of
      [] -> Args
ZArgs
      [Int
i] -> Int -> Args
VArg1 Int
i
      [Int
i, Int
j] -> Int -> Int -> Args
VArg2 Int
i Int
j
      [Int]
is -> PrimArray Int -> Args
VArgN (PrimArray Int -> Args) -> PrimArray Int -> Args
forall a b. (a -> b) -> a -> b
$ [Int] -> PrimArray Int
forall a. Prim a => [a] -> PrimArray a
PA.primArrayFromList [Int]
is
{-# INLINE applyToStackArgs #-}

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

-- fast path application
enter ::
  (RuntimeProfiler prof) =>
  Ticker prof ->
  CCache prof ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  CombIx ->
  Bool ->
  Args ->
  MComb ->
  IO ()
enter :: forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> Bool
-> Args
-> RComb Val
-> IO ()
enter !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k !CombIx
cref !Bool
sck !Args
args = \case
  (RComb (Comb (LamI Int
a Int
f MSection
entry Ptr NativeCell
cell))) -> do
    Ptr ()
native <- Ptr NativeCell -> IO (Ptr ())
readNativeEntry Ptr NativeCell
cell
    if Ptr ()
native Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
      then do
        CCache prof -> CombIx -> Ptr NativeCell -> IO ()
forall prof. CCache prof -> CombIx -> Ptr NativeCell -> IO ()
countInterpreted CCache prof
env CombIx
cref Ptr NativeCell
cell
        -- 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
        Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
cref MSection
entry
      else do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JIT -> Bool
jitTracing (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char] -> IO ()
JIT.jitDump ([Char]
"enter native " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CombIx -> [Char]
forall a. Show a => a -> [Char]
show CombIx
cref [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" arity " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" args " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Args -> [Char]
forall a. Show a => a -> [Char]
show Args
args [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" cell " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ptr NativeCell -> [Char]
forall a. Show a => a -> [Char]
show Ptr NativeCell
cell [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" code " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ptr () -> [Char]
forall a. Show a => a -> [Char]
show Ptr ()
native [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" stack before " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Stack -> [Char]
forall a. Show a => a -> [Char]
show Stack
stk)
        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
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JIT -> Bool
jitTracing (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
JIT.jitDump ([Char]
"  stack after " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Stack -> [Char]
forall a. Show a => a -> [Char]
show Stack
stk)
        Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> FunPtr NativeFn
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> FunPtr NativeFn
-> IO ()
runNative Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k (Ptr () -> FunPtr NativeFn
forall a b. Ptr a -> FunPtr b
castPtrToFunPtr Ptr ()
native)
  (RComb (CachedVal Word64
_ Val
val)) -> do
    Stack
stk <- Stack -> IO Stack
discardFrame Stack
stk
    Stack
stk <- Stack -> IO Stack
bump Stack
stk
    DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
val
    Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k
{-# INLINE enter #-}

-- Counts a call the interpreter is about to run itself because the
-- combinator has no native code, and asks for the combinator's definition
-- to be compiled when the count says it is hot (in the JIT's `on` mode).
countInterpreted :: CCache prof -> CombIx -> Ptr NativeCell -> IO ()
countInterpreted :: forall prof. CCache prof -> CombIx -> Ptr NativeCell -> IO ()
countInterpreted CCache prof
env CombIx
cix Ptr NativeCell
cell = do
  Bool
hot <- Ptr NativeCell -> IO Bool
bumpNativeCount Ptr NativeCell
cell
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hot (JIT
-> Bool
-> TVar (EnumMap Word64 MCombs)
-> TVar (EnumMap Word64 Reference)
-> CombIx
-> Ptr NativeCell
-> IO ()
jitRequestGroup (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env) (CCache prof -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache prof
env) (CCache prof -> TVar (EnumMap Word64 MCombs)
forall prof. CCache prof -> TVar (EnumMap Word64 MCombs)
combs CCache prof
env) (CCache prof -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
combRefs CCache prof
env) CombIx
cix Ptr NativeCell
cell)
{-# INLINE countInterpreted #-}

-- Likewise for a re-entry point: counts a time the interpreter continued
-- at a place where native code would have, had it been generated, and asks
-- for it to be once that has happened often enough.
countReentry :: CCache prof -> Ptr NativeCell -> IO ()
countReentry :: forall prof. CCache prof -> Ptr NativeCell -> IO ()
countReentry CCache prof
env Ptr NativeCell
cell = do
  Bool
hot <- Ptr NativeCell -> IO Bool
bumpNativeCount Ptr NativeCell
cell
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hot (JIT -> Ptr NativeCell -> IO ()
jitRequestCell (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env) Ptr NativeCell
cell)
{-# INLINE countReentry #-}

-- The trampoline: runs compiled code for a combinator whose frame has
-- been set up as `enter` sets it up, then acts on the status it returns.
-- See unison-runtime/src/Unison/Runtime/JIT/design.md, "The trampoline".
runNative ::
  (RuntimeProfiler prof) =>
  Ticker prof ->
  CCache prof ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  FunPtr NativeFn ->
  IO ()
runNative :: forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> FunPtr NativeFn
-> IO ()
runNative !Ticker prof
yld CCache prof
env HEnv
henv0 !ActiveThreads
activeThreads !Stack
stk0 !K
k0 FunPtr NativeFn
fn0 = FunPtr NativeFn -> HEnv -> Stack -> K -> IO ()
go FunPtr NativeFn
fn0 HEnv
henv0 Stack
stk0 K
k0
  where
    -- read once: these are consulted several times per round trip, and
    -- the tables on every one
    !tracing :: Bool
tracing = JIT -> Bool
jitTracing (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env)
    !counting :: Bool
counting = JIT -> Bool
jitStats (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env)
    !exits :: Exits
exits = JIT -> Exits
jitExits (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env)
    !frames :: Frames
frames = JIT -> Frames
jitFrames (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env)
    !pool :: Pool
pool = JIT -> Pool
jitPool (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env)
    go :: FunPtr NativeFn -> HEnv -> Stack -> K -> IO ()
go FunPtr NativeFn
fn HEnv
henv (Stack Int
ap Int
fp Int
sp MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) Closure
bstk) K
k = do
      MutableArray RealWorld Closure
poolArr <- Pool -> IO (MutableArray (PrimState IO) Closure)
currentPool Pool
pool
      let !size :: Int
size = MutableArray RealWorld Closure -> Int
bstkSlots MutableArray RealWorld Closure
MutableArray (PrimState IO) Closure
bstk
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
counting (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Exits -> Ptr (ZonkAny 7) -> IO ()
forall a. Exits -> Ptr a -> IO ()
countEntry Exits
exits (FunPtr NativeFn -> Ptr (ZonkAny 7)
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr NativeFn
fn)
      -- the handler environment goes in the boxed stack's out-area, where
      -- the collector sees it; forced here, since native code can read a
      -- constructor but not a thunk
      let !henvC :: Closure
henvC = HEnv -> Closure
forall a b. a -> b
unsafeCoerce HEnv
henv :: Closure
      MutableArray (PrimState IO) Closure -> Int -> Closure -> IO ()
forall (m :: * -> *) a.
(DebugCallStack, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray (PrimState IO) Closure
bstk Int
size Closure
henvC
      Int
status <- FunPtr NativeFn
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) Closure
-> MutableArray (PrimState IO) Closure
-> Int
-> Int
-> Int
-> Int
-> IO Int
enterNative FunPtr NativeFn
fn MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) Closure
bstk MutableArray RealWorld Closure
MutableArray (PrimState IO) Closure
poolArr Int
size Int
ap Int
fp Int
sp
      Int
ap' <- MutableByteArray (PrimState IO) -> Int -> IO Int
outAp MutableByteArray (PrimState IO)
ustk Int
size
      Int
fp' <- MutableByteArray (PrimState IO) -> Int -> IO Int
outFp MutableByteArray (PrimState IO)
ustk Int
size
      Int
sp' <- MutableByteArray (PrimState IO) -> Int -> IO Int
outSp MutableByteArray (PrimState IO)
ustk Int
size
      let !stk :: Stack
stk = Int
-> Int
-> Int
-> MutableByteArray (PrimState IO)
-> MutableArray (PrimState IO) Closure
-> Stack
Stack Int
ap' Int
fp' Int
sp' MutableByteArray (PrimState IO)
ustk MutableArray (PrimState IO) Closure
bstk
      if Int
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
statusOK
        then do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tracing (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
JIT.jitDump ([Char]
"native returned OK with ap/fp/sp " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
ap', Int
fp', Int
sp') [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (entered with " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
ap, Int
fp, Int
sp) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")")
          Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k
        else
          if Int
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
statusError
            then [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"native code reported an error"
            else do
              -- the frame records of the native callers above the exit;
              -- they can be read once
              Int
n <- MutableByteArray (PrimState IO) -> Int -> IO Int
outFrameCount MutableByteArray (PrimState IO)
ustk Int
size
              [FrameRecord]
records <- if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [FrameRecord] -> IO [FrameRecord]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else MutableByteArray (PrimState IO) -> Int -> IO [FrameRecord]
outFrames MutableByteArray (PrimState IO)
ustk Int
size
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tracing (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                [Char] -> IO ()
JIT.jitDump ([Char]
"native returned " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
status [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" with ap/fp/sp " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
ap', Int
fp', Int
sp') [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (entered with " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
ap, Int
fp, Int
sp) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (FrameRecord -> [Char]) -> [FrameRecord] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char]
"\n  frame record " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char])
-> (FrameRecord -> [Char]) -> FrameRecord -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameRecord -> [Char]
forall a. Show a => a -> [Char]
show) [FrameRecord]
records)
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
counting (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Int
total <- Exits -> Int -> IO Int
countExit Exits
exits Int
status
                let every :: Int
every = Config -> Int
JIT.statsEvery (JIT -> Config
jitConfig (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env))
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
every Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
total Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
every Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (JIT -> IO ()
printJITStats (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env))
              Exit
exit <- Exits -> Int -> IO Exit
lookupExit Exits
exits Int
status
              -- Records are written innermost caller first; K has the
              -- innermost frame on top, so build from the last record.
              K
k <- if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then K -> IO K
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure K
k else (K -> FrameRecord -> IO K) -> K -> [FrameRecord] -> IO K
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (MutableArray RealWorld Closure
-> Int -> Bool -> K -> FrameRecord -> IO K
pushRecord MutableArray RealWorld Closure
MutableArray (PrimState IO) Closure
bstk Int
size (Exit -> Bool
isAdHoc Exit
exit)) K
k ([FrameRecord] -> [FrameRecord]
forall a. [a] -> [a]
reverse [FrameRecord]
records)
              -- the environment native code was running with: switched,
              -- when it exited from inside a handler case
              HEnv
henv' <- Closure -> HEnv
forall a b. a -> b
unsafeCoerce (Closure -> HEnv) -> IO Closure -> IO HEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray (PrimState IO) Closure -> Int -> IO Closure
forall (m :: * -> *) a.
(DebugCallStack, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray (PrimState IO) Closure
bstk Int
size
              HEnv -> Stack -> K -> Exit -> IO ()
act HEnv
henv' Stack
stk K
k Exit
exit
    pushRecord :: MutableArray RealWorld Closure
-> Int -> Bool -> K -> FrameRecord -> IO K
pushRecord MutableArray RealWorld Closure
bstk Int
size Bool
adHoc K
k (FrameRecord Int
i Int
fsz Int
asz)
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = do
          -- an affine handler case's environment switch, in force at the
          -- exit: the frame that switches back (see exec's InLocal)
          HEnv
henv0 <- Closure -> HEnv
forall a b. a -> b
unsafeCoerce (Closure -> HEnv) -> IO Closure -> IO HEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray (PrimState IO) Closure -> Int -> IO Closure
forall (m :: * -> *) a.
(DebugCallStack, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray RealWorld Closure
MutableArray (PrimState IO) Closure
bstk (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (-Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i))
          pure (HEnv -> Int -> K -> K
Local HEnv
henv0 Int
asz K
k)
      | Bool
otherwise = do
          Frame cix :: CombIx
cix@(CIx Reference
_ Word64
grp Word64
_) Int
f MSection
sect Ptr NativeCell
cell <- Frames -> Int -> IO Frame
lookupFrame Frames
frames Int
i
          -- an exit the code didn't cause, through a Let whose body has
          -- no code: the frame carries no cell, so that popping it doesn't
          -- count the miss (leap), and the JIT's budget for such re-entry
          -- functions decides whether to count it (JIT.noteAdHocExit)
          Ptr NativeCell
cell' <-
            if Bool
adHoc Bool -> Bool -> Bool
&& Ptr NativeCell
cell Ptr NativeCell -> Ptr NativeCell -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr NativeCell
noNativeCell
              then do
                Ptr ()
code <- Ptr NativeCell -> IO (Ptr ())
readNativeCode Ptr NativeCell
cell
                if Ptr ()
code Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr then Ptr NativeCell
noNativeCell Ptr NativeCell -> IO () -> IO (Ptr NativeCell)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ JIT -> Word64 -> Ptr NativeCell -> IO ()
noteAdHocExit (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env) Word64
grp Ptr NativeCell
cell else Ptr NativeCell -> IO (Ptr NativeCell)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr NativeCell
cell
              else Ptr NativeCell -> IO (Ptr NativeCell)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr NativeCell
cell
          pure (Int -> Int -> CombIx -> Int -> MSection -> Ptr NativeCell -> K -> K
Push Int
fsz Int
asz CombIx
cix Int
f MSection
sect Ptr NativeCell
cell' K
k)
    act :: HEnv -> Stack -> K -> Exit -> IO ()
act HEnv
henv Stack
stk K
k = \case
      Named [Char]
_ Exit
e -> HEnv -> Stack -> K -> Exit -> IO ()
act HEnv
henv Stack
stk K
k Exit
e
      Resume CombIx
cix MSection
sect -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tracing (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
JIT.jitDump ([Char]
"resume " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CombIx -> [Char]
forall a. Show a => a -> [Char]
show CombIx
cix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" at\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> MSection -> [Char] -> [Char]
forall comb. Show comb => Int -> GSection comb -> [Char] -> [Char]
prettySection Int
4 MSection
sect [Char]
"")
        Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
cix MSection
sect
      -- Grow by at least the stack's current size, ensuring push is amortized O(1)
      GrowStack Int
n Ptr NativeCell
cell -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tracing (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
JIT.jitDump ([Char]
"grow stack by " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)
        Stack
stk <- Stack -> Int -> IO Stack
ensureGenerously Stack
stk Int
n
        Ptr NativeCell -> HEnv -> Stack -> K -> IO ()
again Ptr NativeCell
cell HEnv
henv Stack
stk K
k
      Reenter Ptr NativeCell
cell -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tracing (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
JIT.jitDump [Char]
"reenter"
        IO ()
Conc.yield
        Ptr NativeCell -> HEnv -> Stack -> K -> IO ()
again Ptr NativeCell
cell HEnv
henv Stack
stk K
k
      -- The interpreter runs one instruction, then native code continues
      -- after it, with whatever the instruction did to the handler
      -- environment and K. The exception case is eval's, except that the
      -- handler's continuation can be native too.
      CallOut CombIx
cix MInstr
instr MSection
rest Int
n Ptr NativeCell
cell -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tracing (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
JIT.jitDump ([Char]
"call out " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CombIx -> [Char]
forall a. Show a => a -> [Char]
show CombIx
cix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MInstr -> [Char]
forall a. Show a => a -> [Char]
show MInstr
instr)
        Ptr ()
code <- Ptr NativeCell -> IO (Ptr ())
readNativeEntry Ptr NativeCell
cell
        CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MInstr
-> IO (Bool, HEnv, Stack, K)
forall prof.
RuntimeProfiler prof =>
CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MInstr
-> IO (Bool, HEnv, Stack, K)
exec CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
cix MInstr
instr 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')
            | Bool
exception -> do
                Val
eh <- HEnv -> IO Val
resolveExceptionHandler HEnv
henv
                Val
fv <- DebugCallStack => Stack -> IO Val
Stack -> IO Val
peek Stack
stk'
                DebugCallStack => 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 cell' :: Ptr NativeCell
cell' = if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Ptr NativeCell
cell else Ptr NativeCell
noNativeCell
                    kk :: K
kk = Int -> Int -> CombIx -> Int -> MSection -> Ptr NativeCell -> K -> K
Push Int
fsz Int
asz CombIx
fakeCix Int
10 MSection
rest Ptr NativeCell
cell' K
k'
                Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk' K
kk Bool
False (Int -> Args
VArg1 Int
0) Val
eh
            | Ptr ()
code Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr ()
forall a. Ptr a
nullPtr,
              Stack -> Int
sp Stack
stk' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Stack -> Int
sp Stack
stk Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n,
              Stack -> Int
fp Stack
stk' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Stack -> Int
fp Stack
stk ->
                FunPtr NativeFn -> HEnv -> Stack -> K -> IO ()
go (Ptr () -> FunPtr NativeFn
forall a b. Ptr a -> FunPtr b
castPtrToFunPtr Ptr ()
code) HEnv
henv Stack
stk' K
k'
            | Bool
otherwise -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr ()
code Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr) (CCache prof -> Ptr NativeCell -> IO ()
forall prof. CCache prof -> Ptr NativeCell -> IO ()
countReentry CCache prof
env Ptr NativeCell
cell)
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tracing (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
JIT.jitDump ([Char]
"  no re-entry: pushed " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Stack -> Int
sp Stack
stk' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Stack -> Int
sp Stack
stk) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", expected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"; fp " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Stack -> Int
fp Stack
stk, Stack -> Int
fp Stack
stk') [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", code " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ptr () -> [Char]
forall a. Show a => a -> [Char]
show Ptr ()
code)
                Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk' K
k' CombIx
cix MSection
rest
    -- The exit says which function to call again. It is the one that took
    -- the exit, which after tail calls need not be the one entered here.
    --
    -- Its cell can still be empty: the functions of a module call each
    -- other directly, and one can be running before the compile thread
    -- has written the cell of another that it called. The cell is about
    -- to be filled, so wait for it.
    again :: Ptr NativeCell -> HEnv -> Stack -> K -> IO ()
again Ptr NativeCell
cell HEnv
henv Stack
stk K
k = Int -> IO ()
wait (Int
10000 :: Int)
      where
        wait :: Int -> IO ()
wait Int
n = do
          Ptr ()
code <- Ptr NativeCell -> IO (Ptr ())
readNativeCode Ptr NativeCell
cell
          if Ptr ()
code Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr ()
forall a. Ptr a
nullPtr
            then FunPtr NativeFn -> HEnv -> Stack -> K -> IO ()
go (Ptr () -> FunPtr NativeFn
forall a b. Ptr a -> FunPtr b
castPtrToFunPtr Ptr ()
code) HEnv
henv Stack
stk K
k
            else
              if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                then [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"native code disappeared from its cell"
                else Int -> IO ()
Conc.threadDelay Int
1000 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
wait (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- 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 (RComb Val)
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
    DebugCallStack => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp CombIx
cix GCombInfo (RComb Val)
comb Seg
seg
    pure Stack
stk
  Val
v -> [Word] -> [Char] -> IO Stack
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Stack) -> [Char] -> IO Stack
forall a b. (a -> b) -> a -> b
$ [Char]
"naming non-function: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v
{-# INLINE name #-}

extendPAp :: Val -> Val -> IO Closure
extendPAp :: Val -> Val -> IO Closure
extendPAp (BoxedVal (PAp CombIx
cix GCombInfo (RComb Val)
comb (ByteArray
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 -> ByteArray -> Int -> Int -> IO ()
forall (m :: * -> *).
(DebugCallStack, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> ByteArray -> Int -> Int -> m ()
copyByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
ucop Int
8 ByteArray
useg0 Int
0 Int
ussz
  MutableByteArray (PrimState IO) -> Int -> Int -> IO ()
forall a (m :: * -> *).
(DebugCallStack, 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
  !ByteArray
useg <- MutableByteArray (PrimState IO) -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
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.
(DebugCallStack, 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.
(DebugCallStack, 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

  -- evaluated: the JIT's request code reads the ref this goes into
  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
$! CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp CombIx
cix GCombInfo (RComb Val)
comb (ByteArray
useg, BSeg
bseg)
  where
    ussz :: Int
ussz = ByteArray -> Int
sizeofByteArray ByteArray
useg0
    bssz :: Int
bssz = BSeg -> Int
forall a. Array a -> Int
sizeofArray BSeg
bseg0
extendPAp Val
v Val
_ =
  [Word] -> [Char] -> IO Closure
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Closure) -> [Char] -> IO Closure
forall a b. (a -> b) -> a -> b
$ [Char]
"extendPAp: non partial application" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v
{-# INLINE extendPAp #-}

-- slow path application
apply ::
  (RuntimeProfiler prof) =>
  Ticker prof ->
  CCache prof ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Bool ->
  Args ->
  Val ->
  IO ()
#ifdef STACK_CHECK
apply !yld _env _henv !_activeThreads !stk !_k !_ck !args !val
  | debugger stk "apply" (args, val) = undefined
#endif
apply :: forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k !Bool
ck !Args
args !Val
val =
  case Val
val of
    BoxedVal (PAp CombIx
cix GCombInfo (RComb Val)
comb Seg
seg) ->
      case GCombInfo (RComb Val)
comb of
        LamI Int
a Int
f MSection
entry Ptr NativeCell
cell
          | 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
              Ptr ()
native <- Ptr NativeCell -> IO (Ptr ())
readNativeEntry Ptr NativeCell
cell
              if Ptr ()
native Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr Bool -> Bool -> Bool
|| [Char]
"apply" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Config -> [[Char]]
JIT.disabled (JIT -> Config
jitConfig (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env))
                then do
                  CCache prof -> CombIx -> Ptr NativeCell -> IO ()
forall prof. CCache prof -> CombIx -> Ptr NativeCell -> IO ()
countInterpreted CCache prof
env CombIx
cix Ptr NativeCell
cell
                  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
cix MSection
entry
                else do
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JIT -> Bool
jitTracing (CCache prof -> JIT
forall prof. CCache prof -> JIT
jit CCache prof
env)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char] -> IO ()
JIT.jitDump ([Char]
"apply native " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CombIx -> [Char]
forall a. Show a => a -> [Char]
show CombIx
cix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" arity " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" stack " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Stack -> [Char]
forall a. Show a => a -> [Char]
show Stack
stk)
                  Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> FunPtr NativeFn
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> FunPtr NativeFn
-> IO ()
runNative Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k (Ptr () -> FunPtr NativeFn
forall a b. Ptr a -> FunPtr b
castPtrToFunPtr Ptr ()
native)
          | 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
              DebugCallStack => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp CombIx
cix GCombInfo (RComb Val)
comb Seg
seg
              Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield Ticker prof
yld CCache prof
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
          DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
v
          Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k
      | Bool
otherwise = [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"applying non-function: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v
{-# INLINE apply #-}

jump ::
  (RuntimeProfiler prof) =>
  Ticker prof ->
  CCache prof ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  Args ->
  Closure ->
  IO ()
jump :: forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Args
-> Closure
-> IO ()
jump !Ticker prof
yld CCache prof
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
    Ticker prof
-> CCache prof -> ActiveThreads -> Stack -> HEnv -> K -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> ActiveThreads -> Stack -> HEnv -> K -> K -> IO ()
repush Ticker prof
yld CCache prof
env ActiveThreads
activeThreads Stack
stk HEnv
henv K
sk K
k
  Closure
_ -> [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"jump: non-cont"
  where
    -- Adjusts a repushed continuation to account for pending arguments. If
    -- there are any frames in the pushed continuation, the nearest one needs to
    -- record the additional pending arguments.
    --
    -- If the repushed continuation has no frames, then the arguments are still
    -- pending, and the result stacks need to be adjusted.
    adjust :: K -> (SZ, K)
    adjust :: K -> (Int, K)
adjust (Mark Int
a EnumSet Word64
rs 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 Ptr NativeCell
c K
k) =
      (Int
0, Int -> Int -> CombIx -> Int -> MSection -> Ptr NativeCell -> 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 Ptr NativeCell
c K
k)
    adjust K
k = (Stack -> Int
asize Stack
stk, K
k)
{-# INLINE jump #-}

repush ::
  (RuntimeProfiler prof) =>
  Ticker prof ->
  CCache prof ->
  ActiveThreads ->
  Stack ->
  HEnv ->
  K ->
  K ->
  IO ()
repush :: forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> ActiveThreads -> Stack -> HEnv -> K -> K -> IO ()
repush !Ticker prof
yld CCache prof
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
      -- Pending arguments. The continuation argument must be a function
      -- to be applied to them.
      | Stack -> Int
asize Stack
stk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 =
          DebugCallStack => 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
>>= Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Bool
False Args
ZArgs
      | Bool
otherwise = Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k
      where
        henv :: HEnv
henv = AEnv -> DEnv -> HEnv
HEnv AEnv
aenv DEnv
denv
    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 Ptr NativeCell
c 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 -> Ptr NativeCell -> K -> K
Push Int
n Int
a CombIx
cix Int
f MSection
rsect Ptr NativeCell
c K
k
    go !DEnv
_ (Local {}) !K
_ = [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"repush: captured Local frame"
    go !DEnv
_ (AMark {}) !K
_ = [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"repush: captured AMark frame"
    go !DEnv
_ (Keep {}) !K
_ = [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"repush: captured Keep frame"
    go !DEnv
_ (CB Callback
_) !K
_ = [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"repush: impossible"
{-# INLINE repush #-}

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

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

-- | Pack some number of args into a data type of the provided ref/tag type.
buildData ::
  Stack -> Reference -> PackedTag -> Args -> IO Closure
buildData :: Stack -> Reference -> PackedTag -> Args -> IO Closure
buildData !Stack
_ !Reference
r !PackedTag
t Args
ZArgs = Closure -> IO Closure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ Reference -> PackedTag -> Closure
Enum Reference
r PackedTag
t
buildData !Stack
stk !Reference
r !PackedTag
t (VArg1 Int
i) = do
  Val
v <- DebugCallStack => 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 <- DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Val
v2 <- DebugCallStack => 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)
  | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 = Stack
-> Reference -> PackedTag -> Int -> (Int -> Int) -> IO Closure
buildDataAt Stack
stk Reference
r PackedTag
t Int
l (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
  | Bool
otherwise = 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)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 = Stack
-> Reference -> PackedTag -> Int -> (Int -> Int) -> IO Closure
buildDataAt Stack
stk Reference
r PackedTag
t Int
n (PrimArray Int -> Int -> Int
forall a. (DebugCallStack, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
as)
  | Bool
otherwise = 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
  where
    n :: Int
n = PrimArray Int -> Int
forall a. Prim a => PrimArray a -> Int
PA.sizeofPrimArray PrimArray Int
as
buildData !Stack
stk !Reference
r !PackedTag
t (VArgV Int
i)
  | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 = Stack
-> Reference -> PackedTag -> Int -> (Int -> Int) -> IO Closure
buildDataAt Stack
stk Reference
r PackedTag
t Int
l Int -> Int
forall a. a -> a
id
  | Bool
otherwise = 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
0 Int
l)
      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 #-}

-- | A constructor of @n@ (up to six) fields, field @k@ read from slot
-- @slot k@.
buildDataAt :: Stack -> Reference -> PackedTag -> Int -> (Int -> Int) -> IO Closure
buildDataAt :: Stack
-> Reference -> PackedTag -> Int -> (Int -> Int) -> IO Closure
buildDataAt !Stack
stk !Reference
r !PackedTag
t !Int
n Int -> Int
slot = case Int
n of
  Int
0 -> 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
  Int
1 -> Reference -> PackedTag -> Val -> Closure
Data1 Reference
r PackedTag
t (Val -> Closure) -> IO Val -> IO Closure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Val
at Int
0
  Int
2 -> Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
r PackedTag
t (Val -> Val -> Closure) -> IO Val -> IO (Val -> Closure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Val
at Int
0 IO (Val -> Closure) -> IO Val -> IO Closure
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
1
  Int
3 -> Reference -> PackedTag -> Val -> Val -> Val -> Closure
Data3 Reference
r PackedTag
t (Val -> Val -> Val -> Closure)
-> IO Val -> IO (Val -> Val -> Closure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Val
at Int
0 IO (Val -> Val -> Closure) -> IO Val -> IO (Val -> Closure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
1 IO (Val -> Closure) -> IO Val -> IO Closure
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
2
  Int
4 -> Reference -> PackedTag -> Val -> Val -> Val -> Val -> Closure
Data4 Reference
r PackedTag
t (Val -> Val -> Val -> Val -> Closure)
-> IO Val -> IO (Val -> Val -> Val -> Closure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Val
at Int
0 IO (Val -> Val -> Val -> Closure)
-> IO Val -> IO (Val -> Val -> Closure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
1 IO (Val -> Val -> Closure) -> IO Val -> IO (Val -> Closure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
2 IO (Val -> Closure) -> IO Val -> IO Closure
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
3
  Int
5 -> Reference
-> PackedTag -> Val -> Val -> Val -> Val -> Val -> Closure
Data5 Reference
r PackedTag
t (Val -> Val -> Val -> Val -> Val -> Closure)
-> IO Val -> IO (Val -> Val -> Val -> Val -> Closure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Val
at Int
0 IO (Val -> Val -> Val -> Val -> Closure)
-> IO Val -> IO (Val -> Val -> Val -> Closure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
1 IO (Val -> Val -> Val -> Closure)
-> IO Val -> IO (Val -> Val -> Closure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
2 IO (Val -> Val -> Closure) -> IO Val -> IO (Val -> Closure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
3 IO (Val -> Closure) -> IO Val -> IO Closure
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
4
  Int
6 -> Reference
-> PackedTag -> Val -> Val -> Val -> Val -> Val -> Val -> Closure
Data6 Reference
r PackedTag
t (Val -> Val -> Val -> Val -> Val -> Val -> Closure)
-> IO Val -> IO (Val -> Val -> Val -> Val -> Val -> Closure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Val
at Int
0 IO (Val -> Val -> Val -> Val -> Val -> Closure)
-> IO Val -> IO (Val -> Val -> Val -> Val -> Closure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
1 IO (Val -> Val -> Val -> Val -> Closure)
-> IO Val -> IO (Val -> Val -> Val -> Closure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
2 IO (Val -> Val -> Val -> Closure)
-> IO Val -> IO (Val -> Val -> Closure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
3 IO (Val -> Val -> Closure) -> IO Val -> IO (Val -> Closure)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
4 IO (Val -> Closure) -> IO Val -> IO Closure
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Val
at Int
5
  Int
_ -> [Word] -> [Char] -> IO Closure
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"buildDataAt: more than six fields"
  where
    at :: Int -> IO Val
at Int
k = DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk (Int -> Int
slot Int
k)
{-# INLINE buildDataAt #-}

-- | Pack some number of args into a record value of the given shape. The args
-- are emitted in ascending field-name order, which is the shape's slot order,
-- so this is a straight copy.
buildRec :: Stack -> RecordShape -> Args -> IO Closure
buildRec :: Stack -> RecordShape -> Args -> IO Closure
buildRec !Stack
stk RecordShape
shape Args
args = 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
$ Args -> Args'
argsToArgs' Args
args)
  Closure -> IO Closure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure)
-> (RecordVals -> Closure) -> RecordVals -> IO Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordShape -> RecordVals -> Closure
RecordG RecordShape
shape (RecordVals -> IO Closure) -> RecordVals -> IO Closure
forall a b. (a -> b) -> a -> b
$ Seg -> RecordVals
recordVals Seg
seg
{-# INLINE buildRec #-}

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 =
  [Word] -> [Char] -> IO (PackedTag, Stack)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (PackedTag, Stack))
-> [Char] -> IO (PackedTag, Stack)
forall a b. (a -> b) -> a -> b
$ [Char]
"dumpDataValNoTag: unboxed val: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v
{-# INLINE dumpDataValNoTag #-}

-- Dumps a data type closure to the stack without writing its tag.
-- Instead, the tag is returned for direct case analysis.
dumpDataNoTag ::
  Maybe Reference ->
  Stack ->
  Closure ->
  IO Stack
dumpDataNoTag :: Maybe Reference -> Stack -> Closure -> IO Stack
dumpDataNoTag !Maybe Reference
mr !Stack
stk = \case
  -- Normally we want to avoid dumping unboxed values since it's unnecessary, but sometimes we don't know the type of
  -- the incoming value and end up dumping unboxed values, so we just push them back to the stack as-is. e.g. in type-casts/coercions
  Enum Reference
_ PackedTag
_ -> Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
  Data1 Reference
_ PackedTag
_ Val
a -> 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
<$ DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
a
  Data2 Reference
_ PackedTag
_ Val
a Val
b -> do
    Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
b
    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
<$ DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
a
  clo :: Closure
clo@(Data3 {}) -> Stack -> Closure -> IO Stack
dumpDataWide Stack
stk Closure
clo
  clo :: Closure
clo@(Data4 {}) -> Stack -> Closure -> IO Stack
dumpDataWide Stack
stk Closure
clo
  clo :: Closure
clo@(Data5 {}) -> Stack -> Closure -> IO Stack
dumpDataWide Stack
stk Closure
clo
  clo :: Closure
clo@(Data6 {}) -> Stack -> Closure -> IO Stack
dumpDataWide Stack
stk Closure
clo
  DataG Reference
_ PackedTag
_ Seg
seg -> Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
S
  Closure
clo ->
    [Word] -> [Char] -> IO Stack
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [Word
3320] ([Char] -> IO Stack) -> [Char] -> IO Stack
forall a b. (a -> b) -> a -> b
$
      [Char]
"dumpDataNoTag: bad closure: "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
clo
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> (Reference -> [Char]) -> Maybe Reference -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\Reference
r -> [Char]
"\nexpected type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r) Maybe Reference
mr
{-# INLINE dumpDataNoTag #-}

-- | The fields of a constructor with three to six fields, out of line so
-- that the interpreter's loop only inlines the common shapes.
dumpDataWide :: Stack -> Closure -> IO Stack
dumpDataWide :: Stack -> Closure -> IO Stack
dumpDataWide !Stack
stk = \case
  Data3 Reference
_ PackedTag
_ Val
a Val
b Val
c -> do
    Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
3
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
2 Val
c
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
b
    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
<$ DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
a
  Data4 Reference
_ PackedTag
_ Val
a Val
b Val
c Val
d -> do
    Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
4
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
3 Val
d
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
2 Val
c
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
b
    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
<$ DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
a
  Data5 Reference
_ PackedTag
_ Val
a Val
b Val
c Val
d Val
e -> do
    Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
5
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
4 Val
e
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
3 Val
d
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
2 Val
c
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
b
    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
<$ DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
a
  Data6 Reference
_ PackedTag
_ Val
a Val
b Val
c Val
d Val
e Val
f -> do
    Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
6
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
5 Val
f
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
4 Val
e
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
3 Val
d
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
2 Val
c
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
b
    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
<$ DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
a
  Closure
clo -> [Word] -> [Char] -> IO Stack
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [Word
3321] ([Char] -> IO Stack) -> [Char] -> IO Stack
forall a b. (a -> b) -> a -> b
$ [Char]
"dumpDataWide: bad closure: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
clo
{-# NOINLINE dumpDataWide #-}

-- 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 ::
  (RuntimeProfiler prof) =>
  Ticker prof ->
  CCache prof ->
  HEnv ->
  ActiveThreads ->
  Stack ->
  K ->
  IO ()
yield :: forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield !Ticker prof
yld CCache prof
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 <- DebugCallStack => Stack -> IO Val
Stack -> IO Val
peek Stack
stk
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      DebugCallStack => 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
      Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply Ticker prof
yld CCache prof
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 <- DebugCallStack => 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
      DebugCallStack => 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
emptyDEnv
      Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> Bool
-> Args
-> Val
-> IO ()
apply Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k Bool
False (Int -> Args
VArg1 Int
0) Val
h
    leap (Push Int
fsz Int
asz CombIx
cix Int
f MSection
nx Ptr NativeCell
cell 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
      -- The Let body may have native code (the re-entry point).
      Ptr ()
native <- Ptr NativeCell -> IO (Ptr ())
readNativeEntry Ptr NativeCell
cell
      if Ptr ()
native Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
        then do
          CCache prof -> Ptr NativeCell -> IO ()
forall prof. CCache prof -> Ptr NativeCell -> IO ()
countReentry CCache prof
env Ptr NativeCell
cell
          Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> MSection
-> IO ()
eval Ticker prof
yld CCache prof
env HEnv
henv0 ActiveThreads
activeThreads Stack
stk K
k CombIx
cix MSection
nx
        else Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> FunPtr NativeFn
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> FunPtr NativeFn
-> IO ()
runNative Ticker prof
yld CCache prof
env HEnv
henv0 ActiveThreads
activeThreads Stack
stk K
k (Ptr () -> FunPtr NativeFn
forall a b. Ptr a -> FunPtr b
castPtrToFunPtr Ptr ()
native)
    leap (Local HEnv
henv Int
asz K
k) = do
      Stack
stk <- Stack -> Int -> Int -> IO Stack
restoreFrame Stack
stk Int
0 Int
asz
      Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k
    leap (CB (Hook XStack -> IO ()
f)) = XStack -> IO ()
f (Stack -> XStack
unpackXStack Stack
stk)
    leap (Keep a
_ Int
asz K
k) = do
      Stack
stk <- Stack -> Int -> Int -> IO Stack
restoreFrame Stack
stk Int
0 Int
asz
      Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof -> HEnv -> ActiveThreads -> Stack -> K -> IO ()
yield Ticker prof
yld CCache prof
env HEnv
henv0 ActiveThreads
activeThreads Stack
stk K
k
    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 #-}

selectBytesBranch ::
  Bytes.Bytes -> MSection -> M.Map Bytes.Bytes MSection -> MSection
selectBytesBranch :: Bytes -> MSection -> Map Bytes MSection -> MSection
selectBytesBranch Bytes
b MSection
df Map Bytes MSection
cs = MSection -> Bytes -> Map Bytes MSection -> MSection
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault MSection
df Bytes
b Map Bytes MSection
cs
{-# INLINE selectBytesBranch #-}

selectBranch :: Tag -> MBranch -> MSection
selectBranch :: Word64 -> MBranch -> MSection
selectBranch Word64
t (Test1 Word64
u Arm (RComb Val)
y MSection
n)
  | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u = Arm (RComb Val) -> MSection
forall comb. Arm comb -> GSection comb
armSection Arm (RComb Val)
y
  | Bool
otherwise = MSection
n
selectBranch Word64
t (Test2 Word64
u Arm (RComb Val)
cu Word64
v Arm (RComb Val)
cv MSection
e)
  | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u = Arm (RComb Val) -> MSection
forall comb. Arm comb -> GSection comb
armSection Arm (RComb Val)
cu
  | Word64
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
v = Arm (RComb Val) -> MSection
forall comb. Arm comb -> GSection comb
armSection Arm (RComb Val)
cv
  | Bool
otherwise = MSection
e
selectBranch Word64
t (TestW MSection
df EnumMap Word64 (Arm (RComb Val))
cs) = case Word64
-> EnumMap Word64 (Arm (RComb Val)) -> Maybe (Arm (RComb Val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
t EnumMap Word64 (Arm (RComb Val))
cs of
  Just Arm (RComb Val)
a -> Arm (RComb Val) -> MSection
forall comb. Arm comb -> GSection comb
armSection Arm (RComb Val)
a
  Maybe (Arm (RComb Val))
Nothing -> MSection
df
selectBranch Word64
_ (TestT {}) = [Char] -> MSection
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
selectBranch Word64
_ (TestY {}) = [Char] -> MSection
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
{-# INLINE selectBranch #-}

-- Combined branch selection and field dumping function for data types.
-- Fields should only be dumped on _matches_, not default cases, because
-- default cases potentially cover many constructors which could result
-- in a variable number of values being put on the stack. Default cases
-- uniformly expect _no_ values to be added to the stack.
dataBranch ::
  Maybe Reference -> Stack -> MBranch -> Closure -> IO (MSection, Stack)
dataBranch :: Maybe Reference
-> Stack -> MBranch -> Closure -> IO (MSection, Stack)
dataBranch Maybe Reference
mrf Stack
stk MBranch
br = \case
  -- one case on the closure: each shape looks its arm up and pushes its
  -- fields in the same alternative (a second dispatch to push them cost a
  -- few nanoseconds per match, 2026-10-15)
  Enum Reference
_ PackedTag
t -> PackedTag -> Int -> IO Stack -> IO (MSection, Stack)
pick PackedTag
t Int
0 (Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk)
  Data1 Reference
_ PackedTag
t Val
a -> PackedTag -> Int -> IO Stack -> IO (MSection, Stack)
pick PackedTag
t Int
1 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
<$ DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
a
  Data2 Reference
_ PackedTag
t Val
a Val
b -> PackedTag -> Int -> IO Stack -> IO (MSection, Stack)
pick PackedTag
t Int
2 do
    Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
    DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
b
    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
<$ DebugCallStack => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
a
  clo :: Closure
clo@(Data3 Reference
_ PackedTag
t Val
_ Val
_ Val
_) -> PackedTag -> Int -> IO Stack -> IO (MSection, Stack)
pick PackedTag
t Int
3 (Stack -> Closure -> IO Stack
dumpDataWide Stack
stk Closure
clo)
  clo :: Closure
clo@(Data4 Reference
_ PackedTag
t Val
_ Val
_ Val
_ Val
_) -> PackedTag -> Int -> IO Stack -> IO (MSection, Stack)
pick PackedTag
t Int
4 (Stack -> Closure -> IO Stack
dumpDataWide Stack
stk Closure
clo)
  clo :: Closure
clo@(Data5 Reference
_ PackedTag
t Val
_ Val
_ Val
_ Val
_ Val
_) -> PackedTag -> Int -> IO Stack -> IO (MSection, Stack)
pick PackedTag
t Int
5 (Stack -> Closure -> IO Stack
dumpDataWide Stack
stk Closure
clo)
  clo :: Closure
clo@(Data6 Reference
_ PackedTag
t Val
_ Val
_ Val
_ Val
_ Val
_ Val
_) -> PackedTag -> Int -> IO Stack -> IO (MSection, Stack)
pick PackedTag
t Int
6 (Stack -> Closure -> IO Stack
dumpDataWide Stack
stk Closure
clo)
  DataG Reference
_ PackedTag
t seg :: Seg
seg@(ByteArray
_, BSeg
bseg) -> PackedTag -> Int -> IO Stack -> IO (MSection, Stack)
pick PackedTag
t (BSeg -> Int
forall a. Array a -> Int
sizeofArray BSeg
bseg) (Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
S)
  Foreign (WrapMap Map Val Val
m) -> case Map Val Val
m of
    M.Bin Int
sz Val
k Val
e Map Val Val
l Map Val Val
r
      | Just (Arm Int
_ MSection
ca) <- MBranch -> Word64 -> Maybe (Arm (RComb Val))
branchArm MBranch
br Word64
Rf.mapBin -> (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 (Arm Int
_ MSection
ca) <- MBranch -> Word64 -> Maybe (Arm (RComb Val))
branchArm MBranch
br Word64
Rf.mapTip -> (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 (MBranch -> MSection
branchDefault MBranch
br, Stack
stk)
  Closure
clo -> (MBranch -> MSection
branchDefault MBranch
br, 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
<$ Maybe Reference -> Closure -> IO ()
dataBranchClosureError Maybe Reference
mrf Closure
clo
  where
    -- The arm runs only when the object has the field count the arm was
    -- laid out for: the arm's code and the frame it was given room for
    -- assume that count, and an object with more fields would push past
    -- both. Only ill-typed code arranges a mismatch (Any.unsafeExtract, a
    -- value built elsewhere); native code exits to here on the same
    -- mismatch, so both modes end in this error.
    pick :: PackedTag -> Int -> IO Stack -> IO (MSection, Stack)
    pick :: PackedTag -> Int -> IO Stack -> IO (MSection, Stack)
pick PackedTag
t Int
n IO Stack
push = case MBranch -> Word64 -> Maybe (Arm (RComb Val))
branchArm MBranch
br (PackedTag -> Word64
maskTags PackedTag
t) of
      Just (Arm Int
m MSection
ca)
        | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n -> (MSection
ca,) (Stack -> (MSection, Stack)) -> IO Stack -> IO (MSection, Stack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Stack
push
        | Bool
otherwise -> Maybe Reference -> PackedTag -> Int -> Int -> IO (MSection, Stack)
forall a. Maybe Reference -> PackedTag -> Int -> Int -> IO a
dataBranchArityError Maybe Reference
mrf PackedTag
t Int
m Int
n
      Maybe (Arm (RComb Val))
Nothing -> (MSection, Stack) -> IO (MSection, Stack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MBranch -> MSection
branchDefault MBranch
br, Stack
stk)
    {-# INLINE pick #-}
{-# INLINE dataBranch #-}

-- | The section of a data branch for a constructor number, if it has one.
-- Inlined into a case, so the Maybe costs nothing.
branchArm :: MBranch -> Word64 -> Maybe (Arm (RComb Val))
branchArm :: MBranch -> Word64 -> Maybe (Arm (RComb Val))
branchArm MBranch
br Word64
ct = case MBranch
br of
  Test1 Word64
u Arm (RComb Val)
cu MSection
_ -> if Word64
ct Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u then Arm (RComb Val) -> Maybe (Arm (RComb Val))
forall a. a -> Maybe a
Just Arm (RComb Val)
cu else Maybe (Arm (RComb Val))
forall a. Maybe a
Nothing
  Test2 Word64
u Arm (RComb Val)
cu Word64
v Arm (RComb Val)
cv MSection
_ -> if Word64
ct Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
u then Arm (RComb Val) -> Maybe (Arm (RComb Val))
forall a. a -> Maybe a
Just Arm (RComb Val)
cu else if Word64
ct Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
v then Arm (RComb Val) -> Maybe (Arm (RComb Val))
forall a. a -> Maybe a
Just Arm (RComb Val)
cv else Maybe (Arm (RComb Val))
forall a. Maybe a
Nothing
  TestW MSection
_ EnumMap Word64 (Arm (RComb Val))
bs -> Word64
-> EnumMap Word64 (Arm (RComb Val)) -> Maybe (Arm (RComb Val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
ct EnumMap Word64 (Arm (RComb Val))
bs
  MBranch
_ -> Maybe (Arm (RComb Val))
forall a. Maybe a
Nothing
{-# INLINE branchArm #-}

-- | The default section of a data branch.
branchDefault :: MBranch -> MSection
branchDefault :: MBranch -> MSection
branchDefault = \case
  Test1 Word64
_ Arm (RComb Val)
_ MSection
d -> MSection
d
  Test2 Word64
_ Arm (RComb Val)
_ Word64
_ Arm (RComb Val)
_ MSection
d -> MSection
d
  TestW MSection
d EnumMap Word64 (Arm (RComb Val))
_ -> MSection
d
  MBranch
br -> RuntimePanic -> MSection
forall a e. (HasCallStack, Exception e) => e -> a
throw ([Char] -> Maybe Val -> RuntimePanic
Panic ([Char]
"dataBranch: unexpected branch: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MBranch -> [Char]
forall a. Show a => a -> [Char]
show MBranch
br) Maybe Val
forall a. Maybe a
Nothing)
{-# INLINE branchDefault #-}

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
  DebugCallStack => Stack -> Int -> IO ()
Stack -> Int -> IO ()
unsafePokeIasN Stack
stk Int
sz
  DebugCallStack => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
k
  DebugCallStack => 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 #-}

prettyRef :: Reference -> String
prettyRef :: Reference -> [Char]
prettyRef = FieldName -> [Char]
Text.unpack (FieldName -> [Char])
-> (Reference -> FieldName) -> Reference -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Reference -> FieldName
showShort Int
10

-- | A data match on a value whose constructor has a different number of
-- fields than the arm binds: ill-typed code, which the arm cannot run on
-- (its slot layout is for its own count).
dataBranchArityError :: Maybe Reference -> PackedTag -> Int -> Int -> IO a
dataBranchArityError :: forall a. Maybe Reference -> PackedTag -> Int -> Int -> IO a
dataBranchArityError Maybe Reference
mrf PackedTag
t Int
m Int
n =
  [Word] -> [Char] -> IO a
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$
    [Char]
"dataBranch: a value with the wrong number of fields\n"
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"    type: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Reference -> [Char]) -> Maybe Reference -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"unknown" Reference -> [Char]
prettyRef Maybe Reference
mrf
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n    data tag: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show (PackedTag -> Word64
maskTags PackedTag
t)
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n    the arm binds "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
m
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" fields, the value has "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n

dataBranchClosureError ::
  Maybe Reference -> Closure -> IO ()
dataBranchClosureError :: Maybe Reference -> Closure -> IO ()
dataBranchClosureError (Just Reference
rftgt) (DataC Reference
rf PackedTag
_ [Val]
_)
  | Reference
rftgt Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
/= Reference
rf =
      [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"dataBranch: type mismatch detected\n"
          [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"    expected: "
          [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Reference -> [Char]
prettyRef Reference
rftgt
          [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n"
          [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"    received: "
          [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Reference -> [Char]
prettyRef Reference
rf
dataBranchClosureError Maybe Reference
_ (DataC Reference
rf PackedTag
t [Val]
_) =
  [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char]
"dataBranch: unexpected tag for data type\n"
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"    type: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Reference -> [Char]
prettyRef Reference
rf
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n"
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"    data tag: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show (PackedTag -> Word64
maskTags PackedTag
t)
dataBranchClosureError Maybe Reference
mrf Closure
clo =
  [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char]
"dataBranch: unexpected closure type\n"
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
expected
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"but instead I received "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
description
  where
    expected :: [Char]
expected = case Maybe Reference
mrf of
      Just Reference
rftgt ->
        [Char]
"    expected type: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Reference -> [Char]
prettyRef Reference
rftgt [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n  "
      Maybe Reference
Nothing -> [Char]
"I expected a data type, "
    description :: [Char]
description = case Closure
clo of
      PAp {} -> [Char]
"a partially applied function"
      Captured {} -> [Char]
"a continuation"
      Affine {} -> [Char]
"an affine handler info"
      Closure
BlackHole -> [Char]
"a black hole"
      UnboxedTypeTag UnboxedTypeTag
CharTag -> [Char]
"a character"
      UnboxedTypeTag UnboxedTypeTag
FloatTag -> [Char]
"a floating point number"
      UnboxedTypeTag UnboxedTypeTag
IntTag -> [Char]
"an integer"
      UnboxedTypeTag UnboxedTypeTag
NatTag -> [Char]
"a natural number"
      TextC {} -> [Char]
"a builtin value of type `" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Reference -> [Char]
prettyRef Reference
Rf.textRef [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"
      ListC {} -> [Char]
"a builtin value of type `" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Reference -> [Char]
prettyRef Reference
Rf.listRef [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"
      BytesC {} -> [Char]
"a builtin value of type `" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Reference -> [Char]
prettyRef Reference
Rf.bytesRef [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"
      Foreign (Foreign -> Reference
foreignRef -> Reference
rf) ->
        [Char]
"a builtin value of type `" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Reference -> [Char]
prettyRef Reference
rf [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"
      RecordC {} -> [Char]
"a record"

-- 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 =
      [Word] -> [Char] -> IO (ZonkAny 0)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"fell off stack" IO (ZonkAny 0)
-> 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
_) =
      [Word] -> [Char] -> IO (ZonkAny 1)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"fell off stack" IO (ZonkAny 1)
-> 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 {}) =
      [Word] -> [Char] -> IO (ZonkAny 2)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"splitCont: Local frame" IO (ZonkAny 2)
-> 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 {}) =
      [Word] -> [Char] -> IO (ZonkAny 3)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"splitCont: AMark frame" IO (ZonkAny 3)
-> 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 (Keep {}) =
      [Word] -> [Char] -> IO (ZonkAny 4)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"splitCont: Keep frame" IO (ZonkAny 4)
-> 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 Ptr NativeCell
c 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 -> Ptr NativeCell -> K -> K
Push Int
n Int
a CombIx
br Int
p MSection
brSect Ptr NativeCell
c 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 -> [Word] -> [Char] -> IO (AEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"abortCont: fell off stack"
      (CB Callback
_) -> [Word] -> [Char] -> IO (AEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"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
_ Ptr NativeCell
_ 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
      (Keep a
_ 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
      -- 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 p -> HEnv -> Stack -> MRef -> IO Val
resolve :: forall p. CCache p -> HEnv -> Stack -> GRef (RComb Val) -> IO Val
resolve CCache p
_ HEnv
_ Stack
_ (Env CombIx
cix RComb Val
mcomb) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CombIx -> RComb Val -> Val
mCombVal CombIx
cix RComb Val
mcomb)
resolve CCache p
_ HEnv
_ Stack
stk (Stk Int
i) = DebugCallStack => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
resolve CCache p
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 = [Char] -> CCache p -> Word64 -> IO Val
forall p a. [Char] -> CCache p -> Word64 -> IO a
unhandledErr [Char]
"resolve" CCache p
env Word64
i
{-# INLINE resolve #-}

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

rCombSection :: EnumMap Word64 MCombs -> CombIx -> MComb
rCombSection :: EnumMap Word64 MCombs -> CombIx -> RComb Val
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 (RComb Val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i MCombs
cmbs of
      Just GComb Val (RComb Val)
cmb -> GComb Val (RComb Val) -> RComb Val
forall val. GComb val (RComb val) -> RComb val
RComb GComb Val (RComb Val)
cmb
      Maybe (GComb Val (RComb Val))
Nothing -> [Char] -> RComb Val
forall a. HasCallStack => [Char] -> a
error ([Char] -> RComb Val) -> [Char] -> RComb Val
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown section `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"` of combinator `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"`. Reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r
    Maybe MCombs
Nothing -> [Char] -> RComb Val
forall a. HasCallStack => [Char] -> a
error ([Char] -> RComb Val) -> [Char] -> RComb Val
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown combinator `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"`. Reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

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

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

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

decodeCacheArgument :: USeq -> IO [(Reference, Code Reference)]
decodeCacheArgument :: USeq -> IO [(Reference, Code Reference)]
decodeCacheArgument USeq
s = (Val -> IO (Reference, Code Reference))
-> [Val] -> IO [(Reference, Code 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 ((Referent, Referenced Code) -> IO (Reference, Code Reference)
forall {t :: * -> *}.
Referential t =>
(Referent, Referenced t) -> IO (Reference, t Reference)
f ((Referent, Referenced Code) -> IO (Reference, Code Reference))
-> (Val -> IO (Referent, Referenced Code))
-> Val
-> IO (Reference, Code Reference)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Val -> IO (Referent, Referenced Code)
forall a. ForeignConvention a => Val -> IO a
decodeVal) ([Val] -> IO [(Reference, Code Reference)])
-> [Val] -> IO [(Reference, Code Reference)]
forall a b. (a -> b) -> a -> b
$ USeq -> [Val]
forall a. Deque a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList USeq
s
  where
    f :: (Referent, Referenced t) -> IO (Reference, t Reference)
f (Ref Reference
r, Referenced t
rco) = (Reference, t Reference) -> IO (Reference, t Reference)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference
r, Referenced t -> t Reference
forall (t :: * -> *). Referential t => Referenced t -> t Reference
dereference Referenced t
rco)
    f (Referent, Referenced t)
_ = [Word] -> [Char] -> IO (Reference, t Reference)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"decodeCacheArgument: Con reference"

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 Reference -> Code Reference
normalizeCode co = case deserializeCode (serializeCode False co) of
  Left _ -> error "normalizeCode: impossible"
  Right co -> co

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

#else

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

#endif

cacheAdd0 ::
  (RuntimeProfiler p) =>
  S.Set Reference ->
  [(Reference, Code Reference)] ->
  [(Reference, Set Reference)] ->
  CCache p ->
  IO ()
cacheAdd0 :: forall p.
RuntimeProfiler p =>
Set Reference
-> [(Reference, Code Reference)]
-> [(Reference, Set Reference)]
-> CCache p
-> IO ()
cacheAdd0 Set Reference
ntys0 ([(Reference, Code Reference)] -> [(Reference, Code Reference)]
normalizeCodes -> [(Reference, Code Reference)]
termSuperGroups) [(Reference, Set Reference)]
sands CCache p
cc = IO ()
go
  where
    toAdd :: Map Reference (SuperGroup Reference Symbol)
toAdd = [(Reference, SuperGroup Reference Symbol)]
-> Map Reference (SuperGroup Reference Symbol)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Reference, Code Reference)]
termSuperGroups [(Reference, Code Reference)]
-> ((Reference, Code Reference)
    -> (Reference, SuperGroup Reference Symbol))
-> [(Reference, SuperGroup Reference Symbol)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Code Reference -> SuperGroup Reference Symbol)
-> (Reference, Code Reference)
-> (Reference, SuperGroup Reference 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 Reference -> SuperGroup Reference Symbol
forall ref. Code ref -> SuperGroup ref Symbol
codeGroup)
    -- Which record schemas this code needs is a property of the code, so read it
    -- off the groups rather than making every caller work it out.
    recSchemas :: Set RecordSchema
recSchemas = ((Reference, Code Reference) -> Set RecordSchema)
-> [(Reference, Code Reference)] -> Set RecordSchema
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (SuperGroup Reference Symbol -> Set RecordSchema
forall ref v. SuperGroup ref v -> Set RecordSchema
ANF.groupRecordSchemas (SuperGroup Reference Symbol -> Set RecordSchema)
-> ((Reference, Code Reference) -> SuperGroup Reference Symbol)
-> (Reference, Code Reference)
-> Set RecordSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code Reference -> SuperGroup Reference Symbol
forall ref. Code ref -> SuperGroup ref Symbol
codeGroup (Code Reference -> SuperGroup Reference Symbol)
-> ((Reference, Code Reference) -> Code Reference)
-> (Reference, Code Reference)
-> SuperGroup Reference Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference, Code Reference) -> Code Reference
forall a b. (a, b) -> b
snd) [(Reference, Code Reference)]
termSuperGroups

    -- Every new combinator gets a native code cell (see unison-runtime/src/Unison/Runtime/JIT/design.md).
    -- Cells come from the cache's pool, so the transaction never allocates
    -- memory, which a retried transaction would leak. If the pool is too
    -- small, the transaction makes no changes to the code and reports how
    -- many cells it needs; the pool is grown outside the transaction and
    -- the whole thing is tried again.
    go :: IO ()
go = do
      Either
  Int
  (EnumMap Word64 (GCombs Val CombIx),
   EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
   EnumMap Word64 Reference)
result <- STM
  (Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference))
-> IO
     (Either
        Int
        (EnumMap Word64 (GCombs Val CombIx),
         EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
         EnumMap Word64 Reference))
forall a. STM a -> IO a
atomically STM
  (Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference))
transaction
      case Either
  Int
  (EnumMap Word64 (GCombs Val CombIx),
   EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
   EnumMap Word64 Reference)
result of
        Left Int
needed -> do
          NativeCellPool
pool <- TVar NativeCellPool -> IO NativeCellPool
forall a. TVar a -> IO a
readTVarIO (CCache p -> TVar NativeCellPool
forall prof. CCache prof -> TVar NativeCellPool
nativeCells CCache p
cc)
          NativeCellPool
pool' <- Int -> Int -> NativeCellPool -> IO NativeCellPool
growNativeCellPool (JIT -> Int
initialNativeCount (CCache p -> JIT
forall prof. CCache prof -> JIT
jit CCache p
cc)) Int
needed NativeCellPool
pool
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar NativeCellPool -> NativeCellPool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (CCache p -> TVar NativeCellPool
forall prof. CCache prof -> TVar NativeCellPool
nativeCells CCache p
cc) NativeCellPool
pool'
          IO ()
go
        Right (EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs, EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs, EnumMap Word64 MCombs
newCombs, EnumMap Word64 Reference
newCombRefs) -> do
          TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache p -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
tagRefs CCache p
cc) IO (EnumMap Word64 Reference)
-> (EnumMap Word64 Reference -> 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
>>= JIT -> EnumMap Word64 Reference -> IO ()
registerTypeNumbers (CCache p -> JIT
forall prof. CCache prof -> JIT
jit CCache p
cc)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
JIT.dumpMCode (JIT -> Config
jitConfig (CCache p -> JIT
forall prof. CCache prof -> JIT
jit CCache p
cc))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            [(Word64, GCombs Val CombIx)]
-> ((Word64, GCombs Val CombIx) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (EnumMap Word64 (GCombs Val CombIx) -> [(Word64, GCombs Val CombIx)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList (EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx)
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs)) \(Word64
w, GCombs Val CombIx
cmbs) ->
              [(Word64, GComb Val CombIx)]
-> ((Word64, GComb Val CombIx) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (GCombs Val CombIx -> [(Word64, GComb Val CombIx)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList GCombs Val CombIx
cmbs) \(Word64
i, GComb Val CombIx
c) -> [Char] -> IO ()
JIT.jitDump (Word64 -> Word64 -> GComb Val CombIx -> [Char] -> [Char]
forall val comb.
(Show val, Show comb) =>
Word64 -> Word64 -> GComb val comb -> [Char] -> [Char]
prettyComb Word64
w Word64
i GComb Val CombIx
c [Char]
"")
          [(Word64, MCombs)] -> ((Word64, MCombs) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (EnumMap Word64 MCombs -> [(Word64, MCombs)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 MCombs
newCombs) \(Word64
w, MCombs
cmbs) ->
            Maybe Reference -> (Reference -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Word64 -> EnumMap Word64 Reference -> Maybe Reference
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w EnumMap Word64 Reference
newCombRefs) \Reference
r -> JIT -> Bool -> Reference -> Word64 -> MCombs -> IO ()
jitCompileGroup (CCache p -> JIT
forall prof. CCache prof -> JIT
jit CCache p
cc) (CCache p -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache p
cc) Reference
r Word64
w MCombs
cmbs
          EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx) -> CCache p -> IO ()
forall p.
RuntimeProfiler p =>
EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx) -> CCache p -> IO ()
preEvalTopLevelConstants EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs CCache p
cc

    transaction :: STM
  (Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference))
transaction = do
      Map Reference (SuperGroup Reference Symbol)
have <- TVar (Map Reference (SuperGroup Reference Symbol))
-> STM (Map Reference (SuperGroup Reference Symbol))
forall a. TVar a -> STM a
readTVar (CCache p -> TVar (Map Reference (SuperGroup Reference Symbol))
forall prof.
CCache prof -> TVar (Map Reference (SuperGroup Reference Symbol))
intermed CCache p
cc)
      BiMap RecordSchema RecordRef
haveRecSchemas <- TVar (BiMap RecordSchema RecordRef)
-> STM (BiMap RecordSchema RecordRef)
forall a. TVar a -> STM a
readTVar (CCache p -> TVar (BiMap RecordSchema RecordRef)
forall prof. CCache prof -> TVar (BiMap RecordSchema RecordRef)
recordRefs CCache p
cc)
      let new :: Map Reference (SuperGroup Reference Symbol)
new = Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.difference Map Reference (SuperGroup Reference Symbol)
toAdd Map Reference (SuperGroup Reference 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 Reference Symbol) -> Int
forall k a. Map k a -> Int
M.size Map Reference (SuperGroup Reference Symbol)
new
      let rs :: [Reference]
rs = Map Reference (SuperGroup Reference Symbol) -> [Reference]
forall k a. Map k a -> [k]
M.keys Map Reference (SuperGroup Reference Symbol)
new
      let int :: Map Reference (SuperGroup Reference Symbol)
int = Map Reference (SuperGroup Reference Symbol)
new Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
forall a. Semigroup a => a -> a -> a
<> Map Reference (SuperGroup Reference Symbol)
have
      let replace :: SuperGroup Reference Symbol -> SuperGroup Reference Symbol
replace =
            Map Reference (Map CTag ForeignFunc)
-> SuperGroup Reference Symbol -> SuperGroup Reference Symbol
forall ref v.
(Ord ref, Var v) =>
Map ref (Map CTag ForeignFunc)
-> SuperGroup ref v -> SuperGroup ref v
ANF.replaceConstructors Map Reference (Map CTag ForeignFunc)
pseudoConstructors
              (SuperGroup Reference Symbol -> SuperGroup Reference Symbol)
-> (SuperGroup Reference Symbol -> SuperGroup Reference Symbol)
-> SuperGroup Reference Symbol
-> SuperGroup Reference Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Reference Reference
-> SuperGroup Reference Symbol -> SuperGroup Reference Symbol
forall ref v.
(Ord ref, Var v) =>
Map ref ref -> SuperGroup ref v -> SuperGroup ref v
ANF.replaceFunctions Map Reference Reference
functionReplacements
          haff :: (Map
   (Reference' FieldName h) (SuperGroup (Reference' FieldName h) v),
 OptInfos (Reference' FieldName h) v)
-> (Map
      (Reference' FieldName h) (SuperGroup (Reference' FieldName h) v),
    OptInfos (Reference' FieldName h) v)
haff (Map
  (Reference' FieldName h) (SuperGroup (Reference' FieldName h) v)
cmbs, OptInfos (Reference' FieldName h) v
opts) =
            ((Reference' FieldName h
 -> SuperGroup (Reference' FieldName h) v
 -> SuperGroup (Reference' FieldName h) v)
-> Map
     (Reference' FieldName h) (SuperGroup (Reference' FieldName h) v)
-> Map
     (Reference' FieldName h) (SuperGroup (Reference' FieldName h) v)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey ((FieldName -> Reference' FieldName h)
-> OptInfos (Reference' FieldName h) v
-> Reference' FieldName h
-> SuperGroup (Reference' FieldName h) v
-> SuperGroup (Reference' FieldName h) v
forall ref v.
(Ord ref, Var v) =>
(FieldName -> ref)
-> OptInfos ref v -> ref -> SuperGroup ref v -> SuperGroup ref v
ANF.optimizeHandler FieldName -> Reference' FieldName h
forall t h. t -> Reference' t h
Builtin OptInfos (Reference' FieldName h) v
opts) Map
  (Reference' FieldName h) (SuperGroup (Reference' FieldName h) v)
cmbs, OptInfos (Reference' FieldName h) v
opts)
      (Map Reference (SuperGroup Reference Symbol)
opt, OptInfos Reference Symbol
optInfos') <- (Map Reference (SuperGroup Reference Symbol),
 OptInfos Reference Symbol)
-> (Map Reference (SuperGroup Reference Symbol),
    OptInfos Reference Symbol)
forall {v} {h}.
(Var v, Ord h) =>
(Map
   (Reference' FieldName h) (SuperGroup (Reference' FieldName h) v),
 OptInfos (Reference' FieldName h) v)
-> (Map
      (Reference' FieldName h) (SuperGroup (Reference' FieldName h) v),
    OptInfos (Reference' FieldName h) v)
haff ((Map Reference (SuperGroup Reference Symbol),
  OptInfos Reference Symbol)
 -> (Map Reference (SuperGroup Reference Symbol),
     OptInfos Reference Symbol))
-> (OptInfos Reference Symbol
    -> (Map Reference (SuperGroup Reference Symbol),
        OptInfos Reference Symbol))
-> OptInfos Reference Symbol
-> (Map Reference (SuperGroup Reference Symbol),
    OptInfos Reference Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Reference (SuperGroup Reference Symbol)
-> OptInfos Reference Symbol
-> (Map Reference (SuperGroup Reference Symbol),
    OptInfos Reference Symbol)
forall ref v.
(Ord ref, Var v) =>
Map ref (SuperGroup ref v)
-> OptInfos ref v -> (Map ref (SuperGroup ref v), OptInfos ref v)
ANF.optimize ((SuperGroup Reference Symbol -> SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference 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 Reference Symbol -> SuperGroup Reference Symbol
replace Map Reference (SuperGroup Reference Symbol)
new) (OptInfos Reference Symbol
 -> (Map Reference (SuperGroup Reference Symbol),
     OptInfos Reference Symbol))
-> STM (OptInfos Reference Symbol)
-> STM
     (Map Reference (SuperGroup Reference Symbol),
      OptInfos Reference Symbol)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (OptInfos Reference Symbol) -> STM (OptInfos Reference Symbol)
forall a. TVar a -> STM a
readTVar (CCache p -> TVar (OptInfos Reference Symbol)
forall prof. CCache prof -> TVar (OptInfos Reference Symbol)
optInfos CCache p
cc)
      -- These three number things. Numbering is harmless to commit even if the
      -- pool turns out to be too small: the numbers are simply used or skipped.
      Map Reference Word64
rty <- TVar Word64
-> TVar (Map Reference Word64)
-> TVar (EnumMap Word64 Reference)
-> Set Reference
-> STM (Map Reference Word64)
addRefs (CCache p -> TVar Word64
forall prof. CCache prof -> TVar Word64
freshTy CCache p
cc) (CCache p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTy CCache p
cc) (CCache p -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
tagRefs CCache p
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 p -> TVar Word64
forall prof. CCache prof -> TVar Word64
freshTm CCache p
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)
      let newRefTm :: Map Reference Word64
newRefTm = [(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 ..]
      Map Reference Word64
rtm <- (Map Reference Word64
newRefTm Map Reference Word64
-> Map Reference Word64 -> Map Reference Word64
forall a. Semigroup a => a -> a -> a
<>) (Map Reference Word64 -> Map Reference Word64)
-> STM (Map Reference Word64) -> STM (Map Reference Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map Reference Word64) -> STM (Map Reference Word64)
forall a. TVar a -> STM a
readTVar (CCache p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache p
cc)
      let newRecSchemas :: Set RecordSchema
newRecSchemas = Set RecordSchema
recSchemas Set RecordSchema -> Set RecordSchema -> Set RecordSchema
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` (BiMap RecordSchema RecordRef -> Set RecordSchema
forall k v. BiMap k v -> Set k
BM.keysSetL BiMap RecordSchema RecordRef
haveRecSchemas)
      let numNewRecSchemas :: Word64
numNewRecSchemas = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Set RecordSchema -> Int
forall a. Set a -> Int
Set.size Set RecordSchema
newRecSchemas
      Word64
nrs <- TVar Word64 -> (Word64 -> (Word64, Word64)) -> STM Word64
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar (CCache p -> TVar Word64
forall prof. CCache prof -> TVar Word64
freshRecSchema CCache p
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
numNewRecSchemas)
      let newRecSchemaMap :: BiMap RecordSchema RecordRef
newRecSchemaMap = [(RecordSchema, RecordRef)] -> BiMap RecordSchema RecordRef
forall k v. (Ord k, Ord v) => [(k, v)] -> BiMap k v
BM.fromList ([(RecordSchema, RecordRef)] -> BiMap RecordSchema RecordRef)
-> [(RecordSchema, RecordRef)] -> BiMap RecordSchema RecordRef
forall a b. (a -> b) -> a -> b
$ [RecordSchema] -> [RecordRef] -> [(RecordSchema, RecordRef)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set RecordSchema -> [RecordSchema]
forall a. Set a -> [a]
Set.toList Set RecordSchema
newRecSchemas) (Word64 -> RecordRef
ANF.RecordRef (Word64 -> RecordRef) -> [Word64] -> [RecordRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word64
nrs ..])
          rrLookup :: BiMap RecordSchema RecordRef
rrLookup = BiMap RecordSchema RecordRef
newRecSchemaMap BiMap RecordSchema RecordRef
-> BiMap RecordSchema RecordRef -> BiMap RecordSchema RecordRef
forall a. Semigroup a => a -> a -> a
<> BiMap RecordSchema RecordRef
haveRecSchemas
      -- Field names no longer need pre-registering here: building a record's
      -- shape during emit interns any name it hasn't seen.
      RecordFieldMappings
oldRfms <- TVar RecordFieldMappings -> STM RecordFieldMappings
forall a. TVar a -> STM a
readTVar (CCache p -> TVar RecordFieldMappings
forall prof. CCache prof -> TVar RecordFieldMappings
recordFieldMappings CCache p
cc)
      -- check for missing references
      let arities :: Map Reference Int
arities = (SuperGroup Reference Symbol -> Int)
-> Map Reference (SuperGroup Reference 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 Reference Symbol -> [Int])
-> SuperGroup Reference Symbol
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuperGroup Reference Symbol -> [Int]
forall ref v. SuperGroup ref v -> [Int]
ANF.arities) Map Reference (SuperGroup Reference 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)
-> (RecordSchema -> RecordRef)
-> RefNums
RN ([Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
"ty" Map Reference Word64
rty) ([Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
"tm" Map Reference Word64
rtm) ((Reference -> Map Reference Int -> Maybe Int)
-> Map Reference Int -> Reference -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference -> Map Reference Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map Reference Int
arities) (BiMap RecordSchema RecordRef -> RecordSchema -> RecordRef
recordRefLookup BiMap RecordSchema RecordRef
rrLookup)
          combinate :: Word64 -> (Reference, SuperGroup Reference Symbol) -> State RecordFieldMappings (Word64, EnumMap Word64 Comb)
          combinate :: Word64
-> (Reference, SuperGroup Reference Symbol)
-> State RecordFieldMappings (Word64, GCombs Void CombIx)
combinate Word64
n (Reference
r, SuperGroup Reference Symbol
g) = (Word64
n,) (GCombs Void CombIx -> (Word64, GCombs Void CombIx))
-> StateT RecordFieldMappings Identity (GCombs Void CombIx)
-> State RecordFieldMappings (Word64, GCombs Void CombIx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> SuperGroup Reference Symbol
-> StateT RecordFieldMappings Identity (GCombs Void CombIx)
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> SuperGroup Reference v
-> StateT RecordFieldMappings Identity (GCombs Void CombIx)
emitCombs RefNums
rns Reference
r Word64
n SuperGroup Reference 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 Reference)]
termSuperGroups
              [(Reference, Code Reference)]
-> ([(Reference, Code Reference)] -> [Word64]) -> [Word64]
forall a b. a -> (a -> b) -> b
& ((Reference, Code Reference) -> Maybe Word64)
-> [(Reference, Code Reference)] -> [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 Reference 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 Reference)
_ -> 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
      let ([(Word64, GCombs Void CombIx)]
emittedCombs, RecordFieldMappings
newRFMs) =
            (Word64
 -> (Reference, SuperGroup Reference Symbol)
 -> State RecordFieldMappings (Word64, GCombs Void CombIx))
-> [Word64]
-> [(Reference, SuperGroup Reference Symbol)]
-> [State RecordFieldMappings (Word64, GCombs Void CombIx)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word64
-> (Reference, SuperGroup Reference Symbol)
-> State RecordFieldMappings (Word64, GCombs Void CombIx)
combinate [Word64
ntm ..] (Map Reference (SuperGroup Reference Symbol)
-> [(Reference, SuperGroup Reference Symbol)]
forall k a. Map k a -> [(k, a)]
M.toList Map Reference (SuperGroup Reference Symbol)
opt)
              [State RecordFieldMappings (Word64, GCombs Void CombIx)]
-> ([State RecordFieldMappings (Word64, GCombs Void CombIx)]
    -> StateT
         RecordFieldMappings Identity [(Word64, GCombs Void CombIx)])
-> StateT
     RecordFieldMappings Identity [(Word64, GCombs Void CombIx)]
forall a b. a -> (a -> b) -> b
& [State RecordFieldMappings (Word64, GCombs Void CombIx)]
-> StateT
     RecordFieldMappings Identity [(Word64, GCombs Void CombIx)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
              StateT RecordFieldMappings Identity [(Word64, GCombs Void CombIx)]
-> (StateT
      RecordFieldMappings Identity [(Word64, GCombs Void CombIx)]
    -> ([(Word64, GCombs Void CombIx)], RecordFieldMappings))
-> ([(Word64, GCombs Void CombIx)], RecordFieldMappings)
forall a b. a -> (a -> b) -> b
& (StateT RecordFieldMappings Identity [(Word64, GCombs Void CombIx)]
 -> RecordFieldMappings
 -> ([(Word64, GCombs Void CombIx)], RecordFieldMappings))
-> RecordFieldMappings
-> StateT
     RecordFieldMappings Identity [(Word64, GCombs Void CombIx)]
-> ([(Word64, GCombs Void CombIx)], RecordFieldMappings)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT RecordFieldMappings Identity [(Word64, GCombs Void CombIx)]
-> RecordFieldMappings
-> ([(Word64, GCombs Void CombIx)], RecordFieldMappings)
forall s a. State s a -> s -> (a, s)
runState RecordFieldMappings
oldRfms
          uncelled :: EnumMap Word64 (GCombs Void CombIx)
uncelled =
            Bool
-> Set ForeignFunc
-> EnumMap Word64 (GCombs Void CombIx)
-> EnumMap Word64 (GCombs Void CombIx)
sanitizeCombsOfForeignFuncs (CCache p -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache p
cc) Set ForeignFunc
sandboxedForeignFuncs (EnumMap Word64 (GCombs Void CombIx)
 -> EnumMap Word64 (GCombs Void CombIx))
-> EnumMap Word64 (GCombs Void CombIx)
-> EnumMap Word64 (GCombs Void CombIx)
forall a b. (a -> b) -> a -> b
$
              [(Word64, GCombs Void CombIx)]
-> EnumMap Word64 (GCombs Void CombIx)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList [(Word64, GCombs Void CombIx)]
emittedCombs
          (Int
cellCount, EnumMap Word64 (GCombs Void CombIx)
_) = Ptr NativeCell
-> EnumMap Word64 (GCombs Void CombIx)
-> (Int, EnumMap Word64 (GCombs Void CombIx))
forall val comb.
Ptr NativeCell
-> EnumMap Word64 (GCombs val comb)
-> (Int, EnumMap Word64 (GCombs val comb))
attachNativeCells Ptr NativeCell
forall a. Ptr a
nullPtr EnumMap Word64 (GCombs Void CombIx)
uncelled
      NativeCellPool
pool <- TVar NativeCellPool -> STM NativeCellPool
forall a. TVar a -> STM a
readTVar (CCache p -> TVar NativeCellPool
forall prof. CCache prof -> TVar NativeCellPool
nativeCells CCache p
cc)
      case Int -> NativeCellPool -> Maybe (Ptr NativeCell, NativeCellPool)
takeNativeCells Int
cellCount NativeCellPool
pool of
        Maybe (Ptr NativeCell, NativeCellPool)
Nothing -> Either
  Int
  (EnumMap Word64 (GCombs Val CombIx),
   EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
   EnumMap Word64 Reference)
-> STM
     (Either
        Int
        (EnumMap Word64 (GCombs Val CombIx),
         EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
         EnumMap Word64 Reference))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
forall a b. a -> Either a b
Left Int
cellCount)
        Just (Ptr NativeCell
cells, NativeCellPool
pool') -> do
          -- Everything is in hand. From here on the transaction only writes.
          TVar NativeCellPool -> NativeCellPool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (CCache p -> TVar NativeCellPool
forall prof. CCache prof -> TVar NativeCellPool
nativeCells CCache p
cc) NativeCellPool
pool'
          Map Reference (SuperGroup Reference Symbol)
int' <- Map Reference (SuperGroup Reference Symbol)
-> TVar (Map Reference (SuperGroup Reference Symbol))
-> STM (Map Reference (SuperGroup Reference Symbol))
forall s. Semigroup s => s -> TVar s -> STM s
updateMap Map Reference (SuperGroup Reference Symbol)
new (CCache p -> TVar (Map Reference (SuperGroup Reference Symbol))
forall prof.
CCache prof -> TVar (Map Reference (SuperGroup Reference Symbol))
intermed CCache p
cc)
          TVar (OptInfos Reference Symbol)
-> OptInfos Reference Symbol -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (CCache p -> TVar (OptInfos Reference Symbol)
forall prof. CCache prof -> TVar (OptInfos Reference Symbol)
optInfos CCache p
cc) OptInfos Reference Symbol
optInfos'
          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 Map Reference Word64
newRefTm (CCache p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache p
cc)
          BiMap RecordSchema RecordRef
rrs <- BiMap RecordSchema RecordRef
-> TVar (BiMap RecordSchema RecordRef)
-> STM (BiMap RecordSchema RecordRef)
forall s. Semigroup s => s -> TVar s -> STM s
updateMap BiMap RecordSchema RecordRef
newRecSchemaMap (CCache p -> TVar (BiMap RecordSchema RecordRef)
forall prof. CCache prof -> TVar (BiMap RecordSchema RecordRef)
recordRefs CCache p
cc)
          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 p -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
combRefs CCache p
cc)
          (EnumMap Word64 (GCombs Void CombIx)
unresolvedNewCombs, EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs, EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs, EnumMap Word64 MCombs
newCombs, EnumMap Word64 MCombs
updatedCombs) <- TVar (EnumMap Word64 MCombs)
-> (EnumMap Word64 MCombs
    -> ((EnumMap Word64 (GCombs Void CombIx),
         EnumMap Word64 (GCombs Val CombIx),
         EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
         EnumMap Word64 MCombs),
        EnumMap Word64 MCombs))
-> STM
     (EnumMap Word64 (GCombs Void CombIx),
      EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 MCombs)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar (CCache p -> TVar (EnumMap Word64 MCombs)
forall prof. CCache prof -> TVar (EnumMap Word64 MCombs)
combs CCache p
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 ((Int, EnumMap Word64 (GCombs Void CombIx))
-> EnumMap Word64 (GCombs Void CombIx)
forall a b. (a, b) -> b
snd (Ptr NativeCell
-> EnumMap Word64 (GCombs Void CombIx)
-> (Int, EnumMap Word64 (GCombs Void CombIx))
forall val comb.
Ptr NativeCell
-> EnumMap Word64 (GCombs val comb)
-> (Int, EnumMap Word64 (GCombs val comb))
attachNativeCells Ptr NativeCell
cells EnumMap Word64 (GCombs Void CombIx)
uncelled))
                (EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs, EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs) =
                  EnumMap Word64 (GCombs Val CombIx) -> [(Word64, GCombs Val CombIx)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (GCombs Val CombIx)
forall any. EnumMap Word64 (GCombs any CombIx)
unresolvedNewCombs [(Word64, GCombs Val CombIx)]
-> ([(Word64, GCombs Val CombIx)]
    -> (EnumMap Word64 (GCombs Val CombIx),
        EnumMap Word64 (GCombs Val CombIx)))
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall a b. a -> (a -> b) -> b
& ((Word64, GCombs Val CombIx)
 -> (EnumMap Word64 (GCombs Val CombIx),
     EnumMap Word64 (GCombs Val CombIx)))
-> [(Word64, GCombs Val CombIx)]
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs 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, GCombs 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 -> GCombs Val CombIx -> EnumMap Word64 (GCombs Val CombIx)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
w GCombs Val CombIx
gcombs, EnumMap Word64 (GCombs Val CombIx)
forall a. Monoid a => a
mempty)
                      else (EnumMap Word64 (GCombs Val CombIx)
forall a. Monoid a => a
mempty, Word64 -> GCombs Val CombIx -> EnumMap Word64 (GCombs Val CombIx)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
w GCombs Val CombIx
gcombs)
                newCombs :: EnumMap Word64 MCombs
                newCombs :: EnumMap Word64 MCombs
newCombs = Maybe (EnumMap Word64 MCombs)
-> EnumMap Word64 (GCombs 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 (GCombs Val CombIx) -> EnumMap Word64 MCombs)
-> EnumMap Word64 (GCombs Val CombIx) -> EnumMap Word64 MCombs
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 (GCombs 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 (GCombs Val CombIx)
unresolvedCacheableCombs, EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs, EnumMap Word64 MCombs
newCombs, 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 p -> TVar (EnumMap Word64 (GCombs Void CombIx))
forall prof.
CCache prof -> TVar (EnumMap Word64 (GCombs Void CombIx))
srcCombs CCache p
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 p -> TVar (Map Reference (Set Reference))
forall prof. CCache prof -> TVar (Map Reference (Set Reference))
sandbox CCache p
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 p -> TVar (EnumSet Word64)
forall prof. CCache prof -> TVar (EnumSet Word64)
cacheableCombs CCache p
cc)
          TVar RecordFieldMappings -> RecordFieldMappings -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (CCache p -> TVar RecordFieldMappings
forall prof. CCache prof -> TVar RecordFieldMappings
recordFieldMappings CCache p
cc) RecordFieldMappings
newRFMs
          -- Now that the code cache is primed with everything we need,
          -- we can pre-evaluate the top-level constants.
          pure $ Map Reference (SuperGroup Reference Symbol)
int' Map Reference (SuperGroup Reference Symbol)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
forall a b. a -> b -> b
`seq` Map Reference Word64
rtm' Map Reference Word64
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
forall a b. a -> b -> b
`seq` BiMap RecordSchema RecordRef
rrs BiMap RecordSchema RecordRef
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
forall a b. a -> b -> b
`seq` EnumMap Word64 Reference
newCombRefs EnumMap Word64 Reference
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
forall a b. a -> b -> b
`seq` EnumMap Word64 MCombs
updatedCombs EnumMap Word64 MCombs
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
forall a b. a -> b -> b
`seq` Map Reference (Set Reference)
nsn Map Reference (Set Reference)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
forall a b. a -> b -> b
`seq` EnumSet Word64
ncc EnumSet Word64
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
forall a b. a -> b -> b
`seq` EnumMap Word64 (GCombs Void CombIx)
nsc EnumMap Word64 (GCombs Void CombIx)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
forall a b. a -> b -> b
`seq` (EnumMap Word64 (GCombs Val CombIx),
 EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
 EnumMap Word64 Reference)
-> Either
     Int
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), EnumMap Word64 MCombs,
      EnumMap Word64 Reference)
forall a b. b -> Either a b
Right (EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs, EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs, EnumMap Word64 MCombs
newCombs, EnumMap Word64 Reference
newCombRefs)

preEvalTopLevelConstants ::
  (RuntimeProfiler p) =>
  (EnumMap Word64 (GCombs Val CombIx)) ->
  (EnumMap Word64 (GCombs Val CombIx)) ->
  CCache p ->
  IO ()
preEvalTopLevelConstants :: forall p.
RuntimeProfiler p =>
EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx) -> CCache p -> IO ()
preEvalTopLevelConstants EnumMap Word64 (GCombs Val CombIx)
cacheableCombs EnumMap Word64 (GCombs Val CombIx)
newCombs CCache p
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 (GCombs Val CombIx))
evaluatedCacheableCombsVar <- EnumMap Word64 (GCombs Val CombIx)
-> IO (TVar (EnumMap Word64 (GCombs Val CombIx)))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 (GCombs Val CombIx)
forall a. Monoid a => a
mempty
  [(Word64, GCombs Val CombIx)]
-> ((Word64, GCombs Val CombIx) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (EnumMap Word64 (GCombs Val CombIx) -> [(Word64, GCombs Val CombIx)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (GCombs Val CombIx)
cacheableCombs) \(Word64
w, GCombs 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 <- DebugCallStack => 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 (GCombs Val CombIx))
-> (EnumMap Word64 (GCombs Val CombIx)
    -> EnumMap Word64 (GCombs Val CombIx))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (EnumMap Word64 (GCombs Val CombIx))
evaluatedCacheableCombsVar ((EnumMap Word64 (GCombs Val CombIx)
  -> EnumMap Word64 (GCombs Val CombIx))
 -> STM ())
-> (EnumMap Word64 (GCombs Val CombIx)
    -> EnumMap Word64 (GCombs Val CombIx))
-> STM ()
forall a b. (a -> b) -> a -> b
$ Word64
-> GCombs Val CombIx
-> EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx)
forall k a. EnumKey k => k -> a -> EnumMap k a -> EnumMap k a
EC.mapInsert Word64
w (Word64 -> GComb Val CombIx -> GCombs Val CombIx
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
0 (GComb Val CombIx -> GCombs Val CombIx)
-> GComb Val CombIx -> GCombs 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 p -> ActiveThreads -> Word64 -> IO ()
forall p.
RuntimeProfiler p =>
Maybe (XStack -> IO ())
-> CCache p -> 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 p
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. (HasCallStack, Exception e) => e -> IO a
throwIO RuntimeExn
e

  EnumMap Word64 (GCombs Val CombIx)
evaluatedCacheableCombs <- TVar (EnumMap Word64 (GCombs Val CombIx))
-> IO (EnumMap Word64 (GCombs Val CombIx))
forall a. TVar a -> IO a
readTVarIO TVar (EnumMap Word64 (GCombs Val CombIx))
evaluatedCacheableCombsVar
  let allNew :: EnumMap Word64 (GCombs Val CombIx)
allNew = EnumMap Word64 (GCombs Val CombIx)
evaluatedCacheableCombs EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx)
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 (GCombs 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 p -> TVar (EnumMap Word64 MCombs)
forall prof. CCache prof -> TVar (EnumMap Word64 MCombs)
combs CCache p
cc) (\EnumMap Word64 MCombs
existingCombs -> (Maybe (EnumMap Word64 MCombs)
-> EnumMap Word64 (GCombs 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 (GCombs 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 (GCombs Val CombIx)
allNew) EnumMap Word64 (GCombs 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
_ [Word]
_ (Width -> Pretty ColorText -> FieldName
P.toPlain Width
0 -> FieldName
msg)) =
  FieldName -> FieldName -> Bool
Text.isPrefixOf FieldName
sdbx1 FieldName
msg Bool -> Bool -> Bool
|| FieldName -> FieldName -> Bool
Text.isPrefixOf FieldName
sdbx2 FieldName
msg
  where
    sdbx1 :: FieldName
sdbx1 = FieldName
"attempted to use sandboxed operation"
    sdbx2 :: FieldName
sdbx2 = FieldName
"Attempted to use disallowed builtin in sandboxed"
isSandboxingException RuntimeExn
_ = Bool
False

expandSandbox ::
  Map Reference (Set Reference) ->
  [(Reference, SuperGroup Reference Symbol)] ->
  [(Reference, Set Reference)]
expandSandbox :: Map Reference (Set Reference)
-> [(Reference, SuperGroup Reference Symbol)]
-> [(Reference, Set Reference)]
expandSandbox Map Reference (Set Reference)
sand0 [(Reference, SuperGroup Reference 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 ref (Set a) -> (a, SuperGroup ref v) -> Maybe (a, Set a)
h Map ref (Set a)
sand (a
r, (Bool -> ref -> Set a) -> SuperGroup ref v -> Set a
forall r v ref.
(Monoid r, Var v) =>
(Bool -> ref -> r) -> SuperGroup ref v -> r
foldGroupLinks (Map ref (Set a) -> Bool -> ref -> Set a
forall {a} {k}. (Monoid a, Ord k) => Map k a -> Bool -> k -> a
f Map ref (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 Reference Symbol)
 -> Maybe (Reference, Set Reference))
-> [(Reference, SuperGroup Reference 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 Reference Symbol)
-> Maybe (Reference, Set Reference)
forall {v} {a} {ref} {a}.
(Var v, Ord a, Ord ref) =>
Map ref (Set a) -> (a, SuperGroup ref v) -> Maybe (a, Set a)
h (Map Reference (Set Reference)
 -> (Reference, SuperGroup Reference Symbol)
 -> Maybe (Reference, Set Reference))
-> Map Reference (Set Reference)
-> (Reference, SuperGroup Reference 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 Reference 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 ::
  (RuntimeProfiler p) =>
  [(Reference, Code Reference)] ->
  CCache p ->
  IO [Reference]
cacheAdd :: forall p.
RuntimeProfiler p =>
[(Reference, Code Reference)] -> CCache p -> IO [Reference]
cacheAdd [(Reference, Code Reference)]
l CCache p
cc = do
  Map Reference Word64
rtm <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache p
cc)
  Map Reference Word64
rty <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTy CCache p
cc)
  Map Reference (Set Reference)
sand <- TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a. TVar a -> IO a
readTVarIO (CCache p -> TVar (Map Reference (Set Reference))
forall prof. CCache prof -> TVar (Map Reference (Set Reference))
sandbox CCache p
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
-> (Reference, Code Reference) -> Reference
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Reference (Reference, Code Reference) Reference
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Reference, Code Reference)
  (Reference, Code Reference)
  Reference
  Reference
_1 ((Reference, Code Reference) -> Reference)
-> [(Reference, Code Reference)] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, Code Reference)]
l)
      f :: Bool
-> Reference -> Const (Set Reference, Set Reference) (ZonkAny 6)
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) (ZonkAny 6)
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) (ZonkAny 6)
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) (ZonkAny 6)
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) (ZonkAny 6)
-> (Set Reference, Set Reference)
forall {k} a (b :: k). Const a b -> a
getConst (Const (Set Reference, Set Reference) (ZonkAny 6)
 -> (Set Reference, Set Reference))
-> Const (Set Reference, Set Reference) (ZonkAny 6)
-> (Set Reference, Set Reference)
forall a b. (a -> b) -> a -> b
$ (((Reference, Code Reference)
 -> Const (Set Reference, Set Reference) (ZonkAny 6))
-> [(Reference, Code Reference)]
-> Const (Set Reference, Set Reference) (ZonkAny 6)
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 Reference)
  -> Const (Set Reference, Set Reference) (ZonkAny 6))
 -> [(Reference, Code Reference)]
 -> Const (Set Reference, Set Reference) (ZonkAny 6))
-> ((SuperGroup Reference Symbol
     -> Const (Set Reference, Set Reference) (ZonkAny 6))
    -> (Reference, Code Reference)
    -> Const (Set Reference, Set Reference) (ZonkAny 6))
-> (SuperGroup Reference Symbol
    -> Const (Set Reference, Set Reference) (ZonkAny 6))
-> [(Reference, Code Reference)]
-> Const (Set Reference, Set Reference) (ZonkAny 6)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Code Reference
 -> Const (Set Reference, Set Reference) (ZonkAny 6))
-> (Reference, Code Reference)
-> Const (Set Reference, Set Reference) (ZonkAny 6)
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 Reference
  -> Const (Set Reference, Set Reference) (ZonkAny 6))
 -> (Reference, Code Reference)
 -> Const (Set Reference, Set Reference) (ZonkAny 6))
-> ((SuperGroup Reference Symbol
     -> Const (Set Reference, Set Reference) (ZonkAny 6))
    -> Code Reference
    -> Const (Set Reference, Set Reference) (ZonkAny 6))
-> (SuperGroup Reference Symbol
    -> Const (Set Reference, Set Reference) (ZonkAny 6))
-> (Reference, Code Reference)
-> Const (Set Reference, Set Reference) (ZonkAny 6)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SuperGroup Reference Symbol
 -> Const (Set Reference, Set Reference) (ZonkAny 6))
-> Code Reference
-> Const (Set Reference, Set Reference) (ZonkAny 6)
forall m ref.
Monoid m =>
(SuperGroup ref Symbol -> m) -> Code ref -> m
foldGroup) ((Bool
 -> Reference -> Const (Set Reference, Set Reference) (ZonkAny 6))
-> SuperGroup Reference Symbol
-> Const (Set Reference, Set Reference) (ZonkAny 6)
forall r v ref.
(Monoid r, Var v) =>
(Bool -> ref -> r) -> SuperGroup ref v -> r
foldGroupLinks Bool
-> Reference -> Const (Set Reference, Set Reference) (ZonkAny 6)
f) [(Reference, Code Reference)]
l
      l'' :: [(Reference, Code Reference)]
l'' = ((Reference, Code Reference) -> Bool)
-> [(Reference, Code Reference)] -> [(Reference, Code Reference)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Reference
r, Code Reference
_) -> 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 Reference)]
l
      l' :: [(Reference, SuperGroup Reference Symbol)]
l' = ((Reference, Code Reference)
 -> (Reference, SuperGroup Reference Symbol))
-> [(Reference, Code Reference)]
-> [(Reference, SuperGroup Reference Symbol)]
forall a b. (a -> b) -> [a] -> [b]
map ((Code Reference -> SuperGroup Reference Symbol)
-> (Reference, Code Reference)
-> (Reference, SuperGroup Reference 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 Reference -> SuperGroup Reference Symbol
forall ref. Code ref -> SuperGroup ref Symbol
codeGroup) [(Reference, Code Reference)]
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)]
-> [(Reference, Set Reference)]
-> CCache p
-> IO ()
forall p.
RuntimeProfiler p =>
Set Reference
-> [(Reference, Code Reference)]
-> [(Reference, Set Reference)]
-> CCache p
-> IO ()
cacheAdd0 Set Reference
tys [(Reference, Code Reference)]
l'' (Map Reference (Set Reference)
-> [(Reference, SuperGroup Reference Symbol)]
-> [(Reference, Set Reference)]
expandSandbox Map Reference (Set Reference)
sand [(Reference, SuperGroup Reference Symbol)]
l') CCache p
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

data ReflectionState = RS
  { ReflectionState -> HashMap Word64 RefNum
_tyNums :: HM.HashMap Word64 RefNum,
    ReflectionState -> HashMap Word64 RefNum
_tmNums :: HM.HashMap Word64 RefNum,
    ReflectionState -> CanonST
_canonST :: {-# UNPACK #-} !CanonST
  }

type Reflect = StateT ReflectionState IO

emptyRS :: ReflectionState
emptyRS :: ReflectionState
emptyRS = HashMap Word64 RefNum
-> HashMap Word64 RefNum -> CanonST -> ReflectionState
RS HashMap Word64 RefNum
forall k v. HashMap k v
HM.empty HashMap Word64 RefNum
forall k v. HashMap k v
HM.empty CanonST
emptyCST

mediate :: Canonize a -> Reflect a
mediate :: forall a. Canonize a -> Reflect a
mediate Canonize a
act = (ReflectionState -> IO (a, ReflectionState))
-> StateT ReflectionState IO a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT \(RS HashMap Word64 RefNum
sty HashMap Word64 RefNum
stm CanonST
cst) ->
  (CanonST -> ReflectionState)
-> (a, CanonST) -> (a, ReflectionState)
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 (HashMap Word64 RefNum
-> HashMap Word64 RefNum -> CanonST -> ReflectionState
RS HashMap Word64 RefNum
sty HashMap Word64 RefNum
stm) ((a, CanonST) -> (a, ReflectionState))
-> IO (a, CanonST) -> IO (a, ReflectionState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Canonize a -> CanonST -> IO (a, CanonST)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Canonize a
act CanonST
cst
{-# INLINE mediate #-}

canonicalizeReference :: Bool -> Reference -> Reflect RefNum
canonicalizeReference :: Bool -> Reference -> Reflect RefNum
canonicalizeReference Bool
isTy = Canonize RefNum -> Reflect RefNum
forall a. Canonize a -> Reflect a
mediate (Canonize RefNum -> Reflect RefNum)
-> (Reference -> Canonize RefNum) -> Reference -> Reflect RefNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Reference -> Canonize RefNum
resolveRef Bool
isTy

canonicalizeReferent :: Referent -> Reflect (Referent' RefNum)
canonicalizeReferent :: Referent -> Reflect (Referent' RefNum)
canonicalizeReferent = Canonize (Referent' RefNum) -> Reflect (Referent' RefNum)
forall a. Canonize a -> Reflect a
mediate (Canonize (Referent' RefNum) -> Reflect (Referent' RefNum))
-> (Referent -> Canonize (Referent' RefNum))
-> Referent
-> Reflect (Referent' RefNum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Referent -> Canonize (Referent' RefNum)
forall (t :: * -> *).
Referential t =>
t Reference -> Canonize (t RefNum)
canonicalizeRefs

canonicalizeReferenced ::
  (Referential t) => Referenced t -> Reflect (t RefNum)
canonicalizeReferenced :: forall (t :: * -> *).
Referential t =>
Referenced t -> Reflect (t RefNum)
canonicalizeReferenced Referenced t
x = Canonize (t RefNum) -> Reflect (t RefNum)
forall a. Canonize a -> Reflect a
mediate (Canonize (t RefNum) -> Reflect (t RefNum))
-> Canonize (t RefNum) -> Reflect (t RefNum)
forall a b. (a -> b) -> a -> b
$ Referenced t -> Canonize (t RefNum)
forall (t :: * -> *).
Referential t =>
Referenced t -> Canonize (t RefNum)
recanonicalizeRefs Referenced t
x
{-# INLINE canonicalizeReferenced #-}

reflectValue :: CCache p -> Val -> IO (Referenced ANF.Value)
reflectValue :: forall p. CCache p -> Val -> IO (Referenced Value)
reflectValue CCache p
env Val
val = do
  EnumMap Word64 Reference
tyr <- TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache p -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
tagRefs CCache p
env)
  EnumMap Word64 Reference
tmr <- TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache p -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
combRefs CCache p
env)
  EnumMap Word64 Reference
-> EnumMap Word64 Reference -> Val -> IO (Referenced Value)
reflectValue0 EnumMap Word64 Reference
tyr EnumMap Word64 Reference
tmr Val
val
    IO (Referenced Value)
-> (ReflectExn -> IO (Referenced Value)) -> IO (Referenced Value)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(ReflectExn [Char]
problem) ->
      [Word] -> [Char] -> IO (Referenced Value)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (Referenced Value))
-> [Char] -> IO (Referenced Value)
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
err [Char]
problem [Char]
rendered
  where
    err :: [Char] -> [Char] -> [Char]
err [Char]
s [Char]
v =
      [Char]
"reflectValue: cannot prepare value for serialization: "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\nSerialized value:\n\n"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
v

    rendered :: [Char]
rendered = case CCache p -> Bool -> Val -> Tracer
forall prof. CCache prof -> Bool -> Val -> Tracer
tracer CCache p
env Bool
False Val
val of
      Tracer
NoTrace -> Val -> [Char]
forall a. Show a => a -> [Char]
show Val
val
      MsgTrace [Char]
_ [Char]
_ [Char]
pre -> [Char]
pre
      SimpleTrace [Char]
ugl -> [Char]
ugl

reflExn :: String -> Reflect a
reflExn :: forall a. [Char] -> Reflect a
reflExn [Char]
msg = IO a -> StateT ReflectionState IO a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT ReflectionState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> StateT ReflectionState IO a)
-> (ReflectExn -> IO a)
-> ReflectExn
-> StateT ReflectionState IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReflectExn -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ReflectExn -> StateT ReflectionState IO a)
-> ReflectExn -> StateT ReflectionState IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> ReflectExn
ReflectExn [Char]
msg

-- Converts the numbered reference map to a renumbering operation for
-- reflection.
resolveTy :: EnumMap Word64 Reference -> Word64 -> Reflect RefNum
resolveTy :: EnumMap Word64 Reference -> Word64 -> Reflect RefNum
resolveTy EnumMap Word64 Reference
rty Word64
w =
  (ReflectionState -> IO (RefNum, ReflectionState)) -> Reflect RefNum
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT \st :: ReflectionState
st@(RS HashMap Word64 RefNum
seenty HashMap Word64 RefNum
seentm CanonST
cst) ->
    case Word64 -> HashMap Word64 RefNum -> Maybe RefNum
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Word64
w HashMap Word64 RefNum
seenty of
      Just RefNum
r -> (RefNum, ReflectionState) -> IO (RefNum, ReflectionState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RefNum
r, ReflectionState
st)
      -- if we haven't seen the number before, we need to consult the
      -- reference map and canonicalizers.
      Maybe RefNum
Nothing
        | 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 -> do
            (RefNum
rn, CanonST
cst) <- Canonize RefNum -> CanonST -> IO (RefNum, CanonST)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Bool -> Reference -> Canonize RefNum
resolveRef Bool
True Reference
r) CanonST
cst
            HashMap Word64 RefNum
seenty <- HashMap Word64 RefNum -> IO (HashMap Word64 RefNum)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Word64 RefNum -> IO (HashMap Word64 RefNum))
-> HashMap Word64 RefNum -> IO (HashMap Word64 RefNum)
forall a b. (a -> b) -> a -> b
$ Word64 -> RefNum -> HashMap Word64 RefNum -> HashMap Word64 RefNum
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Word64
w RefNum
rn HashMap Word64 RefNum
seenty
            ReflectionState
st <- ReflectionState -> IO ReflectionState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReflectionState -> IO ReflectionState)
-> ReflectionState -> IO ReflectionState
forall a b. (a -> b) -> a -> b
$ HashMap Word64 RefNum
-> HashMap Word64 RefNum -> CanonST -> ReflectionState
RS HashMap Word64 RefNum
seenty HashMap Word64 RefNum
seentm CanonST
cst
            pure (RefNum
rn, ReflectionState
st)
        | Bool
otherwise -> ReflectExn -> IO (RefNum, ReflectionState)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ReflectExn -> IO (RefNum, ReflectionState))
-> ReflectExn -> IO (RefNum, ReflectionState)
forall a b. (a -> b) -> a -> b
$ [Char] -> ReflectExn
ReflectExn [Char]
"unknown type reference"

-- Converts the numbered refence map to a renumbering operation for
-- reflection, with function unreplacements considered.
resolveTm :: EnumMap Word64 Reference -> Word64 -> Reflect RefNum
resolveTm :: EnumMap Word64 Reference -> Word64 -> Reflect RefNum
resolveTm EnumMap Word64 Reference
rtm Word64
w =
  (ReflectionState -> IO (RefNum, ReflectionState)) -> Reflect RefNum
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT \st :: ReflectionState
st@(RS HashMap Word64 RefNum
seenty HashMap Word64 RefNum
seentm CanonST
cst) ->
    case Word64 -> HashMap Word64 RefNum -> Maybe RefNum
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Word64
w HashMap Word64 RefNum
seentm of
      Just RefNum
r -> (RefNum, ReflectionState) -> IO (RefNum, ReflectionState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RefNum
r, ReflectionState
st)
      -- if we haven't seen the number before, we need to consult the
      -- reference map and canonicalizers.
      Maybe RefNum
Nothing
        | 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
rtm,
          Reference
r <- Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Reference
r Reference
r Map Reference Reference
functionUnreplacements -> do
            (RefNum
rn, CanonST
cst) <- Canonize RefNum -> CanonST -> IO (RefNum, CanonST)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Bool -> Reference -> Canonize RefNum
resolveRef Bool
False Reference
r) CanonST
cst
            HashMap Word64 RefNum
seentm <- HashMap Word64 RefNum -> IO (HashMap Word64 RefNum)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Word64 RefNum -> IO (HashMap Word64 RefNum))
-> HashMap Word64 RefNum -> IO (HashMap Word64 RefNum)
forall a b. (a -> b) -> a -> b
$ Word64 -> RefNum -> HashMap Word64 RefNum -> HashMap Word64 RefNum
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Word64
w RefNum
rn HashMap Word64 RefNum
seentm
            ReflectionState
st <- ReflectionState -> IO ReflectionState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReflectionState -> IO ReflectionState)
-> ReflectionState -> IO ReflectionState
forall a b. (a -> b) -> a -> b
$ HashMap Word64 RefNum
-> HashMap Word64 RefNum -> CanonST -> ReflectionState
RS HashMap Word64 RefNum
seenty HashMap Word64 RefNum
seentm CanonST
cst
            pure (RefNum
rn, ReflectionState
st)
        | Bool
otherwise -> ReflectExn -> IO (RefNum, ReflectionState)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ReflectExn -> IO (RefNum, ReflectionState))
-> ReflectExn -> IO (RefNum, ReflectionState)
forall a b. (a -> b) -> a -> b
$ [Char] -> ReflectExn
ReflectExn [Char]
"unknown term reference"

-- | A map deserialized from the interchange form, in the form the
-- program's own maps have: the Haskell 'WrapMap' when base's @Map@ type is
-- replaced, the Unison tree otherwise (see `mapReplaced`).
mapVal :: M.Map Val Val -> Val
mapVal :: Map Val Val -> Val
mapVal Map Val Val
m
  | Bool
mapReplaced = Map Val Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Map Val Val
m
  | Bool
otherwise = Closure -> Val
boxedVal (Map Val Val -> Closure
inflateMap Map Val Val
m)

-- | The key/value pairs of base's @Map@ tree in key order, when the type
-- isn't replaced and the tree has the shape `inflateMap` builds; the tree
-- is serialized as the interchange `Map` node, as the Haskell map is, so
-- that the bytes (and the typed hash) don't depend on the setting or on
-- the tree's shape.
nativeMapPairs :: Closure -> Maybe [(Val, Val)]
nativeMapPairs :: Closure -> Maybe [(Val, Val)]
nativeMapPairs = [(Val, Val)] -> Closure -> Maybe [(Val, Val)]
go []
  where
    go :: [(Val, Val)] -> Closure -> Maybe [(Val, Val)]
go [(Val, Val)]
acc (Enum Reference
_ PackedTag
t) | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.mapTipTag = [(Val, Val)] -> Maybe [(Val, Val)]
forall a. a -> Maybe a
Just [(Val, Val)]
acc
    go [(Val, Val)]
acc (Data5 Reference
_ PackedTag
t Val
_sz Val
k Val
v (BoxedVal Closure
l) (BoxedVal Closure
r))
      | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.mapBinTag = [(Val, Val)] -> Closure -> Maybe [(Val, Val)]
go [(Val, Val)]
acc Closure
r Maybe [(Val, Val)]
-> ([(Val, Val)] -> Maybe [(Val, Val)]) -> Maybe [(Val, Val)]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[(Val, Val)]
acc' -> [(Val, Val)] -> Closure -> Maybe [(Val, Val)]
go ((Val
k, Val
v) (Val, Val) -> [(Val, Val)] -> [(Val, Val)]
forall a. a -> [a] -> [a]
: [(Val, Val)]
acc') Closure
l
    go [(Val, Val)]
_ Closure
_ = Maybe [(Val, Val)]
forall a. Maybe a
Nothing

-- Reflects a runtime value into an interchange value, given a mapping
-- from numberings to references.
--
-- Note
-- ----
--
-- There is some difficulty with reflecting a value that has already
-- had its references resolved. It is possible to reflect a value that
-- contains a reflected value, and the latter _might_ not have been
-- produced with the same in-memory references as the numbering. This
-- would be the case if the value has been produced by
-- deserialization.
--
-- So, there is an extra canonicalization step that takes place to
-- choose unique `Reference` values over the entire value. Cost for
-- numberings is avoided because we locally remember (in a hash map)
-- the canonical value the first time we see each number. Making the
-- value overall canonical might require some substitution in the
-- embedded values (or code), which could be costly. To avoid that
-- cost, avoid having lots of nested reflected values.
reflectValue0 ::
  EnumMap Word64 Reference ->
  EnumMap Word64 Reference ->
  Val ->
  IO (Referenced ANF.Value)
reflectValue0 :: EnumMap Word64 Reference
-> EnumMap Word64 Reference -> Val -> IO (Referenced Value)
reflectValue0 EnumMap Word64 Reference
rty EnumMap Word64 Reference
rtm = Val -> IO (Referenced Value)
goV0
  where
    goIx :: CombIx -> StateT ReflectionState IO (GroupRef RefNum)
goIx (CIx Reference
_ Word64
top Word64
i) = (RefNum -> Word64 -> GroupRef RefNum)
-> Word64 -> RefNum -> GroupRef RefNum
forall a b c. (a -> b -> c) -> b -> a -> c
flip RefNum -> Word64 -> GroupRef RefNum
forall ref. ref -> Word64 -> GroupRef ref
ANF.GR Word64
i (RefNum -> GroupRef RefNum)
-> Reflect RefNum -> StateT ReflectionState IO (GroupRef RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumMap Word64 Reference -> Word64 -> Reflect RefNum
resolveTm EnumMap Word64 Reference
rtm Word64
top

    finish :: (t RefNum, ReflectionState) -> Referenced t
finish (t RefNum
val, RS HashMap Word64 RefNum
_ HashMap Word64 RefNum
_ (CST Canonicalizer Reference
_ CanonMap Reference RefNum
_ CanonMap Reference RefNum
_ Seq Reference
tys Seq Reference
tms)) =
      [Reference] -> [Reference] -> t RefNum -> Referenced t
forall (t :: * -> *).
[Reference] -> [Reference] -> t RefNum -> Referenced t
WithRefs (Seq Reference -> [Reference]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Reference
tys) (Seq Reference -> [Reference]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Reference
tms) t RefNum
val

    goV0 :: Val -> IO (Referenced ANF.Value)
    goV0 :: Val -> IO (Referenced Value)
goV0 Val
v = (Value RefNum, ReflectionState) -> Referenced Value
forall {t :: * -> *}. (t RefNum, ReflectionState) -> Referenced t
finish ((Value RefNum, ReflectionState) -> Referenced Value)
-> IO (Value RefNum, ReflectionState) -> IO (Referenced Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ReflectionState IO (Value RefNum)
-> ReflectionState -> IO (Value RefNum, ReflectionState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Val -> StateT ReflectionState IO (Value RefNum)
goV Val
v) ReflectionState
emptyRS

    goVs :: Seg -> Reflect [ANF.Value RefNum]
    goVs :: Seg -> Reflect [Value RefNum]
goVs Seg
sg = (Val -> StateT ReflectionState IO (Value RefNum))
-> Seg -> Reflect [Value RefNum]
forall s a. (Val -> StateT s IO a) -> Seg -> StateT s IO [a]
traverseAccumSegToList Val -> StateT ReflectionState IO (Value RefNum)
goV Seg
sg

    goV :: Val -> Reflect (ANF.Value RefNum)
    goV :: Val -> StateT ReflectionState IO (Value RefNum)
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 RefNum -> StateT ReflectionState IO (Value RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value RefNum -> StateT ReflectionState IO (Value RefNum))
-> (BLit RefNum -> Value RefNum)
-> BLit RefNum
-> StateT ReflectionState IO (Value RefNum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit (BLit RefNum -> StateT ReflectionState IO (Value RefNum))
-> BLit RefNum -> StateT ReflectionState IO (Value RefNum)
forall a b. (a -> b) -> a -> b
$ Word64 -> BLit RefNum
forall ref. Word64 -> BLit ref
ANF.Pos Word64
n
      IntVal Int
n
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 -> Value RefNum -> StateT ReflectionState IO (Value RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value RefNum -> StateT ReflectionState IO (Value RefNum))
-> (BLit RefNum -> Value RefNum)
-> BLit RefNum
-> StateT ReflectionState IO (Value RefNum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit (BLit RefNum -> StateT ReflectionState IO (Value RefNum))
-> BLit RefNum -> StateT ReflectionState IO (Value RefNum)
forall a b. (a -> b) -> a -> b
$ Word64 -> BLit RefNum
forall ref. Word64 -> BLit ref
ANF.Pos (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
        | Bool
otherwise -> Value RefNum -> StateT ReflectionState IO (Value RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value RefNum -> StateT ReflectionState IO (Value RefNum))
-> (BLit RefNum -> Value RefNum)
-> BLit RefNum
-> StateT ReflectionState IO (Value RefNum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit (BLit RefNum -> StateT ReflectionState IO (Value RefNum))
-> BLit RefNum -> StateT ReflectionState IO (Value RefNum)
forall a b. (a -> b) -> a -> b
$ Word64 -> BLit RefNum
forall ref. Word64 -> BLit ref
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 RefNum -> StateT ReflectionState IO (Value RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value RefNum -> StateT ReflectionState IO (Value RefNum))
-> (BLit RefNum -> Value RefNum)
-> BLit RefNum
-> StateT ReflectionState IO (Value RefNum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit (BLit RefNum -> StateT ReflectionState IO (Value RefNum))
-> BLit RefNum -> StateT ReflectionState IO (Value RefNum)
forall a b. (a -> b) -> a -> b
$ Double -> BLit RefNum
forall ref. Double -> BLit ref
ANF.Float Double
f
      CharVal Char
c -> Value RefNum -> StateT ReflectionState IO (Value RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value RefNum -> StateT ReflectionState IO (Value RefNum))
-> (BLit RefNum -> Value RefNum)
-> BLit RefNum
-> StateT ReflectionState IO (Value RefNum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit (BLit RefNum -> StateT ReflectionState IO (Value RefNum))
-> BLit RefNum -> StateT ReflectionState IO (Value RefNum)
forall a b. (a -> b) -> a -> b
$ Char -> BLit RefNum
forall ref. Char -> BLit ref
ANF.Char Char
c
      Val Int
_ Closure
clos ->
        case Closure
clos of
          PAp CombIx
cix GCombInfo (RComb Val)
_rComb Seg
args ->
            GroupRef RefNum -> [Value RefNum] -> Value RefNum
forall ref. GroupRef ref -> ValList ref -> Value ref
ANF.Partial (GroupRef RefNum -> [Value RefNum] -> Value RefNum)
-> StateT ReflectionState IO (GroupRef RefNum)
-> StateT ReflectionState IO ([Value RefNum] -> Value RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CombIx -> StateT ReflectionState IO (GroupRef RefNum)
goIx CombIx
cix StateT ReflectionState IO ([Value RefNum] -> Value RefNum)
-> Reflect [Value RefNum]
-> StateT ReflectionState IO (Value RefNum)
forall a b.
StateT ReflectionState IO (a -> b)
-> StateT ReflectionState IO a -> StateT ReflectionState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Seg -> Reflect [Value RefNum]
goVs Seg
args
          Enum Reference
_ PackedTag
t
            | Bool -> Bool
not Bool
mapReplaced, PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.mapTipTag -> Value RefNum -> StateT ReflectionState IO (Value RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value RefNum -> StateT ReflectionState IO (Value RefNum))
-> Value RefNum -> StateT ReflectionState IO (Value RefNum)
forall a b. (a -> b) -> a -> b
$ BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit ([(Value RefNum, Value RefNum)] -> BLit RefNum
forall ref. [(Value ref, Value ref)] -> BLit ref
ANF.Map [])
          DataC Reference
_ PackedTag
t [Val]
vs
            | Bool -> Bool
not Bool
mapReplaced,
              PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.mapBinTag,
              Just [(Val, Val)]
kvs <- Closure -> Maybe [(Val, Val)]
nativeMapPairs Closure
clos ->
                BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit (BLit RefNum -> Value RefNum)
-> ([(Value RefNum, Value RefNum)] -> BLit RefNum)
-> [(Value RefNum, Value RefNum)]
-> Value RefNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Value RefNum, Value RefNum)] -> BLit RefNum
forall ref. [(Value ref, Value ref)] -> BLit ref
ANF.Map ([(Value RefNum, Value RefNum)] -> Value RefNum)
-> StateT ReflectionState IO [(Value RefNum, Value RefNum)]
-> StateT ReflectionState IO (Value RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Val, Val)
 -> StateT ReflectionState IO (Value RefNum, Value RefNum))
-> [(Val, Val)]
-> StateT ReflectionState IO [(Value RefNum, Value RefNum)]
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
k, Val
v) -> (,) (Value RefNum -> Value RefNum -> (Value RefNum, Value RefNum))
-> StateT ReflectionState IO (Value RefNum)
-> StateT
     ReflectionState IO (Value RefNum -> (Value RefNum, Value RefNum))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> StateT ReflectionState IO (Value RefNum)
goV Val
k StateT
  ReflectionState IO (Value RefNum -> (Value RefNum, Value RefNum))
-> StateT ReflectionState IO (Value RefNum)
-> StateT ReflectionState IO (Value RefNum, Value RefNum)
forall a b.
StateT ReflectionState IO (a -> b)
-> StateT ReflectionState IO a -> StateT ReflectionState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> StateT ReflectionState IO (Value RefNum)
goV Val
v) [(Val, Val)]
kvs
            | Bool
otherwise -> do
                RefNum
r <- EnumMap Word64 Reference -> Word64 -> Reflect RefNum
resolveTy EnumMap Word64 Reference
rty (Word64 -> Reflect RefNum) -> Word64 -> Reflect RefNum
forall a b. (a -> b) -> a -> b
$ PackedTag -> Word64
TT.typeTag PackedTag
t
                RefNum -> Word64 -> [Value RefNum] -> Value RefNum
forall ref. ref -> Word64 -> ValList ref -> Value ref
ANF.Data RefNum
r (PackedTag -> Word64
maskTags PackedTag
t) ([Value RefNum] -> Value RefNum)
-> Reflect [Value RefNum]
-> StateT ReflectionState IO (Value RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> StateT ReflectionState IO (Value RefNum))
-> [Val] -> Reflect [Value RefNum]
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 -> StateT ReflectionState IO (Value RefNum)
goV [Val]
vs
          RecordC RecordShape
shape RecordVals
vals ->
            -- The shape carries the field names, in the same ascending order
            -- as the slots, which is also the order `reifyValue` expects.
            RecordSchema -> [Value RefNum] -> Value RefNum
forall ref. RecordSchema -> ValList ref -> Value ref
ANF.Record (Set FieldName -> RecordSchema
ANF.RecordSchema ([FieldName] -> Set FieldName
forall a. Ord a => [a] -> Set a
S.fromList (Vector FieldName -> [FieldName]
forall a. Vector a -> [a]
V.toList (RecordShape -> Vector FieldName
shapeFields RecordShape
shape))))
              ([Value RefNum] -> Value RefNum)
-> Reflect [Value RefNum]
-> StateT ReflectionState IO (Value RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> StateT ReflectionState IO (Value RefNum))
-> [Val] -> Reflect [Value RefNum]
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 -> StateT ReflectionState IO (Value RefNum)
goV (RecordVals -> [Val]
forall a. Vector a -> [a]
V.toList RecordVals
vals)
          Captured K
k Int
_ Seg
segs ->
            [Value RefNum] -> Cont RefNum -> Value RefNum
forall ref. ValList ref -> Cont ref -> Value ref
ANF.Cont ([Value RefNum] -> Cont RefNum -> Value RefNum)
-> Reflect [Value RefNum]
-> StateT ReflectionState IO (Cont RefNum -> Value RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seg -> Reflect [Value RefNum]
goVs Seg
segs StateT ReflectionState IO (Cont RefNum -> Value RefNum)
-> StateT ReflectionState IO (Cont RefNum)
-> StateT ReflectionState IO (Value RefNum)
forall a b.
StateT ReflectionState IO (a -> b)
-> StateT ReflectionState IO a -> StateT ReflectionState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> K -> StateT ReflectionState IO (Cont RefNum)
goK K
k
          TextC Text
t -> Value RefNum -> StateT ReflectionState IO (Value RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit (Text -> BLit RefNum
forall ref. Text -> BLit ref
ANF.Text Text
t))
          ListC USeq
s -> BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit (BLit RefNum -> Value RefNum)
-> ([Value RefNum] -> BLit RefNum)
-> [Value RefNum]
-> Value RefNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Value RefNum) -> BLit RefNum
forall ref. Seq (Value ref) -> BLit ref
ANF.List (Seq (Value RefNum) -> BLit RefNum)
-> ([Value RefNum] -> Seq (Value RefNum))
-> [Value RefNum]
-> BLit RefNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value RefNum] -> Seq (Value RefNum)
forall a. [a] -> Seq a
Seq.fromList ([Value RefNum] -> Value RefNum)
-> Reflect [Value RefNum]
-> StateT ReflectionState IO (Value RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> StateT ReflectionState IO (Value RefNum))
-> [Val] -> Reflect [Value RefNum]
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 -> StateT ReflectionState IO (Value RefNum)
goV (USeq -> [Val]
forall a. Deque a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList USeq
s)
          BytesC Bytes
b -> Value RefNum -> StateT ReflectionState IO (Value RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit (Bytes -> BLit RefNum
forall ref. Bytes -> BLit ref
ANF.Bytes Bytes
b))
          Foreign Foreign
f -> BLit RefNum -> Value RefNum
forall ref. BLit ref -> Value ref
ANF.BLit (BLit RefNum -> Value RefNum)
-> StateT ReflectionState IO (BLit RefNum)
-> StateT ReflectionState IO (Value RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Foreign -> StateT ReflectionState IO (BLit RefNum)
goF Foreign
f
          Closure
BlackHole -> [Char] -> StateT ReflectionState IO (Value RefNum)
forall a. [Char] -> Reflect a
reflExn [Char]
"black hole"
          UnboxedTypeTag {} ->
            [Char] -> StateT ReflectionState IO (Value RefNum)
forall a. [Char] -> Reflect a
reflExn [Char]
"unknown unboxed value"
          Affine {} -> [Char] -> StateT ReflectionState IO (Value RefNum)
forall a. [Char] -> Reflect a
reflExn [Char]
"affine info"

    goK :: K -> StateT ReflectionState IO (Cont RefNum)
goK (CB Callback
_) = [Char] -> StateT ReflectionState IO (Cont RefNum)
forall a. [Char] -> Reflect a
reflExn [Char]
"callback continuation"
    goK (Local {}) = [Char] -> StateT ReflectionState IO (Cont RefNum)
forall a. [Char] -> Reflect a
reflExn [Char]
"captured Local frame"
    goK (AMark {}) = [Char] -> StateT ReflectionState IO (Cont RefNum)
forall a. [Char] -> Reflect a
reflExn [Char]
"captured AMark frame"
    goK (Keep {}) = [Char] -> StateT ReflectionState IO (Cont RefNum)
forall a. [Char] -> Reflect a
reflExn [Char]
"captured Keep frame"
    goK K
KE = Cont RefNum -> StateT ReflectionState IO (Cont RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cont RefNum
forall ref. Cont ref
ANF.KE
    goK (Mark Int
a EnumSet Word64
ps DEnv
de K
k) = do
      [RefNum]
ps <- (Word64 -> Reflect RefNum)
-> [Word64] -> StateT ReflectionState IO [RefNum]
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 (EnumMap Word64 Reference -> Word64 -> Reflect RefNum
resolveTy EnumMap Word64 Reference
rty) (EnumSet Word64 -> [Word64]
forall k. EnumKey k => EnumSet k -> [k]
EC.setToList EnumSet Word64
ps)
      [(RefNum, Value RefNum)]
de <- ((Word64, Val) -> StateT ReflectionState IO (RefNum, Value RefNum))
-> [(Word64, Val)]
-> StateT ReflectionState IO [(RefNum, Value RefNum)]
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) -> (,) (RefNum -> Value RefNum -> (RefNum, Value RefNum))
-> Reflect RefNum
-> StateT
     ReflectionState IO (Value RefNum -> (RefNum, Value RefNum))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumMap Word64 Reference -> Word64 -> Reflect RefNum
resolveTy EnumMap Word64 Reference
rty Word64
k StateT ReflectionState IO (Value RefNum -> (RefNum, Value RefNum))
-> StateT ReflectionState IO (Value RefNum)
-> StateT ReflectionState IO (RefNum, Value RefNum)
forall a b.
StateT ReflectionState IO (a -> b)
-> StateT ReflectionState IO a -> StateT ReflectionState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> StateT ReflectionState IO (Value RefNum)
goV Val
v) (DEnv -> [(Word64, Val)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList DEnv
de)
      Word64
-> [RefNum]
-> [(RefNum, Value RefNum)]
-> Cont RefNum
-> Cont RefNum
forall ref.
Word64 -> [ref] -> [(ref, Value ref)] -> Cont ref -> Cont ref
ANF.Mark (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a) [RefNum]
ps [(RefNum, Value RefNum)]
de (Cont RefNum -> Cont RefNum)
-> StateT ReflectionState IO (Cont RefNum)
-> StateT ReflectionState IO (Cont RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K -> StateT ReflectionState IO (Cont RefNum)
goK K
k
    goK (Push Int
f Int
a CombIx
cix Int
_ MSection
_rsect Ptr NativeCell
_ K
k) =
      Word64 -> Word64 -> GroupRef RefNum -> Cont RefNum -> Cont RefNum
forall ref.
Word64 -> Word64 -> GroupRef ref -> Cont ref -> Cont ref
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)
        (GroupRef RefNum -> Cont RefNum -> Cont RefNum)
-> StateT ReflectionState IO (GroupRef RefNum)
-> StateT ReflectionState IO (Cont RefNum -> Cont RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CombIx -> StateT ReflectionState IO (GroupRef RefNum)
goIx CombIx
cix
        StateT ReflectionState IO (Cont RefNum -> Cont RefNum)
-> StateT ReflectionState IO (Cont RefNum)
-> StateT ReflectionState IO (Cont RefNum)
forall a b.
StateT ReflectionState IO (a -> b)
-> StateT ReflectionState IO a -> StateT ReflectionState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> K -> StateT ReflectionState IO (Cont RefNum)
goK K
k

    goF :: Foreign -> StateT ReflectionState IO (BLit RefNum)
goF = \case
      WrapReferent Referent
l -> Referent' RefNum -> BLit RefNum
forall ref. Referent' ref -> BLit ref
ANF.TmLink (Referent' RefNum -> BLit RefNum)
-> Reflect (Referent' RefNum)
-> StateT ReflectionState IO (BLit RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Referent -> Reflect (Referent' RefNum)
canonicalizeReferent Referent
l
      WrapReference Reference
l -> RefNum -> BLit RefNum
forall ref. ref -> BLit ref
ANF.TyLink (RefNum -> BLit RefNum)
-> Reflect RefNum -> StateT ReflectionState IO (BLit RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Reference -> Reflect RefNum
canonicalizeReference Bool
True Reference
l
      WrapValue Referenced Value
v -> Value RefNum -> BLit RefNum
forall ref. Value ref -> BLit ref
ANF.Quote (Value RefNum -> BLit RefNum)
-> StateT ReflectionState IO (Value RefNum)
-> StateT ReflectionState IO (BLit RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Referenced Value -> StateT ReflectionState IO (Value RefNum)
forall (t :: * -> *).
Referential t =>
Referenced t -> Reflect (t RefNum)
canonicalizeReferenced Referenced Value
v
      WrapCode Referenced Code
g -> Code RefNum -> BLit RefNum
forall ref. Code ref -> BLit ref
ANF.Code (Code RefNum -> BLit RefNum)
-> StateT ReflectionState IO (Code RefNum)
-> StateT ReflectionState IO (BLit RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Referenced Code -> StateT ReflectionState IO (Code RefNum)
forall (t :: * -> *).
Referential t =>
Referenced t -> Reflect (t RefNum)
canonicalizeReferenced Referenced Code
g
      WrapByteArray ByteArray
a -> BLit RefNum -> StateT ReflectionState IO (BLit RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteArray -> BLit RefNum
forall ref. ByteArray -> BLit ref
ANF.BArr ByteArray
a)
      WrapArray Array Val
a -> Array (Value RefNum) -> BLit RefNum
forall ref. Array (Value ref) -> BLit ref
ANF.Arr (Array (Value RefNum) -> BLit RefNum)
-> StateT ReflectionState IO (Array (Value RefNum))
-> StateT ReflectionState IO (BLit RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> StateT ReflectionState IO (Value RefNum))
-> Array Val -> StateT ReflectionState IO (Array (Value RefNum))
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 -> StateT ReflectionState IO (Value RefNum)
goV Array Val
a
      WrapMap Map Val Val
m ->
        [(Value RefNum, Value RefNum)] -> BLit RefNum
forall ref. [(Value ref, Value ref)] -> BLit ref
ANF.Map
          ([(Value RefNum, Value RefNum)] -> BLit RefNum)
-> StateT ReflectionState IO [(Value RefNum, Value RefNum)]
-> StateT ReflectionState IO (BLit RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Val, Val)
 -> StateT ReflectionState IO (Value RefNum, Value RefNum))
-> [(Val, Val)]
-> StateT ReflectionState IO [(Value RefNum, Value RefNum)]
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
k, Val
v) -> (,) (Value RefNum -> Value RefNum -> (Value RefNum, Value RefNum))
-> StateT ReflectionState IO (Value RefNum)
-> StateT
     ReflectionState IO (Value RefNum -> (Value RefNum, Value RefNum))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> StateT ReflectionState IO (Value RefNum)
goV Val
k StateT
  ReflectionState IO (Value RefNum -> (Value RefNum, Value RefNum))
-> StateT ReflectionState IO (Value RefNum)
-> StateT ReflectionState IO (Value RefNum, Value RefNum)
forall a b.
StateT ReflectionState IO (a -> b)
-> StateT ReflectionState IO a -> StateT ReflectionState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> StateT ReflectionState IO (Value RefNum)
goV Val
v) (Map Val Val -> [(Val, Val)]
forall k a. Map k a -> [(k, a)]
M.toList Map Val Val
m)
      WrapInteger Integer
i -> BLit RefNum -> StateT ReflectionState IO (BLit RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> BLit RefNum
forall ref. Integer -> BLit ref
ANF.BigInt Integer
i)
      WrapNatural Natural
n -> BLit RefNum -> StateT ReflectionState IO (BLit RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> BLit RefNum
forall ref. Natural -> BLit ref
ANF.BigNat Natural
n)
      Foreign
_ -> [Char] -> StateT ReflectionState IO (BLit RefNum)
forall a. [Char] -> Reflect a
reflExn [Char]
"foreign value"

data ReflectExn = ReflectExn String deriving (Int -> ReflectExn -> [Char] -> [Char]
[ReflectExn] -> [Char] -> [Char]
ReflectExn -> [Char]
(Int -> ReflectExn -> [Char] -> [Char])
-> (ReflectExn -> [Char])
-> ([ReflectExn] -> [Char] -> [Char])
-> Show ReflectExn
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ReflectExn -> [Char] -> [Char]
showsPrec :: Int -> ReflectExn -> [Char] -> [Char]
$cshow :: ReflectExn -> [Char]
show :: ReflectExn -> [Char]
$cshowList :: [ReflectExn] -> [Char] -> [Char]
showList :: [ReflectExn] -> [Char] -> [Char]
Show)

instance Exception ReflectExn

ixArr :: String -> Array a -> RefNum -> IO a
ixArr :: forall a. [Char] -> Array a -> RefNum -> IO a
ixArr [Char]
pfx Array a
arr (RefNum Int
i)
  | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array a -> Int
forall a. Array a -> Int
sizeofArray Array a
arr = Array a -> Int -> IO a
forall (m :: * -> *) a. Applicative m => Array a -> Int -> m a
indexArrayM Array a
arr Int
i
  | Bool
otherwise = [Word] -> [Char] -> IO a
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO a) -> ([Char] -> [Char]) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
pfx [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
" index out of bounds: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
{-# INLINE ixArr #-}

reifyValue ::
  CCache p -> Referenced ANF.Value -> IO (Either [Reference] Val)
reifyValue :: forall p.
CCache p -> Referenced Value -> IO (Either [Reference] Val)
reifyValue CCache p
cc Referenced Value
val = do
  (Set Reference
tyLinks, Set Reference
tmLinks) <- case Referenced Value
val of
    Plain Value Reference
v -> (Set Reference, Set Reference) -> IO (Set Reference, Set Reference)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Set Reference, Set Reference)
 -> IO (Set Reference, Set Reference))
-> (Set Reference, Set Reference)
-> IO (Set Reference, Set Reference)
forall a b. (a -> b) -> a -> b
$ Value Reference -> (Set Reference, Set Reference)
forall ref. Ord ref => Value ref -> (Set ref, Set ref)
collectValueLinks Value Reference
v
    WithRefs [Reference]
tys [Reference]
tms Value RefNum
v -> do
      let tya :: Array Reference
tya = [Reference] -> Array Reference
forall a. [a] -> Array a
arrayFromList [Reference]
tys
          tma :: Array Reference
tma = [Reference] -> Array Reference
forall a. [a] -> Array a
arrayFromList [Reference]
tms
          (Set RefNum
tyns, Set RefNum
tmns) = Value RefNum -> (Set RefNum, Set RefNum)
forall ref. Ord ref => Value ref -> (Set ref, Set ref)
collectValueLinks Value RefNum
v
          travSet :: (a -> f a) -> Set a -> f (Set a)
travSet a -> f a
f = ([a] -> Set a) -> f [a] -> f (Set a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList (f [a] -> f (Set a)) -> (Set a -> f [a]) -> Set a -> f (Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> [a] -> f [a]
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 a -> f a
f ([a] -> f [a]) -> (Set a -> [a]) -> Set a -> f [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
S.toList
      (,)
        (Set Reference -> Set Reference -> (Set Reference, Set Reference))
-> IO (Set Reference)
-> IO (Set Reference -> (Set Reference, Set Reference))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RefNum -> IO Reference) -> Set RefNum -> IO (Set Reference)
forall {f :: * -> *} {a} {a}.
(Ord a, Applicative f) =>
(a -> f a) -> Set a -> f (Set a)
travSet ([Char] -> Array Reference -> RefNum -> IO Reference
forall a. [Char] -> Array a -> RefNum -> IO a
ixArr [Char]
"reifyValue: type" Array Reference
tya) Set RefNum
tyns
        IO (Set Reference -> (Set Reference, Set Reference))
-> IO (Set Reference) -> IO (Set Reference, Set Reference)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RefNum -> IO Reference) -> Set RefNum -> IO (Set Reference)
forall {f :: * -> *} {a} {a}.
(Ord a, Applicative f) =>
(a -> f a) -> Set a -> f (Set a)
travSet ([Char] -> Array Reference -> RefNum -> IO Reference
forall a. [Char] -> Array a -> RefNum -> IO a
ixArr [Char]
"reifyValue: term" Array Reference
tma) Set RefNum
tmns
  Either
  [Reference]
  (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
   BiMap RecordSchema RecordRef, RecordFieldMappings)
erc <-
    STM
  (Either
     [Reference]
     (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
      BiMap RecordSchema RecordRef, RecordFieldMappings))
-> IO
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
         BiMap RecordSchema RecordRef, RecordFieldMappings))
forall a. STM a -> IO a
atomically (STM
   (Either
      [Reference]
      (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
       BiMap RecordSchema RecordRef, RecordFieldMappings))
 -> IO
      (Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
          BiMap RecordSchema RecordRef, RecordFieldMappings)))
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
         BiMap RecordSchema RecordRef, RecordFieldMappings))
-> IO
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
         BiMap RecordSchema RecordRef, RecordFieldMappings))
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 p -> TVar (EnumMap Word64 MCombs)
forall prof. CCache prof -> TVar (EnumMap Word64 MCombs)
combs CCache p
cc)
      Map Reference Word64
rtm <- TVar (Map Reference Word64) -> STM (Map Reference Word64)
forall a. TVar a -> STM a
readTVar (CCache p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache p
cc)
      BiMap RecordSchema RecordRef
recRefLookup <- TVar (BiMap RecordSchema RecordRef)
-> STM (BiMap RecordSchema RecordRef)
forall a. TVar a -> STM a
readTVar (CCache p -> TVar (BiMap RecordSchema RecordRef)
forall prof. CCache prof -> TVar (BiMap RecordSchema RecordRef)
recordRefs CCache p
cc)
      RecordFieldMappings
rfms <- TVar RecordFieldMappings -> STM RecordFieldMappings
forall a. TVar a -> STM a
readTVar (CCache p -> TVar RecordFieldMappings
forall prof. CCache prof -> TVar RecordFieldMappings
recordFieldMappings CCache p
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 p -> TVar Word64
forall prof. CCache prof -> TVar Word64
freshTy CCache p
cc) (CCache p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTy CCache p
cc) (CCache p -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
tagRefs CCache p
cc) Set Reference
tyLinks
          Either
  [Reference]
  (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
   BiMap RecordSchema RecordRef, RecordFieldMappings)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
         BiMap RecordSchema RecordRef, RecordFieldMappings))
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,
    BiMap RecordSchema RecordRef, RecordFieldMappings)
 -> STM
      (Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
          BiMap RecordSchema RecordRef, RecordFieldMappings)))
-> ((EnumMap Word64 MCombs, Map Reference Word64,
     Map Reference Word64, BiMap RecordSchema RecordRef,
     RecordFieldMappings)
    -> Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
          BiMap RecordSchema RecordRef, RecordFieldMappings))
-> (EnumMap Word64 MCombs, Map Reference Word64,
    Map Reference Word64, BiMap RecordSchema RecordRef,
    RecordFieldMappings)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
         BiMap RecordSchema RecordRef, RecordFieldMappings))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
 BiMap RecordSchema RecordRef, RecordFieldMappings)
-> Either
     [Reference]
     (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
      BiMap RecordSchema RecordRef, RecordFieldMappings)
forall a b. b -> Either a b
Right ((EnumMap Word64 MCombs, Map Reference Word64,
  Map Reference Word64, BiMap RecordSchema RecordRef,
  RecordFieldMappings)
 -> STM
      (Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
          BiMap RecordSchema RecordRef, RecordFieldMappings)))
-> (EnumMap Word64 MCombs, Map Reference Word64,
    Map Reference Word64, BiMap RecordSchema RecordRef,
    RecordFieldMappings)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
         BiMap RecordSchema RecordRef, RecordFieldMappings))
forall a b. (a -> b) -> a -> b
$ (EnumMap Word64 MCombs
combs, Map Reference Word64
newTy, Map Reference Word64
rtm, BiMap RecordSchema RecordRef
recRefLookup, RecordFieldMappings
rfms)
        [Reference]
l -> Either
  [Reference]
  (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
   BiMap RecordSchema RecordRef, RecordFieldMappings)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
         BiMap RecordSchema RecordRef, RecordFieldMappings))
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,
      BiMap RecordSchema RecordRef, RecordFieldMappings)
forall a b. a -> Either a b
Left [Reference]
l)
  case Either
  [Reference]
  (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
   BiMap RecordSchema RecordRef, RecordFieldMappings)
erc of
    Left [Reference]
l -> Either [Reference] Val -> IO (Either [Reference] Val)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Reference] -> Either [Reference] Val
forall a b. a -> Either a b
Left [Reference]
l)
    Right (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
 BiMap RecordSchema RecordRef, RecordFieldMappings)
rfs -> Val -> Either [Reference] Val
forall a b. b -> Either a b
Right (Val -> Either [Reference] Val)
-> IO Val -> IO (Either [Reference] Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
 BiMap RecordSchema RecordRef, RecordFieldMappings)
-> Referenced Value -> IO Val
reifyValue1 (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
 BiMap RecordSchema RecordRef, RecordFieldMappings)
rfs Referenced Value
val

reifyValue1 ::
  (EnumMap Word64 MCombs, M.Map Reference Word64, M.Map Reference Word64, BM.BiMap ANF.RecordSchema ANF.RecordRef, RecordFieldMappings) ->
  Referenced ANF.Value ->
  IO Val
reifyValue1 :: (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
 BiMap RecordSchema RecordRef, RecordFieldMappings)
-> Referenced Value -> IO Val
reifyValue1 (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
 BiMap RecordSchema RecordRef, RecordFieldMappings)
tup (Plain Value Reference
v) = (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
 BiMap RecordSchema RecordRef, RecordFieldMappings)
-> Value Reference -> IO Val
reifyValue0 (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
 BiMap RecordSchema RecordRef, RecordFieldMappings)
tup Value Reference
v
reifyValue1 (EnumMap Word64 MCombs
combs, Map Reference Word64
rty0, Map Reference Word64
rtm0, BiMap RecordSchema RecordRef
rrLookup, RecordFieldMappings
rfms) (WithRefs [Reference]
tys [Reference]
tms Value RefNum
v) = do
  let rty :: HashMap RefNum Word64
rty = [(RefNum, Word64)] -> HashMap RefNum Word64
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(RefNum, Word64)] -> HashMap RefNum Word64)
-> ([(Int, Reference)] -> [(RefNum, Word64)])
-> [(Int, Reference)]
-> HashMap RefNum Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Reference) -> Maybe (RefNum, Word64))
-> [(Int, Reference)] -> [(RefNum, Word64)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe (Int, Reference) -> Maybe (RefNum, Word64)
procTypeRefs ([(Int, Reference)] -> HashMap RefNum Word64)
-> [(Int, Reference)] -> HashMap RefNum Word64
forall a b. (a -> b) -> a -> b
$ [Int] -> [Reference] -> [(Int, Reference)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Reference]
tys
      rtm :: HashMap RefNum Word64
rtm = [(RefNum, Word64)] -> HashMap RefNum Word64
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(RefNum, Word64)] -> HashMap RefNum Word64)
-> ([(Int, Reference)] -> [(RefNum, Word64)])
-> [(Int, Reference)]
-> HashMap RefNum Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Reference) -> Maybe (RefNum, Word64))
-> [(Int, Reference)] -> [(RefNum, Word64)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe (Int, Reference) -> Maybe (RefNum, Word64)
procTermRefs ([(Int, Reference)] -> HashMap RefNum Word64)
-> [(Int, Reference)] -> HashMap RefNum Word64
forall a b. (a -> b) -> a -> b
$ [Int] -> [Reference] -> [(Int, Reference)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Reference]
tms
  EnumMap Word64 MCombs
-> [Reference]
-> [Reference]
-> HashMap RefNum Word64
-> HashMap RefNum Word64
-> BiMap RecordSchema RecordRef
-> RecordFieldMappings
-> Value RefNum
-> IO Val
reifyValue0Canon EnumMap Word64 MCombs
combs [Reference]
tys [Reference]
tms HashMap RefNum Word64
rty HashMap RefNum Word64
rtm BiMap RecordSchema RecordRef
rrLookup RecordFieldMappings
rfms Value RefNum
v
  where
    procTypeRefs :: (Int, Reference) -> Maybe (RefNum, Word64)
procTypeRefs (Int
i, Reference
r) = (Int -> RefNum
RefNum Int
i,) (Word64 -> (RefNum, Word64))
-> Maybe Word64 -> Maybe (RefNum, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference Word64
rty0
    procTermRefs :: (Int, Reference) -> Maybe (RefNum, Word64)
procTermRefs (Int
i, Reference
r) =
      (Int -> RefNum
RefNum Int
i,)
        (Word64 -> (RefNum, Word64))
-> Maybe Word64 -> Maybe (RefNum, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Reference
r Reference
r Map Reference Reference
functionReplacements) Map Reference Word64
rtm0

reifyValue0Canon ::
  EnumMap Word64 MCombs ->
  [Reference] ->
  [Reference] ->
  HM.HashMap RefNum Word64 ->
  HM.HashMap RefNum Word64 ->
  BM.BiMap ANF.RecordSchema ANF.RecordRef ->
  RecordFieldMappings ->
  ANF.Value RefNum ->
  IO Val
reifyValue0Canon :: EnumMap Word64 MCombs
-> [Reference]
-> [Reference]
-> HashMap RefNum Word64
-> HashMap RefNum Word64
-> BiMap RecordSchema RecordRef
-> RecordFieldMappings
-> Value RefNum
-> IO Val
reifyValue0Canon EnumMap Word64 MCombs
combs [Reference]
tys [Reference]
tms HashMap RefNum Word64
rty HashMap RefNum Word64
rtm BiMap RecordSchema RecordRef
rrLookup RecordFieldMappings
rfms = Value RefNum -> IO Val
goV
  where
    err :: [Char] -> [Char]
err [Char]
s = [Char]
"reifyValue: cannot restore value: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

    !tya :: Array Reference
tya = [Reference] -> Array Reference
forall a. [a] -> Array a
arrayFromList [Reference]
tys
    !tma :: Array Reference
tma = [Reference] -> Array Reference
forall a. [a] -> Array a
arrayFromList [Reference]
tms

    ixTy :: RefNum -> IO Reference
ixTy (RefNum Int
i)
      | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array Reference -> Int
forall a. Array a -> Int
sizeofArray Array Reference
tya = 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
$ Array Reference -> Int -> Reference
forall a. Array a -> Int -> a
indexArray Array Reference
tya Int
i
      | Bool
otherwise = [Word] -> [Char] -> IO Reference
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Reference)
-> ([Char] -> [Char]) -> [Char] -> IO Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Reference) -> [Char] -> IO Reference
forall a b. (a -> b) -> a -> b
$ [Char]
"type ref index out of bounds: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i

    ixTm :: RefNum -> IO Reference
ixTm (RefNum Int
i)
      | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array Reference -> Int
forall a. Array a -> Int
sizeofArray Array Reference
tma = 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
$ Array Reference -> Int -> Reference
forall a. Array a -> Int -> a
indexArray Array Reference
tma Int
i
      | Bool
otherwise = [Word] -> [Char] -> IO Reference
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Reference)
-> ([Char] -> [Char]) -> [Char] -> IO Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Reference) -> [Char] -> IO Reference
forall a b. (a -> b) -> a -> b
$ [Char]
"term ref index out of bounds: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i

    numToRef :: Bool -> RefNum -> IO Reference
    numToRef :: Bool -> RefNum -> IO Reference
numToRef Bool
True = RefNum -> IO Reference
ixTy
    numToRef Bool
False = RefNum -> IO Reference
ixTm

    refTy :: RefNum -> IO Word64
refTy RefNum
r = case RefNum -> HashMap RefNum Word64 -> Maybe Word64
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup RefNum
r HashMap RefNum Word64
rty of
      Just Word64
w -> Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
      Maybe Word64
_ -> [Word] -> [Char] -> IO Word64
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Word64) -> ([Char] -> [Char]) -> [Char] -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Word64) -> [Char] -> IO Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown type reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RefNum -> [Char]
forall a. Show a => a -> [Char]
show RefNum
r

    refTm :: RefNum -> IO Word64
refTm RefNum
r = case RefNum -> HashMap RefNum Word64 -> Maybe Word64
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup RefNum
r HashMap RefNum Word64
rtm of
      Just Word64
w -> Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
      Maybe Word64
_ -> [Word] -> [Char] -> IO Word64
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Word64) -> ([Char] -> [Char]) -> [Char] -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Word64) -> [Char] -> IO Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown term reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RefNum -> [Char]
forall a. Show a => a -> [Char]
show RefNum
r

    goIx :: ANF.GroupRef RefNum -> IO (CombIx, MComb)
    goIx :: GroupRef RefNum -> IO (CombIx, RComb Val)
goIx (ANF.GR RefNum
rn Word64
i) = do
      Word64
n <- RefNum -> IO Word64
refTm RefNum
rn
      Reference
rf <- RefNum -> IO Reference
ixTm RefNum
rn
      let cix :: CombIx
cix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
rf Word64
n Word64
i)
      (CombIx, RComb Val) -> IO (CombIx, RComb Val)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CombIx
cix, EnumMap Word64 MCombs -> CombIx -> RComb Val
rCombSection EnumMap Word64 MCombs
combs CombIx
cix)

    goVs :: [ANF.Value RefNum] -> IO Seg
    goVs :: [Value RefNum] -> IO Seg
goVs [Value RefNum]
vs = (Value RefNum -> IO Val) -> [Value RefNum] -> IO Seg
forall a. (a -> IO Val) -> [a] -> IO Seg
traverseListToSeg Value RefNum -> IO Val
goV [Value RefNum]
vs

    goVArr :: Array (ANF.Value RefNum) -> IO (Array Val)
    goVArr :: Array (Value RefNum) -> IO (Array Val)
goVArr Array (Value RefNum)
vs = (Value RefNum -> IO Val) -> Array (Value RefNum) -> IO (Array Val)
forall a b. (a -> IO b) -> Array a -> IO (Array b)
traverseArrayIO Value RefNum -> IO Val
goV Array (Value RefNum)
vs

    goVSeq :: Seq (ANF.Value RefNum) -> IO USeq
    goVSeq :: Seq (Value RefNum) -> IO USeq
goVSeq Seq (Value RefNum)
vs = [Val] -> USeq
forall a. [a] -> Deque a
Sq.fromList ([Val] -> USeq) -> IO [Val] -> IO USeq
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value RefNum -> IO Val) -> [Value RefNum] -> 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 RefNum -> IO Val
goV (Seq (Value RefNum) -> [Value RefNum]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Value RefNum)
vs)

    goV :: ANF.Value RefNum -> IO Val
    goV :: Value RefNum -> IO Val
goV (ANF.Partial GroupRef RefNum
gr [Value RefNum]
vs) =
      GroupRef RefNum -> IO (CombIx, RComb Val)
goIx GroupRef RefNum
gr IO (CombIx, RComb Val) -> ((CombIx, RComb Val) -> 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
        -- A partial application holds fewer arguments than its function
        -- takes: the interpreter computes how many are still missing as the
        -- difference, and a difference of zero or less is a closure it never
        -- builds itself and has no case for.
        (CombIx
cix, RComb (Comb rcomb :: GCombInfo (RComb Val)
rcomb@(LamI Int
arity Int
_ MSection
_ Ptr NativeCell
_)))
          | [Value RefNum] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value RefNum]
vs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
arity -> Closure -> Val
boxedVal (Closure -> Val) -> (Seg -> Closure) -> Seg -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp CombIx
cix GCombInfo (RComb Val)
rcomb (Seg -> Val) -> IO Seg -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value RefNum] -> IO Seg
goVs [Value RefNum]
vs
          | Bool
otherwise -> [Word] -> [Char] -> IO Val
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Val) -> ([Char] -> [Char]) -> [Char] -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Val) -> [Char] -> IO Val
forall a b. (a -> b) -> a -> b
$ [Char]
"a partial application of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Value RefNum] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value RefNum]
vs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" arguments to a function of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
arity
        (CombIx
_, RComb (CachedVal Word64
_ Val
val))
          | [] <- [Value RefNum]
vs -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
val
          | Bool
otherwise -> [Word] -> [Char] -> IO Val
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Val) -> ([Char] -> [Char]) -> [Char] -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Val) -> [Char] -> IO Val
forall a b. (a -> b) -> a -> b
$ [Char]
msg
          where
            msg :: [Char]
msg = [Char]
"reifyValue0: non-trivial partial application to cached value"
    goV (ANF.Data RefNum
rn Word64
t0 [Value RefNum]
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
<$> RefNum -> IO Word64
refTy RefNum
rn
      Reference
rf <- RefNum -> IO Reference
ixTy RefNum
rn
      Closure -> Val
boxedVal (Closure -> Val) -> (Seg -> Closure) -> Seg -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> Seg -> Closure
formDataReplaced Reference
rf PackedTag
t (Seg -> Val) -> IO Seg -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value RefNum] -> IO Seg
goVs [Value RefNum]
vs
    goV (ANF.Record RecordSchema
rs [Value RefNum]
vals) = do
      RecordRef
rref <- case RecordSchema -> BiMap RecordSchema RecordRef -> Maybe RecordRef
forall k v. Ord k => k -> BiMap k v -> Maybe v
BM.lookupL RecordSchema
rs BiMap RecordSchema RecordRef
rrLookup of
        Just RecordRef
r -> RecordRef -> IO RecordRef
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecordRef
r
        Maybe RecordRef
Nothing -> [Word] -> [Char] -> IO RecordRef
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO RecordRef)
-> ([Char] -> [Char]) -> [Char] -> IO RecordRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO RecordRef) -> [Char] -> IO RecordRef
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown record schema reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RecordSchema -> [Char]
forall a. Show a => a -> [Char]
show RecordSchema
rs
      RecordShape
shape <- case RecordFieldMappings
-> RecordRef -> RecordSchema -> Maybe RecordShape
recordShapeFrom RecordFieldMappings
rfms RecordRef
rref RecordSchema
rs of
        Just RecordShape
shape -> RecordShape -> IO RecordShape
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecordShape
shape
        Maybe RecordShape
Nothing -> [Word] -> [Char] -> IO RecordShape
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO RecordShape)
-> ([Char] -> [Char]) -> [Char] -> IO RecordShape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO RecordShape) -> [Char] -> IO RecordShape
forall a b. (a -> b) -> a -> b
$ [Char]
"record schema with un-interned fields: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RecordSchema -> [Char]
forall a. Show a => a -> [Char]
show RecordSchema
rs
      -- `putValue` writes the values in ascending field-name order, which is
      -- the shape's slot order, so no reordering is needed. There has to be
      -- one per field: a record's values are read by slot, with the slot
      -- taken from the shape and no bound taken from the array (native
      -- code's record read), so a short array would be read past its end.
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Value RefNum] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value RefNum]
vals Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Vector FieldName -> Int
forall a. Vector a -> Int
V.length (RecordShape -> Vector FieldName
shapeFields RecordShape
shape)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char]
"a record of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Value RefNum] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value RefNum]
vals) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" values for a schema of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Vector FieldName -> Int
forall a. Vector a -> Int
V.length (RecordShape -> Vector FieldName
shapeFields RecordShape
shape)) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" fields"
      Seg
vals' <- [Value RefNum] -> IO Seg
goVs [Value RefNum]
vals
      Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (RecordVals -> Val) -> RecordVals -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (RecordVals -> Closure) -> RecordVals -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordShape -> RecordVals -> Closure
RecordG RecordShape
shape (RecordVals -> IO Val) -> RecordVals -> IO Val
forall a b. (a -> b) -> a -> b
$ Seg -> RecordVals
recordVals Seg
vals'
    goV (ANF.Cont [Value RefNum]
vs Cont RefNum
k) = do
      K
k' <- Cont RefNum -> IO K
goK Cont RefNum
k
      Seg
vs' <- [Value RefNum] -> IO Seg
goVs [Value RefNum]
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 -> Seg -> Closure
cv K
k' Seg
vs'
      where
        cv :: K -> Seg -> Closure
cv K
k Seg
s = K -> Int -> Seg -> Closure
Captured K
k Int
a Seg
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
$ Seg -> Int
forall a. (ByteArray, a) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seg
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ksz
    goV (ANF.BLit BLit RefNum
l) = BLit RefNum -> IO Val
goL BLit RefNum
l

    goK :: Cont RefNum -> IO K
goK Cont RefNum
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 [RefNum]
ps [(RefNum, Value RefNum)]
de Cont RefNum
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
<$> (RefNum -> IO Word64) -> [RefNum] -> 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 RefNum -> IO Word64
refTy [RefNum]
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
<*> ((RefNum, Value RefNum) -> IO (Word64, Val))
-> [(RefNum, Value RefNum)] -> 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 (\(RefNum
k, Value RefNum
v) -> (,) (Word64 -> Val -> (Word64, Val))
-> IO Word64 -> IO (Val -> (Word64, Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNum -> IO Word64
refTy RefNum
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 RefNum -> IO Val
goV Value RefNum
v)) [(RefNum, Value RefNum)]
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 RefNum -> IO K
goK Cont RefNum
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 RefNum
gr Cont RefNum
k) =
      GroupRef RefNum -> IO (CombIx, RComb Val)
goIx GroupRef RefNum
gr IO (CombIx, RComb Val) -> ((CombIx, RComb Val) -> 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 (Comb (LamI Int
_ Int
fr MSection
sect Ptr NativeCell
cell))) ->
          Int -> Int -> CombIx -> Int -> MSection -> Ptr NativeCell -> 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
            Ptr NativeCell
cell
            (K -> K) -> IO K -> IO K
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cont RefNum -> IO K
goK Cont RefNum
k
        (CIx Reference
r Word64
_ Word64
_, RComb Val
_) ->
          [Word] -> [Char] -> IO K
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO K) -> ([Char] -> [Char]) -> [Char] -> IO K
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO K) -> [Char] -> IO K
forall a b. (a -> b) -> a -> b
$
            [Char]
"tried to reify a continuation with a cached value resumption"
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

    goL :: ANF.BLit RefNum -> IO Val
    goL :: BLit RefNum -> 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) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Text
t
    goL (ANF.List Seq (Value RefNum)
l) = USeq -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (USeq -> Val) -> IO USeq -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Value RefNum) -> IO USeq
goVSeq Seq (Value RefNum)
l
    goL (ANF.TmLink Referent' RefNum
r) = Referent -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Referent -> Val) -> IO Referent -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> RefNum -> IO Reference) -> Referent' RefNum -> IO Referent
forall (t :: * -> *) (f :: * -> *) r s.
(Referential t, Applicative f) =>
(Bool -> r -> f s) -> t r -> f (t s)
forall (f :: * -> *) r s.
Applicative f =>
(Bool -> r -> f s) -> Referent' r -> f (Referent' s)
traverseRefs Bool -> RefNum -> IO Reference
numToRef Referent' RefNum
r
    goL (ANF.TyLink RefNum
r) = Reference -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Reference -> Val) -> IO Reference -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNum -> IO Reference
ixTy RefNum
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) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bytes -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Bytes
b
    goL (ANF.Quote Value RefNum
v) = 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
$ Referenced Value -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ([Reference] -> [Reference] -> Value RefNum -> Referenced Value
forall (t :: * -> *).
[Reference] -> [Reference] -> t RefNum -> Referenced t
WithRefs [Reference]
tys [Reference]
tms Value RefNum
v)
    goL (ANF.Code Code RefNum
g) = 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
$ Referenced Code -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ([Reference] -> [Reference] -> Code RefNum -> Referenced Code
forall (t :: * -> *).
[Reference] -> [Reference] -> t RefNum -> Referenced t
WithRefs [Reference]
tys [Reference]
tms Code RefNum
g)
    goL (ANF.BArr ByteArray
a) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ ByteArray -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ByteArray
a
    goL (ANF.Char Char
c) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Char -> Val
CharVal Char
c
    goL (ANF.Pos Word64
w) =
      -- TODO: Should this be a Nat or an Int?
      Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Word64 -> Val
NatVal Word64
w
    goL (ANF.Neg Word64
w) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Int -> Val
IntVal (Int -> Int
forall a. Num a => a -> a
negate (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w :: Int))
    goL (ANF.Float Double
d) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Double -> Val
DoubleVal Double
d
    goL (ANF.Arr Array (Value RefNum)
a) = Array Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Array Val -> Val) -> IO (Array Val) -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array (Value RefNum) -> IO (Array Val)
goVArr Array (Value RefNum)
a
    goL (ANF.Map [(Value RefNum, Value RefNum)]
l) = Map Val Val -> Val
mapVal (Map Val Val -> Val)
-> ([(Val, Val)] -> Map Val Val) -> [(Val, Val)] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Val, Val)] -> Map Val Val
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Val, Val)] -> Val) -> IO [(Val, Val)] -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Value RefNum, Value RefNum) -> IO (Val, Val))
-> [(Value RefNum, Value RefNum)] -> IO [(Val, 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 RefNum, Value RefNum) -> IO (Val, Val)
goP [(Value RefNum, Value RefNum)]
l
      where
        goP :: (Value RefNum, Value RefNum) -> IO (Val, Val)
goP (Value RefNum
x, Value RefNum
y) = (,) (Val -> Val -> (Val, Val)) -> IO Val -> IO (Val -> (Val, Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value RefNum -> IO Val
goV Value RefNum
x IO (Val -> (Val, Val)) -> IO Val -> IO (Val, 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 RefNum -> IO Val
goV Value RefNum
y
    goL (ANF.BigInt Integer
i) = 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
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Integer
i
    goL (ANF.BigNat Natural
n) = 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
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Natural
n

reifyValue0 ::
  (EnumMap Word64 MCombs, M.Map Reference Word64, M.Map Reference Word64, BM.BiMap ANF.RecordSchema ANF.RecordRef, RecordFieldMappings) ->
  ANF.Value Reference ->
  IO Val
reifyValue0 :: (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64,
 BiMap RecordSchema RecordRef, RecordFieldMappings)
-> Value Reference -> IO Val
reifyValue0 (EnumMap Word64 MCombs
combs, Map Reference Word64
rty, Map Reference Word64
rtm, BiMap RecordSchema RecordRef
rrLookup, RecordFieldMappings
rfms) = Value Reference -> IO Val
goV
  where
    err :: [Char] -> [Char]
err [Char]
s = [Char]
"reifyValue: cannot restore value: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
    refTy :: Reference -> IO Word64
refTy Reference
r
      | Just Word64
w <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference Word64
rty = Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
      | Bool
otherwise = [Word] -> [Char] -> IO Word64
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Word64) -> ([Char] -> [Char]) -> [Char] -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Word64) -> [Char] -> IO Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown type reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r
    refTm :: Reference -> IO Word64
refTm Reference
r
      | Just Word64
w <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference Word64
rtm = Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
      | Bool
otherwise = [Word] -> [Char] -> IO Word64
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Word64) -> ([Char] -> [Char]) -> [Char] -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Word64) -> [Char] -> IO Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown term reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r
    goIx :: ANF.GroupRef Reference -> IO (CombIx, MComb)
    goIx :: GroupRef Reference -> IO (CombIx, RComb Val)
goIx (ANF.GR Reference
r0 Word64
i) =
      Reference -> IO Word64
refTm Reference
r IO Word64
-> (Word64 -> (CombIx, RComb Val)) -> IO (CombIx, RComb Val)
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 -> RComb Val
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

    goVs :: [ANF.Value Reference] -> IO Seg
    goVs :: [Value Reference] -> IO Seg
goVs [Value Reference]
vs = (Value Reference -> IO Val) -> [Value Reference] -> IO Seg
forall a. (a -> IO Val) -> [a] -> IO Seg
traverseListToSeg Value Reference -> IO Val
goV [Value Reference]
vs

    goVArr :: Array (ANF.Value Reference) -> IO (Array Val)
    goVArr :: Array (Value Reference) -> IO (Array Val)
goVArr Array (Value Reference)
vs = (Value Reference -> IO Val)
-> Array (Value Reference) -> IO (Array Val)
forall a b. (a -> IO b) -> Array a -> IO (Array b)
traverseArrayIO Value Reference -> IO Val
goV Array (Value Reference)
vs

    goV :: ANF.Value Reference -> IO Val
    goV :: Value Reference -> IO Val
goV (ANF.Partial GroupRef Reference
gr [Value Reference]
vs) =
      GroupRef Reference -> IO (CombIx, RComb Val)
goIx GroupRef Reference
gr IO (CombIx, RComb Val) -> ((CombIx, RComb Val) -> 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
        -- A partial application holds fewer arguments than its function
        -- takes: the interpreter computes how many are still missing as the
        -- difference, and a difference of zero or less is a closure it never
        -- builds itself and has no case for.
        (CombIx
cix, RComb (Comb rcomb :: GCombInfo (RComb Val)
rcomb@(LamI Int
arity Int
_ MSection
_ Ptr NativeCell
_)))
          | [Value Reference] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value Reference]
vs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
arity -> Closure -> Val
boxedVal (Closure -> Val) -> (Seg -> Closure) -> Seg -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp CombIx
cix GCombInfo (RComb Val)
rcomb (Seg -> Val) -> IO Seg -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value Reference] -> IO Seg
goVs [Value Reference]
vs
          | Bool
otherwise -> [Word] -> [Char] -> IO Val
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Val) -> ([Char] -> [Char]) -> [Char] -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Val) -> [Char] -> IO Val
forall a b. (a -> b) -> a -> b
$ [Char]
"a partial application of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Value Reference] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value Reference]
vs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" arguments to a function of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
arity
        (CombIx
_, RComb (CachedVal Word64
_ Val
val))
          | [] <- [Value Reference]
vs -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
val
          | Bool
otherwise -> [Word] -> [Char] -> IO Val
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Val) -> ([Char] -> [Char]) -> [Char] -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO Val) -> [Char] -> IO Val
forall a b. (a -> b) -> a -> b
$ [Char]
msg
          where
            msg :: [Char]
msg = [Char]
"reifyValue0: non-trivial partial application to cached value"
    goV (ANF.Data Reference
r Word64
t0 [Value Reference]
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) -> (Seg -> Closure) -> Seg -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> Seg -> Closure
formDataReplaced Reference
r PackedTag
t (Seg -> Val) -> IO Seg -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value Reference] -> IO Seg
goVs [Value Reference]
vs
    goV (ANF.Record RecordSchema
rs [Value Reference]
vals) = do
      RecordRef
rref <- case RecordSchema -> BiMap RecordSchema RecordRef -> Maybe RecordRef
forall k v. Ord k => k -> BiMap k v -> Maybe v
BM.lookupL RecordSchema
rs BiMap RecordSchema RecordRef
rrLookup of
        Just RecordRef
r -> RecordRef -> IO RecordRef
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecordRef
r
        Maybe RecordRef
Nothing -> [Word] -> [Char] -> IO RecordRef
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO RecordRef)
-> ([Char] -> [Char]) -> [Char] -> IO RecordRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO RecordRef) -> [Char] -> IO RecordRef
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown record schema reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RecordSchema -> [Char]
forall a. Show a => a -> [Char]
show RecordSchema
rs
      RecordShape
shape <- case RecordFieldMappings
-> RecordRef -> RecordSchema -> Maybe RecordShape
recordShapeFrom RecordFieldMappings
rfms RecordRef
rref RecordSchema
rs of
        Just RecordShape
shape -> RecordShape -> IO RecordShape
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecordShape
shape
        Maybe RecordShape
Nothing -> [Word] -> [Char] -> IO RecordShape
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO RecordShape)
-> ([Char] -> [Char]) -> [Char] -> IO RecordShape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO RecordShape) -> [Char] -> IO RecordShape
forall a b. (a -> b) -> a -> b
$ [Char]
"record schema with un-interned fields: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RecordSchema -> [Char]
forall a. Show a => a -> [Char]
show RecordSchema
rs
      -- `putValue` writes the values in ascending field-name order, which is
      -- the shape's slot order, so no reordering is needed. There has to be
      -- one per field: a record's values are read by slot, with the slot
      -- taken from the shape and no bound taken from the array (native
      -- code's record read), so a short array would be read past its end.
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Value Reference] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value Reference]
vals Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Vector FieldName -> Int
forall a. Vector a -> Int
V.length (RecordShape -> Vector FieldName
shapeFields RecordShape
shape)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Word] -> [Char] -> IO ()
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char]
"a record of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Value Reference] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value Reference]
vals) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" values for a schema of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Vector FieldName -> Int
forall a. Vector a -> Int
V.length (RecordShape -> Vector FieldName
shapeFields RecordShape
shape)) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" fields"
      Seg
vals' <- [Value Reference] -> IO Seg
goVs [Value Reference]
vals
      Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (RecordVals -> Val) -> RecordVals -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
boxedVal (Closure -> Val) -> (RecordVals -> Closure) -> RecordVals -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordShape -> RecordVals -> Closure
RecordG RecordShape
shape (RecordVals -> IO Val) -> RecordVals -> IO Val
forall a b. (a -> b) -> a -> b
$ Seg -> RecordVals
recordVals Seg
vals'
    goV (ANF.Cont [Value Reference]
vs Cont Reference
k) = do
      K
k' <- Cont Reference -> IO K
goK Cont Reference
k
      Seg
vs' <- [Value Reference] -> IO Seg
goVs [Value Reference]
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 -> Seg -> Closure
cv K
k' Seg
vs'
      where
        cv :: K -> Seg -> Closure
cv K
k Seg
s = K -> Int -> Seg -> Closure
Captured K
k Int
a Seg
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
$ Seg -> Int
forall a. (ByteArray, a) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seg
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ksz
    goV (ANF.BLit BLit Reference
l) = BLit Reference -> IO Val
goL BLit Reference
l

    goK :: Cont Reference -> IO K
goK Cont Reference
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 [(Reference, Value Reference)]
de Cont Reference
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 Reference) -> IO (Word64, Val))
-> [(Reference, Value Reference)] -> 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 Reference
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 Reference -> IO Val
goV Value Reference
v)) [(Reference, Value Reference)]
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 Reference -> IO K
goK Cont Reference
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 Reference
gr Cont Reference
k) =
      GroupRef Reference -> IO (CombIx, RComb Val)
goIx GroupRef Reference
gr IO (CombIx, RComb Val) -> ((CombIx, RComb Val) -> 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 (Comb (LamI Int
_ Int
fr MSection
sect Ptr NativeCell
cell))) ->
          Int -> Int -> CombIx -> Int -> MSection -> Ptr NativeCell -> 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
            Ptr NativeCell
cell
            (K -> K) -> IO K -> IO K
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cont Reference -> IO K
goK Cont Reference
k
        (CIx Reference
r Word64
_ Word64
_, RComb Val
_) ->
          [Word] -> [Char] -> IO K
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO K) -> ([Char] -> [Char]) -> [Char] -> IO K
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
err ([Char] -> IO K) -> [Char] -> IO K
forall a b. (a -> b) -> a -> b
$
            [Char]
"tried to reify a continuation with a cached value resumption"
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

    goL :: ANF.BLit Reference -> IO Val
    goL :: BLit Reference -> 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) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Text
t
    goL (ANF.List Seq (Value Reference)
l) = Closure -> Val
boxedVal (Closure -> Val) -> ([Val] -> Closure) -> [Val] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. USeq -> Closure
ListC (USeq -> Closure) -> ([Val] -> USeq) -> [Val] -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> USeq
forall a. [a] -> Deque a
Sq.fromList ([Val] -> Val) -> IO [Val] -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value Reference -> IO Val) -> [Value Reference] -> 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 Reference -> IO Val
goV (Seq (Value Reference) -> [Value Reference]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Value Reference)
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) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Referent -> Val
forall a. ForeignConvention a => a -> Val
encodeVal 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) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Reference -> Val
forall a. ForeignConvention a => a -> Val
encodeVal 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) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bytes -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Bytes
b
    goL (ANF.Quote Value Reference
v) = 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
$ Referenced Value -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Value Reference -> Referenced Value
forall (t :: * -> *). t Reference -> Referenced t
Plain Value Reference
v)
    goL (ANF.Code Code Reference
g) = 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
$ Referenced Code -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Code Reference -> Referenced Code
forall (t :: * -> *). t Reference -> Referenced t
Plain Code Reference
g)
    goL (ANF.BArr ByteArray
a) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ ByteArray -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ByteArray
a
    goL (ANF.Char Char
c) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Char -> Val
CharVal Char
c
    goL (ANF.Pos Word64
w) =
      -- TODO: Should this be a Nat or an Int?
      Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Word64 -> Val
NatVal Word64
w
    goL (ANF.Neg Word64
w) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Int -> Val
IntVal (Int -> Int
forall a. Num a => a -> a
negate (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w :: Int))
    goL (ANF.Float Double
d) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Double -> Val
DoubleVal Double
d
    goL (ANF.Arr Array (Value Reference)
a) = Array Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Array Val -> Val) -> IO (Array Val) -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array (Value Reference) -> IO (Array Val)
goVArr Array (Value Reference)
a
    goL (ANF.Map [(Value Reference, Value Reference)]
l) = Map Val Val -> Val
mapVal (Map Val Val -> Val)
-> ([(Val, Val)] -> Map Val Val) -> [(Val, Val)] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Val, Val)] -> Map Val Val
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Val, Val)] -> Val) -> IO [(Val, Val)] -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Value Reference, Value Reference) -> IO (Val, Val))
-> [(Value Reference, Value Reference)] -> IO [(Val, 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 Reference, Value Reference) -> IO (Val, Val)
goP [(Value Reference, Value Reference)]
l
      where
        goP :: (Value Reference, Value Reference) -> IO (Val, Val)
goP (Value Reference
x, Value Reference
y) = (,) (Val -> Val -> (Val, Val)) -> IO Val -> IO (Val -> (Val, Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value Reference -> IO Val
goV Value Reference
x IO (Val -> (Val, Val)) -> IO Val -> IO (Val, 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 Reference -> IO Val
goV Value Reference
y
    goL (ANF.BigInt Integer
i) = 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
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Integer
i
    goL (ANF.BigNat Natural
n) = 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
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Natural
n

#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