module Unison.Runtime.Machine.Types where

import Control.Concurrent (ThreadId)
import Control.Concurrent.STM as STM
import Control.Exception
import Data.IORef (IORef)
import Data.Map.Strict qualified as M
import Data.Set qualified as S
import Data.Word
import GHC.Stack
import Unison.Builtin.Decls (ioFailureRef)
import Unison.Prelude
import Unison.Reference (Reference, isBuiltin)
import Unison.Referent (Referent, pattern Ref)
import Unison.Runtime.ANF
  (SuperGroup (..), Cacheability (..), Code (..), CompileExn (..), Value, valueLinks, foldGroupLinks)
import Unison.Runtime.Builtin
import Unison.Runtime.Exception hiding (die)
import Unison.Runtime.Foreign (Failure (..))
import Unison.Runtime.MCode
import Unison.Runtime.Stack
import Unison.Symbol
import Unison.Util.EnumContainers as EC
import Unison.Util.Pretty qualified as P
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

-- dynamic environment
type DEnv = EnumMap Word64 Val

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

die :: (HasCallStack) => String -> IO a
die :: forall a. HasCallStack => [Char] -> IO a
die [Char]
s = do
  IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> ([Char] -> IO Any) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuntimeExn -> IO Any
forall e a. Exception e => e -> IO a
throwIO (RuntimeExn -> IO Any)
-> ([Char] -> RuntimeExn) -> [Char] -> IO Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> Pretty ColorText -> RuntimeExn
PE CallStack
HasCallStack => CallStack
callStack (Pretty ColorText -> RuntimeExn)
-> ([Char] -> Pretty ColorText) -> [Char] -> RuntimeExn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorText -> Pretty ColorText
forall s. (IsString s, ListLike s Char) => s -> Pretty s
P.lit (ColorText -> Pretty ColorText)
-> ([Char] -> ColorText) -> [Char] -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ColorText
forall a. IsString a => [Char] -> a
fromString ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
s
  -- This is unreachable, but we need it to fix some quirks in GHC's
  -- worker/wrapper optimization, specifically, it seems that when throwIO's polymorphic return
  -- value is specialized to a type like 'Stack' which we want GHC to unbox, it will sometimes
  -- fail to unbox it, possibly because it can't unbox it when it's strictly a type application.
  -- For whatever reason, this seems to fix it while still allowing us to throw exceptions in IO
  -- like we prefer.
  [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"
{-# INLINE die #-}

-- code caching environment
data CCache = CCache
  { CCache -> Bool
sandboxed :: Bool,
    CCache -> Bool -> Val -> Tracer
tracer :: Bool -> Val -> Tracer,
    -- Combinators in their original form, where they're easier to serialize into SCache
    CCache -> TVar (EnumMap Word64 Combs)
srcCombs :: TVar (EnumMap Word64 Combs),
    CCache -> TVar (EnumMap Word64 MCombs)
combs :: TVar (EnumMap Word64 MCombs),
    CCache -> TVar (EnumMap Word64 Reference)
combRefs :: TVar (EnumMap Word64 Reference),
    -- Combs which we're allowed to cache after evaluating
    CCache -> TVar (EnumSet Word64)
cacheableCombs :: TVar (EnumSet Word64),
    CCache -> TVar (EnumMap Word64 Reference)
tagRefs :: TVar (EnumMap Word64 Reference),
    CCache -> TVar Word64
freshTm :: TVar Word64,
    CCache -> TVar Word64
freshTy :: TVar Word64,
    CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed :: TVar (M.Map Reference (SuperGroup Symbol)),
    CCache -> TVar (Map Reference Word64)
refTm :: TVar (M.Map Reference Word64),
    CCache -> TVar (Map Reference Word64)
refTy :: TVar (M.Map Reference Word64),
    CCache -> TVar (Map Reference (Set Reference))
sandbox :: TVar (M.Map Reference (Set Reference))
  }

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

refNumsTy :: CCache -> IO (M.Map Reference Word64)
refNumsTy :: CCache -> IO (Map Reference Word64)
refNumsTy CCache
cc = TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTy CCache
cc)

refNumTm :: CCache -> Reference -> IO Word64
refNumTm :: CCache -> Reference -> IO Word64
refNumTm CCache
cc Reference
r =
  CCache -> IO (Map Reference Word64)
refNumsTm CCache
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
_ -> [Char] -> IO Word64
forall a. HasCallStack => [Char] -> IO a
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 (EnumMap Word64 Reference)
-> TVar Word64
-> TVar Word64
-> TVar (Map Reference (SuperGroup Symbol))
-> TVar (Map Reference Word64)
-> TVar (Map Reference Word64)
-> TVar (Map Reference (Set Reference))
-> CCache
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 (EnumMap Word64 Reference)
 -> TVar Word64
 -> TVar Word64
 -> TVar (Map Reference (SuperGroup 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 (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup 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 (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup 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 (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup 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 (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup 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 (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup 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 (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar (EnumSet Word64))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup 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 (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup 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 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 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 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 Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar Word64)
-> IO
     (TVar (Map Reference (SuperGroup 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 Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar (Map Reference (SuperGroup 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 Symbol)
-> IO (TVar (Map Reference (SuperGroup Symbol)))
forall a. a -> IO (TVar a)
newTVarIO Map Reference (SuperGroup 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 Symbol)
numberedTermLookup
        EnumMap Word64 (SuperNormal Symbol)
-> (EnumMap Word64 (SuperNormal Symbol) -> EnumMap Word64 Combs)
-> EnumMap Word64 Combs
forall a b. a -> (a -> b) -> b
& (Word64 -> SuperNormal Symbol -> Combs)
-> EnumMap Word64 (SuperNormal Symbol) -> EnumMap Word64 Combs
forall k a b.
EnumKey k =>
(k -> a -> b) -> EnumMap k a -> EnumMap k b
mapWithKey
          (\Word64
k SuperNormal 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 v)
-> Combs
emitComb @Symbol RefNums
rns Reference
r Word64
k RCtx Symbol
forall a. Monoid a => a
mempty (Word64
0, SuperNormal 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 -> Referent -> IO (Maybe Code)
lookupCode :: CCache -> Referent -> IO (Maybe Code)
lookupCode CCache
env (Ref Reference
link) =
  Reference
-> Map Reference (SuperGroup Symbol)
-> Map Reference Word64
-> EnumSet Word64
-> Maybe Code
resolveCode Reference
link (Map Reference (SuperGroup Symbol)
 -> Map Reference Word64 -> EnumSet Word64 -> Maybe Code)
-> IO (Map Reference (SuperGroup Symbol))
-> IO (Map Reference Word64 -> EnumSet Word64 -> Maybe Code)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    TVar (Map Reference (SuperGroup Symbol))
-> IO (Map Reference (SuperGroup Symbol))
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed CCache
env) IO (Map Reference Word64 -> EnumSet Word64 -> Maybe Code)
-> IO (Map Reference Word64) -> IO (EnumSet Word64 -> Maybe Code)
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 -> TVar (Map Reference Word64)
refTm CCache
env) IO (EnumSet Word64 -> Maybe Code)
-> IO (EnumSet Word64) -> IO (Maybe Code)
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 -> TVar (EnumSet Word64)
cacheableCombs CCache
env)
lookupCode CCache
_ Referent
_ = [Char] -> IO (Maybe Code)
forall a. HasCallStack => [Char] -> IO a
die [Char]
"lookupCode: Expected Ref"

resolveCode ::
  Reference ->
  Map Reference (SuperGroup Symbol) ->
  Map Reference Word64 ->
  EnumSet Word64 ->
  Maybe Code
resolveCode :: Reference
-> Map Reference (SuperGroup Symbol)
-> Map Reference Word64
-> EnumSet Word64
-> Maybe Code
resolveCode Reference
link Map Reference (SuperGroup Symbol)
m Map Reference Word64
rfn EnumSet Word64
cach
  | Just SuperGroup Symbol
sg <- Reference
-> Map Reference (SuperGroup Symbol) -> Maybe (SuperGroup Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
link Map Reference (SuperGroup Symbol)
m,
    Cacheability
ch <- Map Reference Word64 -> EnumSet Word64 -> Reference -> Cacheability
cacheability Map Reference Word64
rfn EnumSet Word64
cach Reference
link =
      Code -> Maybe Code
forall a. a -> Maybe a
Just (Code -> Maybe Code) -> Code -> Maybe Code
forall a b. (a -> b) -> a -> b
$ SuperGroup Symbol -> Cacheability -> Code
CodeRep SuperGroup 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 Symbol
sn <- Word64
-> EnumMap Word64 (SuperNormal Symbol)
-> Maybe (SuperNormal Symbol)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w EnumMap Word64 (SuperNormal Symbol)
numberedTermLookup =
      Code -> Maybe Code
forall a. a -> Maybe a
Just (Code -> Maybe Code) -> Code -> Maybe Code
forall a b. (a -> b) -> a -> b
$ SuperGroup Symbol -> Cacheability -> Code
CodeRep ([(Symbol, SuperNormal Symbol)]
-> SuperNormal Symbol -> SuperGroup Symbol
forall v. [(v, SuperNormal v)] -> SuperNormal v -> SuperGroup v
Rec [] SuperNormal Symbol
sn) Cacheability
Uncacheable
  | Bool
otherwise = Maybe Code
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 ->
  [Reference] ->
  Closure ->
  IO Bool
checkSandboxing :: CCache -> [Reference] -> Closure -> IO Bool
checkSandboxing CCache
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 -> TVar (Map Reference (Set Reference))
sandbox CCache
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 ->
  [Reference] ->
  Value ->
  IO (Either [Referent] [Referent])
checkValueSandboxing :: CCache -> [Reference] -> Value -> IO (Either [Referent] [Referent])
checkValueSandboxing CCache
cc [Reference]
allowed0 Value
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 -> TVar (Map Reference (Set Reference))
sandbox CCache
cc
  Map Reference (SuperGroup Symbol)
have <- TVar (Map Reference (SuperGroup Symbol))
-> IO (Map Reference (SuperGroup Symbol))
forall a. TVar a -> IO a
readTVarIO (TVar (Map Reference (SuperGroup Symbol))
 -> IO (Map Reference (SuperGroup Symbol)))
-> TVar (Map Reference (SuperGroup Symbol))
-> IO (Map Reference (SuperGroup Symbol))
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed CCache
cc
  let f :: Bool -> Reference -> (Set Reference, Set Reference)
f Bool
False Reference
r
        | Maybe (SuperGroup Symbol)
Nothing <- Reference
-> Map Reference (SuperGroup Symbol) -> Maybe (SuperGroup Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Reference
r Map Reference (SuperGroup 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 -> (Set Reference, Set Reference)
forall a. Monoid a => (Bool -> Reference -> a) -> Value -> a
valueLinks Bool -> Reference -> (Set Reference, Set Reference)
f Value
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 ->
  [(Reference, SuperGroup Symbol)] ->
  IO (Maybe (Failure UText.Text))
codeValidate :: CCache
-> [(Reference, SuperGroup Symbol)] -> IO (Maybe (Failure Text))
codeValidate CCache
cc [(Reference, SuperGroup Symbol)]
tml = do
  Map Reference Word64
rty0 <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTy CCache
cc)
  Word64
fty <- TVar Word64 -> IO Word64
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar Word64
freshTy CCache
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 Symbol) -> Set Reference)
-> [(Reference, SuperGroup 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 Symbol) -> Set Reference)
 -> [(Reference, SuperGroup Symbol)] -> Set Reference)
-> ((SuperGroup Symbol -> Set Reference)
    -> (Reference, SuperGroup Symbol) -> Set Reference)
-> (SuperGroup Symbol -> Set Reference)
-> [(Reference, SuperGroup Symbol)]
-> Set Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SuperGroup Symbol -> Set Reference)
-> (Reference, SuperGroup 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 Symbol -> Set Reference
forall r v.
(Monoid r, Var v) =>
(Bool -> Reference -> r) -> SuperGroup v -> r
foldGroupLinks Bool -> Reference -> Set Reference
f) [(Reference, SuperGroup 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 -> TVar Word64
freshTm CCache
cc)
  Map Reference Word64
rtm0 <- TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
refTm CCache
cc)
  let rs :: [Reference]
rs = (Reference, SuperGroup Symbol) -> Reference
forall a b. (a, b) -> a
fst ((Reference, SuperGroup Symbol) -> Reference)
-> [(Reference, SuperGroup Symbol)] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, SuperGroup 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 Symbol)) -> IO Combs
combinate (Word64
n, (Reference
r, SuperGroup 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 Symbol -> Combs
forall v.
Var v =>
RefNums -> Reference -> Word64 -> SuperGroup v -> Combs
emitCombs RefNums
rns Reference
r Word64
n SuperGroup 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 Symbol)) -> IO Combs)
-> [(Word64, (Reference, SuperGroup Symbol))] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Word64, (Reference, SuperGroup Symbol)) -> IO Combs
combinate ([Word64]
-> [(Reference, SuperGroup Symbol)]
-> [(Word64, (Reference, SuperGroup Symbol))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64
ftm ..] [(Reference, SuperGroup 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 Pretty ColorText
perr) ->
      let msg :: Text
msg = [Char] -> Text
UText.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Pretty ColorText -> [Char]
P.toPlainUnbroken Pretty ColorText
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