From c7c955c2850006f98e4b9b24975de3f014e7566f Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 9 Jan 2025 10:43:03 -0500 Subject: [PATCH 1/7] Change ForeignConvention structure The new conventions are not aimed to encode structure on the stack, but to instead directly produce corresponding unison values. This should allow the raw foreign operations to be called directly in most cases, without the wrapper having to mediate between the convention encoding and the unison value. This both allows for more efficient direct calls, and avoiding what might be considerable overhead of building up the unison values via multiple iterations through the interpreter loop. The one portion where a 'flattened' encoding is retained is for tuples, but this is just for supporting multi-argument functions, not for actually encoding tuples on the stack. --- .../src/Unison/Builtin/Decls.hs | 11 + unison-runtime/src/Unison/Runtime/Builtin.hs | 4 +- unison-runtime/src/Unison/Runtime/Foreign.hs | 113 +- .../src/Unison/Runtime/Foreign/Function.hs | 1058 +++++++++-------- unison-runtime/src/Unison/Runtime/Stack.hs | 21 +- unison-runtime/src/Unison/Runtime/TypeTags.hs | 76 +- 6 files changed, 789 insertions(+), 494 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index a918671d8d..1c09cad84b 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -153,6 +153,17 @@ bufferModeBlockBufferingId = Maybe.fromJust $ constructorId bufferModeRef "io2.B bufferModeSizedBlockBufferingId = Maybe.fromJust $ constructorId bufferModeRef "io2.BufferMode.SizedBlockBuffering" +fileModeReadId, fileModeWriteId, fileModeAppendId, fileModeReadWriteId :: ConstructorId +fileModeReadId = Maybe.fromJust $ constructorId fileModeRef "io2.FileMode.Read" +fileModeWriteId = Maybe.fromJust $ constructorId fileModeRef "io2.FileMode.Write" +fileModeAppendId = Maybe.fromJust $ constructorId fileModeRef "io2.FileMode.Append" +fileModeReadWriteId = Maybe.fromJust $ constructorId fileModeRef "io2.FileMode.ReadWrite" + +seekModeAbsoluteId, seekModeRelativeId, seekModeEndId :: ConstructorId +seekModeAbsoluteId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.AbsoluteSeek" +seekModeRelativeId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.RelativeSeek" +seekModeEndId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.SeekFromEnd" + okConstructorReferent, failConstructorReferent :: Referent.Referent okConstructorReferent = Referent.Con (ConstructorReference testResultRef okConstructorId) CT.Data failConstructorReferent = Referent.Con (ConstructorReference testResultRef failConstructorId) CT.Data diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 6c292f4a78..b5cdf94e27 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -1859,8 +1859,8 @@ declareForeign sand name op func0 = do let func | sanitize, Tracked <- sand, - FF r w _ <- func0 = - FF r w (bomb name) + FF f <- func0 = + FF (bomb name `asTypeOf` f) | otherwise = func0 code = (name, (sand, uncurry Lambda (op w))) in (w + 1, code : codes, mapInsert w (name, func) funcs) diff --git a/unison-runtime/src/Unison/Runtime/Foreign.hs b/unison-runtime/src/Unison/Runtime/Foreign.hs index 831fb46d5d..953c1e1f80 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign.hs @@ -38,6 +38,7 @@ import Unison.Runtime.ANF (Code, Value) import Unison.Runtime.Array import Unison.Type qualified as Ty import Unison.Util.Bytes (Bytes) +import Unison.Util.RefPromise (Promise) import Unison.Util.Text (Text) import Unison.Util.Text.Pattern (CPattern, CharPattern) import Unsafe.Coerce @@ -220,49 +221,117 @@ maybeUnwrapForeign rt (Wrap r e) {-# NOINLINE maybeUnwrapForeign #-} class BuiltinForeign f where + foreignName :: Tagged f String foreignRef :: Tagged f Reference instance BuiltinForeign Text where + foreignName = Tagged "Text" foreignRef :: Tagged Text Reference foreignRef = Tagged Ty.textRef -instance BuiltinForeign Bytes where foreignRef = Tagged Ty.bytesRef +instance BuiltinForeign Bytes where + foreignName = Tagged "Bytes" + foreignRef = Tagged Ty.bytesRef -instance BuiltinForeign Handle where foreignRef = Tagged Ty.fileHandleRef +instance BuiltinForeign Handle where + foreignName = Tagged "Handle" + foreignRef = Tagged Ty.fileHandleRef -instance BuiltinForeign ProcessHandle where foreignRef = Tagged Ty.processHandleRef +instance BuiltinForeign ProcessHandle where + foreignName = Tagged "ProcessHandle" + foreignRef = Tagged Ty.processHandleRef -instance BuiltinForeign Referent where foreignRef = Tagged Ty.termLinkRef +instance BuiltinForeign Referent where + foreignName = Tagged "Referent" + foreignRef = Tagged Ty.termLinkRef -instance BuiltinForeign Socket where foreignRef = Tagged Ty.socketRef +instance BuiltinForeign Socket where + foreignName = Tagged "Socket" + foreignRef = Tagged Ty.socketRef -instance BuiltinForeign ListenSocket where foreignRef = Tagged Ty.udpListenSocketRef +instance BuiltinForeign ListenSocket where + foreignName = Tagged "ListenSocket" + foreignRef = Tagged Ty.udpListenSocketRef -instance BuiltinForeign ClientSockAddr where foreignRef = Tagged Ty.udpClientSockAddrRef +instance BuiltinForeign ClientSockAddr where + foreignName = Tagged "ClientSockAddr" + foreignRef = Tagged Ty.udpClientSockAddrRef -instance BuiltinForeign UDPSocket where foreignRef = Tagged Ty.udpSocketRef +instance BuiltinForeign UDPSocket where + foreignName = Tagged "UDPSocket" + foreignRef = Tagged Ty.udpSocketRef -instance BuiltinForeign ThreadId where foreignRef = Tagged Ty.threadIdRef +instance BuiltinForeign ThreadId where + foreignName = Tagged "ThreadId" + foreignRef = Tagged Ty.threadIdRef -instance BuiltinForeign TLS.ClientParams where foreignRef = Tagged Ty.tlsClientConfigRef +instance BuiltinForeign TLS.ClientParams where + foreignName = Tagged "ClientParams" + foreignRef = Tagged Ty.tlsClientConfigRef -instance BuiltinForeign TLS.ServerParams where foreignRef = Tagged Ty.tlsServerConfigRef +instance BuiltinForeign TLS.ServerParams where + foreignName = Tagged "ServerParams" + foreignRef = Tagged Ty.tlsServerConfigRef -instance BuiltinForeign X509.SignedCertificate where foreignRef = Tagged Ty.tlsSignedCertRef +instance BuiltinForeign X509.SignedCertificate where + foreignName = Tagged "X509.SignedCertificate" + foreignRef = Tagged Ty.tlsSignedCertRef -instance BuiltinForeign X509.PrivKey where foreignRef = Tagged Ty.tlsPrivateKeyRef +instance BuiltinForeign X509.PrivKey where + foreignName = Tagged "X509.PrivKey" + foreignRef = Tagged Ty.tlsPrivateKeyRef -instance BuiltinForeign FilePath where foreignRef = Tagged Ty.filePathRef +instance BuiltinForeign FilePath where + foreignName = Tagged "FilePath" + foreignRef = Tagged Ty.filePathRef -instance BuiltinForeign TLS.Context where foreignRef = Tagged Ty.tlsRef +instance BuiltinForeign TLS.Context where + foreignName = Tagged "TLS.Context" + foreignRef = Tagged Ty.tlsRef -instance BuiltinForeign Code where foreignRef = Tagged Ty.codeRef +instance BuiltinForeign Code where + foreignName = Tagged "Code" + foreignRef = Tagged Ty.codeRef -instance BuiltinForeign Value where foreignRef = Tagged Ty.valueRef +instance BuiltinForeign Value where + foreignName = Tagged "Value" + foreignRef = Tagged Ty.valueRef -instance BuiltinForeign TimeSpec where foreignRef = Tagged Ty.timeSpecRef +instance BuiltinForeign TimeSpec where + foreignName = Tagged "TimeSpec" + foreignRef = Tagged Ty.timeSpecRef -instance BuiltinForeign (Atomic.Ticket a) where foreignRef = Tagged Ty.ticketRef +instance BuiltinForeign (Atomic.Ticket a) where + foreignName = Tagged "Ticket" + foreignRef = Tagged Ty.ticketRef + +instance BuiltinForeign (MVar a) where + foreignName = Tagged "MVar" + foreignRef = Tagged Ty.mvarRef + +instance BuiltinForeign (TVar a) where + foreignName = Tagged "TVar" + foreignRef = Tagged Ty.tvarRef + +instance BuiltinForeign (Promise a) where + foreignName = Tagged "Promise" + foreignRef = Tagged Ty.promiseRef + +instance BuiltinForeign (MutableArray s e) where + foreignName = Tagged "MutableArray" + foreignRef = Tagged Ty.marrayRef + +instance BuiltinForeign (Array e) where + foreignName = Tagged "Array" + foreignRef = Tagged Ty.iarrayRef + +instance BuiltinForeign (MutableByteArray s) where + foreignName = Tagged "MutableByteArray" + foreignRef = Tagged Ty.mbytearrayRef + +instance BuiltinForeign ByteArray where + foreignName = Tagged "ByteArray" + foreignRef = Tagged Ty.ibytearrayRef data HashAlgorithm where -- Reference is a reference to the hash algorithm @@ -272,12 +341,16 @@ newtype Tls = Tls TLS.Context data Failure a = Failure Reference Text a -instance BuiltinForeign HashAlgorithm where foreignRef = Tagged Ty.hashAlgorithmRef +instance BuiltinForeign HashAlgorithm where + foreignName = Tagged "HashAlgorithm" + foreignRef = Tagged Ty.hashAlgorithmRef instance BuiltinForeign CPattern where + foreignName = Tagged "CPattern" foreignRef = Tagged Ty.patternRef instance BuiltinForeign CharPattern where + foreignName = Tagged "CharPattern" foreignRef = Tagged Ty.charClassRef wrapBuiltin :: forall f. (BuiltinForeign f) => f -> Foreign diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 71808e9ab3..671d4fb946 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -11,55 +11,57 @@ module Unison.Runtime.Foreign.Function ( ForeignFunc (..), ForeignConvention (..), mkForeign, + -- mkForeignExn, + executeForeign, + executeForeignExn ) where -import Control.Concurrent (ThreadId) -import Control.Concurrent.MVar (MVar) -import Control.Concurrent.STM (TVar) -import Control.Exception (evaluate) -import Data.Atomics (Ticket) +import Control.Exception (throwIO) +import Data.Char qualified as Char import Data.Foldable (toList) -import Data.IORef (IORef) import Data.Sequence qualified as Sq +import Data.Tagged (Tagged (..)) import Data.Time.Clock.POSIX (POSIXTime) import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Base (IO (..)) -import GHC.IO.Exception (IOErrorType (..), IOException (..)) -import Network.Socket (Socket) -import Network.UDP (UDPSocket) -import System.IO (BufferMode (..), Handle, IOMode, SeekMode) +import System.IO (BufferMode (..), IOMode (..), SeekMode (..)) import Unison.Builtin.Decls qualified as Ty import Unison.Reference (Reference) -import Unison.Runtime.ANF (Code, PackedTag (..), Value, internalBug) +import Unison.Runtime.ANF (internalBug) import Unison.Runtime.Array qualified as PA -import Unison.Runtime.Exception import Unison.Runtime.Foreign import Unison.Runtime.MCode import Unison.Runtime.Stack import Unison.Type - ( iarrayRef, - ibytearrayRef, - marrayRef, - mbytearrayRef, - mvarRef, - promiseRef, - refRef, - ticketRef, - tvarRef, + ( anyRef, + listRef, + textRef, typeLinkRef, ) -import Unison.Util.Bytes (Bytes) -import Unison.Util.RefPromise (Promise) +import Unison.Runtime.TypeTags import Unison.Util.Text (Text, pack, unpack) --- Foreign functions operating on stacks +-- This type considers two sorts of foreign functions. +-- +-- 1. A 'pure' foreign function accepts a stack and produces a +-- stack, possibly with different contents. This isn't pure in +-- the sense that it could have side effects, but it doesn't +-- throw an observable exception. +-- 2. An exceptional foreign function is similar, except it +-- produces a boolean indicating whether its final stack points +-- to an exceptional value. This allows the interpreter to take +-- steps to raise a unison `Exception` directly. data ForeignFunc where - FF :: - (XStack -> Args -> IO a) -> - (XStack -> r -> IOStack) -> - (a -> IO r) -> - ForeignFunc + FF :: (ForeignConvention i, ForeignConvention o) => (i -> IO o) -> ForeignFunc + -- Idea: have a variety of FF with a calling convention for direct + -- exception requests. Some builtins have such a convention already, + -- and could be efficiently implemented as direct foreign calls. + -- Conceivably this could also be used to implement `Either Failure` + -- builtins, with an optimization that turns the wrapper around + -- _those_ into direct calls to the foreign function. + -- FFE :: (ForeignArgs i, ForeignConvention e, ForeignConvention o) + -- => (i -> IO (Either (Failure e) o)) + -- -> ForeignFunc instance Show ForeignFunc where show _ = "ForeignFunc" @@ -70,327 +72,266 @@ instance Eq ForeignFunc where instance Ord ForeignFunc where compare _ _ = internalBug "Ord ForeignFunc" +-- A ForeignConvention explains how to encode foreign values as +-- unison types. Depending on the situation, this can take three +-- forms. +-- +-- 1. Reading/writing directly from/to the stack +-- 2. Reading a tuple directly from the stack +-- 3. Translating a standalone value +-- +-- The first is used when the value in question is the one that is +-- going to be directly on the stack, to allow for slight +-- optimization (e.g. an `Either` only requires reading/writing the +-- boxed portion of the stack). For compound types, though, it's +-- necessary to be able to de/encode a value that was nested inside +-- something else. +-- +-- The second is used for multi-argument foreign functions. The +-- default implementation expects a single argument, and reads at +-- that specific index. But, tuples and the unit type can override +-- to read multiple arguments directly from the stack. This works +-- out better than having a separate class with a default +-- ForeignConvention instance, because the latter requires +-- incoherence to work as expected. +-- +-- We can give a default implementation of the stack operations in +-- terms of the other coding. class ForeignConvention a where - readForeign :: - [Int] -> Stack -> IO ([Int], a) - writeForeign :: - Stack -> a -> IO Stack + readAtIndex :: Stack -> Int -> IO a + readsAt :: Stack -> Args -> IO a + decodeVal :: Val -> IO a -mkForeign :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeign ev = FF readArgs doWrite ev + readAtIndex stk i = peekOff stk i >>= decodeVal + + readsAt stk (VArg1 i) = readAtIndex stk i + readsAt _ args = readsAtError "one argument" args + + writeBack :: Stack -> a -> IO () + encodeVal :: a -> Val + + writeBack stk v = poke stk (encodeVal v) + +readsAtError :: String -> Args -> IO a +readsAtError expect args = throwIO $ Panic msg Nothing + where + msg = "readsAt: expected " ++ expect ++ ", got: " ++ show args + +foreignConventionError :: String -> Val -> IO a +foreignConventionError ty v = throwIO $ Panic msg (Just v) where - doWrite :: XStack -> r -> IOStack - doWrite stk a = case writeForeign (packXStack stk) a of - (IO f) -> \state -> case f state of - (# state', stk #) -> (# state', unpackXStack stk #) - readArgs (packXStack -> stk) (argsToLists -> args) = - readForeign args stk >>= \case - ([], a) -> pure a - _ -> - internalBug - "mkForeign: too many arguments for foreign function" + msg = "mismatched foreign calling convention for `" ++ ty ++ "`" + +instance + ( ForeignConvention a, + ForeignConvention b + ) => ForeignConvention (Either a b) where + decodeVal (BoxedVal (Data1 _ t v)) + | t == leftTag = Left <$> decodeVal v + | otherwise = Right <$> decodeVal v + decodeVal v = foreignConventionError "Either" v + + encodeVal (Left x) = + BoxedVal . Data1 Ty.eitherRef leftTag $ encodeVal x + encodeVal (Right y) = + BoxedVal . Data1 Ty.eitherRef rightTag $ encodeVal y + + readAtIndex stk i = bpeekOff stk i >>= \case + Data1 _ t v + | t == leftTag -> Left <$> decodeVal v + | otherwise -> Right <$> decodeVal v + c -> foreignConventionError "Either" (BoxedVal c) + + writeBack stk (Left x) = + bpoke stk . Data1 Ty.eitherRef leftTag $ encodeVal x + writeBack stk (Right y) = + bpoke stk . Data1 Ty.eitherRef rightTag $ encodeVal y + +instance ForeignConvention a => ForeignConvention (Maybe a) where + decodeVal (BoxedVal (Enum _ _)) = pure Nothing + decodeVal (BoxedVal (Data1 _ _ v)) = Just <$> decodeVal v + decodeVal v = foreignConventionError "Maybe" v + + encodeVal Nothing = noneVal + encodeVal (Just v) = someVal (encodeVal v) + + readAtIndex stk i = bpeekOff stk i >>= \case + Data1 _ _ v -> Just <$> decodeVal v + Enum _ _ -> pure Nothing + c -> foreignConventionError "Maybe" (BoxedVal c) + + writeBack stk Nothing = bpoke stk noneClo + writeBack stk (Just v) = bpoke stk (someClo (encodeVal v)) + +noneClo :: Closure +noneClo = Enum Ty.optionalRef noneTag + +noneVal :: Val +noneVal = BoxedVal noneClo + +someClo :: Val -> Closure +someClo v = Data1 Ty.optionalRef someTag v + +someVal :: Val -> Val +someVal v = BoxedVal (someClo v) instance ForeignConvention Int where - readForeign (i : args) stk = (args,) <$> peekOffI stk i - readForeign [] _ = foreignCCError "Int" - writeForeign stk i = do - stk <- bump stk - stk <$ pokeI stk i + decodeVal (IntVal v) = pure v + decodeVal v = foreignConventionError "Int" v + encodeVal = IntVal -instance ForeignConvention Word64 where - readForeign (i : args) stk = (args,) <$> peekOffN stk i - readForeign [] _ = foreignCCError "Word64" - writeForeign stk n = do - stk <- bump stk - stk <$ pokeN stk n + readAtIndex stk i = upeekOff stk i + writeBack stk v = upokeT stk v intTypeTag -- We don't have a clear mapping from these types to Unison types, most are just mapped to Nats. instance ForeignConvention Word8 where - readForeign = readForeignAs (fromIntegral :: Word64 -> Word8) - writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64) + decodeVal (NatVal v) = pure $ fromIntegral v + decodeVal v = foreignConventionError "Word8" v + encodeVal w = NatVal $ fromIntegral w + + readAtIndex stk i = fromIntegral <$> peekOffN stk i + writeBack stk v = pokeN stk $ fromIntegral v instance ForeignConvention Word16 where - readForeign = readForeignAs (fromIntegral :: Word64 -> Word16) - writeForeign = writeForeignAs (fromIntegral :: Word16 -> Word64) + decodeVal (NatVal v) = pure $ fromIntegral v + decodeVal v = foreignConventionError "Word16" v + encodeVal w = NatVal $ fromIntegral w + + readAtIndex stk i = fromIntegral <$> peekOffN stk i + writeBack stk v = pokeN stk $ fromIntegral v instance ForeignConvention Word32 where - readForeign = readForeignAs (fromIntegral :: Word64 -> Word32) - writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64) + decodeVal (NatVal v) = pure $ fromIntegral v + decodeVal v = foreignConventionError "Word32" v + encodeVal w = NatVal $ fromIntegral w -instance ForeignConvention Char where - readForeign (i : args) stk = (args,) <$> peekOffC stk i - readForeign [] _ = foreignCCError "Char" - writeForeign stk ch = do - stk <- bump stk - stk <$ pokeC stk ch + readAtIndex stk i = fromIntegral <$> upeekOff stk i + writeBack stk v = pokeN stk $ fromIntegral v -instance ForeignConvention Val where - readForeign (i : args) stk = (args,) <$> peekOff stk i - readForeign [] _ = foreignCCError "Val" - writeForeign stk v = do - stk <- bump stk - stk <$ (poke stk =<< evaluate v) +instance ForeignConvention Word64 where + decodeVal (NatVal w) = pure w + decodeVal v = foreignConventionError "Word64" v + encodeVal w = NatVal w --- In reality this fixes the type to be 'RClosure', but allows us to defer --- the typechecker a bit and avoid a bunch of annoying type annotations. -instance ForeignConvention Closure where - readForeign (i : args) stk = (args,) <$> bpeekOff stk i - readForeign [] _ = foreignCCError "Closure" - writeForeign stk c = do - stk <- bump stk - stk <$ (bpoke stk =<< evaluate c) + readAtIndex stk i = peekOffN stk i + writeBack stk w = pokeN stk w + +instance ForeignConvention Char where + decodeVal (CharVal c) = pure c + decodeVal v = foreignConventionError "Char" v -instance ForeignConvention Text where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin + encodeVal c = CharVal c -instance ForeignConvention Bytes where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin + readAtIndex stk i = Char.chr <$> upeekOff stk i + writeBack stk v = upokeT stk (Char.ord v) charTypeTag -instance ForeignConvention Socket where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin +unitClo :: Closure +unitClo = Enum Ty.unitRef unitTag -instance ForeignConvention UDPSocket where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin +unitVal :: Val +unitVal = BoxedVal unitClo -instance ForeignConvention ThreadId where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin +instance ForeignConvention () where + decodeVal _ = pure () + encodeVal _ = unitVal -instance ForeignConvention Handle where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin + readsAt _ ZArgs = pure () + readsAt _ as = readsAtError "zero arguments" as -instance ForeignConvention POSIXTime where - readForeign = readForeignAs (fromIntegral :: Int -> POSIXTime) - writeForeign = writeForeignAs (round :: POSIXTime -> Int) - -instance (ForeignConvention a) => ForeignConvention (Maybe a) where - readForeign (i : args) stk = - upeekOff stk i >>= \case - 0 -> pure (args, Nothing) - 1 -> fmap Just <$> readForeign args stk - _ -> foreignCCError "Maybe" - readForeign [] _ = foreignCCError "Maybe" - - writeForeign stk Nothing = do - stk <- bump stk - stk <$ pokeTag stk 0 - writeForeign stk (Just x) = do - stk <- writeForeign stk x - stk <- bump stk - stk <$ pokeTag stk 1 + readAtIndex _ _ = pure () + writeBack stk _ = bpoke stk $ unitClo -instance - (ForeignConvention a, ForeignConvention b) => - ForeignConvention (Either a b) - where - readForeign (i : args) stk = - peekTagOff stk i >>= \case - 0 -> readForeignAs Left args stk - 1 -> readForeignAs Right args stk - _ -> foreignCCError "Either" - readForeign _ _ = foreignCCError "Either" - - writeForeign stk (Left a) = do - stk <- writeForeign stk a - stk <- bump stk - stk <$ pokeTag stk 0 - writeForeign stk (Right b) = do - stk <- writeForeign stk b - stk <- bump stk - stk <$ pokeTag stk 1 - -ioeDecode :: Int -> IOErrorType -ioeDecode 0 = AlreadyExists -ioeDecode 1 = NoSuchThing -ioeDecode 2 = ResourceBusy -ioeDecode 3 = ResourceExhausted -ioeDecode 4 = EOF -ioeDecode 5 = IllegalOperation -ioeDecode 6 = PermissionDenied -ioeDecode 7 = UserError -ioeDecode _ = internalBug "ioeDecode" - -ioeEncode :: IOErrorType -> Int -ioeEncode AlreadyExists = 0 -ioeEncode NoSuchThing = 1 -ioeEncode ResourceBusy = 2 -ioeEncode ResourceExhausted = 3 -ioeEncode EOF = 4 -ioeEncode IllegalOperation = 5 -ioeEncode PermissionDenied = 6 -ioeEncode UserError = 7 -ioeEncode _ = internalBug "ioeDecode" - -instance ForeignConvention IOException where - readForeign = readForeignAs (bld . ioeDecode) - where - bld t = IOError Nothing t "" "" Nothing Nothing - - writeForeign = writeForeignAs (ioeEncode . ioe_type) - -readForeignAs :: - (ForeignConvention a) => - (a -> b) -> - [Int] -> - Stack -> - IO ([Int], b) -readForeignAs f args stk = fmap f <$> readForeign args stk - -writeForeignAs :: - (ForeignConvention b) => - (a -> b) -> - Stack -> - a -> - IO Stack -writeForeignAs f stk x = writeForeign stk (f x) - -readForeignEnum :: - (Enum a) => - [Int] -> - Stack -> - IO ([Int], a) -readForeignEnum = readForeignAs toEnum - -writeForeignEnum :: - (Enum a) => - Stack -> - a -> - IO Stack -writeForeignEnum = writeForeignAs fromEnum - -readForeignBuiltin :: - (BuiltinForeign b) => - [Int] -> - Stack -> - IO ([Int], b) -readForeignBuiltin = readForeignAs (unwrapBuiltin . marshalToForeign) - -writeForeignBuiltin :: - (BuiltinForeign b) => - Stack -> - b -> - IO Stack -writeForeignBuiltin = writeForeignAs (Foreign . wrapBuiltin) - -writeTypeLink :: - Stack -> - Reference -> - IO Stack -writeTypeLink = writeForeignAs (Foreign . Wrap typeLinkRef) - -readTypelink :: - [Int] -> - Stack -> - IO ([Int], Reference) -readTypelink = readForeignAs (unwrapForeign . marshalToForeign) +decodeTup2 :: (ForeignConvention a, ForeignConvention b) => Closure -> IO (a, b) +decodeTup2 (Data2 _ _ x (BoxedVal (Data2 _ _ y _))) = + (,) <$> decodeVal x <*> decodeVal y +decodeTup2 c = foreignConventionError "Pair" (BoxedVal c) -instance ForeignConvention Double where - readForeign (i : args) stk = (args,) <$> peekOffD stk i - readForeign _ _ = foreignCCError "Double" - writeForeign stk d = - bump stk >>= \stk -> do - pokeD stk d - pure stk +encodeTup2 :: (ForeignConvention a, ForeignConvention b) => (a, b) -> Closure +encodeTup2 (x,y) = + Data2 Ty.pairRef pairTag (encodeVal x) (encodeVal y) -instance ForeignConvention Bool where - readForeign (i : args) stk = do - b <- peekOffBool stk i - pure (args, b) - readForeign _ _ = foreignCCError "Bool" - writeForeign stk b = do - stk <- bump stk - pokeBool stk b - pure stk - -instance ForeignConvention String where - readForeign = readForeignAs unpack - writeForeign = writeForeignAs pack +instance + ( ForeignConvention a, + ForeignConvention b + ) => ForeignConvention (a, b) where + decodeVal (BoxedVal v) = decodeTup2 v + decodeVal v = foreignConventionError "Pair" v + encodeVal p = BoxedVal $ encodeTup2 p -instance ForeignConvention SeekMode where - readForeign = readForeignEnum - writeForeign = writeForeignEnum + readsAt stk (VArg2 i j) = + (,) <$> readAtIndex stk i + <*> readAtIndex stk j + readsAt _ as = readsAtError "two arguments" as -instance ForeignConvention IOMode where - readForeign = readForeignEnum - writeForeign = writeForeignEnum + readAtIndex stk i = bpeekOff stk i >>= decodeTup2 + writeBack stk p = bpoke stk $ encodeTup2 p -instance ForeignConvention () where - readForeign args _ = pure (args, ()) - writeForeign stk _ = pure stk +decodeTup3 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c) => Closure -> IO (a, b, c) +decodeTup3 (Data2 _ _ x (BoxedVal (Data2 _ _ y (BoxedVal (Data2 _ _ z _))))) = + (,,) <$> decodeVal x <*> decodeVal y <*> decodeVal z +decodeTup3 c = foreignConventionError "Triple" (BoxedVal c) -instance - (ForeignConvention a, ForeignConvention b) => - ForeignConvention (a, b) - where - readForeign args stk = do - (args, a) <- readForeign args stk - (args, b) <- readForeign args stk - pure (args, (a, b)) - - writeForeign stk (x, y) = do - stk <- writeForeign stk y - writeForeign stk x - -instance (ForeignConvention a) => ForeignConvention (Failure a) where - readForeign args stk = do - (args, typeref) <- readTypelink args stk - (args, message) <- readForeign args stk - (args, any) <- readForeign args stk - pure (args, Failure typeref message any) - - writeForeign stk (Failure typeref message any) = do - stk <- writeForeign stk any - stk <- writeForeign stk message - writeTypeLink stk typeref +encodeTup3 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c) => (a, b, c) -> Closure +encodeTup3 (x,y,z) = + Data2 Ty.pairRef pairTag (encodeVal x) (BoxedVal $ encodeTup2 (y,z)) instance ( ForeignConvention a, ForeignConvention b, ForeignConvention c - ) => - ForeignConvention (a, b, c) - where - readForeign args stk = do - (args, a) <- readForeign args stk - (args, b) <- readForeign args stk - (args, c) <- readForeign args stk - pure (args, (a, b, c)) + ) => ForeignConvention (a, b, c) where + decodeVal (BoxedVal v) = decodeTup3 v + decodeVal v = foreignConventionError "Triple" v + encodeVal p = BoxedVal $ encodeTup3 p - writeForeign stk (a, b, c) = do - stk <- writeForeign stk c - stk <- writeForeign stk b - writeForeign stk a + readsAt stk (VArgN v) = + (,,) <$> readAtIndex stk (PA.indexPrimArray v 0) + <*> readAtIndex stk (PA.indexPrimArray v 1) + <*> readAtIndex stk (PA.indexPrimArray v 2) + readsAt _ as = readsAtError "three arguments" as + + readAtIndex stk i = bpeekOff stk i >>= decodeTup3 + writeBack stk p = bpoke stk $ encodeTup3 p + +decodeTup4 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d) => Closure -> IO (a, b, c, d) +decodeTup4 (Data2 _ _ w (BoxedVal (Data2 _ _ x (BoxedVal (Data2 _ _ y (BoxedVal (Data2 _ _ z _))))))) = + (,,,) <$> decodeVal w <*> decodeVal x <*> decodeVal y <*> decodeVal z +decodeTup4 c = foreignConventionError "Quadruple" (BoxedVal c) + +encodeTup4 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d) => (a, b, c, d) -> Closure +encodeTup4 (w,x,y,z) = + Data2 Ty.pairRef pairTag (encodeVal w) (BoxedVal $ encodeTup3 (x,y,z)) instance ( ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d - ) => - ForeignConvention (a, b, c, d) - where - readForeign args stk = do - (args, a) <- readForeign args stk - (args, b) <- readForeign args stk - (args, c) <- readForeign args stk - (args, d) <- readForeign args stk - pure (args, (a, b, c, d)) - - writeForeign stk (a, b, c, d) = do - stk <- writeForeign stk d - stk <- writeForeign stk c - stk <- writeForeign stk b - writeForeign stk a + ) => ForeignConvention (a, b, c, d) where + decodeVal (BoxedVal v) = decodeTup4 v + decodeVal v = foreignConventionError "Quadruple" v + + encodeVal p = BoxedVal $ encodeTup4 p + + readsAt stk (VArgN v) = + (,,,) <$> readAtIndex stk (PA.indexPrimArray v 0) + <*> readAtIndex stk (PA.indexPrimArray v 1) + <*> readAtIndex stk (PA.indexPrimArray v 2) + <*> readAtIndex stk (PA.indexPrimArray v 3) + readsAt _ as = readsAtError "four arguments" as + + readAtIndex stk i = bpeekOff stk i >>= decodeTup4 + writeBack stk p = bpoke stk $ encodeTup4 p + +decodeTup5 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d, ForeignConvention e) => Closure -> IO (a, b, c, d, e) +decodeTup5 (Data2 _ _ v (BoxedVal (Data2 _ _ w (BoxedVal (Data2 _ _ x (BoxedVal (Data2 _ _ y (BoxedVal (Data2 _ _ z _))))))))) = + (,,,,) <$> decodeVal v <*> decodeVal w <*> decodeVal x <*> decodeVal y <*> decodeVal z +decodeTup5 c = foreignConventionError "Quintuple" (BoxedVal c) + +encodeTup5 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d, ForeignConvention e) => (a, b, c, d, e) -> Closure +encodeTup5 (v,w,x,y,z) = + Data2 Ty.pairRef pairTag (encodeVal v) (BoxedVal $ encodeTup4 (w,x,y,z)) instance ( ForeignConvention a, @@ -401,171 +342,356 @@ instance ) => ForeignConvention (a, b, c, d, e) where - readForeign args stk = do - (args, a) <- readForeign args stk - (args, b) <- readForeign args stk - (args, c) <- readForeign args stk - (args, d) <- readForeign args stk - (args, e) <- readForeign args stk - pure (args, (a, b, c, d, e)) - - writeForeign stk (a, b, c, d, e) = do - stk <- writeForeign stk e - stk <- writeForeign stk d - stk <- writeForeign stk c - stk <- writeForeign stk b - writeForeign stk a - -no'buf, line'buf, block'buf, sblock'buf :: Word64 -no'buf = fromIntegral Ty.bufferModeNoBufferingId -line'buf = fromIntegral Ty.bufferModeLineBufferingId -block'buf = fromIntegral Ty.bufferModeBlockBufferingId -sblock'buf = fromIntegral Ty.bufferModeSizedBlockBufferingId + decodeVal (BoxedVal c) = decodeTup5 c + decodeVal v = foreignConventionError "Quintuple" v + + encodeVal = BoxedVal . encodeTup5 + + readsAt stk (VArgN v) = + (,,,,) <$> readAtIndex stk (PA.indexPrimArray v 0) + <*> readAtIndex stk (PA.indexPrimArray v 1) + <*> readAtIndex stk (PA.indexPrimArray v 2) + <*> readAtIndex stk (PA.indexPrimArray v 3) + <*> readAtIndex stk (PA.indexPrimArray v 4) + readsAt _ as = readsAtError "five arguments" as + + readAtIndex stk i = bpeekOff stk i >>= decodeTup5 + writeBack stk p = bpoke stk $ encodeTup5 p + + +decodeFailure :: ForeignConvention a => Closure -> IO (Failure a) +decodeFailure (DataG _ _ (_, args)) = + Failure + <$> decodeTypeLink (PA.indexArray args 0) + <*> decodeText (PA.indexArray args 1) + <*> decodeAny (PA.indexArray args 2) +decodeFailure c = foreignConventionError "Failure" (BoxedVal c) + +encodeFailure :: ForeignConvention a => Failure a -> Closure +encodeFailure (Failure r msg v) = DataG Ty.failureRef failureTag payload + where + payload = boxedSeg [encodeTypeLink r, encodeText msg, encodeAny v] + +boxedSeg :: [Closure] -> Seg +boxedSeg cs = (useg (0 <$ cs), bseg cs) + +decodeTypeLink :: Closure -> IO Reference +decodeTypeLink = marshalUnwrapForeignIO + +encodeTypeLink :: Reference -> Closure +encodeTypeLink rf = Foreign (Wrap typeLinkRef rf) + +encodeAny :: ForeignConvention a => a -> Closure +encodeAny v = Data1 anyRef anyTag (encodeVal v) + +decodeAny :: ForeignConvention a => Closure -> IO a +decodeAny (Data1 _ _ v) = decodeVal v +decodeAny c = foreignConventionError "Any" (BoxedVal c) + +decodeText :: Closure -> IO Text +decodeText = marshalUnwrapForeignIO + +encodeText :: Text -> Closure +encodeText tx = Foreign (Wrap textRef tx) + +instance ForeignConvention a => ForeignConvention (Failure a) where + decodeVal (BoxedVal v) = decodeFailure v + decodeVal v = foreignConventionError "Failure" v + encodeVal v = BoxedVal $ encodeFailure v + + readAtIndex stk i = bpeekOff stk i >>= decodeFailure + writeBack stk f = bpoke stk $ encodeFailure f + +decodeForeignClo :: String -> Closure -> IO a +decodeForeignClo _ (Foreign x) = pure $ unwrapForeign x +decodeForeignClo ty c = foreignConventionError ty (BoxedVal c) + +encodeForeignClo :: Reference -> a -> Closure +encodeForeignClo r = Foreign . Wrap r + +decodeBuiltin :: forall a. BuiltinForeign a => Val -> IO a +decodeBuiltin v + | BoxedVal c <- v = decodeForeignClo ty c + | otherwise = foreignConventionError ty v + where + Tagged ty = foreignName :: Tagged a String + +encodeBuiltin :: forall a. BuiltinForeign a => a -> Val +encodeBuiltin = BoxedVal . encodeForeignClo r + where + Tagged r = foreignRef :: Tagged a Reference + +readBuiltinAt :: forall a. BuiltinForeign a => Stack -> Int -> IO a +readBuiltinAt stk i = bpeekOff stk i >>= decodeForeignClo ty + where + Tagged ty = foreignName :: Tagged a String + +writeBuiltin :: forall a. BuiltinForeign a => Stack -> a -> IO () +writeBuiltin stk = bpoke stk . encodeForeignClo r + where + Tagged r = foreignRef :: Tagged a Reference + +decodeAsBuiltin :: BuiltinForeign t => (t -> a) -> Val -> IO a +decodeAsBuiltin k = fmap k . decodeBuiltin + +encodeAsBuiltin :: BuiltinForeign t => (a -> t) -> a -> Val +encodeAsBuiltin k = encodeBuiltin . k + +readAsBuiltin + :: BuiltinForeign t => (t -> a) -> Stack -> Int -> IO a +readAsBuiltin k stk i = k <$> readBuiltinAt stk i + +writeAsBuiltin :: BuiltinForeign t => (a -> t) -> Stack -> a -> IO () +writeAsBuiltin k stk = writeBuiltin stk . k + +instance ForeignConvention POSIXTime where + decodeVal (IntVal i) = pure (fromIntegral i) + decodeVal v = foreignConventionError "POSIXTime" v + encodeVal pt = IntVal (round pt) + readAtIndex stk i = fromIntegral <$> peekOffI stk i + writeBack stk pt = pokeI stk (round pt) + + +mkForeign :: + ForeignConvention a => + ForeignConvention r => + (a -> IO r) -> ForeignFunc +mkForeign f = FF f +{-# inline mkForeign #-} + +-- mkForeignExn :: +-- ForeignArgs a => +-- ForeignConvention e => +-- ForeignConvention r => +-- (a -> IO (Either (Failure e) r)) -> +-- ForeignFunc +-- mkForeignExn f = FFE f + +executeForeign :: + ForeignConvention a => + ForeignConvention r => + (a -> IO r) -> + Stack -> Args -> IO Stack +executeForeign ev stk args = do + r <- ev =<< readsAt stk args + stk <- bump stk + stk <$ writeBack stk r +{-# inlinable executeForeign #-} + +executeForeignExn :: + ForeignConvention a => + ForeignConvention e => + ForeignConvention r => + (a -> IO (Either (Failure e) r)) -> + Stack -> Args -> IO (Bool, Stack) +executeForeignExn ev stk args = + readsAt stk args >>= ev >>= \case + Left fail -> wb True fail + Right r -> wb False r + where + wb :: ForeignConvention s => v -> s -> IO (v, Stack) + wb v s = do + stk <- bump stk + (v, stk) <$ writeBack stk s + +-- TODO: was this ever actually used? Mapping IO exceptions to numbers. +-- +-- ioeDecode :: Int -> IOErrorType +-- ioeDecode 0 = AlreadyExists +-- ioeDecode 1 = NoSuchThing +-- ioeDecode 2 = ResourceBusy +-- ioeDecode 3 = ResourceExhausted +-- ioeDecode 4 = EOF +-- ioeDecode 5 = IllegalOperation +-- ioeDecode 6 = PermissionDenied +-- ioeDecode 7 = UserError +-- ioeDecode _ = internalBug "ioeDecode" + +-- ioeEncode :: IOErrorType -> Int +-- ioeEncode AlreadyExists = 0 +-- ioeEncode NoSuchThing = 1 +-- ioeEncode ResourceBusy = 2 +-- ioeEncode ResourceExhausted = 3 +-- ioeEncode EOF = 4 +-- ioeEncode IllegalOperation = 5 +-- ioeEncode PermissionDenied = 6 +-- ioeEncode UserError = 7 +-- ioeEncode _ = internalBug "ioeDecode" + +-- instance ForeignConvention IOException where +-- readForeign = readForeignAs (bld . ioeDecode) +-- where +-- bld t = IOError Nothing t "" "" Nothing Nothing +-- +-- writeForeign = writeForeignAs (ioeEncode . ioe_type) + +decodeBufferMode :: Closure -> IO BufferMode +decodeBufferMode (Enum _ t) + | t == noBufTag = pure NoBuffering + | t == lineBufTag = pure LineBuffering + | t == blockBufTag = pure $ BlockBuffering Nothing +decodeBufferMode (Data1 _ t (IntVal i)) + | t == sizedBlockBufTag = pure . BlockBuffering $ Just i +decodeBufferMode c = foreignConventionError "BufferMode" (BoxedVal c) + +encodeBufferMode :: BufferMode -> Closure +encodeBufferMode NoBuffering = no'buf +encodeBufferMode LineBuffering = line'buf +encodeBufferMode (BlockBuffering Nothing) = block'buf +encodeBufferMode (BlockBuffering (Just n)) = + Data1 Ty.bufferModeRef sizedBlockBufTag . NatVal $ fromIntegral n + +no'buf, line'buf, block'buf :: Closure +no'buf = Enum Ty.bufferModeRef noBufTag +line'buf = Enum Ty.bufferModeRef lineBufTag +block'buf = Enum Ty.bufferModeRef blockBufTag instance ForeignConvention BufferMode where - readForeign (i : args) stk = - peekOffN stk i >>= \case - t - | t == no'buf -> pure (args, NoBuffering) - | t == line'buf -> pure (args, LineBuffering) - | t == block'buf -> pure (args, BlockBuffering Nothing) - | t == sblock'buf -> - fmap (BlockBuffering . Just) - <$> readForeign args stk - | otherwise -> - foreignCCError $ - "BufferMode (unknown tag: " <> show t <> ")" - readForeign _ _ = foreignCCError $ "BufferMode (empty stack)" - - writeForeign stk bm = - bump stk >>= \stk -> - case bm of - NoBuffering -> stk <$ pokeN stk no'buf - LineBuffering -> stk <$ pokeN stk line'buf - BlockBuffering Nothing -> stk <$ pokeN stk block'buf - BlockBuffering (Just n) -> do - pokeI stk n - stk <- bump stk - stk <$ pokeN stk sblock'buf + decodeVal (BoxedVal c) = decodeBufferMode c + decodeVal v = foreignConventionError "BufferMode" v + + encodeVal = BoxedVal . encodeBufferMode + + readAtIndex stk i = bpeekOff stk i >>= decodeBufferMode + writeBack stk bm = bpoke stk (encodeBufferMode bm) + +decodeIOMode :: Closure -> IO IOMode +decodeIOMode (Enum _ t) + | t == readModeTag = pure ReadMode + | t == writeModeTag = pure WriteMode + | t == appendModeTag = pure AppendMode + | t == readWriteModeTag = pure ReadWriteMode +decodeIOMode c = foreignConventionError "IOMode" (BoxedVal c) + +encodeIOMode :: IOMode -> Closure +encodeIOMode ReadMode = read'mode +encodeIOMode WriteMode = write'mode +encodeIOMode AppendMode = append'mode +encodeIOMode ReadWriteMode = read'write'mode + +read'mode, write'mode, append'mode, read'write'mode :: Closure +read'mode = Enum Ty.bufferModeRef readModeTag +write'mode = Enum Ty.bufferModeRef writeModeTag +append'mode = Enum Ty.bufferModeRef appendModeTag +read'write'mode = Enum Ty.bufferModeRef readWriteModeTag + +instance ForeignConvention IOMode where + decodeVal (BoxedVal c) = decodeIOMode c + decodeVal v = foreignConventionError "IOMode" v + + encodeVal = BoxedVal . encodeIOMode + + readAtIndex stk i = bpeekOff stk i >>= decodeIOMode + writeBack stk im = bpoke stk (encodeIOMode im) + +decodeSeekMode :: Closure -> IO SeekMode +decodeSeekMode (Enum _ t) + | t == seekAbsoluteTag = pure AbsoluteSeek + | t == seekRelativeTag = pure RelativeSeek + | t == seekEndTag = pure SeekFromEnd +decodeSeekMode v = foreignConventionError "SeekMode" (BoxedVal v) + +encodeSeekMode :: SeekMode -> Closure +encodeSeekMode AbsoluteSeek = absolute'seek +encodeSeekMode RelativeSeek = relative'seek +encodeSeekMode SeekFromEnd = seek'from'end + +absolute'seek, relative'seek, seek'from'end :: Closure +absolute'seek = Enum Ty.seekModeRef seekAbsoluteTag +relative'seek = Enum Ty.seekModeRef seekRelativeTag +seek'from'end = Enum Ty.seekModeRef seekEndTag + +instance ForeignConvention SeekMode where + decodeVal (BoxedVal c) = decodeSeekMode c + decodeVal v = foreignConventionError "SeekMode" v + + encodeVal = BoxedVal . encodeSeekMode + + readAtIndex stk i = bpeekOff stk i >>= decodeSeekMode + writeBack stk sm = bpoke stk (encodeSeekMode sm) -- In reality this fixes the type to be 'RClosure', but allows us to defer -- the typechecker a bit and avoid a bunch of annoying type annotations. -instance {-# OVERLAPPING #-} ForeignConvention [Val] where - readForeign (i : args) stk = - (args,) . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[Val]" - writeForeign stk l = do - stk <- bump stk - stk <$ pokeS stk (Sq.fromList l) +-- instance {-# OVERLAPPING #-} ForeignConvention [Val] where +-- decodeVal = decode +-- readForeign (i : args) stk = +-- (args,) . toList <$> peekOffS stk i +-- readForeign _ _ = foreignCCError "[Val]" +-- writeForeign stk l = do +-- stk <- bump stk +-- stk <$ pokeS stk (Sq.fromList l) -- In reality this fixes the type to be 'RClosure', but allows us to defer -- the typechecker a bit and avoid a bunch of annoying type annotations. -instance {-# OVERLAPPING #-} ForeignConvention [Closure] where - readForeign (i : args) stk = - (args,) . fmap getBoxedVal . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[Closure]" - writeForeign stk l = do - stk <- bump stk - stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l) - -instance ForeignConvention [Foreign] where - readForeign = readForeignAs (fmap marshalToForeign) - writeForeign = writeForeignAs (fmap Foreign) - -instance ForeignConvention (MVar Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap mvarRef) - -instance ForeignConvention (TVar Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap tvarRef) - -instance ForeignConvention (IORef Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap refRef) - -instance ForeignConvention (Ticket Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap ticketRef) - -instance ForeignConvention (Promise Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap promiseRef) - -instance ForeignConvention Code where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -instance ForeignConvention Value where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin +-- instance {-# OVERLAPPING #-} ForeignConvention [Closure] where +-- readForeign (i : args) stk = +-- (args,) . fmap getBoxedVal . toList <$> peekOffS stk i +-- readForeign _ _ = foreignCCError "[Closure]" +-- writeForeign stk l = do +-- stk <- bump stk +-- stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l) +-- +-- instance ForeignConvention [Foreign] where +-- readForeign = readForeignAs (fmap marshalToForeign) +-- writeForeign = writeForeignAs (fmap Foreign) +-- + +instance {-# overlapping #-} ForeignConvention String where + decodeVal = decodeAsBuiltin unpack + encodeVal = encodeAsBuiltin pack + + readAtIndex = readAsBuiltin unpack + writeBack = writeAsBuiltin pack + +instance ForeignConvention Bool where + decodeVal (BoolVal b) = pure b + decodeVal v = foreignConventionError "Bool" v + + encodeVal = BoolVal + + readAtIndex = peekOffBool + writeBack = pokeBool + +instance ForeignConvention Double where + decodeVal (DoubleVal d) = pure d + decodeVal v = foreignConventionError "Double" v + + encodeVal = DoubleVal + + readAtIndex = peekOffD + writeBack = pokeD + +instance ForeignConvention Val where + decodeVal = pure + encodeVal = id + + readAtIndex = peekOff + writeBack = poke instance ForeignConvention Foreign where - readForeign = readForeignAs marshalToForeign - writeForeign = writeForeignAs Foreign - -instance ForeignConvention (PA.MutableArray s Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap marrayRef) - -instance ForeignConvention (PA.MutableByteArray s) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef) - -instance ForeignConvention (PA.Array Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap iarrayRef) - -instance ForeignConvention PA.ByteArray where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap ibytearrayRef) - -instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -fromUnisonPair :: (BuiltinForeign a, BuiltinForeign b) => Closure -> (a, b) -fromUnisonPair (DataC _ _ [BoxedVal x, BoxedVal (DataC _ _ [BoxedVal y, BoxedVal _unit])]) = - (unwrapForeignClosure x, unwrapForeignClosure y) -fromUnisonPair _ = error "fromUnisonPair: invalid closure" - -toUnisonPair :: - (BuiltinForeign a, BuiltinForeign b) => (a, b) -> Closure -toUnisonPair (x, y) = - DataC - Ty.pairRef - (PackedTag 0) - [BoxedVal $ wr x, BoxedVal $ DataC Ty.pairRef (PackedTag 0) [BoxedVal $ wr y, BoxedVal $ un]] - where - un = DataC Ty.unitRef (PackedTag 0) [] - wr z = Foreign $ wrapBuiltin z - -unwrapForeignClosure :: Closure -> a -unwrapForeignClosure = unwrapForeign . marshalToForeign - -instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where - readForeign (i : args) stk = - (args,) - . fmap (fromUnisonPair . getBoxedVal) - . toList - <$> peekOffS stk i - readForeign _ _ = foreignCCError "[(a,b)]" - - writeForeign stk l = do - stk <- bump stk - stk <$ pokeS stk (boxedVal . toUnisonPair <$> Sq.fromList l) - -instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where - readForeign (i : args) stk = - (args,) - . fmap (unwrapForeignClosure . getBoxedVal) - . toList - <$> peekOffS stk i - readForeign _ _ = foreignCCError "[b]" - writeForeign stk l = do - stk <- bump stk - stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l) - -foreignCCError :: String -> IO a -foreignCCError nm = - die $ "mismatched foreign calling convention for `" ++ nm ++ "`" + decodeVal (BoxedVal (Foreign f)) = pure f + decodeVal v = foreignConventionError "Foreign" v + encodeVal f = BoxedVal (Foreign f) + + readAtIndex stk i = bpeekOff stk i >>= \case + Foreign f -> pure f + c -> foreignConventionError "Foreign" (BoxedVal c) + writeBack stk f = bpoke stk (Foreign f) + +instance ForeignConvention a => ForeignConvention [a] where + decodeVal (BoxedVal (Foreign f)) + | (sq :: Sq.Seq Val) <- unwrapForeign f = traverse decodeVal (toList sq) + decodeVal v = foreignConventionError "List" v + + encodeVal l = + BoxedVal . Foreign . Wrap listRef . Sq.fromList $ encodeVal <$> l + + readAtIndex stk i = traverse decodeVal . toList =<< peekOffS stk i + + writeBack stk sq = pokeS stk . Sq.fromList $ encodeVal <$> sq + +instance {-# overlappable #-} (BuiltinForeign b) => ForeignConvention b where + decodeVal = decodeBuiltin + encodeVal = encodeBuiltin + readAtIndex = readBuiltinAt + writeBack = writeBuiltin diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index 330566207d..90768e50fe 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -64,7 +64,9 @@ module Unison.Runtime.Stack USeq, traceK, frameDataSize, + RuntimePanic (..), marshalToForeign, + marshalUnwrapForeignIO, unull, bnull, nullSeg, @@ -134,6 +136,8 @@ module Unison.Runtime.Stack adjustArgs, fsize, asize, + useg, + bseg, -- * Unboxed type tags natTypeTag, @@ -144,6 +148,7 @@ module Unison.Runtime.Stack ) where +import Control.Exception (throwIO) import Control.Monad.Primitive import Data.Char qualified as Char import Data.IORef (IORef) @@ -508,6 +513,18 @@ marshalToForeign (Foreign x) = x marshalToForeign c = error $ "marshalToForeign: unhandled closure: " ++ show c +data RuntimePanic = Panic String (Maybe Val) + deriving (Show) + +instance Exception RuntimePanic + +marshalUnwrapForeignIO :: HasCallStack => Closure -> IO a +marshalUnwrapForeignIO (Foreign x) = pure $ unwrapForeign x +marshalUnwrapForeignIO c = + throwIO $ Panic "marshalUnwrapForeignIO: unhandled closure" (Just v) + where + v = BoxedVal c + type Off = Int type SZ = Int @@ -676,7 +693,9 @@ data Val = Val {getUnboxedVal :: !UVal, getBoxedVal :: !BVal} -- See universalEq. deriving (Show) -instance BuiltinForeign (IORef Val) where foreignRef = Tagged Ty.refRef +instance BuiltinForeign (IORef Val) where + foreignName = Tagged "IORef" + foreignRef = Tagged Ty.refRef -- | A nulled out value you can use when filling empty arrays, etc. emptyVal :: Val diff --git a/unison-runtime/src/Unison/Runtime/TypeTags.hs b/unison-runtime/src/Unison/Runtime/TypeTags.hs index e489138414..e23f172c5e 100644 --- a/unison-runtime/src/Unison/Runtime/TypeTags.hs +++ b/unison-runtime/src/Unison/Runtime/TypeTags.hs @@ -6,6 +6,7 @@ module Unison.Runtime.TypeTags packTags, unpackTags, maskTags, + anyTag, floatTag, natTag, intTag, @@ -13,8 +14,23 @@ module Unison.Runtime.TypeTags unitTag, leftTag, rightTag, + noneTag, + someTag, falseTag, trueTag, + pairTag, + failureTag, + noBufTag, + lineBufTag, + blockBufTag, + sizedBlockBufTag, + readModeTag, + writeModeTag, + appendModeTag, + readWriteModeTag, + seekAbsoluteTag, + seekRelativeTag, + seekEndTag, ) where @@ -134,15 +150,58 @@ falseTag = mkEnumTag "falseTag" Ty.booleanRef 0 trueTag :: PackedTag trueTag = mkEnumTag "trueTag" Ty.booleanRef 1 +pairTag :: PackedTag +pairTag = mkEnumTag "pairTag" Ty.pairRef 0 + +anyTag :: PackedTag +anyTag = mkEnumTag "anyTag" Ty.anyRef 0 + +failureTag :: PackedTag +failureTag = mkEnumTag "failureTag" Ty.failureRef 0 + +noneTag, someTag :: PackedTag +(noneTag, someTag) + | [nt, st] <- + mkTags "optional tags" Ty.optionalRef + [Ty.noneId, Ty.someId] = (nt, st) + | otherwise = error "internal error: optional tags" + leftTag, rightTag :: PackedTag (leftTag, rightTag) - | Just n <- Map.lookup Ty.eitherRef builtinTypeNumbering, - et <- toEnum (fromIntegral n), - lt <- toEnum (fromIntegral Ty.eitherLeftId), - rt <- toEnum (fromIntegral Ty.eitherRightId) = - (packTags et lt, packTags et rt) + | [lt, rt] <- + mkTags "either tags" Ty.eitherRef + [Ty.eitherLeftId, Ty.eitherRightId] = (lt, rt) | otherwise = error "internal error: either tags" +noBufTag, lineBufTag, blockBufTag, sizedBlockBufTag :: PackedTag +(noBufTag, lineBufTag, blockBufTag, sizedBlockBufTag) + | [nt,lt,bt,st] <- + mkTags "buffer mode tags" Ty.bufferModeRef + [ Ty.bufferModeNoBufferingId, + Ty.bufferModeLineBufferingId, + Ty.bufferModeBlockBufferingId, + Ty.bufferModeSizedBlockBufferingId ] = (nt, lt, bt, st) + | otherwise = error "internal error: buffer mode tags" + +readModeTag, writeModeTag, appendModeTag, readWriteModeTag :: PackedTag +(readModeTag, writeModeTag, appendModeTag, readWriteModeTag) + | [rt,wt,at,rwt] <- + mkTags "file mode tags" Ty.fileModeRef + [ Ty.fileModeReadId, + Ty.fileModeWriteId, + Ty.fileModeAppendId, + Ty.fileModeReadWriteId ] = (rt, wt, at, rwt) + | otherwise = error "internal error: file mode tags" + +seekAbsoluteTag, seekRelativeTag, seekEndTag :: PackedTag +(seekAbsoluteTag, seekRelativeTag, seekEndTag) + | [at, rt, et] <- + mkTags "seek mode tags" Ty.seekModeRef + [ Ty.seekModeAbsoluteId, + Ty.seekModeRelativeId, + Ty.seekModeEndId ] = (at, rt, et) + | otherwise = error "internal error: seek mode tags" + -- | Construct a tag for a single-constructor builtin type mkSimpleTag :: String -> Reference -> PackedTag mkSimpleTag msg r = mkEnumTag msg r 0 @@ -153,3 +212,10 @@ mkEnumTag msg r i rt <- toEnum (fromIntegral n) = packTags rt (toEnum i) | otherwise = internalBug $ "internal error: " <> msg + +mkTags :: String -> Reference -> [Word64] -> [PackedTag] +mkTags msg r cs + | Just n <- Map.lookup r builtinTypeNumbering, + tt <- toEnum $ fromIntegral n = + packTags tt . toEnum . fromIntegral <$> cs + | otherwise = error $ "internal error: " ++ msg From cc200c94bd08eeab7d6f0a35117b078ec61176af Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 14 Jan 2025 14:25:28 -0500 Subject: [PATCH 2/7] Add defined tags for Exception --- parser-typechecker/src/Unison/Builtin/Decls.hs | 3 +++ unison-runtime/src/Unison/Runtime/TypeTags.hs | 11 +++++++++++ 2 files changed, 14 insertions(+) diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index 1c09cad84b..d50279f1ad 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -164,6 +164,9 @@ seekModeAbsoluteId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.Ab seekModeRelativeId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.RelativeSeek" seekModeEndId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.SeekFromEnd" +exceptionRaiseId :: ConstructorId +exceptionRaiseId = Maybe.fromJust $ constructorId exceptionRef "Exception.raise" + okConstructorReferent, failConstructorReferent :: Referent.Referent okConstructorReferent = Referent.Con (ConstructorReference testResultRef okConstructorId) CT.Data failConstructorReferent = Referent.Con (ConstructorReference testResultRef failConstructorId) CT.Data diff --git a/unison-runtime/src/Unison/Runtime/TypeTags.hs b/unison-runtime/src/Unison/Runtime/TypeTags.hs index e23f172c5e..d94c73b399 100644 --- a/unison-runtime/src/Unison/Runtime/TypeTags.hs +++ b/unison-runtime/src/Unison/Runtime/TypeTags.hs @@ -31,6 +31,8 @@ module Unison.Runtime.TypeTags seekAbsoluteTag, seekRelativeTag, seekEndTag, + exceptionTag, + exceptionRaiseTag, ) where @@ -202,6 +204,15 @@ seekAbsoluteTag, seekRelativeTag, seekEndTag :: PackedTag Ty.seekModeEndId ] = (at, rt, et) | otherwise = error "internal error: seek mode tags" +exceptionTag :: Word64 +exceptionRaiseTag :: PackedTag +(exceptionTag, exceptionRaiseTag) + | Just n <- Map.lookup Ty.exceptionRef builtinTypeNumbering, + et <- toEnum $ fromIntegral n, + rt <- toEnum $ fromIntegral Ty.exceptionRaiseId = + (n, packTags et rt) + | otherwise = internalBug $ "internal error: Exception tag" + -- | Construct a tag for a single-constructor builtin type mkSimpleTag :: String -> Reference -> PackedTag mkSimpleTag msg r = mkEnumTag msg r 0 From 9472d1fa3be9f1e8b77baf25bd145acd02e5398a Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 14 Jan 2025 14:27:10 -0500 Subject: [PATCH 3/7] Modify foreign declarations and machine implementation for new conventions Most wrappers became obselete for foreigns, and we can just specify how many arguments they take. The foreign functions now have an option for indicating an exceptional result, in which case the returned value is a `Failure`, and the machine will directly call the `Exception` handler using that value. This allows e.g. array operations to have less interpreter overhead. --- unison-runtime/src/Unison/Runtime/Builtin.hs | 1218 ++++------------- .../src/Unison/Runtime/Foreign/Function.hs | 82 +- unison-runtime/src/Unison/Runtime/Machine.hs | 96 +- unison-runtime/src/Unison/Runtime/Stack.hs | 14 + 4 files changed, 415 insertions(+), 995 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 6752dcbd34..67a4d26824 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -138,13 +138,6 @@ seqViewEmpty = TCon Ty.seqViewRef (fromIntegral Ty.seqViewEmpty) [] seqViewElem :: (Var v) => v -> v -> ANormal v seqViewElem l r = TCon Ty.seqViewRef (fromIntegral Ty.seqViewElem) [l, r] -unenum :: (Var v) => Int -> v -> Reference -> v -> ANormal v -> ANormal v -unenum n v0 r v nx = - TMatch v0 $ MatchData r cases Nothing - where - mkCase i = (toEnum i, ([], TLetD v UN (TLit . I $ fromIntegral i) nx)) - cases = mapFromList . fmap mkCase $ [0 .. n - 1] - unop0 :: (Var v) => Int -> ([v] -> ANormal v) -> SuperNormal v unop0 n f = Lambda [BX] @@ -745,15 +738,6 @@ stm'atomic = type ForeignOp = ForeignFunc -> ([Mem], ANormal Symbol) -standard'handle :: ForeignOp -standard'handle instr = - ([BX],) - . TAbss [h0] - . unenum 3 h0 Ty.stdHandleRef h - $ TFOp instr [h] - where - (h0, h) = fresh - any'construct :: SuperNormal Symbol any'construct = unop0 0 $ \[v] -> @@ -813,123 +797,6 @@ ref'readForCas = unop0 0 $ TPrm RRFC ref'new :: SuperNormal Symbol ref'new = unop0 0 $ TPrm REFN -seek'handle :: ForeignOp -seek'handle instr = - ([BX, BX, BX],) - . TAbss [arg1, arg2, arg3] - . unenum 3 arg2 Ty.seekModeRef seek - . TLetD result UN (TFOp instr [arg1, seek, arg3]) - $ outIoFailUnit stack1 stack2 stack3 unit fail result - where - (arg1, arg2, arg3, seek, stack1, stack2, stack3, unit, fail, result) = fresh - -no'buf, line'buf, block'buf, sblock'buf :: (Enum e) => e -no'buf = toEnum $ fromIntegral Ty.bufferModeNoBufferingId -line'buf = toEnum $ fromIntegral Ty.bufferModeLineBufferingId -block'buf = toEnum $ fromIntegral Ty.bufferModeBlockBufferingId -sblock'buf = toEnum $ fromIntegral Ty.bufferModeSizedBlockBufferingId - -infixr 0 --> - -(-->) :: a -> b -> (a, b) -x --> y = (x, y) - -time'zone :: ForeignOp -time'zone instr = - ([BX],) - . TAbss [secs] - . TLets Direct [offset, summer, name] [UN, UN, BX] (TFOp instr [secs]) - . TLetD un BX (TCon Ty.unitRef 0 []) - . TLetD p2 BX (TCon Ty.pairRef 0 [name, un]) - . TLetD p1 BX (TCon Ty.pairRef 0 [summer, p2]) - $ TCon Ty.pairRef 0 [offset, p1] - where - (secs, offset, summer, name, un, p2, p1) = fresh - -start'process :: ForeignOp -start'process instr = - ([BX, BX],) - . TAbss [exe, args] - . TLets Direct [hin, hout, herr, hproc] [BX, BX, BX, BX] (TFOp instr [exe, args]) - . TLetD un BX (TCon Ty.unitRef 0 []) - . TLetD p3 BX (TCon Ty.pairRef 0 [hproc, un]) - . TLetD p2 BX (TCon Ty.pairRef 0 [herr, p3]) - . TLetD p1 BX (TCon Ty.pairRef 0 [hout, p2]) - $ TCon Ty.pairRef 0 [hin, p1] - where - (exe, args, hin, hout, herr, hproc, un, p3, p2, p1) = fresh - -set'buffering :: ForeignOp -set'buffering instr = - ([BX, BX],) - . TAbss [handle, bmode] - . TMatch bmode - . MatchDataCover Ty.bufferModeRef - $ mapFromList - [ no'buf --> [] --> k1 no'buf, - line'buf --> [] --> k1 line'buf, - block'buf --> [] --> k1 block'buf, - sblock'buf - --> [BX] - --> TAbs n - . TMatch n - . MatchDataCover Ty.bufferModeRef - $ mapFromList - [ 0 - --> [UN] - --> TAbs w - . TLetD tag UN (TLit (N sblock'buf)) - $ k2 [tag, w] - ] - ] - where - k1 num = - TLetD tag UN (TLit (N num)) $ - k2 [tag] - k2 args = - TLetD r UN (TFOp instr (handle : args)) $ - outIoFailUnit s1 s2 s3 u f r - (handle, bmode, tag, n, w, s1, s2, s3, u, f, r) = fresh - -get'buffering'output :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v -get'buffering'output eitherResult stack1 stack2 stack3 resultTag anyVar failVar successVar = - TMatch eitherResult . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 anyVar failVar, - ( 1, - ([UN],) - . TAbs resultTag - . TMatch resultTag - . MatchSum - $ mapFromList - [ no'buf - --> [] - --> TLetD successVar BX (TCon Ty.bufferModeRef no'buf []) - $ right successVar, - line'buf - --> [] - --> TLetD successVar BX (TCon Ty.bufferModeRef line'buf []) - $ right successVar, - block'buf - --> [] - --> TLetD successVar BX (TCon Ty.bufferModeRef block'buf []) - $ right successVar, - sblock'buf - --> [UN] - --> TAbs stack1 - . TLetD successVar BX (TCon Ty.bufferModeRef sblock'buf [stack1]) - $ right successVar - ] - ) - ] - -get'buffering :: ForeignOp -get'buffering = - in1 arg1 eitherResult $ - get'buffering'output eitherResult n n2 n3 resultTag anyVar failVar successVar - where - (arg1, eitherResult, n, n2, n3, resultTag, anyVar, failVar, successVar) = fresh - crypto'hash :: ForeignOp crypto'hash instr = ([BX, BX],) @@ -957,161 +824,6 @@ crypto'hmac instr = where (alg, by, x, vl) = fresh --- Input Shape -- these represent different argument lists a --- foreign might expect --- --- They are named according to their shape: --- inUnit : one input arg, unit output --- in1 : one input arg --- --- All of these functions will have take (at least) the same three arguments --- --- instr : the foreign instruction to call --- result : a variable containing the result of the foreign call --- cont : a term which will be evaluated when a result from the foreign call is on the stack --- - --- () -> ... -inUnit :: forall v. (Var v) => v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) -inUnit unit result cont instr = - ([BX], TAbs unit $ TLetD result UN (TFOp instr []) cont) - -inN :: forall v. (Var v) => [v] -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) -inN args result cont instr = - (args $> BX,) - . TAbss args - $ TLetD result UN (TFOp instr args) cont - --- a -> ... -in1 :: forall v. (Var v) => v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) -in1 arg result cont instr = inN [arg] result cont instr - --- a -> b -> ... -in2 :: forall v. (Var v) => v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) -in2 arg1 arg2 result cont instr = inN [arg1, arg2] result cont instr - --- a -> b -> c -> ... -in3 :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) -in3 arg1 arg2 arg3 result cont instr = inN [arg1, arg2, arg3] result cont instr - --- Maybe a -> b -> ... -inMaybeBx :: forall v. (Var v) => v -> v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) -inMaybeBx arg1 arg2 arg3 mb result cont instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . TMatch arg1 - . flip (MatchData Ty.optionalRef) Nothing - $ mapFromList - [ ( fromIntegral Ty.noneId, - ( [], - TLetD mb UN (TLit $ I 0) $ - TLetD result UN (TFOp instr [mb, arg2]) cont - ) - ), - (fromIntegral Ty.someId, ([BX], TAbs arg3 . TLetD mb UN (TLit $ I 1) $ TLetD result UN (TFOp instr [mb, arg3, arg2]) cont)) - ] - -set'echo :: ForeignOp -set'echo instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . TLetD result UN (TFOp instr [arg1, arg2]) - $ outIoFailUnit stack1 stack2 stack3 unit fail result - where - (arg1, arg2, stack1, stack2, stack3, unit, fail, result) = fresh - --- a -> IOMode -> ... -inIomr :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) -inIomr arg1 arg2 fm result cont instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . unenum 4 arg2 Ty.fileModeRef fm - $ TLetD result UN (TFOp instr [arg1, fm]) cont - --- Output Shape -- these will represent different ways of translating --- the result of a foreign call to a Unison Term --- --- They will be named according to the output type --- outInt : a foreign function returning an Int --- outBool : a foreign function returning a boolean --- outIOFail : a function returning (Either Failure a) --- --- All of these functions will take a Var named result containing the --- result of the foreign call --- - -outMaybe :: forall v. (Var v) => v -> v -> ANormal v -outMaybe tag result = - TMatch tag . MatchSum $ - mapFromList - [ (0, ([], none)), - (1, ([BX], TAbs result $ some result)) - ] - -outMaybeNTup :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outMaybeNTup a b u bp p result = - TMatch result . MatchSum $ - mapFromList - [ (0, ([], none)), - ( 1, - ( [UN, BX], - TAbss [a, b] - . TLetD u BX (TCon Ty.unitRef 0 []) - . TLetD bp BX (TCon Ty.pairRef 0 [b, u]) - . TLetD p BX (TCon Ty.pairRef 0 [a, bp]) - $ some p - ) - ) - ] - -outMaybeTup :: (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outMaybeTup a b u bp ap result = - TMatch result . MatchSum $ - mapFromList - [ (0, ([], none)), - ( 1, - ( [BX, BX], - TAbss [a, b] - . TLetD u BX (TCon Ty.unitRef 0 []) - . TLetD bp BX (TCon Ty.pairRef 0 [b, u]) - . TLetD ap BX (TCon Ty.pairRef 0 [a, bp]) - $ some ap - ) - ) - ] - --- Note: the Io part doesn't really do anything. There's no actual --- representation of `IO`. -outIoFail :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFail stack1 stack2 stack3 any fail result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 any fail, - (1, ([BX], TAbs stack1 $ right stack1)) - ] - -outIoFailChar :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailChar stack1 stack2 stack3 fail extra result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 extra fail, - ( 1, - ([UN],) - . TAbs extra - $ right extra - ) - ] - -failureCase :: - (Var v) => v -> v -> v -> v -> v -> (Word64, ([Mem], ANormal v)) -failureCase stack1 stack2 stack3 any fail = - (0,) - . ([BX, BX, BX],) - . TAbss [stack1, stack2, stack3] - . TLetD any BX (TCon Ty.anyRef 0 [stack3]) - . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2, any]) - $ left fail - exnCase :: (Var v) => v -> v -> v -> v -> v -> (Word64, ([Mem], ANormal v)) exnCase stack1 stack2 stack3 any fail = @@ -1122,103 +834,6 @@ exnCase stack1 stack2 stack3 any fail = . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2, any]) $ TReq Ty.exceptionRef 0 [fail] -outIoExnUnit :: - forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoExnUnit stack1 stack2 stack3 any fail result = - TMatch result . MatchSum $ - mapFromList - [ exnCase stack1 stack2 stack3 any fail, - (1, ([], TCon Ty.unitRef 0 [])) - ] - -outIoExn :: - (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoExn stack1 stack2 stack3 any fail result = - TMatch result . MatchSum $ - mapFromList - [ exnCase stack1 stack2 stack3 any fail, - (1, ([BX], TAbs stack1 $ TVar stack1)) - ] - -outIoExnEither :: - (Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v -outIoExnEither stack1 stack2 stack3 any fail t0 t1 res = - TMatch t0 . MatchSum $ - mapFromList - [ exnCase stack1 stack2 stack3 any fail, - ( 1, - ([UN],) - . TAbs t1 - . TMatch t1 - . MatchSum - $ mapFromList - [ (0, ([BX], TAbs res $ left res)), - (1, ([BX], TAbs res $ right res)) - ] - ) - ] - -outIoFailUnit :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailUnit stack1 stack2 stack3 extra fail result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 extra fail, - ( 1, - ([],) - . TLetD extra BX (TCon Ty.unitRef 0 []) - $ right extra - ) - ] - -outIoFailBool :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailBool stack1 stack2 stack3 extra fail result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 extra fail, - ( 1, - ([UN],) - . TAbs stack3 - $ right stack3 - ) - ] - -outIoFailTup :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v -outIoFailTup stack1 stack2 stack3 stack4 stack5 extra fail result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 extra fail, - ( 1, - ( [BX, BX], - TAbss [stack1, stack2] - . TLetD stack3 BX (TCon Ty.unitRef 0 []) - . TLetD stack4 BX (TCon Ty.pairRef 0 [stack2, stack3]) - . TLetD stack5 BX (TCon Ty.pairRef 0 [stack1, stack4]) - $ right stack5 - ) - ) - ] - -outIoFailG :: - (Var v) => - v -> - v -> - v -> - v -> - v -> - v -> - ((ANormal v -> ANormal v) -> ([Mem], ANormal v)) -> - ANormal v -outIoFailG stack1 stack2 stack3 fail result output k = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 output fail, - ( 1, - k $ \t -> - TLetD output BX t $ - right output - ) - ] - -- Input / Output glue -- -- These are pairings of input and output functions to handle a @@ -1231,44 +846,6 @@ outIoFailG stack1 stack2 stack3 fail result output k = direct :: ForeignOp direct instr = ([], TFOp instr []) --- () -> r -unitToR :: ForeignOp -unitToR = - inUnit unit result $ TVar result - where - (unit, result) = fresh - --- () -> Either Failure a -unitToEF :: ForeignOp -unitToEF = - inUnit unit result $ - outIoFail stack1 stack2 stack3 any fail result - where - (unit, stack1, stack2, stack3, fail, any, result) = fresh - -argIomrToEF :: ForeignOp -argIomrToEF = - inIomr arg1 arg2 enum result $ - outIoFail stack1 stack2 stack3 any fail result - where - (arg1, arg2, enum, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> () -argToUnit :: ForeignOp -argToUnit = in1 arg result (TCon Ty.unitRef 0 []) - where - (arg, result) = fresh - --- a -> b ->{E} () -arg2To0 :: ForeignOp -arg2To0 instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . TLets Direct [] [] (TFOp instr [arg1, arg2]) - $ TCon Ty.unitRef 0 [] - where - (arg1, arg2) = fresh - argNDirect :: Int -> ForeignOp argNDirect n instr = (replicate n BX,) @@ -1283,222 +860,6 @@ argNDirect n instr = unitDirect :: ForeignOp unitDirect instr = ([BX],) . TAbs arg $ TFOp instr [] where arg = fresh1 --- a -> Either Failure b -argToEF :: ForeignOp -argToEF = - in1 arg result $ - outIoFail stack1 stack2 stack3 any fail result - where - (arg, result, stack1, stack2, stack3, any, fail) = fresh - --- a -> Either Failure (b, c) -argToEFTup :: ForeignOp -argToEFTup = - in1 arg result $ - outIoFailTup stack1 stack2 stack3 stack4 stack5 extra fail result - where - (arg, result, stack1, stack2, stack3, stack4, stack5, extra, fail) = fresh - --- a -> Either Failure (Maybe b) -argToEFM :: ForeignOp -argToEFM = - in1 arg result - . outIoFailG stack1 stack2 stack3 fail result output - $ \k -> - ( [UN], - TAbs stack3 . TMatch stack3 . MatchSum $ - mapFromList - [ (0, ([], k $ none)), - (1, ([BX], TAbs stack4 . k $ some stack4)) - ] - ) - where - (arg, result, stack1, stack2, stack3, stack4, fail, output) = fresh - --- a -> Maybe b -argToMaybe :: ForeignOp -argToMaybe = in1 arg tag $ outMaybe tag result - where - (arg, tag, result) = fresh - --- a -> Maybe (Nat, b) -argToMaybeNTup :: ForeignOp -argToMaybeNTup = - in1 arg result $ outMaybeNTup a b u bp p result - where - (arg, a, b, u, bp, p, result) = fresh - --- a -> b -> Maybe (c, d) -arg2ToMaybeTup :: ForeignOp -arg2ToMaybeTup = - in2 arg1 arg2 result $ outMaybeTup a b u bp ap result - where - (arg1, arg2, a, b, u, bp, ap, result) = fresh - --- a -> Either Failure Bool -argToEFBool :: ForeignOp -argToEFBool = - in1 arg result $ - outIoFailBool stack1 stack2 stack3 bool fail result - where - (arg, stack1, stack2, stack3, bool, fail, result) = fresh - --- a -> Either Failure Char -argToEFChar :: ForeignOp -argToEFChar = - in1 arg result $ - outIoFailChar stack1 stack2 stack3 bool fail result - where - (arg, stack1, stack2, stack3, bool, fail, result) = fresh - --- a -> b -> Either Failure Bool -arg2ToEFBool :: ForeignOp -arg2ToEFBool = - in2 arg1 arg2 result $ - outIoFailBool stack1 stack2 stack3 bool fail result - where - (arg1, arg2, stack1, stack2, stack3, bool, fail, result) = fresh - --- a -> b -> c -> Either Failure Bool -arg3ToEFBool :: ForeignOp -arg3ToEFBool = - in3 arg1 arg2 arg3 result $ - outIoFailBool stack1 stack2 stack3 bool fail result - where - (arg1, arg2, arg3, stack1, stack2, stack3, bool, fail, result) = fresh - --- a -> Either Failure () -argToEF0 :: ForeignOp -argToEF0 = - in1 arg result $ - outIoFailUnit stack1 stack2 stack3 unit fail result - where - (arg, result, stack1, stack2, stack3, unit, fail) = fresh - --- a -> b -> Either Failure () -arg2ToEF0 :: ForeignOp -arg2ToEF0 = - in2 arg1 arg2 result $ - outIoFailUnit stack1 stack2 stack3 fail unit result - where - (arg1, arg2, result, stack1, stack2, stack3, fail, unit) = fresh - --- a -> b -> c -> Either Failure () -arg3ToEF0 :: ForeignOp -arg3ToEF0 = - in3 arg1 arg2 arg3 result $ - outIoFailUnit stack1 stack2 stack3 fail unit result - where - (arg1, arg2, arg3, result, stack1, stack2, stack3, fail, unit) = fresh - --- a -> Either Failure b -argToEFNat :: ForeignOp -argToEFNat = - in1 arg result $ - outIoFail stack1 stack2 stack3 nat fail result - where - (arg, result, stack1, stack2, stack3, nat, fail) = fresh - --- Maybe a -> b -> Either Failure c -maybeToEF :: ForeignOp -maybeToEF = - inMaybeBx arg1 arg2 arg3 mb result $ - outIoFail stack1 stack2 stack3 any fail result - where - (arg1, arg2, arg3, mb, result, stack1, stack2, stack3, any, fail) = fresh - --- a -> b -> Either Failure c -arg2ToEF :: ForeignOp -arg2ToEF = - in2 arg1 arg2 result $ - outIoFail stack1 stack2 stack3 any fail result - where - (arg1, arg2, result, stack1, stack2, stack3, any, fail) = fresh - --- a -> b -> c -> Either Failure d -arg3ToEF :: ForeignOp -arg3ToEF = - in3 arg1 arg2 arg3 result $ - outIoFail stack1 stack2 stack3 any fail result - where - (arg1, arg2, arg3, result, stack1, stack2, stack3, any, fail) = fresh - --- a -> b ->{Exception} c -arg2ToExn :: ForeignOp -arg2ToExn = - in2 arg1 arg2 result $ - outIoExn stack1 stack2 stack3 any fail result - where - (arg1, arg2, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> b -> c ->{Exception} () -arg3ToExnUnit :: ForeignOp -arg3ToExnUnit = - in3 arg1 arg2 arg3 result $ - outIoExnUnit stack1 stack2 stack3 any fail result - where - (arg1, arg2, arg3, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> Nat -> Nat ->{Exception} b -arg3ToExn :: ForeignOp -arg3ToExn = - in3 arg1 arg2 arg3 result $ - outIoExn stack1 stack2 stack3 any fail result - where - (arg1, arg2, arg3, result, stack1, stack2, stack3, any, fail) = fresh - --- a -> Nat -> b -> Nat -> Nat ->{Exception} () -arg5ToExnUnit :: ForeignOp -arg5ToExnUnit instr = - ([BX, BX, BX, BX, BX],) - . TAbss [a0, ua1, a2, ua3, ua4] - . TLetD result UN (TFOp instr [a0, ua1, a2, ua3, ua4]) - $ outIoExnUnit stack1 stack2 stack3 any fail result - where - (a0, a2, ua1, ua3, ua4, result, stack1, stack2, stack3, any, fail) = fresh - --- a ->{Exception} Either b c -argToExnE :: ForeignOp -argToExnE instr = - ([BX],) - . TAbs a - . TLetD t0 UN (TFOp instr [a]) - $ outIoExnEither stack1 stack2 stack3 any fail t0 t1 result - where - (a, stack1, stack2, stack3, any, fail, t0, t1, result) = fresh - --- Nat -> Either Failure () -argToEFUnit :: ForeignOp -argToEFUnit = - in1 nat result - . TMatch result - . MatchSum - $ mapFromList - [ failureCase stack1 stack2 stack3 unit fail, - ( 1, - ([],) - . TLetD unit BX (TCon Ty.unitRef 0 []) - $ right unit - ) - ] - where - (nat, result, fail, stack1, stack2, stack3, unit) = fresh - --- a -> Either b c -argToEither :: ForeignOp -argToEither instr = - ([BX],) - . TAbss [b] - . TLetD e UN (TFOp instr [b]) - . TMatch e - . MatchSum - $ mapFromList - [ (0, ([BX], TAbs ev $ left ev)), - (1, ([BX], TAbs ev $ right ev)) - ] - where - (e, b, ev) = fresh - builtinLookup :: Map.Map Reference (Sandbox, SuperNormal Symbol) builtinLookup = Map.fromList @@ -1698,15 +1059,26 @@ type FDecl v = State (Map ForeignFunc (Sandbox, SuperNormal v)) data Sandbox = Tracked | Untracked deriving (Eq, Ord, Show, Read, Enum, Bounded) -declareForeign :: +declareForeignWrap :: Sandbox -> ForeignOp -> ForeignFunc -> FDecl Symbol () -declareForeign sand op func = do - modify $ \funcs -> - let code = uncurry Lambda (op func) - in (Map.insert func (sand, code) funcs) +declareForeignWrap sand wrap func = + modify $ Map.insert func (sand, code) + where + code = uncurry Lambda (wrap func) + +declareForeign :: + Sandbox -> + Int -> + ForeignFunc -> + FDecl Symbol () +declareForeign sand arity func = declareForeignWrap sand wrap func + where + -- Special case: turn 0-arg foreigns into unit-accepting functions + wrap | 0 == arity = unitDirect + | otherwise = argNDirect arity unitValue :: Val unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) @@ -1716,367 +1088,367 @@ natValue w = NatVal w declareUdpForeigns :: FDecl Symbol () declareUdpForeigns = do - declareForeign Tracked arg2ToEF IO_UDP_clientSocket_impl_v1 + declareForeign Tracked 2 IO_UDP_clientSocket_impl_v1 - declareForeign Tracked argToEF IO_UDP_UDPSocket_recv_impl_v1 + declareForeign Tracked 1 IO_UDP_UDPSocket_recv_impl_v1 - declareForeign Tracked arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 - declareForeign Tracked argToEF0 IO_UDP_UDPSocket_close_impl_v1 + declareForeign Tracked 2 IO_UDP_UDPSocket_send_impl_v1 + declareForeign Tracked 1 IO_UDP_UDPSocket_close_impl_v1 - declareForeign Tracked argToEF0 IO_UDP_ListenSocket_close_impl_v1 + declareForeign Tracked 1 IO_UDP_ListenSocket_close_impl_v1 - declareForeign Tracked (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 + declareForeign Tracked 1 IO_UDP_UDPSocket_toText_impl_v1 - declareForeign Tracked arg2ToEF IO_UDP_serverSocket_impl_v1 + declareForeign Tracked 2 IO_UDP_serverSocket_impl_v1 - declareForeign Tracked (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 + declareForeign Tracked 1 IO_UDP_ListenSocket_toText_impl_v1 - declareForeign Tracked argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 + declareForeign Tracked 1 IO_UDP_ListenSocket_recvFrom_impl_v1 - declareForeign Tracked (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 + declareForeign Tracked 1 IO_UDP_ClientSockAddr_toText_v1 - declareForeign Tracked arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 + declareForeign Tracked 3 IO_UDP_ListenSocket_sendTo_impl_v1 declareForeigns :: FDecl Symbol () declareForeigns = do declareUdpForeigns - declareForeign Tracked argIomrToEF IO_openFile_impl_v3 + declareForeign Tracked 1 IO_openFile_impl_v3 - declareForeign Tracked argToEF0 IO_closeFile_impl_v3 - declareForeign Tracked argToEFBool IO_isFileEOF_impl_v3 - declareForeign Tracked argToEFBool IO_isFileOpen_impl_v3 - declareForeign Tracked argToEFBool IO_getEcho_impl_v1 - declareForeign Tracked argToEFBool IO_ready_impl_v1 - declareForeign Tracked argToEFChar IO_getChar_impl_v1 - declareForeign Tracked argToEFBool IO_isSeekable_impl_v3 + declareForeign Tracked 1 IO_closeFile_impl_v3 + declareForeign Tracked 1 IO_isFileEOF_impl_v3 + declareForeign Tracked 1 IO_isFileOpen_impl_v3 + declareForeign Tracked 1 IO_getEcho_impl_v1 + declareForeign Tracked 1 IO_ready_impl_v1 + declareForeign Tracked 1 IO_getChar_impl_v1 + declareForeign Tracked 1 IO_isSeekable_impl_v3 - declareForeign Tracked seek'handle IO_seekHandle_impl_v3 + declareForeign Tracked 3 IO_seekHandle_impl_v3 - declareForeign Tracked argToEFNat IO_handlePosition_impl_v3 + declareForeign Tracked 1 IO_handlePosition_impl_v3 - declareForeign Tracked get'buffering IO_getBuffering_impl_v3 + declareForeign Tracked 1 IO_getBuffering_impl_v3 - declareForeign Tracked set'buffering IO_setBuffering_impl_v3 + declareForeign Tracked 2 IO_setBuffering_impl_v3 - declareForeign Tracked set'echo IO_setEcho_impl_v1 + declareForeign Tracked 2 IO_setEcho_impl_v1 - declareForeign Tracked argToEF IO_getLine_impl_v1 + declareForeign Tracked 1 IO_getLine_impl_v1 - declareForeign Tracked arg2ToEF IO_getBytes_impl_v3 - declareForeign Tracked arg2ToEF IO_getSomeBytes_impl_v1 - declareForeign Tracked arg2ToEF0 IO_putBytes_impl_v3 - declareForeign Tracked unitToEF IO_systemTime_impl_v3 + declareForeign Tracked 2 IO_getBytes_impl_v3 + declareForeign Tracked 2 IO_getSomeBytes_impl_v1 + declareForeign Tracked 2 IO_putBytes_impl_v3 + declareForeign Tracked 0 IO_systemTime_impl_v3 - declareForeign Tracked unitToR IO_systemTimeMicroseconds_v1 + declareForeign Tracked 0 IO_systemTimeMicroseconds_v1 - declareForeign Tracked unitToEF Clock_internals_monotonic_v1 + declareForeign Tracked 0 Clock_internals_monotonic_v1 - declareForeign Tracked unitToEF Clock_internals_realtime_v1 + declareForeign Tracked 0 Clock_internals_realtime_v1 - declareForeign Tracked unitToEF Clock_internals_processCPUTime_v1 + declareForeign Tracked 0 Clock_internals_processCPUTime_v1 - declareForeign Tracked unitToEF Clock_internals_threadCPUTime_v1 + declareForeign Tracked 0 Clock_internals_threadCPUTime_v1 - declareForeign Tracked (argNDirect 1) Clock_internals_sec_v1 + declareForeign Tracked 1 Clock_internals_sec_v1 -- A TimeSpec that comes from getTime never has negative nanos, -- so we can safely cast to Nat - declareForeign Tracked (argNDirect 1) Clock_internals_nsec_v1 + declareForeign Tracked 1 Clock_internals_nsec_v1 - declareForeign Tracked time'zone Clock_internals_systemTimeZone_v1 + declareForeign Tracked 1 Clock_internals_systemTimeZone_v1 - declareForeign Tracked unitToEF IO_getTempDirectory_impl_v3 + declareForeign Tracked 0 IO_getTempDirectory_impl_v3 - declareForeign Tracked argToEF IO_createTempDirectory_impl_v3 + declareForeign Tracked 1 IO_createTempDirectory_impl_v3 - declareForeign Tracked unitToEF IO_getCurrentDirectory_impl_v3 + declareForeign Tracked 0 IO_getCurrentDirectory_impl_v3 - declareForeign Tracked argToEF0 IO_setCurrentDirectory_impl_v3 + declareForeign Tracked 1 IO_setCurrentDirectory_impl_v3 - declareForeign Tracked argToEFBool IO_fileExists_impl_v3 + declareForeign Tracked 1 IO_fileExists_impl_v3 - declareForeign Tracked argToEF IO_getEnv_impl_v1 + declareForeign Tracked 1 IO_getEnv_impl_v1 - declareForeign Tracked unitToEF IO_getArgs_impl_v1 + declareForeign Tracked 0 IO_getArgs_impl_v1 - declareForeign Tracked argToEFBool IO_isDirectory_impl_v3 + declareForeign Tracked 1 IO_isDirectory_impl_v3 - declareForeign Tracked argToEF0 IO_createDirectory_impl_v3 + declareForeign Tracked 1 IO_createDirectory_impl_v3 - declareForeign Tracked argToEF0 IO_removeDirectory_impl_v3 + declareForeign Tracked 1 IO_removeDirectory_impl_v3 - declareForeign Tracked arg2ToEF0 IO_renameDirectory_impl_v3 + declareForeign Tracked 2 IO_renameDirectory_impl_v3 - declareForeign Tracked argToEF IO_directoryContents_impl_v3 + declareForeign Tracked 1 IO_directoryContents_impl_v3 - declareForeign Tracked argToEF0 IO_removeFile_impl_v3 + declareForeign Tracked 1 IO_removeFile_impl_v3 - declareForeign Tracked arg2ToEF0 IO_renameFile_impl_v3 + declareForeign Tracked 2 IO_renameFile_impl_v3 - declareForeign Tracked argToEFNat IO_getFileTimestamp_impl_v3 + declareForeign Tracked 1 IO_getFileTimestamp_impl_v3 - declareForeign Tracked argToEFNat IO_getFileSize_impl_v3 + declareForeign Tracked 1 IO_getFileSize_impl_v3 - declareForeign Tracked maybeToEF IO_serverSocket_impl_v3 + declareForeign Tracked 2 IO_serverSocket_impl_v3 - declareForeign Tracked (argNDirect 1) Socket_toText + declareForeign Tracked 1 Socket_toText - declareForeign Tracked (argNDirect 1) Handle_toText + declareForeign Tracked 1 Handle_toText - declareForeign Tracked (argNDirect 1) ThreadId_toText + declareForeign Tracked 1 ThreadId_toText - declareForeign Tracked argToEFNat IO_socketPort_impl_v3 + declareForeign Tracked 1 IO_socketPort_impl_v3 - declareForeign Tracked argToEF0 IO_listen_impl_v3 + declareForeign Tracked 1 IO_listen_impl_v3 - declareForeign Tracked arg2ToEF IO_clientSocket_impl_v3 + declareForeign Tracked 2 IO_clientSocket_impl_v3 - declareForeign Tracked argToEF0 IO_closeSocket_impl_v3 + declareForeign Tracked 1 IO_closeSocket_impl_v3 - declareForeign Tracked argToEF IO_socketAccept_impl_v3 + declareForeign Tracked 1 IO_socketAccept_impl_v3 - declareForeign Tracked arg2ToEF0 IO_socketSend_impl_v3 + declareForeign Tracked 2 IO_socketSend_impl_v3 - declareForeign Tracked arg2ToEF IO_socketReceive_impl_v3 + declareForeign Tracked 2 IO_socketReceive_impl_v3 - declareForeign Tracked argToEF0 IO_kill_impl_v3 + declareForeign Tracked 1 IO_kill_impl_v3 - declareForeign Tracked argToEFUnit IO_delay_impl_v3 + declareForeign Tracked 1 IO_delay_impl_v3 - declareForeign Tracked standard'handle IO_stdHandle + declareForeign Tracked 1 IO_stdHandle - declareForeign Tracked (argNDirect 2) IO_process_call + declareForeign Tracked 2 IO_process_call - declareForeign Tracked start'process IO_process_start + declareForeign Tracked 2 IO_process_start - declareForeign Tracked argToUnit IO_process_kill + declareForeign Tracked 1 IO_process_kill - declareForeign Tracked (argNDirect 1) IO_process_wait + declareForeign Tracked 1 IO_process_wait - declareForeign Tracked argToMaybe IO_process_exitCode - declareForeign Tracked (argNDirect 1) MVar_new + declareForeign Tracked 1 IO_process_exitCode + declareForeign Tracked 1 MVar_new - declareForeign Tracked unitDirect MVar_newEmpty_v2 + declareForeign Tracked 0 MVar_newEmpty_v2 - declareForeign Tracked argToEF MVar_take_impl_v3 + declareForeign Tracked 1 MVar_take_impl_v3 - declareForeign Tracked argToMaybe MVar_tryTake + declareForeign Tracked 1 MVar_tryTake - declareForeign Tracked arg2ToEF0 MVar_put_impl_v3 + declareForeign Tracked 2 MVar_put_impl_v3 - declareForeign Tracked arg2ToEFBool MVar_tryPut_impl_v3 + declareForeign Tracked 2 MVar_tryPut_impl_v3 - declareForeign Tracked arg2ToEF MVar_swap_impl_v3 + declareForeign Tracked 2 MVar_swap_impl_v3 - declareForeign Tracked (argNDirect 1) MVar_isEmpty + declareForeign Tracked 1 MVar_isEmpty - declareForeign Tracked argToEF MVar_read_impl_v3 + declareForeign Tracked 1 MVar_read_impl_v3 - declareForeign Tracked argToEFM MVar_tryRead_impl_v3 + declareForeign Tracked 1 MVar_tryRead_impl_v3 - declareForeign Untracked (argNDirect 1) Char_toText - declareForeign Untracked (argNDirect 2) Text_repeat - declareForeign Untracked (argNDirect 1) Text_reverse - declareForeign Untracked (argNDirect 1) Text_toUppercase - declareForeign Untracked (argNDirect 1) Text_toLowercase - declareForeign Untracked (argNDirect 1) Text_toUtf8 - declareForeign Untracked argToEF Text_fromUtf8_impl_v3 - declareForeign Tracked (argNDirect 2) Tls_ClientConfig_default - declareForeign Tracked (argNDirect 2) Tls_ServerConfig_default - declareForeign Tracked (argNDirect 2) Tls_ClientConfig_certificates_set + declareForeign Untracked 1 Char_toText + declareForeign Untracked 2 Text_repeat + declareForeign Untracked 1 Text_reverse + declareForeign Untracked 1 Text_toUppercase + declareForeign Untracked 1 Text_toLowercase + declareForeign Untracked 1 Text_toUtf8 + declareForeign Untracked 1 Text_fromUtf8_impl_v3 + declareForeign Tracked 2 Tls_ClientConfig_default + declareForeign Tracked 2 Tls_ServerConfig_default + declareForeign Tracked 2 Tls_ClientConfig_certificates_set - declareForeign Tracked (argNDirect 2) Tls_ServerConfig_certificates_set + declareForeign Tracked 2 Tls_ServerConfig_certificates_set - declareForeign Tracked (argNDirect 1) TVar_new + declareForeign Tracked 1 TVar_new - declareForeign Tracked (argNDirect 1) TVar_read - declareForeign Tracked arg2To0 TVar_write - declareForeign Tracked (argNDirect 1) TVar_newIO + declareForeign Tracked 1 TVar_read + declareForeign Tracked 2 TVar_write + declareForeign Tracked 1 TVar_newIO - declareForeign Tracked (argNDirect 1) TVar_readIO - declareForeign Tracked (argNDirect 2) TVar_swap - declareForeign Tracked unitDirect STM_retry - declareForeign Tracked unitDirect Promise_new + declareForeign Tracked 1 TVar_readIO + declareForeign Tracked 2 TVar_swap + declareForeign Tracked 0 STM_retry + declareForeign Tracked 0 Promise_new -- the only exceptions from Promise.read are async and shouldn't be caught - declareForeign Tracked (argNDirect 1) Promise_read - declareForeign Tracked argToMaybe Promise_tryRead - - declareForeign Tracked (argNDirect 2) Promise_write - declareForeign Tracked arg2ToEF Tls_newClient_impl_v3 - declareForeign Tracked arg2ToEF Tls_newServer_impl_v3 - declareForeign Tracked argToEF0 Tls_handshake_impl_v3 - declareForeign Tracked arg2ToEF0 Tls_send_impl_v3 - declareForeign Tracked argToEF Tls_decodeCert_impl_v3 - - declareForeign Tracked (argNDirect 1) Tls_encodeCert - - declareForeign Tracked (argNDirect 1) Tls_decodePrivateKey - declareForeign Tracked (argNDirect 1) Tls_encodePrivateKey - - declareForeign Tracked argToEF Tls_receive_impl_v3 - - declareForeign Tracked argToEF0 Tls_terminate_impl_v3 - declareForeign Untracked argToExnE Code_validateLinks - declareForeign Untracked (argNDirect 1) Code_dependencies - declareForeign Untracked (argNDirect 1) Code_serialize - declareForeign Untracked argToEither Code_deserialize - declareForeign Untracked (argNDirect 2) Code_display - declareForeign Untracked (argNDirect 1) Value_dependencies - declareForeign Untracked (argNDirect 1) Value_serialize - declareForeign Untracked argToEither Value_deserialize + declareForeign Tracked 1 Promise_read + declareForeign Tracked 1 Promise_tryRead + + declareForeign Tracked 2 Promise_write + declareForeign Tracked 2 Tls_newClient_impl_v3 + declareForeign Tracked 2 Tls_newServer_impl_v3 + declareForeign Tracked 1 Tls_handshake_impl_v3 + declareForeign Tracked 2 Tls_send_impl_v3 + declareForeign Tracked 1 Tls_decodeCert_impl_v3 + + declareForeign Tracked 1 Tls_encodeCert + + declareForeign Tracked 1 Tls_decodePrivateKey + declareForeign Tracked 1 Tls_encodePrivateKey + + declareForeign Tracked 1 Tls_receive_impl_v3 + + declareForeign Tracked 1 Tls_terminate_impl_v3 + declareForeign Untracked 1 Code_validateLinks + declareForeign Untracked 1 Code_dependencies + declareForeign Untracked 1 Code_serialize + declareForeign Untracked 1 Code_deserialize + declareForeign Untracked 2 Code_display + declareForeign Untracked 1 Value_dependencies + declareForeign Untracked 1 Value_serialize + declareForeign Untracked 1 Value_deserialize -- Hashing functions - declareForeign Untracked direct Crypto_HashAlgorithm_Sha3_512 - declareForeign Untracked direct Crypto_HashAlgorithm_Sha3_256 - declareForeign Untracked direct Crypto_HashAlgorithm_Sha2_512 - declareForeign Untracked direct Crypto_HashAlgorithm_Sha2_256 - declareForeign Untracked direct Crypto_HashAlgorithm_Sha1 - declareForeign Untracked direct Crypto_HashAlgorithm_Blake2b_512 - declareForeign Untracked direct Crypto_HashAlgorithm_Blake2b_256 - declareForeign Untracked direct Crypto_HashAlgorithm_Blake2s_256 - declareForeign Untracked direct Crypto_HashAlgorithm_Md5 - - declareForeign Untracked (argNDirect 2) Crypto_hashBytes - declareForeign Untracked (argNDirect 3) Crypto_hmacBytes - - declareForeign Untracked crypto'hash Crypto_hash - declareForeign Untracked crypto'hmac Crypto_hmac - declareForeign Untracked arg3ToEF Crypto_Ed25519_sign_impl - - declareForeign Untracked arg3ToEFBool Crypto_Ed25519_verify_impl - - declareForeign Untracked arg2ToEF Crypto_Rsa_sign_impl - - declareForeign Untracked arg3ToEFBool Crypto_Rsa_verify_impl - - declareForeign Untracked murmur'hash Universal_murmurHash - declareForeign Tracked (argNDirect 1) IO_randomBytes - declareForeign Untracked (argNDirect 1) Bytes_zlib_compress - declareForeign Untracked (argNDirect 1) Bytes_gzip_compress - declareForeign Untracked argToEither Bytes_zlib_decompress - declareForeign Untracked argToEither Bytes_gzip_decompress - - declareForeign Untracked (argNDirect 1) Bytes_toBase16 - declareForeign Untracked (argNDirect 1) Bytes_toBase32 - declareForeign Untracked (argNDirect 1) Bytes_toBase64 - declareForeign Untracked (argNDirect 1) Bytes_toBase64UrlUnpadded - - declareForeign Untracked argToEither Bytes_fromBase16 - declareForeign Untracked argToEither Bytes_fromBase32 - declareForeign Untracked argToEither Bytes_fromBase64 - declareForeign Untracked argToEither Bytes_fromBase64UrlUnpadded - - declareForeign Untracked argToMaybeNTup Bytes_decodeNat64be - declareForeign Untracked argToMaybeNTup Bytes_decodeNat64le - declareForeign Untracked argToMaybeNTup Bytes_decodeNat32be - declareForeign Untracked argToMaybeNTup Bytes_decodeNat32le - declareForeign Untracked argToMaybeNTup Bytes_decodeNat16be - declareForeign Untracked argToMaybeNTup Bytes_decodeNat16le - - declareForeign Untracked (argNDirect 1) Bytes_encodeNat64be - declareForeign Untracked (argNDirect 1) Bytes_encodeNat64le - declareForeign Untracked (argNDirect 1) Bytes_encodeNat32be - declareForeign Untracked (argNDirect 1) Bytes_encodeNat32le - declareForeign Untracked (argNDirect 1) Bytes_encodeNat16be - declareForeign Untracked (argNDirect 1) Bytes_encodeNat16le - - declareForeign Untracked arg5ToExnUnit MutableArray_copyTo_force - - declareForeign Untracked arg5ToExnUnit MutableByteArray_copyTo_force - - declareForeign Untracked arg5ToExnUnit ImmutableArray_copyTo_force - - declareForeign Untracked (argNDirect 1) ImmutableArray_size - declareForeign Untracked (argNDirect 1) MutableArray_size - declareForeign Untracked (argNDirect 1) ImmutableByteArray_size - declareForeign Untracked (argNDirect 1) MutableByteArray_size - - declareForeign Untracked arg5ToExnUnit ImmutableByteArray_copyTo_force - - declareForeign Untracked arg2ToExn MutableArray_read - declareForeign Untracked arg2ToExn MutableByteArray_read8 - declareForeign Untracked arg2ToExn MutableByteArray_read16be - declareForeign Untracked arg2ToExn MutableByteArray_read24be - declareForeign Untracked arg2ToExn MutableByteArray_read32be - declareForeign Untracked arg2ToExn MutableByteArray_read40be - declareForeign Untracked arg2ToExn MutableByteArray_read64be - - declareForeign Untracked arg3ToExnUnit MutableArray_write - declareForeign Untracked arg3ToExnUnit MutableByteArray_write8 - declareForeign Untracked arg3ToExnUnit MutableByteArray_write16be - declareForeign Untracked arg3ToExnUnit MutableByteArray_write32be - declareForeign Untracked arg3ToExnUnit MutableByteArray_write64be - - declareForeign Untracked arg2ToExn ImmutableArray_read - declareForeign Untracked arg2ToExn ImmutableByteArray_read8 - declareForeign Untracked arg2ToExn ImmutableByteArray_read16be - declareForeign Untracked arg2ToExn ImmutableByteArray_read24be - declareForeign Untracked arg2ToExn ImmutableByteArray_read32be - declareForeign Untracked arg2ToExn ImmutableByteArray_read40be - declareForeign Untracked arg2ToExn ImmutableByteArray_read64be - - declareForeign Untracked (argNDirect 1) MutableByteArray_freeze_force - declareForeign Untracked (argNDirect 1) MutableArray_freeze_force - - declareForeign Untracked arg3ToExn MutableByteArray_freeze - declareForeign Untracked arg3ToExn MutableArray_freeze - - declareForeign Untracked (argNDirect 1) MutableByteArray_length - - declareForeign Untracked (argNDirect 1) ImmutableByteArray_length - - declareForeign Tracked (argNDirect 1) IO_array - declareForeign Tracked (argNDirect 2) IO_arrayOf - declareForeign Tracked (argNDirect 1) IO_bytearray - declareForeign Tracked (argNDirect 2) IO_bytearrayOf - - declareForeign Untracked (argNDirect 1) Scope_array - declareForeign Untracked (argNDirect 2) Scope_arrayOf - declareForeign Untracked (argNDirect 1) Scope_bytearray - declareForeign Untracked (argNDirect 2) Scope_bytearrayOf - - declareForeign Untracked (argNDirect 1) Text_patterns_literal - declareForeign Untracked direct Text_patterns_digit - declareForeign Untracked direct Text_patterns_letter - declareForeign Untracked direct Text_patterns_space - declareForeign Untracked direct Text_patterns_punctuation - declareForeign Untracked direct Text_patterns_anyChar - declareForeign Untracked direct Text_patterns_eof - declareForeign Untracked (argNDirect 2) Text_patterns_charRange - declareForeign Untracked (argNDirect 2) Text_patterns_notCharRange - declareForeign Untracked (argNDirect 1) Text_patterns_charIn - declareForeign Untracked (argNDirect 1) Text_patterns_notCharIn - declareForeign Untracked (argNDirect 1) Pattern_many - declareForeign Untracked (argNDirect 1) Pattern_many_corrected - declareForeign Untracked (argNDirect 1) Pattern_capture - declareForeign Untracked (argNDirect 2) Pattern_captureAs - declareForeign Untracked (argNDirect 1) Pattern_join - declareForeign Untracked (argNDirect 2) Pattern_or - declareForeign Untracked (argNDirect 3) Pattern_replicate - - declareForeign Untracked arg2ToMaybeTup Pattern_run - - declareForeign Untracked (argNDirect 2) Pattern_isMatch - - declareForeign Untracked direct Char_Class_any - declareForeign Untracked (argNDirect 1) Char_Class_not - declareForeign Untracked (argNDirect 2) Char_Class_and - declareForeign Untracked (argNDirect 2) Char_Class_or - declareForeign Untracked (argNDirect 2) Char_Class_range - declareForeign Untracked (argNDirect 1) Char_Class_anyOf - declareForeign Untracked direct Char_Class_alphanumeric - declareForeign Untracked direct Char_Class_upper - declareForeign Untracked direct Char_Class_lower - declareForeign Untracked direct Char_Class_whitespace - declareForeign Untracked direct Char_Class_control - declareForeign Untracked direct Char_Class_printable - declareForeign Untracked direct Char_Class_mark - declareForeign Untracked direct Char_Class_number - declareForeign Untracked direct Char_Class_punctuation - declareForeign Untracked direct Char_Class_symbol - declareForeign Untracked direct Char_Class_separator - declareForeign Untracked direct Char_Class_letter - declareForeign Untracked (argNDirect 2) Char_Class_is - declareForeign Untracked (argNDirect 1) Text_patterns_char + declareForeignWrap Untracked direct Crypto_HashAlgorithm_Sha3_512 + declareForeignWrap Untracked direct Crypto_HashAlgorithm_Sha3_256 + declareForeignWrap Untracked direct Crypto_HashAlgorithm_Sha2_512 + declareForeignWrap Untracked direct Crypto_HashAlgorithm_Sha2_256 + declareForeignWrap Untracked direct Crypto_HashAlgorithm_Sha1 + declareForeignWrap Untracked direct Crypto_HashAlgorithm_Blake2b_512 + declareForeignWrap Untracked direct Crypto_HashAlgorithm_Blake2b_256 + declareForeignWrap Untracked direct Crypto_HashAlgorithm_Blake2s_256 + declareForeignWrap Untracked direct Crypto_HashAlgorithm_Md5 + + declareForeign Untracked 2 Crypto_hashBytes + declareForeign Untracked 3 Crypto_hmacBytes + + declareForeignWrap Untracked crypto'hash Crypto_hash + declareForeignWrap Untracked crypto'hmac Crypto_hmac + declareForeign Untracked 3 Crypto_Ed25519_sign_impl + + declareForeign Untracked 3 Crypto_Ed25519_verify_impl + + declareForeign Untracked 2 Crypto_Rsa_sign_impl + + declareForeign Untracked 3 Crypto_Rsa_verify_impl + + declareForeignWrap Untracked murmur'hash Universal_murmurHash + declareForeign Tracked 1 IO_randomBytes + declareForeign Untracked 1 Bytes_zlib_compress + declareForeign Untracked 1 Bytes_gzip_compress + declareForeign Untracked 1 Bytes_zlib_decompress + declareForeign Untracked 1 Bytes_gzip_decompress + + declareForeign Untracked 1 Bytes_toBase16 + declareForeign Untracked 1 Bytes_toBase32 + declareForeign Untracked 1 Bytes_toBase64 + declareForeign Untracked 1 Bytes_toBase64UrlUnpadded + + declareForeign Untracked 1 Bytes_fromBase16 + declareForeign Untracked 1 Bytes_fromBase32 + declareForeign Untracked 1 Bytes_fromBase64 + declareForeign Untracked 1 Bytes_fromBase64UrlUnpadded + + declareForeign Untracked 1 Bytes_decodeNat64be + declareForeign Untracked 1 Bytes_decodeNat64le + declareForeign Untracked 1 Bytes_decodeNat32be + declareForeign Untracked 1 Bytes_decodeNat32le + declareForeign Untracked 1 Bytes_decodeNat16be + declareForeign Untracked 1 Bytes_decodeNat16le + + declareForeign Untracked 1 Bytes_encodeNat64be + declareForeign Untracked 1 Bytes_encodeNat64le + declareForeign Untracked 1 Bytes_encodeNat32be + declareForeign Untracked 1 Bytes_encodeNat32le + declareForeign Untracked 1 Bytes_encodeNat16be + declareForeign Untracked 1 Bytes_encodeNat16le + + declareForeign Untracked 5 MutableArray_copyTo_force + + declareForeign Untracked 5 MutableByteArray_copyTo_force + + declareForeign Untracked 5 ImmutableArray_copyTo_force + + declareForeign Untracked 1 ImmutableArray_size + declareForeign Untracked 1 MutableArray_size + declareForeign Untracked 1 ImmutableByteArray_size + declareForeign Untracked 1 MutableByteArray_size + + declareForeign Untracked 5 ImmutableByteArray_copyTo_force + + declareForeign Untracked 2 MutableArray_read + declareForeign Untracked 2 MutableByteArray_read8 + declareForeign Untracked 2 MutableByteArray_read16be + declareForeign Untracked 2 MutableByteArray_read24be + declareForeign Untracked 2 MutableByteArray_read32be + declareForeign Untracked 2 MutableByteArray_read40be + declareForeign Untracked 2 MutableByteArray_read64be + + declareForeign Untracked 3 MutableArray_write + declareForeign Untracked 3 MutableByteArray_write8 + declareForeign Untracked 3 MutableByteArray_write16be + declareForeign Untracked 3 MutableByteArray_write32be + declareForeign Untracked 3 MutableByteArray_write64be + + declareForeign Untracked 2 ImmutableArray_read + declareForeign Untracked 2 ImmutableByteArray_read8 + declareForeign Untracked 2 ImmutableByteArray_read16be + declareForeign Untracked 2 ImmutableByteArray_read24be + declareForeign Untracked 2 ImmutableByteArray_read32be + declareForeign Untracked 2 ImmutableByteArray_read40be + declareForeign Untracked 2 ImmutableByteArray_read64be + + declareForeign Untracked 1 MutableByteArray_freeze_force + declareForeign Untracked 1 MutableArray_freeze_force + + declareForeign Untracked 3 MutableByteArray_freeze + declareForeign Untracked 3 MutableArray_freeze + + declareForeign Untracked 1 MutableByteArray_length + + declareForeign Untracked 1 ImmutableByteArray_length + + declareForeign Tracked 1 IO_array + declareForeign Tracked 2 IO_arrayOf + declareForeign Tracked 1 IO_bytearray + declareForeign Tracked 2 IO_bytearrayOf + + declareForeign Untracked 1 Scope_array + declareForeign Untracked 2 Scope_arrayOf + declareForeign Untracked 1 Scope_bytearray + declareForeign Untracked 2 Scope_bytearrayOf + + declareForeign Untracked 1 Text_patterns_literal + declareForeignWrap Untracked direct Text_patterns_digit + declareForeignWrap Untracked direct Text_patterns_letter + declareForeignWrap Untracked direct Text_patterns_space + declareForeignWrap Untracked direct Text_patterns_punctuation + declareForeignWrap Untracked direct Text_patterns_anyChar + declareForeignWrap Untracked direct Text_patterns_eof + declareForeign Untracked 2 Text_patterns_charRange + declareForeign Untracked 2 Text_patterns_notCharRange + declareForeign Untracked 1 Text_patterns_charIn + declareForeign Untracked 1 Text_patterns_notCharIn + declareForeign Untracked 1 Pattern_many + declareForeign Untracked 1 Pattern_many_corrected + declareForeign Untracked 1 Pattern_capture + declareForeign Untracked 2 Pattern_captureAs + declareForeign Untracked 1 Pattern_join + declareForeign Untracked 2 Pattern_or + declareForeign Untracked 3 Pattern_replicate + + declareForeign Untracked 2 Pattern_run + + declareForeign Untracked 2 Pattern_isMatch + + declareForeignWrap Untracked direct Char_Class_any + declareForeign Untracked 1 Char_Class_not + declareForeign Untracked 2 Char_Class_and + declareForeign Untracked 2 Char_Class_or + declareForeign Untracked 2 Char_Class_range + declareForeign Untracked 1 Char_Class_anyOf + declareForeignWrap Untracked direct Char_Class_alphanumeric + declareForeignWrap Untracked direct Char_Class_upper + declareForeignWrap Untracked direct Char_Class_lower + declareForeignWrap Untracked direct Char_Class_whitespace + declareForeignWrap Untracked direct Char_Class_control + declareForeignWrap Untracked direct Char_Class_printable + declareForeignWrap Untracked direct Char_Class_mark + declareForeignWrap Untracked direct Char_Class_number + declareForeignWrap Untracked direct Char_Class_punctuation + declareForeignWrap Untracked direct Char_Class_symbol + declareForeignWrap Untracked direct Char_Class_separator + declareForeignWrap Untracked direct Char_Class_letter + declareForeign Untracked 2 Char_Class_is + declareForeign Untracked 1 Text_patterns_char foreignDeclResults :: (Map ForeignFunc (Sandbox, SuperNormal Symbol)) foreignDeclResults = diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 7c8036e994..8e7e87168d 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -175,12 +175,12 @@ import UnliftIO qualified -- unbox all of 'foreignCallHelper' when we write it this way, but it's way less work to use the regular lifted stack -- in its implementation. {-# NOINLINE foreignCall #-} -foreignCall :: ForeignFunc -> Args -> XStack -> IOXStack +foreignCall :: ForeignFunc -> Args -> XStack -> IOEXStack foreignCall !ff !args !xstk = - stackIOToIOX $ foreignCallHelper ff args (packXStack xstk) + estackIOToIOX $ foreignCallHelper ff args (packXStack xstk) {-# INLINE foreignCallHelper #-} -foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO Stack +foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO (Bool, Stack) foreignCallHelper = \case IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> let hostStr = Util.Text.toString host @@ -483,7 +483,7 @@ foreignCallHelper = \case pure $ Bytes.fromArray bs Tls_terminate_impl_v3 -> mkForeignTls $ \(tls :: TLS.Context) -> TLS.bye tls - Code_validateLinks -> mkForeign $ + Code_validateLinks -> mkForeignExn $ \(lsgs0 :: [(Referent, ANF.Code)]) -> do let f (msg, rs) = F.Failure Ty.miscFailureRef (Util.Text.fromText msg) rs @@ -598,7 +598,7 @@ foreignCallHelper = \case Bytes_encodeNat32le -> mkForeign $ pure . Bytes.encodeNat32le Bytes_encodeNat16be -> mkForeign $ pure . Bytes.encodeNat16be Bytes_encodeNat16le -> mkForeign $ pure . Bytes.encodeNat16le - MutableArray_copyTo_force -> mkForeign $ + MutableArray_copyTo_force -> mkForeignExn $ \(dst, doff, src, soff, l) -> let name = "MutableArray.copyTo!" in if l == 0 @@ -613,7 +613,7 @@ foreignCallHelper = \case src (fromIntegral soff) (fromIntegral l) - MutableByteArray_copyTo_force -> mkForeign $ + MutableByteArray_copyTo_force -> mkForeignExn $ \(dst, doff, src, soff, l) -> let name = "MutableByteArray.copyTo!" in if l == 0 @@ -628,7 +628,7 @@ foreignCallHelper = \case src (fromIntegral soff) (fromIntegral l) - ImmutableArray_copyTo_force -> mkForeign $ + ImmutableArray_copyTo_force -> mkForeignExn $ \(dst, doff, src, soff, l) -> let name = "ImmutableArray.copyTo!" in if l == 0 @@ -655,7 +655,7 @@ foreignCallHelper = \case MutableByteArray_size -> mkForeign $ pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld - ImmutableByteArray_copyTo_force -> mkForeign $ + ImmutableByteArray_copyTo_force -> mkForeignExn $ \(dst, doff, src, soff, l) -> let name = "ImmutableByteArray.copyTo!" in if l == 0 @@ -671,61 +671,61 @@ foreignCallHelper = \case (fromIntegral soff) (fromIntegral l) MutableArray_read -> - mkForeign $ + mkForeignExn $ checkedRead "MutableArray.read" MutableByteArray_read8 -> - mkForeign $ + mkForeignExn $ checkedRead8 "MutableByteArray.read8" MutableByteArray_read16be -> - mkForeign $ + mkForeignExn $ checkedRead16 "MutableByteArray.read16be" MutableByteArray_read24be -> - mkForeign $ + mkForeignExn $ checkedRead24 "MutableByteArray.read24be" MutableByteArray_read32be -> - mkForeign $ + mkForeignExn $ checkedRead32 "MutableByteArray.read32be" MutableByteArray_read40be -> - mkForeign $ + mkForeignExn $ checkedRead40 "MutableByteArray.read40be" MutableByteArray_read64be -> - mkForeign $ + mkForeignExn $ checkedRead64 "MutableByteArray.read64be" MutableArray_write -> - mkForeign $ + mkForeignExn $ checkedWrite "MutableArray.write" MutableByteArray_write8 -> - mkForeign $ + mkForeignExn $ checkedWrite8 "MutableByteArray.write8" MutableByteArray_write16be -> - mkForeign $ + mkForeignExn $ checkedWrite16 "MutableByteArray.write16be" MutableByteArray_write32be -> - mkForeign $ + mkForeignExn $ checkedWrite32 "MutableByteArray.write32be" MutableByteArray_write64be -> - mkForeign $ + mkForeignExn $ checkedWrite64 "MutableByteArray.write64be" ImmutableArray_read -> - mkForeign $ + mkForeignExn $ checkedIndex "ImmutableArray.read" ImmutableByteArray_read8 -> - mkForeign $ + mkForeignExn $ checkedIndex8 "ImmutableByteArray.read8" ImmutableByteArray_read16be -> - mkForeign $ + mkForeignExn $ checkedIndex16 "ImmutableByteArray.read16be" ImmutableByteArray_read24be -> - mkForeign $ + mkForeignExn $ checkedIndex24 "ImmutableByteArray.read24be" ImmutableByteArray_read32be -> - mkForeign $ + mkForeignExn $ checkedIndex32 "ImmutableByteArray.read32be" ImmutableByteArray_read40be -> - mkForeign $ + mkForeignExn $ checkedIndex40 "ImmutableByteArray.read40be" ImmutableByteArray_read64be -> - mkForeign $ + mkForeignExn $ checkedIndex64 "ImmutableByteArray.read64be" MutableByteArray_freeze_force -> mkForeign $ @@ -885,17 +885,17 @@ foreignCallHelper = \case Right a -> Right a {-# INLINE mkHashAlgorithm #-} -mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO Stack +mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO (Bool, Stack) mkHashAlgorithm txt alg = let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) in mkForeign $ \() -> pure (HashAlgorithm algoRef alg) {-# INLINE mkForeign #-} -mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack +mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO (Bool, Stack) mkForeign !f !args !stk = do r <- f =<< readsAt stk args stk <- bump stk - stk <$ writeBack stk r + (False, stk) <$ writeBack stk r {-# INLINE mkForeignIOF #-} mkForeignIOF :: @@ -903,7 +903,7 @@ mkForeignIOF :: (a -> IO r) -> Args -> Stack -> - IO Stack + IO (Bool, Stack) mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) where tryIOE :: IO a -> IO (Either (F.Failure Val) a) @@ -912,6 +912,22 @@ mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) handleIOE (Left e) = Left $ F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue handleIOE (Right a) = Right a +{-# inline mkForeignExn #-} +mkForeignExn :: + (ForeignConvention a, ForeignConvention e, ForeignConvention r) => + (a -> IO (Either (F.Failure e) r)) -> + Args -> + Stack -> + IO (Bool, Stack) +mkForeignExn f args stk = + readsAt stk args >>= f >>= \case + Left e -> do + stk <- bump stk + (True, stk) <$ writeBack stk e + Right r -> do + stk <- bump stk + (False, stk) <$ writeBack stk r + {-# INLINE mkForeignTls #-} mkForeignTls :: forall a r. @@ -919,7 +935,7 @@ mkForeignTls :: (a -> IO r) -> Args -> Stack -> - IO Stack + IO (Bool, Stack) mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) where tryIO1 :: IO r -> IO (Either TLS.TLSException r) @@ -938,7 +954,7 @@ mkForeignTlsE :: (a -> IO (Either Failure r)) -> Args -> Stack -> - IO Stack + IO (Bool, Stack) mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) where tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index bfc7ab0c00..b088ebc2a2 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -329,7 +329,7 @@ exec :: K -> Reference -> MInstr -> - IO (DEnv, Stack, K) + IO (Bool, DEnv, Stack, K) {- ORMOLU_DISABLE -} #ifdef STACK_CHECK exec _ !_ !_ !stk !_ !_ instr @@ -339,25 +339,25 @@ exec _ !_ !_ !stk !_ !_ instr exec _ !denv !_activeThreads !stk !k _ (Info tx) = do info tx stk info tx k - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (Name r args) = do v <- resolve env denv stk r stk <- name stk args v - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (SetDyn p i) = do val <- peekOff stk i - pure (EC.mapInsert p val denv, stk, k) + pure (False, EC.mapInsert p val denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (Capture p) = do (cap, denv, stk, k) <- splitCont denv stk k p stk <- bump stk poke stk cap - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (UPrim1 op i) = do stk <- uprim1 stk op i - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (UPrim2 op i j) = do stk <- uprim2 stk op i j - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim1 MISS i) | sandboxed env = die "attempted to use sandboxed operation: isMissing" | otherwise = do @@ -368,7 +368,7 @@ exec env !denv !_activeThreads !stk !k _ (BPrim1 MISS i) m <- readTVarIO (intermed env) stk <- bump stk pokeBool stk $ (link `M.member` m) - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim1 CACH i) | sandboxed env = die "attempted to use sandboxed operation: cache" | otherwise = do @@ -379,7 +379,7 @@ exec env !denv !_activeThreads !stk !k _ (BPrim1 CACH i) pokeS stk (Sq.fromList $ boxedVal . Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim1 CVLD i) | sandboxed env = die "attempted to use sandboxed operation: validate" | otherwise = do @@ -389,7 +389,7 @@ exec env !denv !_activeThreads !stk !k _ (BPrim1 CVLD i) Nothing -> do stk <- bump stk pokeTag stk 0 - pure (denv, stk, k) + pure (False, denv, stk, k) Just (Failure ref msg clo) -> do stk <- bumpn stk 3 bpoke stk (Foreign $ Wrap Rf.typeLinkRef ref) @@ -397,7 +397,7 @@ exec env !denv !_activeThreads !stk !k _ (BPrim1 CVLD i) bpokeOff stk 2 clo stk <- bump stk pokeTag stk 1 - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim1 LKUP i) | sandboxed env = die "attempted to use sandboxed operation: lookup" | otherwise = do @@ -426,7 +426,7 @@ exec env !denv !_activeThreads !stk !k _ (BPrim1 LKUP i) pokeBi stk (CodeRep sg ch) stk <- bump stk stk <$ pokeTag stk 1 - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (BPrim1 TLTT i) = do clink <- bpeekOff stk i let shortHash = case unwrapForeign $ marshalToForeign clink of @@ -435,7 +435,7 @@ exec _ !denv !_activeThreads !stk !k _ (BPrim1 TLTT i) = do let sh = Util.Text.fromText . SH.toText $ shortHash stk <- bump stk pokeBi stk sh - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim1 LOAD i) | sandboxed env = die "attempted to use sandboxed operation: load" | otherwise = do @@ -450,13 +450,13 @@ exec env !denv !_activeThreads !stk !k _ (BPrim1 LOAD i) Right x -> do pokeOff stk 1 x pokeTag stk 1 - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim1 VALU i) = do m <- readTVarIO (tagRefs env) c <- peekOff stk i stk <- bump stk pokeBi stk =<< reflectValue m c - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim1 DBTX i) | sandboxed env = die "attempted to use sandboxed operation: Debug.toText" @@ -473,7 +473,7 @@ exec env !denv !_activeThreads !stk !k _ (BPrim1 DBTX i) pokeBi stk (Util.Text.pack tx) stk <- bump stk stk <$ pokeTag stk 2 - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim1 SDBL i) | sandboxed env = die "attempted to use sandboxed operation: sandboxLinks" @@ -481,10 +481,10 @@ exec env !denv !_activeThreads !stk !k _ (BPrim1 SDBL i) tl <- peekOffBi stk i stk <- bump stk pokeS stk . encodeSandboxListResult =<< sandboxList env tl - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim1 op i) = do stk <- bprim1 env stk op i - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim2 SDBX i j) = do s <- peekOffS stk i c <- bpeekOff stk j @@ -492,7 +492,7 @@ exec env !denv !_activeThreads !stk !k _ (BPrim2 SDBX i j) = do b <- checkSandboxing env l c stk <- bump stk pokeBool stk $ b - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (BPrim2 SDBV i j) | sandboxed env = die "attempted to use sandboxed operation: Value.validateSandboxed" @@ -503,31 +503,31 @@ exec env !denv !_activeThreads !stk !k _ (BPrim2 SDBV i j) res <- checkValueSandboxing env l v stk <- bump stk bpoke stk $ encodeSandboxResult res - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (BPrim2 EQLU i j) = do x <- peekOff stk i y <- peekOff stk j stk <- bump stk pokeBool stk $ universalEq (==) x y - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (BPrim2 LEQU i j) = do x <- peekOff stk i y <- peekOff stk j stk <- bump stk pokeBool stk $ (universalCompare compare x y) /= GT - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (BPrim2 LESU i j) = do x <- peekOff stk i y <- peekOff stk j stk <- bump stk pokeBool stk $ (universalCompare compare x y) == LT - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (BPrim2 CMPU i j) = do x <- peekOff stk i y <- peekOff stk j stk <- bump stk pokeI stk . pred . fromEnum $ universalCompare compare x y - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !_ !_activeThreads !stk !k r (BPrim2 THRO i j) = do name <- peekOffBi @Util.Text.Text stk i x <- peekOff stk j @@ -551,10 +551,10 @@ exec env !denv !_activeThreads !stk !k _ (BPrim2 TRCE i j) putStrLn ugl putStrLn "partial decompilation:\n" putStrLn pre - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_trackThreads !stk !k _ (BPrim2 op i j) = do stk <- bprim2 stk op i j - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !_activeThreads !stk !k _ (RefCAS refI ticketI valI) | sandboxed env = die "attempted to use sandboxed operation: Ref.cas" | otherwise = do @@ -567,47 +567,47 @@ exec env !denv !_activeThreads !stk !k _ (RefCAS refI ticketI valI) (r, _) <- Atomic.casIORef ref ticket v stk <- bump stk pokeBool stk r - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (Pack r t args) = do clo <- buildData stk r t args stk <- bump stk bpoke stk clo - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (Print i) = do t <- peekOffBi stk i Tx.putStrLn (Util.Text.toText t) - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (Lit ml) = do stk <- bump stk poke stk $ litToVal ml - pure (denv, stk, k) + pure (False, denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (Reset ps) = do (stk, a) <- saveArgs stk - pure (denv, stk, Mark a ps clos k) + pure (False, denv, stk, Mark a ps clos k) where clos = EC.restrictKeys denv ps exec _ !denv !_activeThreads !stk !k _ (Seq as) = do l <- closureArgs stk as stk <- bump stk pokeS stk $ Sq.fromList l - pure (denv, stk, k) + pure (False, denv, stk, k) exec _env !denv !_activeThreads !stk !k _ (ForeignCall _ func args) = do - stk <- xStackIOToIO $ foreignCall func args (unpackXStack stk) - pure (denv, stk, k) + (b, stk) <- exStackIOToIO $ foreignCall func args (unpackXStack stk) + pure (b, denv, stk, k) exec env !denv !activeThreads !stk !k _ (Fork i) | sandboxed env = die "attempted to use sandboxed operation: fork" | otherwise = do tid <- forkEval env activeThreads =<< peekOff stk i stk <- bump stk bpoke stk . Foreign . Wrap Rf.threadIdRef $ tid - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !activeThreads !stk !k _ (Atomically i) | sandboxed env = die $ "attempted to use sandboxed operation: atomically" | otherwise = do v <- peekOff stk i stk <- bump stk atomicEval env activeThreads (poke stk) v - pure (denv, stk, k) + pure (False, denv, stk, k) exec env !denv !activeThreads !stk !k _ (TryForce i) | sandboxed env = die $ "attempted to use sandboxed operation: tryForce" | otherwise = do @@ -615,7 +615,7 @@ exec env !denv !activeThreads !stk !k _ (TryForce i) stk <- bump stk -- Bump the boxed stack to make a slot for the result, which will be written in the callback if we succeed. ev <- Control.Exception.try $ nestEval env activeThreads (poke stk) v stk <- encodeExn stk ev - pure (denv, stk, k) + pure (False, denv, stk, k) exec !_ !_ !_ !_ !_ _ (SandboxingFailure t) = do die $ "Attempted to use disallowed builtin in sandboxed environment: " <> DTx.unpack t {-# INLINE exec #-} @@ -724,12 +724,30 @@ eval env !denv !activeThreads !stk !k r (Let nw cix f sect) = do r nw eval env !denv !activeThreads !stk !k r (Ins i nx) = do - (denv, stk, k) <- exec env denv activeThreads stk k r i - eval env denv activeThreads stk k r nx + exec env denv activeThreads stk k r i >>= \case + (exception, denv, stk, k) + -- In this case, the instruction indicated an exception to + -- be handled by the current {Exception} handler. The stack + -- currently points to an appropriate `Failure` value, and + -- we must handle the rest. + | exception -> case EC.lookup TT.exceptionTag denv of + Just eh -> do + -- wrap the failure in an exception raise box + fv <- peek stk + bpoke stk $ Data1 exceptionRef TT.exceptionRaiseTag fv + (stk, fsz, asz) <- saveFrame stk + let kk = Push fsz asz fakeCix 10 nx k + apply env denv activeThreads stk kk False (VArg1 0) eh + Nothing -> -- should be impossible + unhandledAbilityRequest + | otherwise -> eval env denv activeThreads stk k r nx eval _ !_ !_ !_activeThreads !_ _ Exit = pure () eval _ !_ !_ !_activeThreads !_ _ (Die s) = die s {-# NOINLINE eval #-} +fakeCix :: CombIx +fakeCix = CIx exceptionRef maxBound maxBound + unhandledAbilityRequest :: (HasCallStack) => IO a unhandledAbilityRequest = error . show . PE callStack . P.lit . fromString $ "eval: unhandled ability request" diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index 1988d14cc1..164a4591f3 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -36,7 +36,10 @@ module Unison.Runtime.Stack unpackXStack, xStackIOToIO, stackIOToIOX, + estackIOToIOX, + exStackIOToIO, IOXStack, + IOEXStack, apX, fpX, spX, @@ -667,6 +670,9 @@ type XStack = (# Int#, Int#, Int#, MutableByteArray# (PrimState IO), MutableArra type IOXStack = State# RealWorld -> (# State# RealWorld, XStack #) +type IOEXStack = + State# RealWorld -> (# State# RealWorld, Bool, XStack #) + pattern XStack :: Int# -> Int# -> Int# -> MutableByteArray# RealWorld -> MutableArray# RealWorld Closure -> Stack pattern XStack {apX, fpX, spX, ustkX, bstkX} = Stack (I# apX) (I# fpX) (I# spX) (MutableByteArray ustkX) (MutableArray bstkX) @@ -690,6 +696,14 @@ stackIOToIOX :: IO Stack -> IOXStack stackIOToIOX (IO f) = \s -> case f s of (# s', x #) -> (# s', unpackXStack x #) {-# INLINE stackIOToIOX #-} +estackIOToIOX :: IO (Bool, Stack) -> IOEXStack +estackIOToIOX (IO f) = \s -> case f s of + (# s', (b, x) #) -> (# s', b, unpackXStack x #) + +exStackIOToIO :: IOEXStack -> IO (Bool, Stack) +exStackIOToIO f = IO $ \s -> case f s of + (# s , b, x #) -> (# s, (b, packXStack x) #) + instance Show Stack where show (Stack ap fp sp _ _) = "Stack " ++ show ap ++ " " ++ show fp ++ " " ++ show sp From e397f804d2d88ec69f6c3716241cf6e2cb4f5ad4 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 14 Jan 2025 15:22:52 -0500 Subject: [PATCH 4/7] Fix tuple conventions, and make them more concise --- .../src/Unison/Runtime/Foreign/Function.hs | 41 ++++++++++++++----- 1 file changed, 30 insertions(+), 11 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 8e7e87168d..aa1496321f 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -1484,14 +1484,26 @@ instance ForeignConvention () where readAtIndex _ _ = pure () writeBack stk _ = bpoke stk $ unitClo +pattern ConsC :: Val -> Val -> Closure +pattern ConsC x y <- Data2 _ _ x y + where + ConsC x y = Data2 Ty.pairRef pairTag x y + +pattern ConsV x y = BoxedVal (ConsC x y) + +pattern Tup2C :: Val -> Val -> Closure +pattern Tup2C x y <- ConsC x (ConsV y _) + where + Tup2C x y = ConsC x (ConsV y unitVal) + +pattern Tup2V x y = BoxedVal (Tup2C x y) + decodeTup2 :: (ForeignConvention a, ForeignConvention b) => Closure -> IO (a, b) -decodeTup2 (Data2 _ _ x (BoxedVal (Data2 _ _ y _))) = - (,) <$> decodeVal x <*> decodeVal y +decodeTup2 (Tup2C x y) = (,) <$> decodeVal x <*> decodeVal y decodeTup2 c = foreignConventionError "Pair" (BoxedVal c) encodeTup2 :: (ForeignConvention a, ForeignConvention b) => (a, b) -> Closure -encodeTup2 (x,y) = - Data2 Ty.pairRef pairTag (encodeVal x) (encodeVal y) +encodeTup2 (x,y) = Tup2C (encodeVal x) (encodeVal y) instance ( ForeignConvention a, @@ -1509,14 +1521,16 @@ instance readAtIndex stk i = bpeekOff stk i >>= decodeTup2 writeBack stk p = bpoke stk $ encodeTup2 p +pattern Tup3C x y z = ConsC x (Tup2V y z) +pattern Tup3V x y z = BoxedVal (Tup3C x y z) + decodeTup3 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c) => Closure -> IO (a, b, c) -decodeTup3 (Data2 _ _ x (BoxedVal (Data2 _ _ y (BoxedVal (Data2 _ _ z _))))) = +decodeTup3 (Tup3C x y z) = (,,) <$> decodeVal x <*> decodeVal y <*> decodeVal z decodeTup3 c = foreignConventionError "Triple" (BoxedVal c) encodeTup3 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c) => (a, b, c) -> Closure -encodeTup3 (x,y,z) = - Data2 Ty.pairRef pairTag (encodeVal x) (BoxedVal $ encodeTup2 (y,z)) +encodeTup3 (x,y,z) = Tup3C (encodeVal x) (encodeVal y) (encodeVal z) instance ( ForeignConvention a, @@ -1536,14 +1550,17 @@ instance readAtIndex stk i = bpeekOff stk i >>= decodeTup3 writeBack stk p = bpoke stk $ encodeTup3 p +pattern Tup4C w x y z = ConsC w (Tup3V x y z) +pattern Tup4V w x y z = BoxedVal (Tup4C w x y z) + decodeTup4 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d) => Closure -> IO (a, b, c, d) -decodeTup4 (Data2 _ _ w (BoxedVal (Data2 _ _ x (BoxedVal (Data2 _ _ y (BoxedVal (Data2 _ _ z _))))))) = +decodeTup4 (Tup4C w x y z) = (,,,) <$> decodeVal w <*> decodeVal x <*> decodeVal y <*> decodeVal z decodeTup4 c = foreignConventionError "Quadruple" (BoxedVal c) encodeTup4 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d) => (a, b, c, d) -> Closure encodeTup4 (w,x,y,z) = - Data2 Ty.pairRef pairTag (encodeVal w) (BoxedVal $ encodeTup3 (x,y,z)) + Tup4C (encodeVal w) (encodeVal x) (encodeVal y) (encodeVal z) instance ( ForeignConvention a, @@ -1566,14 +1583,16 @@ instance readAtIndex stk i = bpeekOff stk i >>= decodeTup4 writeBack stk p = bpoke stk $ encodeTup4 p +pattern Tup5C v w x y z = ConsC v (Tup4V w x y z) + decodeTup5 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d, ForeignConvention e) => Closure -> IO (a, b, c, d, e) -decodeTup5 (Data2 _ _ v (BoxedVal (Data2 _ _ w (BoxedVal (Data2 _ _ x (BoxedVal (Data2 _ _ y (BoxedVal (Data2 _ _ z _))))))))) = +decodeTup5 (Tup5C v w x y z) = (,,,,) <$> decodeVal v <*> decodeVal w <*> decodeVal x <*> decodeVal y <*> decodeVal z decodeTup5 c = foreignConventionError "Quintuple" (BoxedVal c) encodeTup5 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d, ForeignConvention e) => (a, b, c, d, e) -> Closure encodeTup5 (v,w,x,y,z) = - Data2 Ty.pairRef pairTag (encodeVal v) (BoxedVal $ encodeTup4 (w,x,y,z)) + Tup5C (encodeVal v) (encodeVal w) (encodeVal x) (encodeVal y) (encodeVal z) instance ( ForeignConvention a, From 4939b998f5e089396564724604f4170b365ffb9a Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 14 Jan 2025 15:43:02 -0500 Subject: [PATCH 5/7] Fix calling convention of safe array freezes All base tests pass --- unison-runtime/src/Unison/Runtime/Foreign/Function.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index aa1496321f..be97b6fbc1 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -733,7 +733,7 @@ foreignCallHelper = \case MutableArray_freeze_force -> mkForeign $ PA.unsafeFreezeArray @IO @Val - MutableByteArray_freeze -> mkForeign $ + MutableByteArray_freeze -> mkForeignExn $ \(src, off, len) -> if len == 0 then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 @@ -744,7 +744,7 @@ foreignCallHelper = \case (off + len) 0 $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) - MutableArray_freeze -> mkForeign $ + MutableArray_freeze -> mkForeignExn $ \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> if len == 0 then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal From c95c31addcaa770b4e08c2b958c09a88e08eaa72 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 14 Jan 2025 18:07:46 -0500 Subject: [PATCH 6/7] Fix various calling convention problems Transcripts now pass --- .../src/Unison/Builtin/Decls.hs | 12 ++++- unison-runtime/src/Unison/Runtime/Builtin.hs | 2 +- .../src/Unison/Runtime/Foreign/Function.hs | 48 ++++++++++++++----- unison-runtime/src/Unison/Runtime/TypeTags.hs | 12 +++++ 4 files changed, 59 insertions(+), 15 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index d50279f1ad..9bfe9c9a30 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -107,6 +107,11 @@ constructorId ref name = do (_, _, dd) <- find (\(_, r, _) -> Reference.DerivedId r == ref) builtinDataDecls fmap fromIntegral . elemIndex name $ DD.constructorNames dd +effectId :: Reference -> Text -> Maybe ConstructorId +effectId ref name = do + (_, _, ed) <- find (\(_, r, _) -> Reference.DerivedId r == ref) builtinEffectDecls + fmap fromIntegral . elemIndex name . DD.constructorNames $ DD.toDataDecl ed + noneId, someId, okConstructorId, failConstructorId, docBlobId, docLinkId, docSignatureId, docSourceId, docEvaluateId, docJoinId, linkTermId, linkTypeId, eitherRightId, eitherLeftId :: ConstructorId isPropagatedConstructorId, isTestConstructorId, bufferModeNoBufferingId, bufferModeLineBufferingId, bufferModeBlockBufferingId, bufferModeSizedBlockBufferingId :: ConstructorId seqViewEmpty, seqViewElem :: ConstructorId @@ -164,8 +169,13 @@ seekModeAbsoluteId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.Ab seekModeRelativeId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.RelativeSeek" seekModeEndId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.SeekFromEnd" +stdInId, stdOutId, stdErrId :: ConstructorId +stdInId = Maybe.fromJust $ constructorId stdHandleRef "io2.StdHandle.StdIn" +stdOutId = Maybe.fromJust $ constructorId stdHandleRef "io2.StdHandle.StdOut" +stdErrId = Maybe.fromJust $ constructorId stdHandleRef "io2.StdHandle.StdErr" + exceptionRaiseId :: ConstructorId -exceptionRaiseId = Maybe.fromJust $ constructorId exceptionRef "Exception.raise" +exceptionRaiseId = Maybe.fromJust $ effectId exceptionRef "Exception.raise" okConstructorReferent, failConstructorReferent :: Referent.Referent okConstructorReferent = Referent.Con (ConstructorReference testResultRef okConstructorId) CT.Data diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 67a4d26824..cf3e0db295 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -1112,7 +1112,7 @@ declareUdpForeigns = do declareForeigns :: FDecl Symbol () declareForeigns = do declareUdpForeigns - declareForeign Tracked 1 IO_openFile_impl_v3 + declareForeign Tracked 2 IO_openFile_impl_v3 declareForeign Tracked 1 IO_closeFile_impl_v3 declareForeign Tracked 1 IO_isFileEOF_impl_v3 diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index be97b6fbc1..1cbd9305d4 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -214,13 +214,8 @@ foreignCallHelper = \case IO_UDP_ListenSocket_sendTo_impl_v1 -> mkForeignIOF $ \(socket :: ListenSocket, bytes :: Bytes.Bytes, addr :: ClientSockAddr) -> UDP.sendTo socket (Bytes.toArray bytes) addr - IO_openFile_impl_v3 -> mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) -> + IO_openFile_impl_v3 -> mkForeignIOF $ \(fnameText :: Util.Text.Text, mode :: IOMode) -> let fname = Util.Text.toString fnameText - mode = case n of - 0 -> ReadMode - 1 -> WriteMode - 2 -> AppendMode - _ -> ReadWriteMode in openFile fname mode IO_closeFile_impl_v3 -> mkForeignIOF hClose IO_isFileEOF_impl_v3 -> mkForeignIOF hIsEOF @@ -336,11 +331,10 @@ foreignCallHelper = \case IO_kill_impl_v3 -> mkForeignIOF killThread IO_delay_impl_v3 -> mkForeignIOF customDelay IO_stdHandle -> mkForeign $ - \(n :: Int) -> case n of - 0 -> pure SYS.stdin - 1 -> pure SYS.stdout - 2 -> pure SYS.stderr - _ -> die "IO.stdHandle: invalid input." + \case + StdIn -> pure SYS.stdin + StdOut -> pure SYS.stdout + StdErr -> pure SYS.stderr IO_process_call -> mkForeign $ \(exe, map Util.Text.unpack -> args) -> withCreateProcess (proc exe args) $ \_ _ _ p -> @@ -1757,8 +1751,8 @@ decodeBufferMode (Enum _ t) | t == noBufTag = pure NoBuffering | t == lineBufTag = pure LineBuffering | t == blockBufTag = pure $ BlockBuffering Nothing -decodeBufferMode (Data1 _ t (IntVal i)) - | t == sizedBlockBufTag = pure . BlockBuffering $ Just i +decodeBufferMode (Data1 _ t (NatVal i)) + | t == sizedBlockBufTag = pure . BlockBuffering $ Just (fromIntegral i) decodeBufferMode c = foreignConventionError "BufferMode" (BoxedVal c) encodeBufferMode :: BufferMode -> Closure @@ -1837,6 +1831,34 @@ instance ForeignConvention SeekMode where readAtIndex stk i = bpeekOff stk i >>= decodeSeekMode writeBack stk sm = bpoke stk (encodeSeekMode sm) +data StdHnd = StdIn | StdOut | StdErr + +decodeStdHnd :: Closure -> IO StdHnd +decodeStdHnd (Enum _ t) + | t == stdInTag = pure StdIn + | t == stdOutTag = pure StdOut + | t == stdErrTag = pure StdErr +decodeStdHnd c = foreignConventionError "StdHandle" (BoxedVal c) + +encodeStdHnd :: StdHnd -> Closure +encodeStdHnd StdIn = std'in +encodeStdHnd StdOut = std'out +encodeStdHnd StdErr = std'err + +std'in, std'out, std'err :: Closure +std'in = Enum Ty.stdHandleRef stdInTag +std'out = Enum Ty.stdHandleRef stdOutTag +std'err = Enum Ty.stdHandleRef stdErrTag + +instance ForeignConvention StdHnd where + decodeVal (BoxedVal c) = decodeStdHnd c + decodeVal v = foreignConventionError "StdHandle" v + + encodeVal = BoxedVal . encodeStdHnd + + readAtIndex stk i = bpeekOff stk i >>= decodeStdHnd + writeBack stk = bpoke stk . encodeStdHnd + -- In reality this fixes the type to be 'RClosure', but allows us to defer -- the typechecker a bit and avoid a bunch of annoying type annotations. -- instance {-# OVERLAPPING #-} ForeignConvention [Val] where diff --git a/unison-runtime/src/Unison/Runtime/TypeTags.hs b/unison-runtime/src/Unison/Runtime/TypeTags.hs index d94c73b399..ea8a9236d4 100644 --- a/unison-runtime/src/Unison/Runtime/TypeTags.hs +++ b/unison-runtime/src/Unison/Runtime/TypeTags.hs @@ -33,6 +33,9 @@ module Unison.Runtime.TypeTags seekEndTag, exceptionTag, exceptionRaiseTag, + stdInTag, + stdOutTag, + stdErrTag, ) where @@ -204,6 +207,15 @@ seekAbsoluteTag, seekRelativeTag, seekEndTag :: PackedTag Ty.seekModeEndId ] = (at, rt, et) | otherwise = error "internal error: seek mode tags" +stdInTag, stdOutTag, stdErrTag :: PackedTag +(stdInTag, stdOutTag, stdErrTag) + | [it, ot, et] <- + mkTags "standard handle tags" Ty.stdHandleRef + [ Ty.stdInId, + Ty.stdOutId, + Ty.stdErrId ] = (it, ot, et) + | otherwise = error "internal error: standard handle tags" + exceptionTag :: Word64 exceptionRaiseTag :: PackedTag (exceptionTag, exceptionRaiseTag) From 85feecc1eca29005745cf71b27ff3df1be4933b5 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Wed, 15 Jan 2025 15:58:44 -0500 Subject: [PATCH 7/7] Delete some dead, commented code --- .../src/Unison/Runtime/Foreign/Function.hs | 40 ------------------- 1 file changed, 40 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 6af7c150be..f1f614c580 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -1706,46 +1706,6 @@ instance ForeignConvention POSIXTime where readAtIndex stk i = fromIntegral <$> peekOffI stk i writeBack stk pt = pokeI stk (round pt) - --- mkForeignExn :: --- ForeignArgs a => --- ForeignConvention e => --- ForeignConvention r => --- (a -> IO (Either (Failure e) r)) -> --- ForeignFunc --- mkForeignExn f = FFE f - --- TODO: was this ever actually used? Mapping IO exceptions to numbers. --- --- ioeDecode :: Int -> IOErrorType --- ioeDecode 0 = AlreadyExists --- ioeDecode 1 = NoSuchThing --- ioeDecode 2 = ResourceBusy --- ioeDecode 3 = ResourceExhausted --- ioeDecode 4 = EOF --- ioeDecode 5 = IllegalOperation --- ioeDecode 6 = PermissionDenied --- ioeDecode 7 = UserError --- ioeDecode _ = internalBug "ioeDecode" - --- ioeEncode :: IOErrorType -> Int --- ioeEncode AlreadyExists = 0 --- ioeEncode NoSuchThing = 1 --- ioeEncode ResourceBusy = 2 --- ioeEncode ResourceExhausted = 3 --- ioeEncode EOF = 4 --- ioeEncode IllegalOperation = 5 --- ioeEncode PermissionDenied = 6 --- ioeEncode UserError = 7 --- ioeEncode _ = internalBug "ioeDecode" - --- instance ForeignConvention IOException where --- readForeign = readForeignAs (bld . ioeDecode) --- where --- bld t = IOError Nothing t "" "" Nothing Nothing --- --- writeForeign = writeForeignAs (ioeEncode . ioe_type) - decodeBufferMode :: Closure -> IO BufferMode decodeBufferMode (Enum _ t) | t == TT.noBufTag = pure NoBuffering