{-# LANGUAGE CPP #-}

module Unison.Runtime.Machine.Types where

#if !defined(mingw32_HOST_OS)
import Control.Concurrent
  (ThreadId, MVar, newEmptyMVar, tryPutMVar, tryTakeMVar)
#else
import Control.Concurrent (ThreadId)
#endif

import Control.Concurrent.STM as STM
import Control.Exception hiding (Handler)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Kind (Type)
import Data.Map.Strict qualified as M
import Data.Set qualified as S
import Data.Word
#if !defined(mingw32_HOST_OS)
import GHC.Event (getSystemTimerManager, registerTimeout)
#else
import System.CPUTime
#endif
import Unison.Builtin.Decls (ioFailureRef)
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.Optimize (OptInfos)
import Unison.Runtime.Builtin
import Unison.Runtime.Exception qualified as Exception
import Unison.Runtime.Foreign (Failure (..))
import Unison.Runtime.InternalError (CompileExn (CE))
import Unison.Runtime.MCode
import Unison.Runtime.Profiling
import Unison.Runtime.Referenced
import Unison.Runtime.Stack
import Unison.Symbol
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 MCombs = RCombs Val

type Combs = GCombs Void CombIx

type MSection = RSection Val

type MBranch = RBranch Val

type MInstr = RInstr Val

type MComb = RComb Val

type MRef = RRef Val

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

-- 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 (MVar Tick)

  startTicker :: ProfileComm -> IO (Ticker ProfileComm, IO ())
startTicker (PC CombIx -> K -> IO ()
pf IO ()
_ IO (Profile Word64)
_) = do
    MVar (CombIx -> K -> IO ())
ticker <- IO (MVar (CombIx -> K -> IO ()))
forall a. IO (MVar a)
newEmptyMVar
    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
-> (CombIx -> K -> IO ())
-> MVar (CombIx -> K -> IO ())
-> IORef Bool
-> IO ()
tickCallback Int
100 CombIx -> K -> IO ()
pf MVar (CombIx -> K -> IO ())
ticker IORef Bool
cancel
    pure (MVar (CombIx -> K -> IO ()) -> Ticker ProfileComm
ProfTicker MVar (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 MVar (CombIx -> K -> IO ())
tick) CombIx
cix K
k = MVar (CombIx -> K -> IO ()) -> IO (Maybe (CombIx -> K -> IO ()))
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar (CombIx -> K -> IO ())
tick 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 -> Tick -> MVar Tick -> IORef Bool -> IO ()
tickCallback :: Int
-> (CombIx -> K -> IO ())
-> MVar (CombIx -> K -> IO ())
-> IORef Bool
-> IO ()
tickCallback Int
interval CombIx -> K -> IO ()
tick MVar (CombIx -> K -> IO ())
ticker IORef Bool
cancel = IO ()
body
  where
    body :: IO ()
body = do
      MVar (CombIx -> K -> IO ()) -> (CombIx -> K -> IO ()) -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar (CombIx -> K -> IO ())
ticker CombIx -> K -> IO ()
tick
      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  <$> 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),
    -- 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),
    forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
tagRefs :: TVar (EnumMap Word64 Reference),
    forall prof. CCache prof -> TVar Word64
freshTm :: TVar Word64,
    forall prof. CCache prof -> TVar Word64
freshTy :: 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 (Map Reference Word64)
refTy :: TVar (M.Map Reference Word64),
    forall prof. CCache prof -> TVar (Map Reference (Set Reference))
sandbox :: TVar (M.Map Reference (Set Reference))
  }

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)

refNumsTy :: CCache prof -> IO (M.Map Reference Word64)
refNumsTy :: forall prof. CCache prof -> IO (Map Reference Word64)
refNumsTy 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)
refTy CCache prof
cc)

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

baseCCache :: Bool -> IO (CCache ())
baseCCache :: Bool -> IO (CCache ())
baseCCache Bool
sandboxed = do
  Bool
-> (Bool -> Val -> Tracer)
-> ()
-> TVar (EnumMap Word64 Combs)
-> TVar (EnumMap Word64 MCombs)
-> TVar (EnumMap Word64 Reference)
-> TVar (EnumSet Word64)
-> TVar (OptInfos Reference Symbol)
-> TVar (EnumMap Word64 Reference)
-> TVar Word64
-> TVar Word64
-> TVar (Map Reference (SuperGroup Reference Symbol))
-> TVar (Map Reference Word64)
-> TVar (Map Reference Word64)
-> TVar (Map Reference (Set Reference))
-> CCache ()
forall prof.
Bool
-> (Bool -> Val -> Tracer)
-> prof
-> TVar (EnumMap Word64 Combs)
-> TVar (EnumMap Word64 MCombs)
-> TVar (EnumMap Word64 Reference)
-> TVar (EnumSet Word64)
-> TVar (OptInfos Reference Symbol)
-> TVar (EnumMap Word64 Reference)
-> TVar Word64
-> TVar Word64
-> TVar (Map Reference (SuperGroup Reference Symbol))
-> TVar (Map Reference Word64)
-> TVar (Map Reference Word64)
-> TVar (Map Reference (Set Reference))
-> 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 (EnumSet Word64)
 -> TVar (OptInfos Reference Symbol)
 -> TVar (EnumMap Word64 Reference)
 -> TVar Word64
 -> TVar Word64
 -> TVar (Map Reference (SuperGroup Reference Symbol))
 -> TVar (Map Reference Word64)
 -> TVar (Map Reference Word64)
 -> TVar (Map Reference (Set Reference))
 -> CCache ())
-> IO (TVar (EnumMap Word64 Combs))
-> IO
     (TVar (EnumMap Word64 MCombs)
      -> TVar (EnumMap Word64 Reference)
      -> TVar (EnumSet Word64)
      -> TVar (OptInfos Reference Symbol)
      -> TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> 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 (EnumSet Word64)
   -> TVar (OptInfos Reference Symbol)
   -> TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (EnumMap Word64 MCombs))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar (EnumSet Word64)
      -> TVar (OptInfos Reference Symbol)
      -> TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> 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 (EnumSet Word64)
   -> TVar (OptInfos Reference Symbol)
   -> TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (EnumMap Word64 Reference))
-> IO
     (TVar (EnumSet Word64)
      -> TVar (OptInfos Reference Symbol)
      -> TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> 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 (EnumSet Word64)
   -> TVar (OptInfos Reference Symbol)
   -> TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (EnumSet Word64))
-> IO
     (TVar (OptInfos Reference Symbol)
      -> TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> 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 (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (OptInfos Reference Symbol))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> 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 (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (EnumMap Word64 Reference))
-> IO
     (TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> 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
builtinTypeBackref
    IO
  (TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar Word64)
-> IO
     (TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> 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 (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar Word64)
-> IO
     (TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> 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
fty
    IO
  (TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (Map Reference (SuperGroup Reference Symbol)))
-> IO
     (TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> 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 (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (Map Reference Word64))
-> IO
     (TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference)) -> 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 (Map Reference Word64)
   -> TVar (Map Reference (Set Reference)) -> CCache ())
-> IO (TVar (Map Reference Word64))
-> IO (TVar (Map Reference (Set Reference)) -> 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
builtinTypeNumbering
    IO (TVar (Map Reference (Set Reference)) -> CCache ())
-> IO (TVar (Map Reference (Set Reference))) -> 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
<*> Map Reference (Set Reference)
-> IO (TVar (Map Reference (Set Reference)))
forall a. a -> IO (TVar a)
newTVarIO Map Reference (Set Reference)
baseSandboxInfo
  where
    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
    fty :: Word64
fty = 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
builtinTypeNumbering

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

    srcCombs :: EnumMap Word64 Combs
    srcCombs :: EnumMap Word64 Combs
srcCombs =
      EnumMap Word64 (SuperNormal Reference Symbol)
numberedTermLookup
        EnumMap Word64 (SuperNormal Reference Symbol)
-> (EnumMap Word64 (SuperNormal Reference Symbol)
    -> EnumMap Word64 Combs)
-> EnumMap Word64 Combs
forall a b. a -> (a -> b) -> b
& (Word64 -> SuperNormal Reference Symbol -> Combs)
-> EnumMap Word64 (SuperNormal Reference Symbol)
-> EnumMap Word64 Combs
forall k a b.
EnumKey k =>
(k -> a -> b) -> EnumMap k a -> EnumMap k b
mapWithKey
          (\Word64
k SuperNormal Reference Symbol
v -> 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 in forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> Combs
emitComb @Symbol RefNums
rns Reference
r Word64
k RCtx Symbol
forall a. Monoid a => a
mempty (Word64
0, SuperNormal Reference Symbol
v))
    combs :: EnumMap Word64 MCombs
    combs :: EnumMap Word64 MCombs
combs =
      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
        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

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
  Map Reference Word64
rty0 <- 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)
refTy CCache prof
cc)
  Word64
fty <- TVar Word64 -> IO Word64
forall a. TVar a -> IO a
readTVarIO (CCache prof -> TVar Word64
forall prof. CCache prof -> TVar Word64
freshTy CCache prof
cc)
  let f :: Bool -> Reference -> Set Reference
f Bool
b Reference
r
        | Bool
b, Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Reference
r Map Reference Word64
rty0 = Reference -> Set Reference
forall a. a -> Set a
S.singleton Reference
r
        | Bool
otherwise = Set Reference
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
f) [(Reference, SuperGroup Reference Symbol)]
tml
      ntys :: Map Reference Word64
ntys = [(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 (Set Reference -> [Reference]
forall a. Set a -> [a]
S.toList Set Reference
ntys0) [Word64
fty ..]
      rty :: Map Reference Word64
rty = Map Reference Word64
ntys Map Reference Word64
-> Map Reference Word64 -> Map Reference Word64
forall a. Semigroup a => a -> a -> a
<> Map Reference Word64
rty0
  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) -> 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)
      combinate :: (Word64, (Reference, SuperGroup Reference Symbol)) -> IO Combs
combinate (Word64
n, (Reference
r, SuperGroup Reference Symbol
g)) = Combs -> IO Combs
forall a. a -> IO a
evaluate (Combs -> IO Combs) -> Combs -> IO Combs
forall a b. (a -> b) -> a -> b
$ RefNums
-> Reference -> Word64 -> SuperGroup Reference Symbol -> Combs
forall v.
Var v =>
RefNums -> Reference -> Word64 -> SuperGroup Reference v -> Combs
emitCombs RefNums
rns Reference
r Word64
n SuperGroup Reference Symbol
g
  (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)
-> [(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
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