module Unison.Runtime.Machine.Types where

import Control.Concurrent (ThreadId)
import Control.Concurrent.STM as STM
import Control.Exception hiding (Handler)
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
  ( Cacheability (..),
    Code (..),
    CompileExn (..),
    SuperGroup (..),
    Value,
    foldGroupLinks,
    valueLinks,
  )
import Unison.Runtime.ANF.Optimize (OptInfos)
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

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 (OptInfos Symbol)
optInfos :: TVar (OptInfos Symbol),
    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 (OptInfos Symbol)
-> 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 (OptInfos Symbol)
 -> 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 (OptInfos Symbol)
      -> 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 (OptInfos Symbol)
   -> 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 (OptInfos Symbol)
      -> 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 (OptInfos Symbol)
   -> 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 (OptInfos Symbol)
      -> 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 (OptInfos Symbol)
   -> 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 (OptInfos Symbol)
      -> 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 (OptInfos Symbol)
   -> 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 (OptInfos Symbol))
-> 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
<*> OptInfos Symbol -> IO (TVar (OptInfos Symbol))
forall a. a -> IO (TVar a)
newTVarIO OptInfos Symbol
builtinOptInfo
    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