{-# LANGUAGE CPP #-}

-- The code synonyms (MCombs, MSection, ...) are defined in Stack.hs and
-- re-exported here, so that the JIT modules can use them without
-- importing this module, which carries the JIT handle in the code cache.
module Unison.Runtime.Machine.Types
  ( module Unison.Runtime.Machine.Types,
    MCombs,
    MSection,
    MBranch,
    MInstr,
    MComb,
    MRef,
  )
where

import Control.Concurrent (ThreadId)
import Control.Concurrent.STM as STM
import Control.Exception hiding (Handler)
#if !defined(mingw32_HOST_OS)
import Data.IORef
  (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef)
#else
import Data.IORef
  (IORef, newIORef, readIORef, writeIORef)
#endif
import Data.Kind (Type)
import Data.Map.Strict qualified as M
import Data.Set qualified as S
import Data.Word
import Foreign.Ptr (nullPtr)
#if !defined(mingw32_HOST_OS)
import GHC.Event (getSystemTimerManager, registerTimeout)
#else
import System.CPUTime
#endif
import Control.Monad.State.Strict
import Unison.Prelude
import Unison.Reference (Reference, isBuiltin)
import Unison.Referent (Referent, pattern Ref)
import Unison.Runtime.ANF
  ( Cacheability (..),
    Code (..),
    SuperGroup (..),
    Value,
    foldGroupLinks,
    valueLinks,
  )
import Unison.Runtime.ANF qualified as ANF
import Unison.Runtime.ANF.Optimize (OptInfos)
import Unison.Runtime.Builtin
import Unison.Runtime.Builtin.Decls (ioFailureRef)
import Unison.Runtime.Exception qualified as Exception
import Unison.Runtime.InternalError (CompileExn (CE), internalBug)
import Unison.Runtime.JIT (JIT, initialNativeCount)
import Unison.Runtime.MCode
import Unison.Runtime.Profiling
import Unison.Runtime.Referenced
import Unison.Runtime.Stack
import Unison.Runtime.TypeNumbers qualified as TN
import Unison.Symbol
import Unison.Util.BiMap (BiMap)
import Unison.Util.BiMap qualified as BM
import Unison.Util.EnumContainers as EC
import Unison.Util.Text as UText

-- | A ref storing every currently active thread.
-- This is helpful for cleaning up orphaned threads when the main process
-- completes.
--
-- We track threads when running in a host process like UCM,
-- otherwise, in one-off environments 'Nothing' is used and we don't bother tracking forked threads since they'll be
-- cleaned up automatically on process termination.
type ActiveThreads = Maybe (IORef (Set ThreadId))

type Tag = Word64

type Combs = GCombs Void CombIx

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

refLookup :: String -> M.Map Reference Word64 -> Reference -> Word64
refLookup :: [Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
s Map Reference Word64
m Reference
r
  | Just Word64
w <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference Word64
m = Word64
w
  | Bool
otherwise =
      [Char] -> Word64
forall a. HasCallStack => [Char] -> a
error ([Char] -> Word64) -> [Char] -> Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"refLookup:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": unknown reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

recordRefLookup :: BM.BiMap ANF.RecordSchema ANF.RecordRef -> ANF.RecordSchema -> ANF.RecordRef
recordRefLookup :: BiMap RecordSchema RecordRef -> RecordSchema -> RecordRef
recordRefLookup BiMap RecordSchema RecordRef
m RecordSchema
r
  | Just RecordRef
rr <- RecordSchema -> BiMap RecordSchema RecordRef -> Maybe RecordRef
forall k v. Ord k => k -> BiMap k v -> Maybe v
BM.lookupL RecordSchema
r BiMap RecordSchema RecordRef
m = RecordRef
rr
  | Bool
otherwise =
      [Word] -> [Char] -> RecordRef
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> RecordRef) -> [Char] -> RecordRef
forall a b. (a -> b) -> a -> b
$ [Char]
"recordRefLookup: unknown record schema: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RecordSchema -> [Char]
forall a. Show a => a -> [Char]
show RecordSchema
r

-- A class parameterizing profiling. The interpreter loop can be
-- specialized to a class, which allows the same code to be used for both
-- normal and profiling execution without sacrificing performance. If
-- desired, other aspects of the runtime could be configured this way.
class RuntimeProfiler prof where
  data Ticker prof :: Type

  -- starts a ticker for a profiler
  startTicker :: prof -> IO (Ticker prof, IO ())
  checkTicker :: Ticker prof -> CombIx -> K -> IO ()

instance RuntimeProfiler () where
  data Ticker () = NilTick
  startTicker :: () -> IO (Ticker (), IO ())
startTicker () = (Ticker (), IO ()) -> IO (Ticker (), IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ticker ()
NilTick, () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  checkTicker :: Ticker () -> CombIx -> K -> IO ()
checkTicker Ticker ()
_ CombIx
_ K
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  {-# INLINE checkTicker #-}

type Tick = CombIx -> K -> IO ()
#if !defined(mingw32_HOST_OS)
-- GHC.Event, time-baed profiler
instance RuntimeProfiler ProfileComm where
  newtype Ticker ProfileComm = ProfTicker (IORef (Maybe Tick))

  startTicker :: ProfileComm -> IO (Ticker ProfileComm, IO ())
startTicker (PC Bool -> CombIx -> K -> IO ()
pf IO ()
_ IO (Profile Word64)
_) = do
    IORef (Maybe (CombIx -> K -> IO ()))
ticker <- Maybe (CombIx -> K -> IO ())
-> IO (IORef (Maybe (CombIx -> K -> IO ())))
forall a. a -> IO (IORef a)
newIORef Maybe (CombIx -> K -> IO ())
forall a. Maybe a
Nothing
    IORef Bool
cancel <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    TimerManager
tm <- IO TimerManager
getSystemTimerManager
    IO TimeoutKey -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO TimeoutKey -> IO ())
-> (IO () -> IO TimeoutKey) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
tm Int
100 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Int
-> (Bool -> CombIx -> K -> IO ())
-> IORef (Maybe (CombIx -> K -> IO ()))
-> IORef Bool
-> IO ()
tickCallback Int
100 Bool -> CombIx -> K -> IO ()
pf IORef (Maybe (CombIx -> K -> IO ()))
ticker IORef Bool
cancel
    pure (IORef (Maybe (CombIx -> K -> IO ())) -> Ticker ProfileComm
ProfTicker IORef (Maybe (CombIx -> K -> IO ()))
ticker, IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
cancel Bool
True)

  checkTicker :: Ticker ProfileComm -> CombIx -> K -> IO ()
checkTicker (ProfTicker IORef (Maybe (CombIx -> K -> IO ()))
ticker) CombIx
cix K
k =
    IORef (Maybe (CombIx -> K -> IO ()))
-> (Maybe (CombIx -> K -> IO ())
    -> (Maybe (CombIx -> K -> IO ()), Maybe (CombIx -> K -> IO ())))
-> IO (Maybe (CombIx -> K -> IO ()))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe (CombIx -> K -> IO ()))
ticker (Maybe (CombIx -> K -> IO ())
forall a. Maybe a
Nothing,) IO (Maybe (CombIx -> K -> IO ()))
-> (Maybe (CombIx -> K -> IO ()) -> 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
      Maybe (CombIx -> K -> IO ())
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just CombIx -> K -> IO ()
pf -> CombIx -> K -> IO ()
pf CombIx
cix K
k
  {-# INLINE checkTicker #-}

-- Callback for producing ticks via event manager timeouts. These happen
-- promptly, but probably should have short callbacks, since they're
-- running in the scheduler. here, we just write a tick to the MVar that
-- is checked periodically by runtime threads, then set a new timeout
-- unless we've been cancelled.
--
-- The callback doesn't block trying to write to the MVar, so if something
-- is already there, a second tick just won't happen.
tickCallback ::
  Int ->
  (Bool -> Tick) ->
  IORef (Maybe Tick) ->
  IORef Bool ->
  IO ()
tickCallback :: Int
-> (Bool -> CombIx -> K -> IO ())
-> IORef (Maybe (CombIx -> K -> IO ()))
-> IORef Bool
-> IO ()
tickCallback Int
interval Bool -> CombIx -> K -> IO ()
ptick IORef (Maybe (CombIx -> K -> IO ()))
ticker IORef Bool
cancel = IO ()
body
  where
    body :: IO ()
body = do
      Bool
_full <- IORef (Maybe (CombIx -> K -> IO ()))
-> (Maybe (CombIx -> K -> IO ())
    -> (Maybe (CombIx -> K -> IO ()), Bool))
-> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe (CombIx -> K -> IO ()))
ticker \(Maybe (CombIx -> K -> IO ()) -> Bool
forall a. Maybe a -> Bool
isJust -> Bool
b) ->
        ((CombIx -> K -> IO ()) -> Maybe (CombIx -> K -> IO ())
forall a. a -> Maybe a
Just ((CombIx -> K -> IO ()) -> Maybe (CombIx -> K -> IO ()))
-> (CombIx -> K -> IO ()) -> Maybe (CombIx -> K -> IO ())
forall a b. (a -> b) -> a -> b
$ Bool -> CombIx -> K -> IO ()
ptick Bool
b, Bool
b)
      Bool
b <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
cancel
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b) do
        TimerManager
tm <- IO TimerManager
getSystemTimerManager
        () () -> IO TimeoutKey -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
tm Int
interval IO ()
body

#else

-- CPUTime based profiler for Windows
instance RuntimeProfiler ProfileComm where
  data Ticker ProfileComm = TPC !Tick !(IORef Word8)
  startTicker (PC pf _ _) = (, pure ()) . TPC (pf False)  <$> newIORef 1

  checkTicker (TPC tick r) cix k = do
    n <- readIORef r
    when (n `mod` 128 == 0) do
      n <- getCPUTime
      when (n `mod` 100000 == 0) $ tick cix k
    writeIORef r (n+1)

#endif

-- code caching environment
data CCache prof = CCache
  { forall prof. CCache prof -> Bool
sandboxed :: Bool,
    forall prof. CCache prof -> Bool -> Val -> Tracer
tracer :: Bool -> Val -> Tracer,
    forall prof. CCache prof -> prof
profiler :: !prof,
    -- Combinators in their original form, where they're easier to serialize into SCache
    forall prof. CCache prof -> TVar (EnumMap Word64 Combs)
srcCombs :: TVar (EnumMap Word64 Combs),
    forall prof. CCache prof -> TVar (EnumMap Word64 MCombs)
combs :: TVar (EnumMap Word64 MCombs),
    forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
combRefs :: TVar (EnumMap Word64 Reference),
    -- the number of the unoptimized copy of each group the explosion
    -- rewrote (MCode.emitCombs): what a continuation from another process
    -- resumes (reifyValue), never compiled, so not in combRefs
    forall prof. CCache prof -> TVar (EnumMap Word64 Word64)
baseNums :: TVar (EnumMap Word64 Word64),
    -- Combs which we're allowed to cache after evaluating
    forall prof. CCache prof -> TVar (EnumSet Word64)
cacheableCombs :: TVar (EnumSet Word64),
    forall prof. CCache prof -> TVar (OptInfos Reference Symbol)
optInfos :: TVar (OptInfos Reference Symbol),
    -- types are numbered by the process, not the cache
    -- (Unison.Runtime.TypeNumbers)
    forall prof. CCache prof -> TVar Word64
freshTm :: TVar Word64,
    forall prof. CCache prof -> TVar Word64
freshRecSchema :: TVar Word64,
    forall prof.
CCache prof -> TVar (Map Reference (SuperGroup Reference Symbol))
intermed :: TVar (M.Map Reference (SuperGroup Reference Symbol)),
    forall prof. CCache prof -> TVar (Map Reference Word64)
refTm :: TVar (M.Map Reference Word64),
    forall prof. CCache prof -> TVar (BiMap RecordSchema RecordRef)
recordRefs :: TVar (BiMap ANF.RecordSchema ANF.RecordRef),
    forall prof. CCache prof -> TVar (Map Reference (Set Reference))
sandbox :: TVar (M.Map Reference (Set Reference)),
    forall prof. CCache prof -> TVar RecordFieldMappings
recordFieldMappings :: TVar RecordFieldMappings,
    -- native code cells for combinators loaded through this cache (see unison-runtime/src/Unison/Runtime/JIT/design.md)
    forall prof. CCache prof -> TVar NativeCellPool
nativeCells :: TVar NativeCellPool,
    -- the JIT, one for the whole process and shared by every cache in it
    -- (see JIT.hs); this is how the interpreter reaches it. Not unpacked,
    -- so that handing it on doesn't rebuild it.
    forall prof. CCache prof -> JIT
jit :: {-# NOUNPACK #-} !JIT
  }

refNumsTm :: CCache prof -> IO (M.Map Reference Word64)
refNumsTm :: forall prof. CCache prof -> IO (Map Reference Word64)
refNumsTm CCache prof
cc = TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache prof -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache prof
cc)

-- | The process-wide type numbering (Unison.Runtime.TypeNumbers).
refNumsTy :: CCache prof -> IO (M.Map Reference Word64)
refNumsTy :: forall prof. CCache prof -> IO (Map Reference Word64)
refNumsTy CCache prof
_ = IO (Map Reference Word64)
TN.typeNumberMap

refNumTm :: CCache prof -> Reference -> IO Word64
refNumTm :: forall prof. CCache prof -> Reference -> IO Word64
refNumTm CCache prof
cc Reference
r =
  CCache prof -> IO (Map Reference Word64)
forall prof. CCache prof -> IO (Map Reference Word64)
refNumsTm CCache prof
cc IO (Map Reference Word64)
-> (Map Reference Word64 -> IO Word64) -> IO Word64
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r -> Just Word64
w) -> Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
    Map Reference Word64
_ -> [Word] -> [Char] -> IO Word64
forall a. HasCallStack => [Word] -> [Char] -> IO a
Exception.die [] ([Char] -> IO Word64) -> [Char] -> IO Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"refNumTm: unknown reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r

-- | How many native code cells a fresh cache starts with. Each is 16 bytes.
initialNativeCells :: Int
initialNativeCells :: Int
initialNativeCells = Int
16384

baseCCache :: JIT -> Bool -> IO (CCache ())
baseCCache :: JIT -> Bool -> IO (CCache ())
baseCCache JIT
jit Bool
sandboxed = do
  -- The builtin combinators get native code cells like any loaded code, so
  -- that the JIT can compile the ones that are worth it and native code
  -- can call them (docs/jit/m6.md, step 4).
  let uncelled :: EnumMap Word64 Combs
uncelled =
        EnumMap Word64 Combs
srcCombs
          EnumMap Word64 Combs
-> (EnumMap Word64 Combs -> EnumMap Word64 Combs)
-> EnumMap Word64 Combs
forall a b. a -> (a -> b) -> b
& Bool
-> Set ForeignFunc -> EnumMap Word64 Combs -> EnumMap Word64 Combs
sanitizeCombsOfForeignFuncs Bool
sandboxed Set ForeignFunc
sandboxedForeignFuncs
      (Int
cellCount, EnumMap Word64 Combs
_) = Ptr NativeCell
-> EnumMap Word64 Combs -> (Int, EnumMap Word64 Combs)
forall val comb.
Ptr NativeCell
-> EnumMap Word64 (GCombs val comb)
-> (Int, EnumMap Word64 (GCombs val comb))
attachNativeCells Ptr NativeCell
forall a. Ptr a
nullPtr EnumMap Word64 Combs
uncelled
  NativeCellPool Ptr NativeCell
cells Int
_ Int
_ <- Int -> Int -> IO NativeCellPool
newNativeCellPool (JIT -> Int
initialNativeCount JIT
jit) Int
cellCount
  let combs :: EnumMap Word64 MCombs
      combs :: EnumMap Word64 MCombs
combs =
        (Int, EnumMap Word64 Combs) -> EnumMap Word64 Combs
forall a b. (a, b) -> b
snd (Ptr NativeCell
-> EnumMap Word64 Combs -> (Int, EnumMap Word64 Combs)
forall val comb.
Ptr NativeCell
-> EnumMap Word64 (GCombs val comb)
-> (Int, EnumMap Word64 (GCombs val comb))
attachNativeCells Ptr NativeCell
cells EnumMap Word64 Combs
uncelled)
          EnumMap Word64 Combs
-> (EnumMap Word64 Combs -> EnumMap Word64 (GCombs Val CombIx))
-> EnumMap Word64 (GCombs Val CombIx)
forall a b. a -> (a -> b) -> b
& EnumMap Word64 Combs -> EnumMap Word64 (GCombs Val CombIx)
forall cix any.
EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
absurdCombs
          EnumMap Word64 (GCombs Val CombIx)
-> (EnumMap Word64 (GCombs Val CombIx) -> EnumMap Word64 MCombs)
-> EnumMap Word64 MCombs
forall a b. a -> (a -> b) -> b
& 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 Maybe (EnumMap Word64 MCombs)
forall a. Maybe a
Nothing
  Bool
-> (Bool -> Val -> Tracer)
-> ()
-> TVar (EnumMap Word64 Combs)
-> TVar (EnumMap Word64 MCombs)
-> TVar (EnumMap Word64 Reference)
-> TVar (EnumMap Word64 Word64)
-> TVar (EnumSet Word64)
-> TVar (OptInfos Reference Symbol)
-> TVar Word64
-> TVar Word64
-> TVar (Map Reference (SuperGroup Reference Symbol))
-> TVar (Map Reference Word64)
-> TVar (BiMap RecordSchema RecordRef)
-> TVar (Map Reference (Set Reference))
-> TVar RecordFieldMappings
-> TVar NativeCellPool
-> JIT
-> CCache ()
forall prof.
Bool
-> (Bool -> Val -> Tracer)
-> prof
-> TVar (EnumMap Word64 Combs)
-> TVar (EnumMap Word64 MCombs)
-> TVar (EnumMap Word64 Reference)
-> TVar (EnumMap Word64 Word64)
-> TVar (EnumSet Word64)
-> TVar (OptInfos Reference Symbol)
-> TVar Word64
-> TVar Word64
-> TVar (Map Reference (SuperGroup Reference Symbol))
-> TVar (Map Reference Word64)
-> TVar (BiMap RecordSchema RecordRef)
-> TVar (Map Reference (Set Reference))
-> TVar RecordFieldMappings
-> TVar NativeCellPool
-> JIT
-> CCache prof
CCache Bool
sandboxed Bool -> Val -> Tracer
forall {p} {p}. p -> p -> Tracer
noTrace ()
    (TVar (EnumMap Word64 Combs)
 -> TVar (EnumMap Word64 MCombs)
 -> TVar (EnumMap Word64 Reference)
 -> TVar (EnumMap Word64 Word64)
 -> TVar (EnumSet Word64)
 -> TVar (OptInfos Reference Symbol)
 -> TVar Word64
 -> TVar Word64
 -> TVar (Map Reference (SuperGroup Reference Symbol))
 -> TVar (Map Reference Word64)
 -> TVar (BiMap RecordSchema RecordRef)
 -> TVar (Map Reference (Set Reference))
 -> TVar RecordFieldMappings
 -> TVar NativeCellPool
 -> JIT
 -> CCache ())
-> IO (TVar (EnumMap Word64 Combs))
-> IO
     (TVar (EnumMap Word64 MCombs)
      -> TVar (EnumMap Word64 Reference)
      -> TVar (EnumMap Word64 Word64)
      -> TVar (EnumSet Word64)
      -> TVar (OptInfos Reference Symbol)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (BiMap RecordSchema RecordRef)
      -> TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumMap Word64 Combs -> IO (TVar (EnumMap Word64 Combs))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 Combs
srcCombs
    IO
  (TVar (EnumMap Word64 MCombs)
   -> TVar (EnumMap Word64 Reference)
   -> TVar (EnumMap Word64 Word64)
   -> TVar (EnumSet Word64)
   -> TVar (OptInfos Reference Symbol)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (BiMap RecordSchema RecordRef)
   -> TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar (EnumMap Word64 MCombs))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar (EnumMap Word64 Word64)
      -> TVar (EnumSet Word64)
      -> TVar (OptInfos Reference Symbol)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (BiMap RecordSchema RecordRef)
      -> TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumMap Word64 MCombs -> IO (TVar (EnumMap Word64 MCombs))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 MCombs
combs
    IO
  (TVar (EnumMap Word64 Reference)
   -> TVar (EnumMap Word64 Word64)
   -> TVar (EnumSet Word64)
   -> TVar (OptInfos Reference Symbol)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (BiMap RecordSchema RecordRef)
   -> TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar (EnumMap Word64 Reference))
-> IO
     (TVar (EnumMap Word64 Word64)
      -> TVar (EnumSet Word64)
      -> TVar (OptInfos Reference Symbol)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (BiMap RecordSchema RecordRef)
      -> TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumMap Word64 Reference -> IO (TVar (EnumMap Word64 Reference))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 Reference
builtinTermBackref
    IO
  (TVar (EnumMap Word64 Word64)
   -> TVar (EnumSet Word64)
   -> TVar (OptInfos Reference Symbol)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (BiMap RecordSchema RecordRef)
   -> TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar (EnumMap Word64 Word64))
-> IO
     (TVar (EnumSet Word64)
      -> TVar (OptInfos Reference Symbol)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (BiMap RecordSchema RecordRef)
      -> TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumMap Word64 Word64 -> IO (TVar (EnumMap Word64 Word64))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 Word64
forall a. Monoid a => a
mempty
    IO
  (TVar (EnumSet Word64)
   -> TVar (OptInfos Reference Symbol)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (BiMap RecordSchema RecordRef)
   -> TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar (EnumSet Word64))
-> IO
     (TVar (OptInfos Reference Symbol)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (BiMap RecordSchema RecordRef)
      -> TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumSet Word64 -> IO (TVar (EnumSet Word64))
forall a. a -> IO (TVar a)
newTVarIO EnumSet Word64
cacheableCombs
    IO
  (TVar (OptInfos Reference Symbol)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (BiMap RecordSchema RecordRef)
   -> TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar (OptInfos Reference Symbol))
-> IO
     (TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (BiMap RecordSchema RecordRef)
      -> TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OptInfos Reference Symbol -> IO (TVar (OptInfos Reference Symbol))
forall a. a -> IO (TVar a)
newTVarIO OptInfos Reference Symbol
builtinOptInfo
    IO
  (TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (BiMap RecordSchema RecordRef)
   -> TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar Word64)
-> IO
     (TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (BiMap RecordSchema RecordRef)
      -> TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word64 -> IO (TVar Word64)
forall a. a -> IO (TVar a)
newTVarIO Word64
ftm
    IO
  (TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (BiMap RecordSchema RecordRef)
   -> TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar Word64)
-> IO
     (TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (BiMap RecordSchema RecordRef)
      -> TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word64 -> IO (TVar Word64)
forall a. a -> IO (TVar a)
newTVarIO Word64
frs
    IO
  (TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (BiMap RecordSchema RecordRef)
   -> TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar (Map Reference (SuperGroup Reference Symbol)))
-> IO
     (TVar (Map Reference Word64)
      -> TVar (BiMap RecordSchema RecordRef)
      -> TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference (SuperGroup Reference Symbol)
-> IO (TVar (Map Reference (SuperGroup Reference Symbol)))
forall a. a -> IO (TVar a)
newTVarIO Map Reference (SuperGroup Reference Symbol)
forall a. Monoid a => a
mempty
    IO
  (TVar (Map Reference Word64)
   -> TVar (BiMap RecordSchema RecordRef)
   -> TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar (Map Reference Word64))
-> IO
     (TVar (BiMap RecordSchema RecordRef)
      -> TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference Word64 -> IO (TVar (Map Reference Word64))
forall a. a -> IO (TVar a)
newTVarIO Map Reference Word64
builtinTermNumbering
    IO
  (TVar (BiMap RecordSchema RecordRef)
   -> TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar (BiMap RecordSchema RecordRef))
-> IO
     (TVar (Map Reference (Set Reference))
      -> TVar RecordFieldMappings
      -> TVar NativeCellPool
      -> JIT
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BiMap RecordSchema RecordRef
-> IO (TVar (BiMap RecordSchema RecordRef))
forall a. a -> IO (TVar a)
newTVarIO BiMap RecordSchema RecordRef
builtinFieldNumbering
    IO
  (TVar (Map Reference (Set Reference))
   -> TVar RecordFieldMappings
   -> TVar NativeCellPool
   -> JIT
   -> CCache ())
-> IO (TVar (Map Reference (Set Reference)))
-> IO
     (TVar RecordFieldMappings
      -> TVar NativeCellPool -> JIT -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference (Set Reference)
-> IO (TVar (Map Reference (Set Reference)))
forall a. a -> IO (TVar a)
newTVarIO Map Reference (Set Reference)
baseSandboxInfo
    IO
  (TVar RecordFieldMappings
   -> TVar NativeCellPool -> JIT -> CCache ())
-> IO (TVar RecordFieldMappings)
-> IO (TVar NativeCellPool -> JIT -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RecordFieldMappings -> IO (TVar RecordFieldMappings)
forall a. a -> IO (TVar a)
newTVarIO RecordFieldMappings
rfm
    IO (TVar NativeCellPool -> JIT -> CCache ())
-> IO (TVar NativeCellPool) -> IO (JIT -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (NativeCellPool -> IO (TVar NativeCellPool)
forall a. a -> IO (TVar a)
newTVarIO (NativeCellPool -> IO (TVar NativeCellPool))
-> IO NativeCellPool -> IO (TVar NativeCellPool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Int -> IO NativeCellPool
newNativeCellPool (JIT -> Int
initialNativeCount JIT
jit) Int
initialNativeCells)
    IO (JIT -> CCache ()) -> IO JIT -> IO (CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JIT -> IO JIT
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JIT
jit
  where
    builtinFieldNumbering :: BiMap RecordSchema RecordRef
builtinFieldNumbering = BiMap RecordSchema RecordRef
forall a. Monoid a => a
mempty
    cacheableCombs :: EnumSet Word64
cacheableCombs = EnumSet Word64
forall a. Monoid a => a
mempty
    noTrace :: p -> p -> Tracer
noTrace p
_ p
_ = Tracer
NoTrace
    ftm :: Word64
ftm = Word64
1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Map Reference Word64 -> Word64
forall a. Ord a => Map Reference a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum Map Reference Word64
builtinTermNumbering
    -- No builtin record schemas yet
    frs :: Word64
frs = Word64
1

    rns :: RefNums
rns = RefNums
emptyRNs {dnum = refLookup "ty" builtinTypeNumbering}

    srcCombs :: EnumMap Word64 Combs
    rfm :: RecordFieldMappings
    (EnumMap Word64 Combs
srcCombs, RecordFieldMappings
rfm) =
      (State RecordFieldMappings (EnumMap Word64 Combs)
 -> RecordFieldMappings
 -> (EnumMap Word64 Combs, RecordFieldMappings))
-> RecordFieldMappings
-> State RecordFieldMappings (EnumMap Word64 Combs)
-> (EnumMap Word64 Combs, RecordFieldMappings)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State RecordFieldMappings (EnumMap Word64 Combs)
-> RecordFieldMappings
-> (EnumMap Word64 Combs, RecordFieldMappings)
forall s a. State s a -> s -> (a, s)
runState RecordFieldMappings
emptyRecordFieldMappings (State RecordFieldMappings (EnumMap Word64 Combs)
 -> (EnumMap Word64 Combs, RecordFieldMappings))
-> State RecordFieldMappings (EnumMap Word64 Combs)
-> (EnumMap Word64 Combs, RecordFieldMappings)
forall a b. (a -> b) -> a -> b
$
        ( EnumMap Word64 (SuperNormal Reference Symbol)
numberedTermLookup
            EnumMap Word64 (SuperNormal Reference Symbol)
-> (EnumMap Word64 (SuperNormal Reference Symbol)
    -> State RecordFieldMappings (EnumMap Word64 Combs))
-> State RecordFieldMappings (EnumMap Word64 Combs)
forall a b. a -> (a -> b) -> b
& (Word64
 -> SuperNormal Reference Symbol
 -> StateT RecordFieldMappings Identity Combs)
-> EnumMap Word64 (SuperNormal Reference Symbol)
-> State RecordFieldMappings (EnumMap Word64 Combs)
forall (f :: * -> *) k a b.
(Applicative f, EnumKey k) =>
(k -> a -> f b) -> EnumMap k a -> f (EnumMap k b)
traverseWithKey
              ( \Word64
k SuperNormal Reference Symbol
v -> do
                  let r :: Reference
r = EnumMap Word64 Reference
builtinTermBackref EnumMap Word64 Reference -> Word64 -> Reference
forall k a. EnumKey k => EnumMap k a -> k -> a
! Word64
k
                  (Combs, EnumMap Word64 (Chain Symbol)) -> Combs
forall a b. (a, b) -> a
fst ((Combs, EnumMap Word64 (Chain Symbol)) -> Combs)
-> StateT
     RecordFieldMappings Identity (Combs, EnumMap Word64 (Chain Symbol))
-> StateT RecordFieldMappings Identity Combs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> State RecordFieldMappings (Combs, EnumMap Word64 (Chain v))
emitComb @Symbol RefNums
rns Reference
r Word64
k RCtx Symbol
forall v. RCtx v
emptyRCtx (Word64
0, SuperNormal Reference Symbol
v)
              )
        )

lookupCode :: CCache prof -> Referent -> IO (Maybe (Referenced Code))
lookupCode :: forall prof.
CCache prof -> Referent -> IO (Maybe (Referenced Code))
lookupCode CCache prof
env (Ref Reference
link) =
  Reference
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference Word64
-> EnumSet Word64
-> Maybe (Code Reference)
resolveCode Reference
link
    (Map Reference (SuperGroup Reference Symbol)
 -> Map Reference Word64
 -> EnumSet Word64
 -> Maybe (Code Reference))
-> IO (Map Reference (SuperGroup Reference Symbol))
-> IO
     (Map Reference Word64 -> EnumSet Word64 -> Maybe (Code Reference))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map Reference (SuperGroup Reference Symbol))
-> IO (Map Reference (SuperGroup Reference Symbol))
forall a. TVar a -> IO a
readTVarIO (CCache prof -> TVar (Map Reference (SuperGroup Reference Symbol))
forall prof.
CCache prof -> TVar (Map Reference (SuperGroup Reference Symbol))
intermed CCache prof
env)
    IO
  (Map Reference Word64 -> EnumSet Word64 -> Maybe (Code Reference))
-> IO (Map Reference Word64)
-> IO (EnumSet Word64 -> Maybe (Code Reference))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache prof -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache prof
env)
    IO (EnumSet Word64 -> Maybe (Code Reference))
-> IO (EnumSet Word64) -> IO (Maybe (Code Reference))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (EnumSet Word64) -> IO (EnumSet Word64)
forall a. TVar a -> IO a
readTVarIO (CCache prof -> TVar (EnumSet Word64)
forall prof. CCache prof -> TVar (EnumSet Word64)
cacheableCombs CCache prof
env)
    IO (Maybe (Code Reference))
-> (Maybe (Code Reference) -> IO (Maybe (Referenced Code)))
-> IO (Maybe (Referenced Code))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Code Reference -> IO (Referenced Code))
-> Maybe (Code Reference) -> IO (Maybe (Referenced Code))
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) -> Maybe a -> f (Maybe b)
traverse Code Reference -> IO (Referenced Code)
canonicalizeCodeRefs
lookupCode CCache prof
_ Referent
_ = [Word] -> [Char] -> IO (Maybe (Referenced Code))
forall a. HasCallStack => [Word] -> [Char] -> IO a
Exception.die [] [Char]
"lookupCode: Expected Ref"

-- Traverses a `Code`, calculating the used references within, and
-- canonicalizing them in memory.
canonicalizeCodeRefs ::
  Code Reference -> IO (Referenced Code)
canonicalizeCodeRefs :: Code Reference -> IO (Referenced Code)
canonicalizeCodeRefs = Canonize (Code RefNum) -> IO (Referenced Code)
forall (t :: * -> *). Canonize (t RefNum) -> IO (Referenced t)
toReferenced (Canonize (Code RefNum) -> IO (Referenced Code))
-> (Code Reference -> Canonize (Code RefNum))
-> Code Reference
-> IO (Referenced Code)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code Reference -> Canonize (Code RefNum)
forall (t :: * -> *).
Referential t =>
t Reference -> Canonize (t RefNum)
canonicalizeRefs

resolveCode ::
  Reference ->
  Map Reference (SuperGroup Reference Symbol) ->
  Map Reference Word64 ->
  EnumSet Word64 ->
  Maybe (Code Reference)
resolveCode :: Reference
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference Word64
-> EnumSet Word64
-> Maybe (Code Reference)
resolveCode Reference
link Map Reference (SuperGroup Reference Symbol)
m Map Reference Word64
rfn EnumSet Word64
cach
  | Just SuperGroup Reference Symbol
sg <- Reference
-> Map Reference (SuperGroup Reference Symbol)
-> Maybe (SuperGroup Reference Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
link Map Reference (SuperGroup Reference Symbol)
m,
    Cacheability
ch <- Map Reference Word64 -> EnumSet Word64 -> Reference -> Cacheability
cacheability Map Reference Word64
rfn EnumSet Word64
cach Reference
link =
      Code Reference -> Maybe (Code Reference)
forall a. a -> Maybe a
Just (Code Reference -> Maybe (Code Reference))
-> Code Reference -> Maybe (Code Reference)
forall a b. (a -> b) -> a -> b
$ SuperGroup Reference Symbol -> Cacheability -> Code Reference
forall ref. SuperGroup ref Symbol -> Cacheability -> Code ref
CodeRep SuperGroup Reference Symbol
sg Cacheability
ch
  | Just Word64
w <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
link Map Reference Word64
builtinTermNumbering,
    Just SuperNormal Reference Symbol
sn <- Word64
-> EnumMap Word64 (SuperNormal Reference Symbol)
-> Maybe (SuperNormal Reference Symbol)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w EnumMap Word64 (SuperNormal Reference Symbol)
numberedTermLookup =
      Code Reference -> Maybe (Code Reference)
forall a. a -> Maybe a
Just (Code Reference -> Maybe (Code Reference))
-> Code Reference -> Maybe (Code Reference)
forall a b. (a -> b) -> a -> b
$ SuperGroup Reference Symbol -> Cacheability -> Code Reference
forall ref. SuperGroup ref Symbol -> Cacheability -> Code ref
CodeRep ([(Symbol, SuperNormal Reference Symbol)]
-> SuperNormal Reference Symbol -> SuperGroup Reference Symbol
forall ref v.
[(v, SuperNormal ref v)] -> SuperNormal ref v -> SuperGroup ref v
Rec [] SuperNormal Reference Symbol
sn) Cacheability
Uncacheable
  | Bool
otherwise = Maybe (Code Reference)
forall a. Maybe a
Nothing

cacheability ::
  Map Reference Word64 ->
  EnumSet Word64 ->
  Reference ->
  Cacheability
cacheability :: Map Reference Word64 -> EnumSet Word64 -> Reference -> Cacheability
cacheability Map Reference Word64
rfn EnumSet Word64
cach Reference
link
  | Just Word64
n <- Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
link Map Reference Word64
rfn,
    Word64 -> EnumSet Word64 -> Bool
forall k. EnumKey k => k -> EnumSet k -> Bool
EC.member Word64
n EnumSet Word64
cach =
      Cacheability
Cacheable
  | Bool
otherwise = Cacheability
Uncacheable

checkSandboxing ::
  CCache prof ->
  [Reference] ->
  Closure ->
  IO Bool
checkSandboxing :: forall prof. CCache prof -> [Reference] -> Closure -> IO Bool
checkSandboxing CCache prof
cc [Reference]
allowed0 Closure
c = do
  Map Reference (Set Reference)
sands <- TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a. TVar a -> IO a
readTVarIO (TVar (Map Reference (Set Reference))
 -> IO (Map Reference (Set Reference)))
-> TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a b. (a -> b) -> a -> b
$ CCache prof -> TVar (Map Reference (Set Reference))
forall prof. CCache prof -> TVar (Map Reference (Set Reference))
sandbox CCache prof
cc
  let f :: Reference -> Set Reference
f Reference
r
        | Just Set Reference
rs <- Reference -> Map Reference (Set Reference) -> Maybe (Set Reference)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference (Set Reference)
sands =
            Set Reference
rs Set Reference -> Set Reference -> Set Reference
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Reference
allowed
        | Bool
otherwise = Set Reference
forall a. Monoid a => a
mempty
  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Set Reference -> Bool
forall a. Set a -> Bool
S.null ((Reference -> Set Reference) -> Closure -> Set Reference
forall m. Monoid m => (Reference -> m) -> Closure -> m
closureTermRefs Reference -> Set Reference
f Closure
c)
  where
    allowed :: Set Reference
allowed = [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
S.fromList [Reference]
allowed0

-- Checks a Value for sandboxing. A Left result indicates that some
-- dependencies of the Value are unknown. A Right result indicates
-- builtins transitively referenced by the Value that are disallowed.
checkValueSandboxing ::
  CCache prof ->
  [Reference] ->
  Value Reference ->
  IO (Either [Referent] [Referent])
checkValueSandboxing :: forall prof.
CCache prof
-> [Reference]
-> Value Reference
-> IO (Either [Referent] [Referent])
checkValueSandboxing CCache prof
cc [Reference]
allowed0 Value Reference
v = do
  Map Reference (Set Reference)
sands <- TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a. TVar a -> IO a
readTVarIO (TVar (Map Reference (Set Reference))
 -> IO (Map Reference (Set Reference)))
-> TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a b. (a -> b) -> a -> b
$ CCache prof -> TVar (Map Reference (Set Reference))
forall prof. CCache prof -> TVar (Map Reference (Set Reference))
sandbox CCache prof
cc
  Map Reference (SuperGroup Reference Symbol)
have <- TVar (Map Reference (SuperGroup Reference Symbol))
-> IO (Map Reference (SuperGroup Reference Symbol))
forall a. TVar a -> IO a
readTVarIO (TVar (Map Reference (SuperGroup Reference Symbol))
 -> IO (Map Reference (SuperGroup Reference Symbol)))
-> TVar (Map Reference (SuperGroup Reference Symbol))
-> IO (Map Reference (SuperGroup Reference Symbol))
forall a b. (a -> b) -> a -> b
$ CCache prof -> TVar (Map Reference (SuperGroup Reference Symbol))
forall prof.
CCache prof -> TVar (Map Reference (SuperGroup Reference Symbol))
intermed CCache prof
cc
  let f :: Bool -> Reference -> (Set Reference, Set Reference)
f Bool
False Reference
r
        | Maybe (SuperGroup Reference Symbol)
Nothing <- Reference
-> Map Reference (SuperGroup Reference Symbol)
-> Maybe (SuperGroup Reference Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference (SuperGroup Reference Symbol)
have,
          Bool -> Bool
not (Reference -> Bool
isBuiltin Reference
r) =
            (Reference -> Set Reference
forall a. a -> Set a
S.singleton Reference
r, Set Reference
forall a. Monoid a => a
mempty)
        | Just Set Reference
rs <- Reference -> Map Reference (Set Reference) -> Maybe (Set Reference)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference (Set Reference)
sands =
            (Set Reference
forall a. Monoid a => a
mempty, Set Reference
rs Set Reference -> Set Reference -> Set Reference
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Reference
allowed)
      f Bool
_ Reference
_ = (Set Reference
forall a. Monoid a => a
mempty, Set Reference
forall a. Monoid a => a
mempty)
  case (Bool -> Reference -> (Set Reference, Set Reference))
-> Value Reference -> (Set Reference, Set Reference)
forall a ref. Monoid a => (Bool -> ref -> a) -> Value ref -> a
valueLinks Bool -> Reference -> (Set Reference, Set Reference)
f Value Reference
v of
    (Set Reference
miss, Set Reference
sbx)
      | Set Reference -> Bool
forall a. Set a -> Bool
S.null Set Reference
miss -> Either [Referent] [Referent] -> IO (Either [Referent] [Referent])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Referent] [Referent] -> IO (Either [Referent] [Referent]))
-> ([Reference] -> Either [Referent] [Referent])
-> [Reference]
-> IO (Either [Referent] [Referent])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Referent] -> Either [Referent] [Referent]
forall a b. b -> Either a b
Right ([Referent] -> Either [Referent] [Referent])
-> ([Reference] -> [Referent])
-> [Reference]
-> Either [Referent] [Referent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference -> Referent) -> [Reference] -> [Referent]
forall a b. (a -> b) -> [a] -> [b]
map Reference -> Referent
Ref ([Reference] -> IO (Either [Referent] [Referent]))
-> [Reference] -> IO (Either [Referent] [Referent])
forall a b. (a -> b) -> a -> b
$ Set Reference -> [Reference]
forall a. Set a -> [a]
S.toList Set Reference
sbx
      | Bool
otherwise -> Either [Referent] [Referent] -> IO (Either [Referent] [Referent])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Referent] [Referent] -> IO (Either [Referent] [Referent]))
-> ([Reference] -> Either [Referent] [Referent])
-> [Reference]
-> IO (Either [Referent] [Referent])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Referent] -> Either [Referent] [Referent]
forall a b. a -> Either a b
Left ([Referent] -> Either [Referent] [Referent])
-> ([Reference] -> [Referent])
-> [Reference]
-> Either [Referent] [Referent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference -> Referent) -> [Reference] -> [Referent]
forall a b. (a -> b) -> [a] -> [b]
map Reference -> Referent
Ref ([Reference] -> IO (Either [Referent] [Referent]))
-> [Reference] -> IO (Either [Referent] [Referent])
forall a b. (a -> b) -> a -> b
$ Set Reference -> [Reference]
forall a. Set a -> [a]
S.toList Set Reference
miss
  where
    allowed :: Set Reference
allowed = [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
S.fromList [Reference]
allowed0

codeValidate ::
  CCache prof ->
  [(Reference, SuperGroup Reference Symbol)] ->
  IO (Maybe (Failure UText.Text))
codeValidate :: forall prof.
CCache prof
-> [(Reference, SuperGroup Reference Symbol)]
-> IO (Maybe (Failure Text))
codeValidate CCache prof
cc [(Reference, SuperGroup Reference Symbol)]
tml = do
  BiMap RecordSchema RecordRef
recRefs <- TVar (BiMap RecordSchema RecordRef)
-> IO (BiMap RecordSchema RecordRef)
forall a. TVar a -> IO a
readTVarIO (CCache prof -> TVar (BiMap RecordSchema RecordRef)
forall prof. CCache prof -> TVar (BiMap RecordSchema RecordRef)
recordRefs CCache prof
cc)
  Word64
frs <- TVar Word64 -> IO Word64
forall a. TVar a -> IO a
readTVarIO (CCache prof -> TVar Word64
forall prof. CCache prof -> TVar Word64
freshRecSchema CCache prof
cc)
  RecordFieldMappings
rfms <- TVar RecordFieldMappings -> IO RecordFieldMappings
forall a. TVar a -> IO a
readTVarIO (CCache prof -> TVar RecordFieldMappings
forall prof. CCache prof -> TVar RecordFieldMappings
recordFieldMappings CCache prof
cc)
  let f :: Bool -> a -> Set a
f Bool
b a
r
        | Bool
b = a -> Set a
forall a. a -> Set a
S.singleton a
r
        | Bool
otherwise = Set a
forall a. Monoid a => a
mempty
      ntys0 :: Set Reference
ntys0 = (((Reference, SuperGroup Reference Symbol) -> Set Reference)
-> [(Reference, SuperGroup Reference Symbol)] -> Set Reference
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((Reference, SuperGroup Reference Symbol) -> Set Reference)
 -> [(Reference, SuperGroup Reference Symbol)] -> Set Reference)
-> ((SuperGroup Reference Symbol -> Set Reference)
    -> (Reference, SuperGroup Reference Symbol) -> Set Reference)
-> (SuperGroup Reference Symbol -> Set Reference)
-> [(Reference, SuperGroup Reference Symbol)]
-> Set Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SuperGroup Reference Symbol -> Set Reference)
-> (Reference, SuperGroup Reference Symbol) -> Set Reference
forall m a. Monoid m => (a -> m) -> (Reference, a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) ((Bool -> Reference -> Set Reference)
-> SuperGroup Reference Symbol -> Set Reference
forall r v ref.
(Monoid r, Var v) =>
(Bool -> ref -> r) -> SuperGroup ref v -> r
foldGroupLinks Bool -> Reference -> Set Reference
forall {a}. Ord a => Bool -> a -> Set a
f) [(Reference, SuperGroup Reference Symbol)]
tml
  -- Validation must not mutate the cache. The types are numbered by the
  -- process-wide registry, which is no mutation of the cache: a number
  -- is just a number, assigned once whoever asks first.
  Map Reference Word64
rty <- Set Reference -> IO (Map Reference Word64)
TN.typeNumbers Set Reference
ntys0
  let -- any schema this code
      -- introduces gets a provisional reference above the fresh counter, and
      -- the field mappings it interns are discarded along with the result.
      newSchemas :: Set RecordSchema
newSchemas = (((Reference, SuperGroup Reference Symbol) -> Set RecordSchema)
-> [(Reference, SuperGroup Reference Symbol)] -> Set RecordSchema
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((Reference, SuperGroup Reference Symbol) -> Set RecordSchema)
 -> [(Reference, SuperGroup Reference Symbol)] -> Set RecordSchema)
-> ((SuperGroup Reference Symbol -> Set RecordSchema)
    -> (Reference, SuperGroup Reference Symbol) -> Set RecordSchema)
-> (SuperGroup Reference Symbol -> Set RecordSchema)
-> [(Reference, SuperGroup Reference Symbol)]
-> Set RecordSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SuperGroup Reference Symbol -> Set RecordSchema)
-> (Reference, SuperGroup Reference Symbol) -> Set RecordSchema
forall m a. Monoid m => (a -> m) -> (Reference, a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) SuperGroup Reference Symbol -> Set RecordSchema
forall ref v. SuperGroup ref v -> Set RecordSchema
ANF.groupRecordSchemas [(Reference, SuperGroup Reference Symbol)]
tml Set RecordSchema -> Set RecordSchema -> Set RecordSchema
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` BiMap RecordSchema RecordRef -> Set RecordSchema
forall k v. BiMap k v -> Set k
BM.keysSetL BiMap RecordSchema RecordRef
recRefs
      recRefs' :: BiMap RecordSchema RecordRef
recRefs' =
        [(RecordSchema, RecordRef)] -> BiMap RecordSchema RecordRef
forall k v. (Ord k, Ord v) => [(k, v)] -> BiMap k v
BM.fromList ([RecordSchema] -> [RecordRef] -> [(RecordSchema, RecordRef)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set RecordSchema -> [RecordSchema]
forall a. Set a -> [a]
S.toList Set RecordSchema
newSchemas) (Word64 -> RecordRef
ANF.RecordRef (Word64 -> RecordRef) -> [Word64] -> [RecordRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word64
frs ..])) BiMap RecordSchema RecordRef
-> BiMap RecordSchema RecordRef -> BiMap RecordSchema RecordRef
forall a. Semigroup a => a -> a -> a
<> BiMap RecordSchema RecordRef
recRefs
  Word64
ftm <- TVar Word64 -> IO Word64
forall a. TVar a -> IO a
readTVarIO (CCache prof -> TVar Word64
forall prof. CCache prof -> TVar Word64
freshTm CCache prof
cc)
  Map Reference Word64
rtm0 <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache prof -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache prof
cc)
  let rs :: [Reference]
rs = (Reference, SuperGroup Reference Symbol) -> Reference
forall a b. (a, b) -> a
fst ((Reference, SuperGroup Reference Symbol) -> Reference)
-> [(Reference, SuperGroup Reference Symbol)] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, SuperGroup Reference Symbol)]
tml
      rtm :: Map Reference Word64
rtm = Map Reference Word64
rtm0 Map Reference Word64
-> Map Reference Word64 -> Map Reference Word64
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` [(Reference, Word64)] -> Map Reference Word64
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Reference] -> [Word64] -> [(Reference, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Reference]
rs [Word64
ftm ..])
      rns :: RefNums
rns = (Reference -> Word64)
-> (Reference -> Word64)
-> (Reference -> Maybe Int)
-> (Reference -> Maybe [Pattern])
-> (Reference -> Maybe Shape)
-> (RecordSchema -> RecordRef)
-> RefNums
RN ([Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
"ty" Map Reference Word64
rty) ([Char] -> Map Reference Word64 -> Reference -> Word64
refLookup [Char]
"tm" Map Reference Word64
rtm) (Maybe Int -> Reference -> Maybe Int
forall a b. a -> b -> a
const Maybe Int
forall a. Maybe a
Nothing) (Maybe [Pattern] -> Reference -> Maybe [Pattern]
forall a b. a -> b -> a
const Maybe [Pattern]
forall a. Maybe a
Nothing) (Maybe Shape -> Reference -> Maybe Shape
forall a b. a -> b -> a
const Maybe Shape
forall a. Maybe a
Nothing) (BiMap RecordSchema RecordRef -> RecordSchema -> RecordRef
recordRefLookup BiMap RecordSchema RecordRef
recRefs')
      combinate :: (Word64, (Reference, SuperGroup Reference Symbol))
-> IO (Combs, Maybe Combs)
combinate (Word64
n, (Reference
r, SuperGroup Reference Symbol
g)) = (Combs, Maybe Combs) -> IO (Combs, Maybe Combs)
forall a. a -> IO a
evaluate ((Combs, Maybe Combs) -> IO (Combs, Maybe Combs))
-> (((Combs, Maybe Combs), RecordFieldMappings)
    -> (Combs, Maybe Combs))
-> ((Combs, Maybe Combs), RecordFieldMappings)
-> IO (Combs, Maybe Combs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Combs, Maybe Combs), RecordFieldMappings) -> (Combs, Maybe Combs)
forall a b. (a, b) -> a
fst (((Combs, Maybe Combs), RecordFieldMappings)
 -> IO (Combs, Maybe Combs))
-> ((Combs, Maybe Combs), RecordFieldMappings)
-> IO (Combs, Maybe Combs)
forall a b. (a -> b) -> a -> b
$ State RecordFieldMappings (Combs, Maybe Combs)
-> RecordFieldMappings
-> ((Combs, Maybe Combs), RecordFieldMappings)
forall s a. State s a -> s -> (a, s)
runState (RefNums
-> Reference
-> Word64
-> Word64
-> SuperGroup Reference Symbol
-> State RecordFieldMappings (Combs, Maybe Combs)
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> Word64
-> SuperGroup Reference v
-> State RecordFieldMappings (Combs, Maybe Combs)
emitCombs RefNums
rns Reference
r Word64
n Word64
n SuperGroup Reference Symbol
g) RecordFieldMappings
rfms
  (Maybe (Failure Text)
forall a. Maybe a
Nothing Maybe (Failure Text) -> IO () -> IO (Maybe (Failure Text))
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((Word64, (Reference, SuperGroup Reference Symbol))
 -> IO (Combs, Maybe Combs))
-> [(Word64, (Reference, SuperGroup Reference Symbol))] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Word64, (Reference, SuperGroup Reference Symbol))
-> IO (Combs, Maybe Combs)
combinate ([Word64]
-> [(Reference, SuperGroup Reference Symbol)]
-> [(Word64, (Reference, SuperGroup Reference Symbol))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64
ftm ..] [(Reference, SuperGroup Reference Symbol)]
tml))
    IO (Maybe (Failure Text))
-> (CompileExn -> IO (Maybe (Failure Text)))
-> IO (Maybe (Failure Text))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(CE CallStack
cs [Word]
_issues [Char]
perr) ->
      let msg :: Text
msg = [Char] -> Text
UText.pack [Char]
perr
          extra :: Text
extra = [Char] -> Text
UText.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ CallStack -> [Char]
forall a. Show a => a -> [Char]
show CallStack
cs
       in Maybe (Failure Text) -> IO (Maybe (Failure Text))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Failure Text) -> IO (Maybe (Failure Text)))
-> (Failure Text -> Maybe (Failure Text))
-> Failure Text
-> IO (Maybe (Failure Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure Text -> Maybe (Failure Text)
forall a. a -> Maybe a
Just (Failure Text -> IO (Maybe (Failure Text)))
-> Failure Text -> IO (Maybe (Failure Text))
forall a b. (a -> b) -> a -> b
$ Reference -> Text -> Text -> Failure Text
forall a. Reference -> Text -> a -> Failure a
Failure Reference
ioFailureRef Text
msg Text
extra