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
type ActiveThreads = Maybe (IORef (Set ThreadId))
type Tag = Word64
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
[Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"
{-# INLINE die #-}
data CCache = CCache
{ CCache -> Bool
sandboxed :: Bool,
CCache -> Bool -> Val -> Tracer
tracer :: Bool -> Val -> Tracer,
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),
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
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