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

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

import Control.Concurrent (ThreadId)
import Control.Concurrent.STM as STM
import Control.Exception
import Control.Lens
import 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.List qualified as List
import Data.Map.Strict qualified as M
import Data.Map.Strict.Internal qualified as M
import Data.Sequence qualified as Sq
import Data.Set qualified as S
import Data.Set qualified as Set
import Data.Text qualified as DTx
import Data.Text.IO qualified as Tx
import Data.Traversable
import GHC.Conc as STM (unsafeIOToSTM)
import GHC.Stack
import Unison.Builtin.Decls (exceptionRef)
import Unison.Builtin.Decls qualified as Rf
import Unison.Prelude hiding (Text)
import Unison.Reference
  ( Reference,
    Reference' (Builtin),
  )
import Unison.Referent (Referent, pattern Ref)
import Unison.ReferentPrime (Referent' (..))
import Unison.Runtime.ANF as ANF
  ( Cacheability (..),
    Code (..),
    PackedTag (..),
    SuperGroup,
    codeGroup,
    foldGroup,
    foldGroupLinks,
    maskTags,
    packTags,
    valueLinks,
  )
import Unison.Runtime.ANF qualified as ANF
import Unison.Runtime.ANF.Optimize qualified as ANF
#ifdef CODE_SERIAL_CHECK
import Unison.Runtime.ANF.Serialize (serializeCode, deserializeCode)
#endif
import Unison.Runtime.Array as PA
import Unison.Runtime.Builtin hiding (unitValue)
import Unison.Runtime.Exception (RuntimeExn (BU, PE), die, exn)
import Unison.Runtime.Foreign
import Unison.Runtime.Foreign.Function
  ( decodeVal,
    encodeVal,
    foreignCall,
    functionReplacements,
    functionUnreplacements,
    pseudoConstructors,
  )
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.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
import System.IO.Unsafe (unsafePerformIO)
#endif

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

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

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

-- Entry point for evaluating a section
eval0 ::
  (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 <- IO Stack
alloc
  EnumMap Word64 MCombs
cmbs <- TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs)
forall a. TVar a -> IO a
readTVarIO (TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs))
-> TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs)
forall a b. (a -> b) -> a -> b
$ CCache 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 -> MComb -> Val
mCombVal CombIx
cix (RComb (Comb GCombInfo MComb
comb)) =
  Closure -> Val
BoxedVal (CombIx -> GCombInfo MComb -> Seg -> Closure
PAp CombIx
cix GCombInfo MComb
comb Seg
nullSeg)
mCombVal CombIx
_ (RComb (CachedVal Word64
_ Val
clo)) = Val
clo

topAEnv ::
  EnumMap Word64 MCombs ->
  M.Map Reference Word64 ->
  M.Map Reference Word64 ->
  IO (AEnv, K -> K)
topAEnv :: EnumMap Word64 MCombs
-> Map Reference Word64
-> Map Reference Word64
-> IO (AEnv, K -> K)
topAEnv EnumMap Word64 MCombs
combs Map Reference Word64
rfTy Map Reference Word64
rfTm
  | Just Word64
n <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
exceptionRef Map Reference Word64
rfTy,
    Reference
rcrf <- Text -> Reference
forall t h. t -> Reference' t h
Builtin ([Char] -> Text
DTx.pack [Char]
"raise"),
    Just Word64
j <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
rcrf Map Reference Word64
rfTm,
    CombIx
cix <- Reference -> Word64 -> Word64 -> CombIx
CIx Reference
rcrf Word64
j Word64
0,
    Val
clo <- CombIx -> MComb -> Val
mCombVal CombIx
cix (MComb -> Val) -> MComb -> Val
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 MCombs -> CombIx -> MComb
rCombSection EnumMap Word64 MCombs
combs CombIx
cix = do
      IORef Closure
r <- Closure -> IO (IORef Closure)
forall a. a -> IO (IORef a)
newIORef Closure
BlackHole
      let ar :: AffineRef
ar = IORef Closure -> AffineRef
ARef IORef Closure
r
      Closure
ahv <- Val -> Val -> IO Closure
extendPAp Val
clo (Val -> IO Closure) -> (Closure -> Val) -> Closure -> IO Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
BoxedVal (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ EnumSet Word64 -> AEnv -> AffineRef -> Closure
Affine (Word64 -> EnumSet Word64
forall k. EnumKey k => k -> EnumSet k
setSingleton Word64
n) AEnv
forall a. Monoid a => a
mempty AffineRef
ar
      IORef Closure -> Closure -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Closure
r Closure
ahv
      pure (Word64 -> AffineRef -> AEnv
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
n AffineRef
ar, Int -> AEnv -> AffineRef -> K -> K
AMark Int
0 AEnv
forall a. Monoid a => a
mempty AffineRef
ar)
topAEnv EnumMap Word64 MCombs
_ Map Reference Word64
_ Map Reference Word64
_ = (AEnv, K -> K) -> IO (AEnv, K -> K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AEnv
forall a. Monoid a => a
mempty, K -> K
forall a. a -> a
id)

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

-- Entry point for evaluating a numbered combinator.
-- An optional callback for the base of the stack may be supplied.
--
-- This is the entry point actually used in the interactive
-- environment currently.
apply0 ::
  (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 <- IO Stack
alloc
  EnumMap Word64 Reference
cmbrs <- TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference))
-> TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a b. (a -> b) -> a -> b
$ CCache 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 MComb -> GComb Val MComb
forall val. RComb val -> GComb val (RComb val)
unRComb (MComb -> GComb Val MComb) -> MComb -> GComb Val MComb
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 MCombs -> CombIx -> MComb
rCombSection EnumMap Word64 MCombs
cmbs CombIx
entryCix of
    Comb GCombInfo MComb
entryComb -> do
      (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 MComb -> Seg -> Closure
PAp CombIx
entryCix GCombInfo MComb
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 -> (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
val
  where
    k0 :: K
k0 = K -> Maybe K -> K
forall a. a -> Maybe a -> a
fromMaybe K
KE (Maybe
  ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
      MutableArray# RealWorld Closure #)
   -> IO ())
Maybe (XStack -> IO ())
callback Maybe
  ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
      MutableArray# RealWorld Closure #)
   -> IO ())
-> (((# Int#, Int#, Int#, MutableByteArray# RealWorld,
        MutableArray# RealWorld Closure #)
     -> IO ())
    -> K)
-> Maybe K
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
-> IO ()
cb -> Callback -> K
CB (Callback -> K)
-> (((# Int#, Int#, Int#, MutableByteArray# RealWorld,
        MutableArray# RealWorld Closure #)
     -> IO ())
    -> Callback)
-> ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
       MutableArray# RealWorld Closure #)
    -> IO ())
-> K
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
    MutableArray# RealWorld Closure #)
 -> IO ())
-> Callback
(XStack -> IO ()) -> Callback
Hook (((# Int#, Int#, Int#, MutableByteArray# RealWorld,
     MutableArray# RealWorld Closure #)
  -> IO ())
 -> K)
-> ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
       MutableArray# RealWorld Closure #)
    -> IO ())
-> K
forall a b. (a -> b) -> a -> b
$ \(# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
stk -> (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
-> IO ()
cb (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
stk)
{-# 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 <- IO Stack
alloc
  (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
forall a. Monoid a => a
mempty 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
$ Foreign -> Closure
Foreign (Reference -> Text -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.textRef Text
t)
  MM Referent
r -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (Reference -> Referent -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.termLinkRef Referent
r)
  MY Reference
r -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.typeLinkRef Reference
r)
  MI Int
i -> Int -> Val
IntVal Int
i
  MN Word64
n -> Word64 -> Val
NatVal Word64
n
  MC Char
c -> Char -> Val
CharVal Char
c
  MD Double
d -> Double -> Val
DoubleVal Double
d
{-# INLINE litToVal #-}

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

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

-- | Execute an instruction
--
-- Note: both `env` and `henv` are intentionally not strict arguments.
-- It seems to be slower to unpack them into many arguments. `env` is
-- never modified, so this is no worry. `henv` is modified, but it is
-- immediately evaluated when created to avoid thunks building up, so
-- that it doesn't need to be a strict argument.
exec ::
  (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 MComb
r Args
args) = do
  Val
v <- CCache prof -> HEnv -> Stack -> GRef MComb -> IO Val
forall p. CCache p -> HEnv -> Stack -> GRef MComb -> IO Val
resolve CCache prof
env HEnv
henv Stack
stk GRef MComb
r
  Stack
stk <- Stack -> Args -> Val -> IO Stack
name Stack
stk Args
args Val
v
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (SetAff Bool
u Int
i Int
j) =
  (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure
-> (Closure -> IO (Bool, HEnv, Stack, K))
-> IO (Bool, HEnv, Stack, K)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Affine EnumSet Word64
ps AEnv
_ ar :: AffineRef
ar@(ARef IORef Closure
r) -> do
      (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
j IO Closure -> (Closure -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef Closure -> Closure -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Closure
r
      HEnv
henv <-
        if Bool
u
          then do
            AEnv
aenv <-
              AEnv -> IO AEnv
forall a. a -> IO a
evaluate (AEnv -> IO AEnv) -> AEnv -> IO AEnv
forall a b. (a -> b) -> a -> b
$ (AffineRef -> AffineRef -> AffineRef) -> AEnv -> AEnv -> AEnv
forall k a.
EnumKey k =>
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EC.unionWith AffineRef -> AffineRef -> AffineRef
forall a b. a -> b -> a
const (EnumSet Word64 -> AffineRef -> AEnv
forall k a. EnumKey k => EnumSet k -> a -> EnumMap k a
mapFromSet EnumSet Word64
ps AffineRef
ar) (HEnv -> AEnv
aenv HEnv
henv)
            HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ HEnv
henv {aenv = aenv}
          else HEnv -> IO HEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HEnv
henv
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
    Closure
_ -> [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
  (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
cap
  HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ HEnv
henv {denv = denv}
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
_henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Discard Int
i) = do
  (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure
-> (Closure -> IO (Bool, HEnv, Stack, K))
-> IO (Bool, HEnv, Stack, K)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Affine EnumSet Word64
_ AEnv
_ AffineRef
r -> do
      (AEnv
aenv, Stack
stk, K
k) <- Stack -> K -> AffineRef -> IO (AEnv, Stack, K)
abortCont Stack
stk K
k AffineRef
r
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ AEnv -> DEnv -> HEnv
HEnv AEnv
aenv DEnv
forall a. Monoid a => a
mempty
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
    Closure
_ -> [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
  (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure
-> (Closure -> IO (Bool, HEnv, Stack, K))
-> IO (Bool, HEnv, Stack, K)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Affine EnumSet Word64
_ AEnv
aenv AffineRef
_ -> do
      (Stack
stk, Int
a) <- Stack -> IO (Stack, Int)
saveArgs Stack
stk
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ AEnv -> DEnv -> HEnv
HEnv AEnv
aenv DEnv
forall a. Monoid a => a
mempty
      pure (Bool
False, HEnv
henv, Stack
stk, HEnv -> Int -> K -> K
Local HEnv
henv0 Int
a K
k)
    Closure
v -> [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] -> Seq 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] -> Seq 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
          (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
        Right Val
x -> do
          (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
x
          (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
env HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Prim1 Prim1
VALU Int
i) = do
  Val
c <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  Stack -> 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 <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  () <- RuntimeExn -> IO ()
forall e a. Exception e => e -> IO a
throwIO (RuntimeExn -> IO ()) -> RuntimeExn -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Reference, Int)] -> Text -> Val -> RuntimeExn
BU (Reference -> K -> [(Reference, Int)]
traceK Reference
r K
k) (Text -> Text
Util.Text.toText Text
name) Val
x
  [Char] -> IO (Bool, 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 = [Word] -> [Char] -> IO (Bool, HEnv, Stack, K)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"attempted to use sandboxed operation: trace"
  | Bool
otherwise = do
      Text
tx <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
      Val
clo <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
      case CCache 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 <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
valI
      (Bool
r, Ticket Val
_) <- IORef Val -> Ticket Val -> Val -> IO (Bool, Ticket Val)
forall a. IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
Atomic.casIORef IORef Val
ref Ticket Val
ticket Val
v
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool Stack
stk Bool
r
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache 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
  (() :: Constraint) => 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
_ (Print Int
i) = do
  Text
t <- Stack -> Int -> IO Text
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
i
  Text -> IO ()
Tx.putStrLn (Text -> Text
Util.Text.toText Text
t)
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
henv !ActiveThreads
_activeThreads !Stack
stk !K
k CombIx
_ (Lit MLit
ml) = do
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk (Val -> IO ()) -> Val -> IO ()
forall a b. (a -> b) -> a -> b
$ MLit -> Val
litToVal MLit
ml
  pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache 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 <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
ahi
      IORef Closure
r <- Closure -> IO (IORef Closure)
forall a. a -> IO (IORef a)
newIORef Closure
BlackHole
      let ar :: AffineRef
ar = IORef Closure -> AffineRef
ARef IORef Closure
r
      Closure
ahv <- Val -> Val -> IO Closure
extendPAp Val
ahv0 (Val -> IO Closure) -> (Closure -> Val) -> Closure -> IO Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Val
BoxedVal (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ EnumSet Word64 -> AEnv -> AffineRef -> Closure
Affine EnumSet Word64
ps AEnv
aenv0 AffineRef
ar
      IORef Closure -> Closure -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Closure
r Closure
ahv
      AEnv
aenv <- AEnv -> IO AEnv
forall a. a -> IO a
evaluate (AEnv -> IO AEnv) -> AEnv -> IO AEnv
forall a b. (a -> b) -> a -> b
$ (AffineRef -> AffineRef -> AffineRef) -> AEnv -> AEnv -> AEnv
forall k a.
EnumKey k =>
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EC.unionWith AffineRef -> AffineRef -> AffineRef
forall a b. a -> b -> a
const (EnumSet Word64 -> AffineRef -> AEnv
forall k a. EnumKey k => EnumSet k -> a -> EnumMap k a
mapFromSet EnumSet Word64
ps AffineRef
ar) AEnv
aenv0
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ HEnv
henv {aenv = aenv}
      pure (Bool
False, HEnv
henv, Stack
stk, Int -> AEnv -> AffineRef -> K -> K
AMark Int
a AEnv
aenv0 AffineRef
ar K
k)
  | HEnv AEnv
aenv0 DEnv
denv0 <- HEnv
henv = do
      (Stack
stk, Int
a) <- Stack -> IO (Stack, Int)
saveArgs Stack
stk
      Val
nh <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
nhi
      DEnv
denv <- DEnv -> IO DEnv
forall a. a -> IO a
evaluate (DEnv -> IO DEnv) -> DEnv -> IO DEnv
forall a b. (a -> b) -> a -> b
$ (Val -> Val -> Val) -> DEnv -> DEnv -> DEnv
forall k a.
EnumKey k =>
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EC.unionWith Val -> Val -> Val
forall a b. a -> b -> a
const (EnumSet Word64 -> Val -> DEnv
forall k a. EnumKey k => EnumSet k -> a -> EnumMap k a
mapFromSet EnumSet Word64
ps Val
nh) DEnv
denv0
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ AEnv -> DEnv -> HEnv
HEnv AEnv
aenv0 DEnv
denv
      DEnv
clos <- DEnv -> IO DEnv
forall a. a -> IO a
evaluate (DEnv -> IO DEnv) -> DEnv -> IO DEnv
forall a b. (a -> b) -> a -> b
$ DEnv -> EnumSet Word64 -> DEnv
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys DEnv
denv0 EnumSet Word64
ps
      pure (Bool
False, HEnv
henv, Stack
stk, Int -> EnumSet Word64 -> DEnv -> K -> K
Mark Int
a EnumSet Word64
ps DEnv
clos K
k)
exec CCache 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] -> Seq 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)
  (Bool, HEnv, Stack, K) -> IO (Bool, HEnv, Stack, K)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
b, HEnv
henv, Stack
stk, K
k)
exec CCache 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
=<< (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> (ThreadId -> Closure) -> ThreadId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure)
-> (ThreadId -> Foreign) -> ThreadId -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> ThreadId -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.threadIdRef (ThreadId -> IO ()) -> ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId
tid
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache 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 <- (() :: Constraint) => 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 ((() :: Constraint) => 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 <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
      Stack
stk <- Stack -> IO Stack
bump Stack
stk -- Bump the boxed stack to make a slot for the result, which will be written in the callback if we succeed.
      Either SomeException ()
ev <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ CCache prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
forall prof.
RuntimeProfiler prof =>
CCache prof -> ActiveThreads -> (Val -> IO ()) -> Val -> IO ()
nestEval CCache prof
env ActiveThreads
activeThreads ((() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk) Val
v
      Stack
stk <- Stack -> Either SomeException () -> IO Stack
encodeExn Stack
stk Either SomeException ()
ev
      pure (Bool
False, HEnv
henv, Stack
stk, K
k)
exec CCache prof
_ HEnv
_ !ActiveThreads
_ !Stack
_ !K
_ CombIx
_ (SandboxingFailure Text
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
<> Text -> [Char]
DTx.unpack Text
t
{-# INLINE exec #-}

encodeExn ::
  Stack ->
  Either SomeException () ->
  IO Stack
encodeExn :: Stack -> Either SomeException () -> IO Stack
encodeExn Stack
stk Either SomeException ()
exc = do
  case Either SomeException ()
exc of
    Right () -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
1
    Left SomeException
exn -> do
      -- If we hit an exception, we have one unused slot on the stack
      -- from where the result _would_ have been placed.
      -- So here we bump one less than it looks like we should, and re-use
      -- that slot.
      Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
3
      (() :: Constraint) => Stack -> Int -> IO ()
Stack -> Int -> IO ()
pokeTag Stack
stk Int
0
      (() :: Constraint) => Stack -> Int -> Closure -> IO ()
Stack -> Int -> Closure -> IO ()
bpokeOff Stack
stk Int
1 (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.typeLinkRef Reference
link)
      Stack -> Int -> Text -> IO ()
forall b. BuiltinForeign b => Stack -> Int -> b -> IO ()
pokeOffBi Stack
stk Int
2 Text
msg
      Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
3 Val
extra
      where
        disp :: (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, [Char] -> Text
Util.Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Width -> Pretty ColorText -> [Char]
P.toPlain Width
0 Pretty ColorText
msg, Val
unitValue)
              BU [(Reference, Int)]
_ Text
tx Val
val -> (Reference
Rf.runtimeFailureRef, Text -> Text
Util.Text.fromText Text
tx, Val
val)
          | Just (ArithException
ae :: ArithException) <- SomeException -> Maybe ArithException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn =
              (Reference
Rf.arithmeticFailureRef, ArithException -> Text
forall 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 (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 GBranch MComb
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 -> GBranch MComb -> MSection
selectBranch Word64
n GBranch MComb
br
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
r (DMatch Maybe Reference
mr Int
i GBranch MComb
br) = do
  (MSection
nx, Stack
stk) <- Maybe Reference
-> Stack -> GBranch MComb -> Closure -> IO (MSection, Stack)
dataBranch Maybe Reference
mr Stack
stk GBranch MComb
br (Closure -> IO (MSection, Stack))
-> IO Closure -> IO (MSection, Stack)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i
  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 GBranch MComb
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 -> GBranch MComb -> MSection
selectBranch Word64
n GBranch MComb
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 (GBranch MComb)
br) = do
  (PackedTag
t, Stack
stk) <- Stack -> Val -> IO (PackedTag, Stack)
dumpDataValNoTag Stack
stk (Val -> IO (PackedTag, Stack)) -> IO Val -> IO (PackedTag, Stack)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  if PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.pureEffectTag
    then 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 GBranch MComb
ebs <- Word64 -> EnumMap Word64 (GBranch MComb) -> Maybe (GBranch MComb)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
e EnumMap Word64 (GBranch MComb)
br ->
            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 -> GBranch MComb -> MSection
selectBranch Word64
t GBranch MComb
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
      (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i IO Val -> (Val -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 MComb
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 MComb -> IO Val
forall p. CCache p -> HEnv -> Stack -> GRef MComb -> IO Val
resolve CCache prof
env HEnv
henv Stack
stk GRef MComb
r
    IO Val -> (Val -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 MComb
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
-> MComb
-> IO ()
forall prof.
RuntimeProfiler prof =>
Ticker prof
-> CCache prof
-> HEnv
-> ActiveThreads
-> Stack
-> K
-> CombIx
-> Bool
-> Args
-> MComb
-> IO ()
enter Ticker prof
yld CCache prof
env HEnv
henv ActiveThreads
activeThreads Stack
stk K
k CombIx
combIx Bool
ck Args
args MComb
rcomb
eval' !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k CombIx
_ (Jump Int
i Args
args) =
  (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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) = 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 -> K -> K
Push Int
fsz Int
asz CombIx
cix Int
f MSection
sect 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 <- (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek Stack
stk
          (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Reference -> PackedTag -> Val -> Closure
Data1 Reference
exceptionRef PackedTag
TT.exceptionRaiseTag Val
fv
          (Stack
stk, Int
fsz, Int
asz) <- Stack -> IO (Stack, Int, Int)
saveFrame Stack
stk
          let kk :: K
kk = Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push Int
fsz Int
asz CombIx
fakeCix Int
10 MSection
nx K
k
          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 = (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek Stack
stk IO Val -> (Val -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Val -> IO ()
write
{-# INLINE nestEval #-}

atomicEval ::
  (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
-> MComb
-> IO ()
enter !Ticker prof
yld CCache prof
env HEnv
henv !ActiveThreads
activeThreads !Stack
stk !K
k !CombIx
cref !Bool
sck !Args
args = \case
  (RComb (Lam Int
a Int
f MSection
entry)) -> do
    -- check for stack check _skip_
    Stack
stk <- if Bool
sck then Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk else Stack -> Int -> IO Stack
ensure Stack
stk Int
f
    Stack
stk <- Stack -> Args -> IO Stack
moveArgs Stack
stk Args
args
    Stack
stk <- Stack -> Int -> IO Stack
acceptArgs Stack
stk Int
a
    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
  (RComb (CachedVal Word64
_ Val
val)) -> do
    Stack
stk <- Stack -> IO Stack
discardFrame Stack
stk
    Stack
stk <- Stack -> IO Stack
bump Stack
stk
    (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
val
    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 #-}

-- fast path by-name delaying
name :: Stack -> Args -> Val -> IO Stack
name :: Stack -> Args -> Val -> IO Stack
name !Stack
stk !Args
args = \case
  BoxedVal (PAp CombIx
cix GCombInfo MComb
comb Seg
seg) -> do
    Seg
seg <- Augment -> Stack -> Seg -> Args -> IO Seg
closeArgs Augment
I Stack
stk Seg
seg Args
args
    Stack
stk <- Stack -> IO Stack
bump Stack
stk
    (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ CombIx -> GCombInfo MComb -> Seg -> Closure
PAp CombIx
cix GCombInfo MComb
comb Seg
seg
    pure Stack
stk
  Val
v -> [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 MComb
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 :: * -> *).
(() :: Constraint, 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 :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
ucop Int
0 (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Val -> Int
getUnboxedVal Val
new
  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.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> Array a -> Int -> Int -> m ()
copyArray MutableArray RealWorld Closure
MutableArray (PrimState IO) Closure
bcop Int
1 BSeg
bseg0 Int
0 Int
bssz
  MutableArray (PrimState IO) Closure -> Int -> Closure -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Closure
MutableArray (PrimState IO) Closure
bcop Int
0 (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Val -> Closure
getBoxedVal Val
new
  BSeg
bseg <- MutableArray (PrimState IO) Closure -> IO BSeg
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
unsafeFreezeArray MutableArray RealWorld Closure
MutableArray (PrimState IO) Closure
bcop

  pure $ CombIx -> GCombInfo MComb -> Seg -> Closure
PAp CombIx
cix GCombInfo MComb
comb (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 MComb
comb Seg
seg) ->
      case GCombInfo MComb
comb of
        LamI Int
a Int
f MSection
entry
          | Bool
ck Bool -> Bool -> Bool
|| Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
ac -> do
              Stack
stk <- Stack -> Int -> IO Stack
ensure Stack
stk Int
f
              Stack
stk <- Stack -> Args -> IO Stack
moveArgs Stack
stk Args
args
              Stack
stk <- Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
A
              Stack
stk <- Stack -> Int -> IO Stack
acceptArgs Stack
stk Int
a
              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
          | Bool
otherwise -> do
              Seg
seg <- Augment -> Stack -> Seg -> Args -> IO Seg
closeArgs Augment
C Stack
stk Seg
seg Args
args
              Stack
stk <- Stack -> IO Stack
discardFrame (Stack -> IO Stack) -> IO Stack -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack -> IO Stack
frameArgs Stack
stk
              Stack
stk <- Stack -> IO Stack
bump Stack
stk
              (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ CombIx -> GCombInfo MComb -> Seg -> Closure
PAp CombIx
cix GCombInfo MComb
comb Seg
seg
              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
          (() :: Constraint) => 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 K
k) =
      (Int
0, Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push Int
n (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Stack -> Int
asize Stack
stk) CombIx
cix Int
f MSection
rsect K
k)
    adjust K
k = (Stack -> Int
asize Stack
stk, K
k)
{-# INLINE jump #-}

repush ::
  (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 = 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 (AEnv -> DEnv -> HEnv
HEnv AEnv
aenv DEnv
denv) ActiveThreads
activeThreads Stack
stk K
k
    go !DEnv
denv (Mark Int
a EnumSet Word64
ps DEnv
cs K
sk) !K
k = DEnv -> K -> K -> IO ()
go DEnv
denv' K
sk (K -> IO ()) -> K -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> EnumSet Word64 -> DEnv -> K -> K
Mark Int
a EnumSet Word64
ps DEnv
cs' K
k
      where
        denv' :: DEnv
denv' = DEnv
cs DEnv -> DEnv -> DEnv
forall a. Semigroup a => a -> a -> a
<> DEnv -> EnumSet Word64 -> DEnv
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.withoutKeys DEnv
denv EnumSet Word64
ps
        cs' :: DEnv
cs' = DEnv -> EnumSet Word64 -> DEnv
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
EC.restrictKeys DEnv
denv EnumSet Word64
ps
    go !DEnv
denv (Push Int
n Int
a CombIx
cix Int
f MSection
rsect K
sk) !K
k =
      DEnv -> K -> K -> IO ()
go DEnv
denv K
sk (K -> IO ()) -> K -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push Int
n Int
a CombIx
cix Int
f MSection
rsect K
k
    go !DEnv
_ (Local {}) !K
_ = [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
_ (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 <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  pure [Val
x]
closureArgs !Stack
stk (VArg2 Int
i Int
j) = do
  Val
x <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i
  Val
y <- (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
j
  pure [Val
x, Val
y]
closureArgs !Stack
stk (VArgR Int
i Int
l) =
  [Int] -> (Int -> IO Val) -> IO [Val]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
l [Int
i ..]) ((() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk)
closureArgs !Stack
stk (VArgN PrimArray Int
bs) =
  [Int] -> (Int -> IO Val) -> IO [Val]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (PrimArray Int -> [Int]
forall a. Prim a => PrimArray a -> [a]
PA.primArrayToList PrimArray Int
bs) ((() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk)
closureArgs !Stack
_ Args
_ =
  [Char] -> IO [Val]
forall a. HasCallStack => [Char] -> a
error [Char]
"closure arguments can only be boxed."
{-# INLINE closureArgs #-}

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

dumpDataValNoTag ::
  Stack ->
  Val ->
  IO (PackedTag, Stack)
dumpDataValNoTag :: Stack -> Val -> IO (PackedTag, Stack)
dumpDataValNoTag Stack
stk (BoxedVal Closure
c) =
  (Closure -> PackedTag
closureTag Closure
c,) (Stack -> (PackedTag, Stack)) -> IO Stack -> IO (PackedTag, Stack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Reference -> Stack -> Closure -> IO Stack
dumpDataNoTag Maybe Reference
forall a. Maybe a
Nothing Stack
stk Closure
c
dumpDataValNoTag Stack
_ Val
v =
  [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
x -> do
    Stack
stk <- Stack -> IO Stack
bump Stack
stk
    (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
    pure Stack
stk
  Data2 Reference
_ PackedTag
_ Val
x Val
y -> do
    Stack
stk <- Stack -> Int -> IO Stack
bumpn Stack
stk Int
2
    (() :: Constraint) => Stack -> Int -> Val -> IO ()
Stack -> Int -> Val -> IO ()
pokeOff Stack
stk Int
1 Val
y
    Stack
stk Stack -> IO () -> IO Stack
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk Val
x
  DataG Reference
_ PackedTag
_ Seg
seg -> Stack -> Seg -> Dump -> IO Stack
dumpSeg Stack
stk Seg
seg Dump
S
  Closure
clo ->
    [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 #-}

-- 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 <- (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek Stack
stk
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Reference -> PackedTag -> Val -> Closure
Data1 Reference
Rf.effectRef (Word64 -> PackedTag
PackedTag Word64
0) Val
v
      Stack
stk <- Stack -> Int -> IO Stack
adjustArgs Stack
stk Int
a
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ AEnv -> DEnv -> HEnv
HEnv AEnv
aenv0 DEnv
denv
      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 <- (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek Stack
stk
      Val
h <- Closure -> Val
BoxedVal (Closure -> Val) -> IO Closure -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Closure -> IO Closure
forall a. IORef a -> IO a
readIORef IORef Closure
r
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Reference -> PackedTag -> Val -> Closure
Data1 Reference
Rf.effectRef (Word64 -> PackedTag
PackedTag Word64
0) Val
v
      Stack
stk <- Stack -> Int -> IO Stack
adjustArgs Stack
stk Int
a
      HEnv
henv <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (HEnv -> IO HEnv) -> HEnv -> IO HEnv
forall a b. (a -> b) -> a -> b
$ AEnv -> DEnv -> HEnv
HEnv AEnv
aenv DEnv
forall a. Monoid a => a
mempty
      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 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
      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
    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 K
KE = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINE yield #-}

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

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

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

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

dataBranchClosureError :: Maybe Reference -> Closure -> IO a
dataBranchClosureError :: forall a. Maybe Reference -> Closure -> IO a
dataBranchClosureError Maybe Reference
mrf Closure
clo =
  [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: bad closure: "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
clo
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> (Reference -> [Char]) -> Maybe Reference -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\Reference
r -> [Char]
"\nexpected type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r) Maybe Reference
mrf

dataBranchBranchError :: MBranch -> IO a
dataBranchBranchError :: forall a. GBranch MComb -> IO a
dataBranchBranchError GBranch MComb
br =
  [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: unexpected branch: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GBranch MComb -> [Char]
forall a. Show a => a -> [Char]
show GBranch MComb
br

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

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

abortCont ::
  Stack ->
  K ->
  AffineRef ->
  IO (AEnv, Stack, K)
abortCont :: Stack -> K -> AffineRef -> IO (AEnv, Stack, K)
abortCont !Stack
stk !K
k !AffineRef
r = Int -> K -> IO (AEnv, Stack, K)
walk (Stack -> Int
asize Stack
stk) K
k
  where
    walk :: SZ -> K -> IO (AEnv, Stack, K)
    walk :: Int -> K -> IO (AEnv, Stack, K)
walk !Int
sz = \case
      K
KE -> [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
_ K
k) -> Int -> K -> IO (AEnv, Stack, K)
walk (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a) K
k
      -- dynamic mark cannot match
      (Mark Int
a EnumSet Word64
_ DEnv
_ K
k) -> Int -> K -> IO (AEnv, Stack, K)
walk (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a) K
k
      (AMark Int
a AEnv
aenv AffineRef
s K
k)
        | AffineRef
r AffineRef -> AffineRef -> Bool
forall a. Eq a => a -> a -> Bool
== AffineRef
s -> AEnv -> Int -> Int -> K -> IO (AEnv, Stack, K)
finish AEnv
aenv Int
sz Int
a K
k
        | Bool
otherwise -> Int -> K -> IO (AEnv, Stack, K)
walk (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a) K
k

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

resolve :: CCache p -> HEnv -> Stack -> MRef -> IO Val
resolve :: forall p. CCache p -> HEnv -> Stack -> GRef MComb -> IO Val
resolve CCache p
_ HEnv
_ Stack
_ (Env CombIx
cix MComb
mcomb) = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CombIx -> MComb -> Val
mCombVal CombIx
cix MComb
mcomb)
resolve CCache p
_ HEnv
_ Stack
stk (Stk Int
i) = (() :: Constraint) => 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 -> MComb
rCombSection EnumMap Word64 MCombs
combs (CIx Reference
r Word64
n Word64
i) =
  case Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
n EnumMap Word64 MCombs
combs of
    Just MCombs
cmbs -> case Word64 -> MCombs -> Maybe (GComb Val MComb)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i MCombs
cmbs of
      Just GComb Val MComb
cmb -> GComb Val MComb -> MComb
forall val. GComb val (RComb val) -> RComb val
RComb GComb Val MComb
cmb
      Maybe (GComb Val MComb)
Nothing -> [Char] -> MComb
forall a. HasCallStack => [Char] -> a
error ([Char] -> MComb) -> [Char] -> MComb
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown section `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"` of combinator `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"`. Reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r
    Maybe MCombs
Nothing -> [Char] -> MComb
forall a. HasCallStack => [Char] -> a
error ([Char] -> MComb) -> [Char] -> MComb
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown combinator `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"`. Reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

resolveSection :: CCache 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 -> MComb
rCombSection EnumMap Word64 MCombs
rcombs (CombIx -> MComb) -> Section -> MSection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Section
section

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

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

decodeCacheArgument :: USeq -> IO [(Reference, Code 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. Seq 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 = do
  let 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)
  (EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs, EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs) <- STM
  (EnumMap Word64 (GCombs Val CombIx),
   EnumMap Word64 (GCombs Val CombIx))
-> IO
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx))
forall a. STM a -> IO a
atomically (STM
   (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
 -> IO
      (EnumMap Word64 (GCombs Val CombIx),
       EnumMap Word64 (GCombs Val CombIx)))
-> STM
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx))
-> IO
     (EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx))
forall a b. (a -> b) -> a -> b
$ 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)
    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
    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)
    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' Text h) (SuperGroup (Reference' Text h) v),
 OptInfos (Reference' Text h) v)
-> (Map (Reference' Text h) (SuperGroup (Reference' Text h) v),
    OptInfos (Reference' Text h) v)
haff (Map (Reference' Text h) (SuperGroup (Reference' Text h) v)
cmbs, OptInfos (Reference' Text h) v
opts) =
          ((Reference' Text h
 -> SuperGroup (Reference' Text h) v
 -> SuperGroup (Reference' Text h) v)
-> Map (Reference' Text h) (SuperGroup (Reference' Text h) v)
-> Map (Reference' Text h) (SuperGroup (Reference' Text h) v)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey ((Text -> Reference' Text h)
-> OptInfos (Reference' Text h) v
-> Reference' Text h
-> SuperGroup (Reference' Text h) v
-> SuperGroup (Reference' Text h) v
forall ref v.
(Ord ref, Var v) =>
(Text -> ref)
-> OptInfos ref v -> ref -> SuperGroup ref v -> SuperGroup ref v
ANF.optimizeHandler Text -> Reference' Text h
forall t h. t -> Reference' t h
Builtin OptInfos (Reference' Text h) v
opts) Map (Reference' Text h) (SuperGroup (Reference' Text h) v)
cmbs, OptInfos (Reference' Text h) v
opts)
    Map Reference (SuperGroup Reference Symbol)
opt <-
      TVar (OptInfos Reference Symbol)
-> (OptInfos Reference Symbol
    -> (Map Reference (SuperGroup Reference Symbol),
        OptInfos Reference Symbol))
-> STM (Map Reference (SuperGroup Reference Symbol))
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar (CCache p -> TVar (OptInfos Reference Symbol)
forall prof. CCache prof -> TVar (OptInfos Reference Symbol)
optInfos CCache p
cc) ((OptInfos Reference Symbol
  -> (Map Reference (SuperGroup Reference Symbol),
      OptInfos Reference Symbol))
 -> STM (Map Reference (SuperGroup Reference Symbol)))
-> (OptInfos Reference Symbol
    -> (Map Reference (SuperGroup Reference Symbol),
        OptInfos Reference Symbol))
-> STM (Map Reference (SuperGroup Reference Symbol))
forall a b. (a -> b) -> a -> b
$ (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' Text h) (SuperGroup (Reference' Text h) v),
 OptInfos (Reference' Text h) v)
-> (Map (Reference' Text h) (SuperGroup (Reference' Text h) v),
    OptInfos (Reference' Text 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)
    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)
    Map Reference Word64
rtm <- Map Reference Word64
-> TVar (Map Reference Word64) -> STM (Map Reference Word64)
forall s. Semigroup s => s -> TVar s -> STM s
updateMap ([(Reference, Word64)] -> Map Reference Word64
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Reference, Word64)] -> Map Reference Word64)
-> [(Reference, Word64)] -> Map Reference Word64
forall a b. (a -> b) -> a -> b
$ [Reference] -> [Word64] -> [(Reference, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Reference]
rs [Word64
ntm ..]) (CCache p -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm 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) -> RefNums
RN ([Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
"ty" Map Reference Word64
rty) ([Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
"tm" Map Reference Word64
rtm) ((Reference -> Map Reference Int -> Maybe Int)
-> Map Reference Int -> Reference -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference -> Map Reference Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map Reference Int
arities)
        combinate :: Word64 -> (Reference, SuperGroup Reference Symbol) -> (Word64, EnumMap Word64 Comb)
        combinate :: Word64
-> (Reference, SuperGroup Reference Symbol)
-> (Word64, GCombs Void CombIx)
combinate Word64
n (Reference
r, SuperGroup Reference Symbol
g) = (Word64
n, RefNums
-> Reference
-> Word64
-> SuperGroup Reference Symbol
-> GCombs Void CombIx
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> SuperGroup Reference v
-> 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
    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
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))
-> STM
     (EnumMap Word64 (GCombs Void CombIx),
      EnumMap Word64 (GCombs Val CombIx),
      EnumMap Word64 (GCombs Val CombIx), 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
              (EnumMap Word64 (GCombs Void CombIx)
 -> EnumMap Word64 (GCombs any CombIx))
-> ([(Word64, GCombs Void CombIx)]
    -> EnumMap Word64 (GCombs Void CombIx))
-> [(Word64, GCombs Void CombIx)]
-> EnumMap Word64 (GCombs any CombIx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Set ForeignFunc
-> EnumMap Word64 (GCombs Void CombIx)
-> EnumMap Word64 (GCombs Void CombIx)
sanitizeCombsOfForeignFuncs (CCache p -> Bool
forall prof. CCache prof -> Bool
sandboxed CCache p
cc) Set ForeignFunc
sandboxedForeignFuncs
              (EnumMap Word64 (GCombs Void CombIx)
 -> EnumMap Word64 (GCombs Void CombIx))
-> ([(Word64, GCombs Void CombIx)]
    -> EnumMap Word64 (GCombs Void CombIx))
-> [(Word64, GCombs Void CombIx)]
-> EnumMap Word64 (GCombs Void CombIx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Word64, GCombs Void CombIx)]
-> EnumMap Word64 (GCombs Void CombIx)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList
              ([(Word64, GCombs Void CombIx)]
 -> EnumMap Word64 (GCombs any CombIx))
-> [(Word64, GCombs Void CombIx)]
-> EnumMap Word64 (GCombs any CombIx)
forall a b. (a -> b) -> a -> b
$ (Word64
 -> (Reference, SuperGroup Reference Symbol)
 -> (Word64, GCombs Void CombIx))
-> [Word64]
-> [(Reference, SuperGroup Reference Symbol)]
-> [(Word64, GCombs Void CombIx)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word64
-> (Reference, SuperGroup Reference Symbol)
-> (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)
          (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
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)
    -- 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)
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall a b. a -> b -> b
`seq` Map Reference Word64
rtm Map Reference Word64
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall a b. a -> b -> b
`seq` EnumMap Word64 Reference
newCombRefs EnumMap Word64 Reference
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall a b. a -> b -> b
`seq` EnumMap Word64 MCombs
updatedCombs EnumMap Word64 MCombs
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall a b. a -> b -> b
`seq` Map Reference (Set Reference)
nsn Map Reference (Set Reference)
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall a b. a -> b -> b
`seq` EnumSet Word64
ncc EnumSet Word64
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall a b. a -> b -> b
`seq` EnumMap Word64 (GCombs Void CombIx)
nsc EnumMap Word64 (GCombs Void 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 -> b -> b
`seq` (EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs, EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs)
  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

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 <- (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek (XStack -> Stack
packXStack (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld Closure #)
XStack
xstk)
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            TVar (EnumMap Word64 (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. 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 -> [Char]
P.toPlain Width
0 -> [Char]
msg)) =
  [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf [Char]
sdbx1 [Char]
msg Bool -> Bool -> Bool
|| [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf [Char]
sdbx2 [Char]
msg
  where
    sdbx1 :: [Char]
sdbx1 = [Char]
"attempted to use sandboxed operation"
    sdbx2 :: [Char]
sdbx2 = [Char]
"Attempted to use disallowed builtin in sandboxed"
isSandboxingException RuntimeExn
_ = Bool
False

expandSandbox ::
  Map Reference (Set Reference) ->
  [(Reference, SuperGroup 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) Any
f Bool
b Reference
r
        | Bool -> Bool
not Bool
b, Reference -> Set Reference -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember Reference
r Set Reference
known = (Set Reference, Set Reference)
-> Const (Set Reference, Set Reference) Any
forall {k} a (b :: k). a -> Const a b
Const (Reference -> Set Reference
forall a. a -> Set a
S.singleton Reference
r, Set Reference
forall a. Monoid a => a
mempty)
        | Bool
b, Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Reference
r Map Reference Word64
rty = (Set Reference, Set Reference)
-> Const (Set Reference, Set Reference) Any
forall {k} a (b :: k). a -> Const a b
Const (Set Reference
forall a. Monoid a => a
mempty, Reference -> Set Reference
forall a. a -> Set a
S.singleton Reference
r)
        | Bool
otherwise = (Set Reference, Set Reference)
-> Const (Set Reference, Set Reference) Any
forall {k} a (b :: k). a -> Const a b
Const (Set Reference
forall a. Monoid a => a
mempty, Set Reference
forall a. Monoid a => a
mempty)
      (Set Reference
missing, Set Reference
tys) =
        Const (Set Reference, Set Reference) Any
-> (Set Reference, Set Reference)
forall {k} a (b :: k). Const a b -> a
getConst (Const (Set Reference, Set Reference) Any
 -> (Set Reference, Set Reference))
-> Const (Set Reference, Set Reference) Any
-> (Set Reference, Set Reference)
forall a b. (a -> b) -> a -> b
$ (((Reference, Code Reference)
 -> Const (Set Reference, Set Reference) Any)
-> [(Reference, Code Reference)]
-> Const (Set Reference, Set Reference) Any
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((Reference, Code Reference)
  -> Const (Set Reference, Set Reference) Any)
 -> [(Reference, Code Reference)]
 -> Const (Set Reference, Set Reference) Any)
-> ((SuperGroup Reference Symbol
     -> Const (Set Reference, Set Reference) Any)
    -> (Reference, Code Reference)
    -> Const (Set Reference, Set Reference) Any)
-> (SuperGroup Reference Symbol
    -> Const (Set Reference, Set Reference) Any)
-> [(Reference, Code Reference)]
-> Const (Set Reference, Set Reference) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Code Reference -> Const (Set Reference, Set Reference) Any)
-> (Reference, Code Reference)
-> Const (Set Reference, Set Reference) Any
forall m a. Monoid m => (a -> m) -> (Reference, a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Code Reference -> Const (Set Reference, Set Reference) Any)
 -> (Reference, Code Reference)
 -> Const (Set Reference, Set Reference) Any)
-> ((SuperGroup Reference Symbol
     -> Const (Set Reference, Set Reference) Any)
    -> Code Reference -> Const (Set Reference, Set Reference) Any)
-> (SuperGroup Reference Symbol
    -> Const (Set Reference, Set Reference) Any)
-> (Reference, Code Reference)
-> Const (Set Reference, Set Reference) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SuperGroup Reference Symbol
 -> Const (Set Reference, Set Reference) Any)
-> Code Reference -> Const (Set Reference, Set Reference) Any
forall m ref.
Monoid m =>
(SuperGroup ref Symbol -> m) -> Code ref -> m
foldGroup) ((Bool -> Reference -> Const (Set Reference, Set Reference) Any)
-> SuperGroup Reference Symbol
-> Const (Set Reference, Set Reference) Any
forall r v ref.
(Monoid r, Var v) =>
(Bool -> ref -> r) -> SuperGroup ref v -> r
foldGroupLinks Bool -> Reference -> Const (Set Reference, Set Reference) Any
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. 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. 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. 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"

-- 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

    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
          PApV CombIx
cix GCombInfo MComb
_rComb [Val]
args ->
            GroupRef RefNum -> ValList RefNum -> Value RefNum
forall ref. GroupRef ref -> ValList ref -> Value ref
ANF.Partial (GroupRef RefNum -> ValList RefNum -> Value RefNum)
-> StateT ReflectionState IO (GroupRef RefNum)
-> StateT ReflectionState IO (ValList 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 (ValList RefNum -> Value RefNum)
-> StateT ReflectionState IO (ValList 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
<*> (Val -> StateT ReflectionState IO (Value RefNum))
-> [Val] -> StateT ReflectionState IO (ValList 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]
args
          DataC Reference
_ PackedTag
t [Val]
segs -> 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 -> ValList RefNum -> Value RefNum
forall ref. ref -> Word64 -> ValList ref -> Value ref
ANF.Data RefNum
r (PackedTag -> Word64
maskTags PackedTag
t) (ValList RefNum -> Value RefNum)
-> StateT ReflectionState IO (ValList 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] -> StateT ReflectionState IO (ValList 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]
segs
          CapV K
k Int
_ [Val]
segs ->
            ValList RefNum -> Cont RefNum -> Value RefNum
forall ref. ValList ref -> Cont ref -> Value ref
ANF.Cont (ValList RefNum -> Cont RefNum -> Value RefNum)
-> StateT ReflectionState IO (ValList RefNum)
-> StateT ReflectionState IO (Cont RefNum -> Value RefNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> StateT ReflectionState IO (Value RefNum))
-> [Val] -> StateT ReflectionState IO (ValList 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]
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
          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 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 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 Foreign
f
      | Just Text
t <- Foreign -> Maybe Text
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f =
          BLit RefNum -> StateT ReflectionState IO (BLit RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> BLit RefNum
forall ref. Text -> BLit ref
ANF.Text Text
t)
      | Just Bytes
b <- Foreign -> Maybe Bytes
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f =
          BLit RefNum -> StateT ReflectionState IO (BLit RefNum)
forall a. a -> StateT ReflectionState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> BLit RefNum
forall ref. Bytes -> BLit ref
ANF.Bytes Bytes
b)
      | Just USeq
s <- Reference -> Foreign -> Maybe USeq
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.listRef Foreign
f =
          Seq (Value RefNum) -> BLit RefNum
forall ref. Seq (Value ref) -> BLit ref
ANF.List (Seq (Value RefNum) -> BLit RefNum)
-> StateT ReflectionState IO (Seq (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))
-> USeq -> StateT ReflectionState IO (Seq (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) -> Seq a -> f (Seq b)
traverse Val -> StateT ReflectionState IO (Value RefNum)
goV USeq
s
      | Just Referent
l <- Foreign -> Maybe Referent
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f =
          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
      | Just Reference
l <- Foreign -> Maybe Reference
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f =
          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
      | Just Referenced Value
v <- Foreign -> Maybe (Referenced Value)
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f =
          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
      | Just Referenced Code
g <- Foreign -> Maybe (Referenced Code)
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f =
          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
      | Just ByteArray
a <- Reference -> Foreign -> Maybe ByteArray
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.ibytearrayRef Foreign
f =
          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)
      | Just Array Val
a <- Reference -> Foreign -> Maybe (Array Val)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
Rf.iarrayRef Foreign
f =
          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
      | Just Map Val Val
m <- Foreign -> Maybe (Map Val Val)
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f =
          [(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)
      | Bool
otherwise = [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

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
  Either
  [Reference]
  (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
erc <-
    STM
  (Either
     [Reference]
     (EnumMap Word64 MCombs, Map Reference Word64,
      Map Reference Word64))
-> IO
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall a. STM a -> IO a
atomically (STM
   (Either
      [Reference]
      (EnumMap Word64 MCombs, Map Reference Word64,
       Map Reference Word64))
 -> IO
      (Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64,
          Map Reference Word64)))
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
-> IO
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall a b. (a -> b) -> a -> b
$ do
      EnumMap Word64 MCombs
combs <- TVar (EnumMap Word64 MCombs) -> STM (EnumMap Word64 MCombs)
forall a. TVar a -> STM a
readTVar (CCache 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)
      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)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   [Reference]
   (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
 -> STM
      (Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64,
          Map Reference Word64)))
-> ((EnumMap Word64 MCombs, Map Reference Word64,
     Map Reference Word64)
    -> Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64,
          Map Reference Word64))
-> (EnumMap Word64 MCombs, Map Reference Word64,
    Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> Either
     [Reference]
     (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
forall a b. b -> Either a b
Right ((EnumMap Word64 MCombs, Map Reference Word64,
  Map Reference Word64)
 -> STM
      (Either
         [Reference]
         (EnumMap Word64 MCombs, Map Reference Word64,
          Map Reference Word64)))
-> (EnumMap Word64 MCombs, Map Reference Word64,
    Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall a b. (a -> b) -> a -> b
$ (EnumMap Word64 MCombs
combs, Map Reference Word64
newTy, Map Reference Word64
rtm)
        [Reference]
l -> Either
  [Reference]
  (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> STM
     (Either
        [Reference]
        (EnumMap Word64 MCombs, Map Reference Word64,
         Map Reference Word64))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Reference]
-> Either
     [Reference]
     (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
forall a b. a -> Either a b
Left [Reference]
l)
  ((EnumMap Word64 MCombs, Map Reference Word64,
  Map Reference Word64)
 -> IO Val)
-> Either
     [Reference]
     (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> IO (Either [Reference] Val)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Either [Reference] a -> f (Either [Reference] b)
traverse (\(EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
rfs -> (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> Referenced Value -> IO Val
reifyValue1 (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
rfs Referenced Value
val) Either
  [Reference]
  (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
erc
  where
    f :: Bool -> a -> (Set a, Set a)
f Bool
False a
r = (Set a
forall a. Monoid a => a
mempty, a -> Set a
forall a. a -> Set a
S.singleton a
r)
    f Bool
True a
r = (a -> Set a
forall a. a -> Set a
S.singleton a
r, Set a
forall a. Monoid a => a
mempty)

    (Set Reference
tyLinks, Set Reference
tmLinks) = (Bool -> Reference -> (Set Reference, Set Reference))
-> Value Reference -> (Set Reference, Set Reference)
forall a ref. Monoid a => (Bool -> ref -> a) -> Value ref -> a
valueLinks Bool -> Reference -> (Set Reference, Set Reference)
forall {a}. Ord a => Bool -> a -> (Set a, Set a)
f (Referenced Value -> Value Reference
forall (t :: * -> *). Referential t => Referenced t -> t Reference
dereference Referenced Value
val)

reifyValue1 ::
  (EnumMap Word64 MCombs, M.Map Reference Word64, M.Map Reference Word64) ->
  Referenced ANF.Value ->
  IO Val
reifyValue1 :: (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> Referenced Value -> IO Val
reifyValue1 (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
tup (Plain Value Reference
v) = (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> Value Reference -> IO Val
reifyValue0 (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
tup Value Reference
v
reifyValue1 (EnumMap Word64 MCombs
combs, Map Reference Word64
rty0, Map Reference Word64
rtm0) (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
-> Value RefNum
-> IO Val
reifyValue0Canon EnumMap Word64 MCombs
combs [Reference]
tys [Reference]
tms HashMap RefNum Word64
rty HashMap RefNum Word64
rtm 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 ->
  ANF.Value RefNum ->
  IO Val
reifyValue0Canon :: EnumMap Word64 MCombs
-> [Reference]
-> [Reference]
-> HashMap RefNum Word64
-> HashMap RefNum Word64
-> Value RefNum
-> IO Val
reifyValue0Canon EnumMap Word64 MCombs
combs [Reference]
tys [Reference]
tms HashMap RefNum Word64
rty HashMap RefNum Word64
rtm = 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, MComb)
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, MComb) -> IO (CombIx, MComb)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CombIx
cix, EnumMap Word64 MCombs -> CombIx -> MComb
rCombSection EnumMap Word64 MCombs
combs CombIx
cix)

    goV :: ANF.Value RefNum -> IO Val
    goV :: Value RefNum -> IO Val
goV (ANF.Partial GroupRef RefNum
gr ValList RefNum
vs) =
      GroupRef RefNum -> IO (CombIx, MComb)
goIx GroupRef RefNum
gr IO (CombIx, MComb) -> ((CombIx, MComb) -> IO Val) -> IO Val
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (CombIx
cix, RComb (Comb GCombInfo MComb
rcomb)) -> Closure -> Val
boxedVal (Closure -> Val) -> ([Val] -> Closure) -> [Val] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CombIx -> GCombInfo MComb -> [Val] -> Closure
PApV CombIx
cix GCombInfo MComb
rcomb ([Val] -> Val) -> IO [Val] -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value RefNum -> IO Val) -> ValList 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 ValList RefNum
vs
        (CombIx
_, RComb (CachedVal Word64
_ Val
val))
          | [] <- ValList 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 ValList 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) -> ([Val] -> Closure) -> [Val] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> [Val] -> Closure
formDataReplaced Reference
rf PackedTag
t ([Val] -> Val) -> IO [Val] -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value RefNum -> IO Val) -> ValList 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 ValList RefNum
vs
    goV (ANF.Cont ValList RefNum
vs Cont RefNum
k) = do
      K
k' <- Cont RefNum -> IO K
goK Cont RefNum
k
      [Val]
vs' <- (Value RefNum -> IO Val) -> ValList 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 ValList 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 -> [Val] -> Closure
cv K
k' [Val]
vs'
      where
        cv :: K -> [Val] -> Closure
cv K
k [Val]
s = K -> Int -> [Val] -> Closure
CapV K
k Int
a [Val]
s
          where
            ksz :: Int
ksz = K -> Int
frameDataSize K
k
            a :: Int
a = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Val] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Val]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ksz
    goV (ANF.BLit BLit 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, MComb)
goIx GroupRef RefNum
gr IO (CombIx, MComb) -> ((CombIx, MComb) -> IO K) -> IO K
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (CombIx
cix, RComb (Lam Int
_ Int
fr MSection
sect)) ->
          Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push
            (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
f)
            (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a)
            CombIx
cix
            Int
fr
            MSection
sect
            (K -> K) -> IO K -> IO K
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cont RefNum -> IO K
goK Cont RefNum
k
        (CIx Reference
r Word64
_ Word64
_, MComb
_) ->
          [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) = Closure -> Val
boxedVal (Closure -> Val) -> (USeq -> Closure) -> USeq -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure) -> (USeq -> Foreign) -> USeq -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> USeq -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.listRef (USeq -> Val) -> IO USeq -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value RefNum -> IO Val) -> Seq (Value RefNum) -> IO USeq
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seq a -> f (Seq b)
traverse Value RefNum -> IO Val
goV 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) = Closure -> Val
boxedVal (Closure -> Val) -> (Array Val -> Closure) -> Array Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure)
-> (Array Val -> Foreign) -> Array Val -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Array Val -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.iarrayRef (Array Val -> Val) -> IO (Array Val) -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value RefNum -> IO Val) -> Array (Value RefNum) -> IO (Array Val)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Array a -> f (Array b)
traverse Value RefNum -> IO Val
goV Array (Value RefNum)
a
    goL (ANF.Map [(Value RefNum, Value RefNum)]
l) = Map Val Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (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

reifyValue0 ::
  (EnumMap Word64 MCombs, M.Map Reference Word64, M.Map Reference Word64) ->
  ANF.Value Reference ->
  IO Val
reifyValue0 :: (EnumMap Word64 MCombs, Map Reference Word64, Map Reference Word64)
-> Value Reference -> IO Val
reifyValue0 (EnumMap Word64 MCombs
combs, Map Reference Word64
rty, Map Reference Word64
rtm) = 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, MComb)
goIx (ANF.GR Reference
r0 Word64
i) =
      Reference -> IO Word64
refTm Reference
r IO Word64 -> (Word64 -> (CombIx, MComb)) -> IO (CombIx, MComb)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Word64
n ->
        let cix :: CombIx
cix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
r Word64
n Word64
i)
         in (CombIx
cix, EnumMap Word64 MCombs -> CombIx -> MComb
rCombSection EnumMap Word64 MCombs
combs CombIx
cix)
      where
        r :: Reference
r = Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Reference
r0 Reference
r0 Map Reference Reference
functionReplacements

    goV :: ANF.Value Reference -> IO Val
    goV :: Value Reference -> IO Val
goV (ANF.Partial GroupRef Reference
gr ValList Reference
vs) =
      GroupRef Reference -> IO (CombIx, MComb)
goIx GroupRef Reference
gr IO (CombIx, MComb) -> ((CombIx, MComb) -> IO Val) -> IO Val
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (CombIx
cix, RComb (Comb GCombInfo MComb
rcomb)) -> Closure -> Val
boxedVal (Closure -> Val) -> ([Val] -> Closure) -> [Val] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CombIx -> GCombInfo MComb -> [Val] -> Closure
PApV CombIx
cix GCombInfo MComb
rcomb ([Val] -> Val) -> IO [Val] -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value Reference -> IO Val) -> ValList 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 ValList Reference
vs
        (CombIx
_, RComb (CachedVal Word64
_ Val
val))
          | [] <- ValList 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 ValList 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) -> ([Val] -> Closure) -> [Val] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> [Val] -> Closure
formDataReplaced Reference
r PackedTag
t ([Val] -> Val) -> IO [Val] -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value Reference -> IO Val) -> ValList 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 ValList Reference
vs
    goV (ANF.Cont ValList Reference
vs Cont Reference
k) = do
      K
k' <- Cont Reference -> IO K
goK Cont Reference
k
      [Val]
vs' <- (Value Reference -> IO Val) -> ValList 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 ValList 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 -> [Val] -> Closure
cv K
k' [Val]
vs'
      where
        cv :: K -> [Val] -> Closure
cv K
k [Val]
s = K -> Int -> [Val] -> Closure
CapV K
k Int
a [Val]
s
          where
            ksz :: Int
ksz = K -> Int
frameDataSize K
k
            a :: Int
a = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Val] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Val]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ksz
    goV (ANF.BLit BLit 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, MComb)
goIx GroupRef Reference
gr IO (CombIx, MComb) -> ((CombIx, MComb) -> IO K) -> IO K
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (CombIx
cix, RComb (Lam Int
_ Int
fr MSection
sect)) ->
          Int -> Int -> CombIx -> Int -> MSection -> K -> K
Push
            (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
f)
            (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a)
            CombIx
cix
            Int
fr
            MSection
sect
            (K -> K) -> IO K -> IO K
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cont Reference -> IO K
goK Cont Reference
k
        (CIx Reference
r Word64
_ Word64
_, MComb
_) ->
          [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) -> (USeq -> Closure) -> USeq -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure) -> (USeq -> Foreign) -> USeq -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> USeq -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Rf.listRef (USeq -> Val) -> IO USeq -> IO Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value Reference -> IO Val) -> Seq (Value Reference) -> IO USeq
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seq a -> f (Seq b)
traverse Value Reference -> IO Val
goV 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
<$> (Value Reference -> IO Val)
-> Array (Value Reference) -> IO (Array Val)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Array a -> f (Array b)
traverse Value Reference -> IO Val
goV Array (Value Reference)
a
    goL (ANF.Map [(Value Reference, Value Reference)]
l) = Map Val Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (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

#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