From 7f96a4dff9b6e812540ee17b31cb58f972e76be6 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 19 Nov 2024 15:16:07 -0800 Subject: [PATCH 01/36] Add Ord to *DefinitionDiffs --- .../src/Unison/Util/AnnotatedText.hs | 5 ++--- unison-share-api/src/Unison/Server/Types.hs | 22 +++++++++---------- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs b/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs index 47bb6d9ca7..7061ece97f 100644 --- a/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs +++ b/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs @@ -21,13 +21,13 @@ import Unison.Util.Monoid (intercalateMap) import Unison.Util.Range (Range (..), inRange) data Segment a = Segment {segment :: String, annotation :: Maybe a} - deriving (Eq, Show, Functor, Foldable, Generic) + deriving (Eq, Show, Ord, Functor, Foldable, Generic) toPair :: Segment a -> (String, Maybe a) toPair (Segment s a) = (s, a) newtype AnnotatedText a = AnnotatedText (Seq (Segment a)) - deriving (Eq, Functor, Foldable, Show, Generic) + deriving (Eq, Functor, Foldable, Show, Ord, Generic) instance Semigroup (AnnotatedText a) where AnnotatedText (as :|> Segment "" _) <> bs = AnnotatedText as <> bs @@ -204,7 +204,6 @@ snipWithContext margin source = -- if all annotations so far can be joined without .. separations if null rest then -- if this one can be joined to the new region without .. separation - if withinMargin r0 r1 then -- add it to the first set and grow the compare region (Just $ r0 <> r1, Map.insert r1 a1 taken, mempty) diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 6139c395af..21799f4337 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -198,14 +198,14 @@ data TermDefinitionDiff = TermDefinitionDiff right :: TermDefinition, diff :: DisplayObjectDiff } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) data TypeDefinitionDiff = TypeDefinitionDiff { left :: TypeDefinition, right :: TypeDefinition, diff :: DisplayObjectDiff } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) newtype Suffixify = Suffixify {suffixified :: Bool} deriving (Eq, Ord, Show, Generic) @@ -218,7 +218,7 @@ data TermDefinition = TermDefinition signature :: Syntax.SyntaxText, termDocs :: [(HashQualifiedName, UnisonHash, Doc)] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Ord, Generic) data TypeDefinition = TypeDefinition { typeNames :: [HashQualifiedName], @@ -227,14 +227,14 @@ data TypeDefinition = TypeDefinition typeDefinition :: DisplayObject Syntax.SyntaxText Syntax.SyntaxText, typeDocs :: [(HashQualifiedName, UnisonHash, Doc)] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Ord, Generic) data DefinitionDisplayResults = DefinitionDisplayResults { termDefinitions :: Map UnisonHash TermDefinition, typeDefinitions :: Map UnisonHash TypeDefinition, missingDefinitions :: [HashQualifiedName] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Ord, Generic) instance Semigroup DefinitionDisplayResults where DefinitionDisplayResults terms1 types1 missing1 <> DefinitionDisplayResults terms2 types2 missing2 = @@ -260,7 +260,7 @@ data SemanticSyntaxDiff SegmentChange (String, String) (Maybe Syntax.Element) | -- (shared segment) (fromAnnotation, toAnnotation) AnnotationChange String (Maybe Syntax.Element, Maybe Syntax.Element) - deriving (Eq, Show, Generic) + deriving (Eq, Show, Ord, Generic) deriving instance ToSchema SemanticSyntaxDiff @@ -303,7 +303,7 @@ instance ToJSON SemanticSyntaxDiff where data DisplayObjectDiff = DisplayObjectDiff (DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff]) | MismatchedDisplayObjects (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) - deriving stock (Show, Eq, Generic) + deriving stock (Show, Eq, Ord, Generic) deriving instance ToSchema DisplayObjectDiff @@ -324,7 +324,7 @@ data NamedTerm = NamedTerm termType :: Maybe Syntax.SyntaxText, termTag :: TermTag } - deriving (Eq, Generic, Show) + deriving (Eq, Ord, Generic, Show) instance ToJSON NamedTerm where toJSON (NamedTerm n h typ tag) = @@ -350,7 +350,7 @@ data NamedType = NamedType typeHash :: ShortHash, typeTag :: TypeTag } - deriving (Eq, Generic, Show) + deriving (Eq, Ord, Generic, Show) instance ToJSON NamedType where toJSON (NamedType n h tag) = @@ -474,7 +474,7 @@ data TermDiffResponse = TermDiffResponse newTerm :: TermDefinition, diff :: DisplayObjectDiff } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriving instance ToSchema TermDiffResponse @@ -512,7 +512,7 @@ data TypeDiffResponse = TypeDiffResponse newType :: TypeDefinition, diff :: DisplayObjectDiff } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriving instance ToSchema TypeDiffResponse From 40eac6a121a5edb8e083523b769aa656df0fa54e Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 20 Nov 2024 09:12:28 -0800 Subject: [PATCH 02/36] Add instances --- unison-share-api/src/Unison/Server/Doc.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Doc.hs b/unison-share-api/src/Unison/Server/Doc.hs index ec2ee1cd1d..7a9ad22ab0 100644 --- a/unison-share-api/src/Unison/Server/Doc.hs +++ b/unison-share-api/src/Unison/Server/Doc.hs @@ -90,7 +90,7 @@ data DocG specialForm | UntitledSection [(DocG specialForm)] | Column [(DocG specialForm)] | Group (DocG specialForm) - deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) + deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) deriving anyclass (ToJSON) deriving instance (ToSchema specialForm) => ToSchema (DocG specialForm) @@ -98,13 +98,13 @@ deriving instance (ToSchema specialForm) => ToSchema (DocG specialForm) type UnisonHash = Text data Ref a = Term a | Type a - deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) + deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) deriving anyclass (ToJSON) instance (ToSchema a) => ToSchema (Ref a) data MediaSource = MediaSource {mediaSourceUrl :: Text, mediaSourceMimeType :: Maybe Text} - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving anyclass (ToJSON, ToSchema) data RenderedSpecialForm @@ -124,7 +124,7 @@ data RenderedSpecialForm | LaTeXInline Text | Svg Text | RenderError (RenderError SyntaxText) - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving anyclass (ToJSON, ToSchema) data EvaluatedSpecialForm v @@ -146,11 +146,11 @@ data EvaluatedSpecialForm v | ELaTeXInline Text | ESvg Text | ERenderError (RenderError (Term v ())) - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) -- `Src folded unfolded` data Src = Src SyntaxText SyntaxText - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving anyclass (ToJSON, ToSchema) -- | Evaluate the doc, then render it. @@ -447,7 +447,7 @@ evalDoc terms typeOf eval types tm = data RenderError trm = InvalidTerm trm - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving anyclass (ToJSON) deriving anyclass instance (ToSchema trm) => ToSchema (RenderError trm) @@ -455,20 +455,20 @@ deriving anyclass instance (ToSchema trm) => ToSchema (RenderError trm) data EvaluatedSrc v = EvaluatedSrcDecl (EvaluatedDecl v) | EvaluatedSrcTerm (EvaluatedTerm v) - deriving stock (Show, Eq, Generic) + deriving stock (Show, Ord, Eq, Generic) data EvaluatedDecl v = MissingDecl Reference | BuiltinDecl Reference | FoundDecl Reference (DD.Decl v ()) - deriving stock (Show, Eq, Generic) + deriving stock (Show, Ord, Eq, Generic) data EvaluatedTerm v = MissingTerm Reference | BuiltinTypeSig Reference (Type v ()) | MissingBuiltinTypeSig Reference | FoundTerm Reference (Type v ()) (Term v ()) - deriving stock (Show, Eq, Generic) + deriving stock (Show, Eq, Ord, Generic) -- Determines all dependencies which will be required to render a doc. dependencies :: (Ord v) => EvaluatedDoc v -> Set LD.LabeledDependency From fc413e1ed5dd29640c302983a5b0e31991686405 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Wed, 4 Dec 2024 11:56:05 -0500 Subject: [PATCH 03/36] add failing transcript --- unison-src/transcripts/idempotent/fix-5427.md | 100 ++++++++++++++++++ 1 file changed, 100 insertions(+) create mode 100644 unison-src/transcripts/idempotent/fix-5427.md diff --git a/unison-src/transcripts/idempotent/fix-5427.md b/unison-src/transcripts/idempotent/fix-5427.md new file mode 100644 index 0000000000..6455f38eed --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5427.md @@ -0,0 +1,100 @@ +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +foo : Nat +foo = 17 + +bar : Nat +bar = + foo = .foo + foo + +baz : Nat +baz = foo + foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + baz : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + baz : Nat + foo : Nat +``` + +``` unison +foo : Nat +foo = 18 + +bar : Nat +bar = + foo = .foo + foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + bar : Nat + foo : Nat +``` + +This should succeed, but `bar` gets printed incorrectly\! + +``` ucm :error +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Typechecking failed. I've updated your scratch file with the + definitions that need fixing. Once the file is compiling, try + `update` again. +``` + +``` unison :added-by-ucm scratch.u +foo : Nat +foo = 18 + +bar : Nat +bar = + foo = foo + foo + +-- The definitions below no longer typecheck with the changes above. +-- Please fix the errors and try `update` again. + +baz : Nat +baz = + use Nat + + foo + foo + +``` From 91cb40a3094d43e26c86c40d5cd4757650fde406 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 4 Dec 2024 14:32:26 -0800 Subject: [PATCH 04/36] Define enum for all foreign calls --- unison-runtime/src/Unison/Runtime/Builtin.hs | 249 +++++++++++++++++ .../src/Unison/Runtime/Foreign/Function.hs | 250 ++++++++++++++++++ 2 files changed, 499 insertions(+) diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 6c292f4a78..9ee5f04904 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -1844,6 +1844,255 @@ type FDecl v = data Sandbox = Tracked | Untracked deriving (Eq, Ord, Show, Read, Enum, Bounded) +foreignFuncTracking :: ForeignFunc' -> Sandbox +foreignFuncTracking = \case + IO_UDP_clientSocket_impl_v1 -> Tracked + IO_UDP_UDPSocket_recv_impl_v1 -> Tracked + IO_UDP_UDPSocket_send_impl_v1 -> Tracked + IO_UDP_UDPSocket_close_impl_v1 -> Tracked + IO_UDP_ListenSocket_close_impl_v1 -> Tracked + IO_UDP_UDPSocket_toText_impl_v1 -> Tracked + IO_UDP_serverSocket_impl_v1 -> Tracked + IO_UDP_ListenSocket_toText_impl_v1 -> Tracked + IO_UDP_ListenSocket_recvFrom_impl_v1 -> Tracked + IO_UDP_ClientSockAddr_toText_v1 -> Tracked + IO_UDP_ListenSocket_sendTo_impl_v1 -> Tracked + IO_openFile_impl_v3 -> Tracked + IO_closeFile_impl_v3 -> Tracked + IO_isFileEOF_impl_v3 -> Tracked + IO_isFileOpen_impl_v3 -> Tracked + IO_getEcho_impl_v1 -> Tracked + IO_ready_impl_v1 -> Tracked + IO_getChar_impl_v1 -> Tracked + IO_isSeekable_impl_v3 -> Tracked + IO_seekHandle_impl_v3 -> Tracked + IO_handlePosition_impl_v3 -> Tracked + IO_getBuffering_impl_v3 -> Tracked + IO_setBuffering_impl_v3 -> Tracked + IO_setEcho_impl_v1 -> Tracked + IO_getLine_impl_v1 -> Tracked + IO_getBytes_impl_v3 -> Tracked + IO_getSomeBytes_impl_v1 -> Tracked + IO_putBytes_impl_v3 -> Tracked + IO_systemTime_impl_v3 -> Tracked + IO_systemTimeMicroseconds_v1 -> Tracked + Clock_internals_monotonic_v1 -> Tracked + Clock_internals_realtime_v1 -> Tracked + Clock_internals_processCPUTime_v1 -> Tracked + Clock_internals_threadCPUTime_v1 -> Tracked + Clock_internals_sec_v1 -> Tracked + Clock_internals_nsec_v1 -> Tracked + Clock_internals_systemTimeZone_v1 -> Tracked + IO_getTempDirectory_impl_v3 -> Tracked + IO_createTempDirectory_impl_v3 -> Tracked + IO_getCurrentDirectory_impl_v3 -> Tracked + IO_setCurrentDirectory_impl_v3 -> Tracked + IO_fileExists_impl_v3 -> Tracked + IO_getEnv_impl_v1 -> Tracked + IO_getArgs_impl_v1 -> Tracked + IO_isDirectory_impl_v3 -> Tracked + IO_createDirectory_impl_v3 -> Tracked + IO_removeDirectory_impl_v3 -> Tracked + IO_renameDirectory_impl_v3 -> Tracked + IO_directoryContents_impl_v3 -> Tracked + IO_removeFile_impl_v3 -> Tracked + IO_renameFile_impl_v3 -> Tracked + IO_getFileTimestamp_impl_v3 -> Tracked + IO_getFileSize_impl_v3 -> Tracked + IO_serverSocket_impl_v3 -> Tracked + Socket_toText -> Tracked + Handle_toText -> Tracked + ThreadId_toText -> Tracked + IO_socketPort_impl_v3 -> Tracked + IO_listen_impl_v3 -> Tracked + IO_clientSocket_impl_v3 -> Tracked + IO_closeSocket_impl_v3 -> Tracked + IO_socketAccept_impl_v3 -> Tracked + IO_socketSend_impl_v3 -> Tracked + IO_socketReceive_impl_v3 -> Tracked + IO_kill_impl_v3 -> Tracked + IO_delay_impl_v3 -> Tracked + IO_stdHandle -> Tracked + IO_process_call -> Tracked + IO_process_start -> Tracked + IO_process_kill -> Tracked + IO_process_wait -> Tracked + IO_process_exitCode -> Tracked + MVar_new -> Tracked + MVar_newEmpty_v2 -> Tracked + MVar_take_impl_v3 -> Tracked + MVar_tryTake -> Tracked + MVar_put_impl_v3 -> Tracked + MVar_tryPut_impl_v3 -> Tracked + MVar_swap_impl_v3 -> Tracked + MVar_isEmpty -> Tracked + MVar_read_impl_v3 -> Tracked + MVar_tryRead_impl_v3 -> Tracked + Char_toText -> Untracked + Text_repeat -> Untracked + Text_reverse -> Untracked + Text_toUppercase -> Untracked + Text_toLowercase -> Untracked + Text_toUtf8 -> Untracked + Text_fromUtf8_impl_v3 -> Untracked + Tls_ClientConfig_default -> Tracked + Tls_ServerConfig_default -> Tracked + Tls_ClientConfig_certificates_set -> Tracked + Tls_ServerConfig_certificates_set -> Tracked + TVar_new -> Tracked + TVar_read -> Tracked + TVar_write -> Tracked + TVar_newIO -> Tracked + TVar_readIO -> Tracked + TVar_swap -> Tracked + STM_retry -> Tracked + Promise_new -> Tracked + Promise_read -> Tracked + Promise_tryRead -> Tracked + Promise_write -> Tracked + Tls_newClient_impl_v3 -> Tracked + Tls_newServer_impl_v3 -> Tracked + Tls_handshake_impl_v3 -> Tracked + Tls_send_impl_v3 -> Tracked + Tls_decodeCert_impl_v3 -> Tracked + Tls_encodeCert -> Tracked + Tls_decodePrivateKey -> Tracked + Tls_encodePrivateKey -> Tracked + Tls_receive_impl_v3 -> Tracked + Tls_terminate_impl_v3 -> Tracked + Code_validateLinks -> Untracked + Code_dependencies -> Untracked + Code_serialize -> Untracked + Code_deserialize -> Untracked + Code_display -> Untracked + Value_dependencies -> Untracked + Value_serialize -> Untracked + Value_deserialize -> Untracked + Crypto_HashAlgorithm_Sha3_512 -> Untracked + Crypto_HashAlgorithm_Sha3_256 -> Untracked + Crypto_HashAlgorithm_Sha2_512 -> Untracked + Crypto_HashAlgorithm_Sha2_256 -> Untracked + Crypto_HashAlgorithm_Sha1 -> Untracked + Crypto_HashAlgorithm_Blake2b_512 -> Untracked + Crypto_HashAlgorithm_Blake2b_256 -> Untracked + Crypto_HashAlgorithm_Blake2s_256 -> Untracked + Crypto_HashAlgorithm_Md5 -> Untracked + Crypto_hashBytes -> Untracked + Crypto_hmacBytes -> Untracked + Crypto_hash -> Untracked + Crypto_hmac -> Untracked + Crypto_Ed25519_sign_impl -> Untracked + Crypto_Ed25519_verify_impl -> Untracked + Crypto_Rsa_sign_impl -> Untracked + Crypto_Rsa_verify_impl -> Untracked + Universal_murmurHash -> Untracked + IO_randomBytes -> Tracked + Bytes_zlib_compress -> Untracked + Bytes_gzip_compress -> Untracked + Bytes_zlib_decompress -> Untracked + Bytes_gzip_decompress -> Untracked + Bytes_toBase16 -> Untracked + Bytes_toBase32 -> Untracked + Bytes_toBase64 -> Untracked + Bytes_toBase64UrlUnpadded -> Untracked + Bytes_fromBase16 -> Untracked + Bytes_fromBase32 -> Untracked + Bytes_fromBase64 -> Untracked + Bytes_fromBase64UrlUnpadded -> Untracked + Bytes_decodeNat64be -> Untracked + Bytes_decodeNat64le -> Untracked + Bytes_decodeNat32be -> Untracked + Bytes_decodeNat32le -> Untracked + Bytes_decodeNat16be -> Untracked + Bytes_decodeNat16le -> Untracked + Bytes_encodeNat64be -> Untracked + Bytes_encodeNat64le -> Untracked + Bytes_encodeNat32be -> Untracked + Bytes_encodeNat32le -> Untracked + Bytes_encodeNat16be -> Untracked + Bytes_encodeNat16le -> Untracked + MutableArray_copyTo_force -> Untracked + MutableByteArray_copyTo_force -> Untracked + ImmutableArray_copyTo_force -> Untracked + ImmutableArray_size -> Untracked + MutableArray_size -> Untracked + ImmutableByteArray_size -> Untracked + MutableByteArray_size -> Untracked + ImmutableByteArray_copyTo_force -> Untracked + MutableArray_read -> Untracked + MutableByteArray_read8 -> Untracked + MutableByteArray_read16be -> Untracked + MutableByteArray_read24be -> Untracked + MutableByteArray_read32be -> Untracked + MutableByteArray_read40be -> Untracked + MutableByteArray_read64be -> Untracked + MutableArray_write -> Untracked + MutableByteArray_write8 -> Untracked + MutableByteArray_write16be -> Untracked + MutableByteArray_write32be -> Untracked + MutableByteArray_write64be -> Untracked + ImmutableArray_read -> Untracked + ImmutableByteArray_read8 -> Untracked + ImmutableByteArray_read16be -> Untracked + ImmutableByteArray_read24be -> Untracked + ImmutableByteArray_read32be -> Untracked + ImmutableByteArray_read40be -> Untracked + ImmutableByteArray_read64be -> Untracked + MutableByteArray_freeze_force -> Untracked + MutableArray_freeze_force -> Untracked + MutableByteArray_freeze -> Untracked + MutableArray_freeze -> Untracked + MutableByteArray_length -> Untracked + ImmutableByteArray_length -> Untracked + IO_array -> Tracked + IO_arrayOf -> Tracked + IO_bytearray -> Tracked + IO_bytearrayOf -> Tracked + Scope_array -> Untracked + Scope_arrayOf -> Untracked + Scope_bytearray -> Untracked + Scope_bytearrayOf -> Untracked + Text_patterns_literal -> Untracked + Text_patterns_digit -> Untracked + Text_patterns_letter -> Untracked + Text_patterns_space -> Untracked + Text_patterns_punctuation -> Untracked + Text_patterns_anyChar -> Untracked + Text_patterns_eof -> Untracked + Text_patterns_charRange -> Untracked + Text_patterns_notCharRange -> Untracked + Text_patterns_charIn -> Untracked + Text_patterns_notCharIn -> Untracked + Pattern_many -> Untracked + Pattern_many_corrected -> Untracked + Pattern_capture -> Untracked + Pattern_captureAs -> Untracked + Pattern_join -> Untracked + Pattern_or -> Untracked + Pattern_replicate -> Untracked + Pattern_run -> Untracked + Pattern_isMatch -> Untracked + Char_Class_any -> Untracked + Char_Class_not -> Untracked + Char_Class_and -> Untracked + Char_Class_or -> Untracked + Char_Class_range -> Untracked + Char_Class_anyOf -> Untracked + Char_Class_alphanumeric -> Untracked + Char_Class_upper -> Untracked + Char_Class_lower -> Untracked + Char_Class_whitespace -> Untracked + Char_Class_control -> Untracked + Char_Class_printable -> Untracked + Char_Class_mark -> Untracked + Char_Class_number -> Untracked + Char_Class_punctuation -> Untracked + Char_Class_symbol -> Untracked + Char_Class_separator -> Untracked + Char_Class_letter -> Untracked + Char_Class_is -> Untracked + Text_patterns_char -> Untracked + bomb :: Data.Text.Text -> a -> IO r bomb name _ = die $ "attempted to use sandboxed operation: " ++ Data.Text.unpack name diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 60808351e1..654ca70f32 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -8,6 +8,7 @@ module Unison.Runtime.Foreign.Function ( ForeignFunc (..), ForeignConvention (..), + ForeignFunc' (..), mkForeign, ) where @@ -50,6 +51,255 @@ import Unison.Util.Bytes (Bytes) import Unison.Util.RefPromise (Promise) import Unison.Util.Text (Text, pack, unpack) +-- | Enum representing every foreign call. +data ForeignFunc' + = IO_UDP_clientSocket_impl_v1 + | IO_UDP_UDPSocket_recv_impl_v1 + | IO_UDP_UDPSocket_send_impl_v1 + | IO_UDP_UDPSocket_close_impl_v1 + | IO_UDP_ListenSocket_close_impl_v1 + | IO_UDP_UDPSocket_toText_impl_v1 + | IO_UDP_serverSocket_impl_v1 + | IO_UDP_ListenSocket_toText_impl_v1 + | IO_UDP_ListenSocket_recvFrom_impl_v1 + | IO_UDP_ClientSockAddr_toText_v1 + | IO_UDP_ListenSocket_sendTo_impl_v1 + | IO_openFile_impl_v3 + | IO_closeFile_impl_v3 + | IO_isFileEOF_impl_v3 + | IO_isFileOpen_impl_v3 + | IO_getEcho_impl_v1 + | IO_ready_impl_v1 + | IO_getChar_impl_v1 + | IO_isSeekable_impl_v3 + | IO_seekHandle_impl_v3 + | IO_handlePosition_impl_v3 + | IO_getBuffering_impl_v3 + | IO_setBuffering_impl_v3 + | IO_setEcho_impl_v1 + | IO_getLine_impl_v1 + | IO_getBytes_impl_v3 + | IO_getSomeBytes_impl_v1 + | IO_putBytes_impl_v3 + | IO_systemTime_impl_v3 + | IO_systemTimeMicroseconds_v1 + | Clock_internals_monotonic_v1 + | Clock_internals_realtime_v1 + | Clock_internals_processCPUTime_v1 + | Clock_internals_threadCPUTime_v1 + | Clock_internals_sec_v1 + | Clock_internals_nsec_v1 + | Clock_internals_systemTimeZone_v1 + | IO_getTempDirectory_impl_v3 + | IO_createTempDirectory_impl_v3 + | IO_getCurrentDirectory_impl_v3 + | IO_setCurrentDirectory_impl_v3 + | IO_fileExists_impl_v3 + | IO_getEnv_impl_v1 + | IO_getArgs_impl_v1 + | IO_isDirectory_impl_v3 + | IO_createDirectory_impl_v3 + | IO_removeDirectory_impl_v3 + | IO_renameDirectory_impl_v3 + | IO_directoryContents_impl_v3 + | IO_removeFile_impl_v3 + | IO_renameFile_impl_v3 + | IO_getFileTimestamp_impl_v3 + | IO_getFileSize_impl_v3 + | IO_serverSocket_impl_v3 + | Socket_toText + | Handle_toText + | ThreadId_toText + | IO_socketPort_impl_v3 + | IO_listen_impl_v3 + | IO_clientSocket_impl_v3 + | IO_closeSocket_impl_v3 + | IO_socketAccept_impl_v3 + | IO_socketSend_impl_v3 + | IO_socketReceive_impl_v3 + | IO_kill_impl_v3 + | IO_delay_impl_v3 + | IO_stdHandle + | IO_process_call + | IO_process_start + | IO_process_kill + | IO_process_wait + | IO_process_exitCode + | MVar_new + | MVar_newEmpty_v2 + | MVar_take_impl_v3 + | MVar_tryTake + | MVar_put_impl_v3 + | MVar_tryPut_impl_v3 + | MVar_swap_impl_v3 + | MVar_isEmpty + | MVar_read_impl_v3 + | MVar_tryRead_impl_v3 + | Char_toText + | Text_repeat + | Text_reverse + | Text_toUppercase + | Text_toLowercase + | Text_toUtf8 + | Text_fromUtf8_impl_v3 + | Tls_ClientConfig_default + | Tls_ServerConfig_default + | Tls_ClientConfig_certificates_set + | Tls_ServerConfig_certificates_set + | TVar_new + | TVar_read + | TVar_write + | TVar_newIO + | TVar_readIO + | TVar_swap + | STM_retry + | Promise_new + | Promise_read + | Promise_tryRead + | Promise_write + | Tls_newClient_impl_v3 + | Tls_newServer_impl_v3 + | Tls_handshake_impl_v3 + | Tls_send_impl_v3 + | Tls_decodeCert_impl_v3 + | Tls_encodeCert + | Tls_decodePrivateKey + | Tls_encodePrivateKey + | Tls_receive_impl_v3 + | Tls_terminate_impl_v3 + | Code_validateLinks + | Code_dependencies + | Code_serialize + | Code_deserialize + | Code_display + | Value_dependencies + | Value_serialize + | Value_deserialize + | Crypto_HashAlgorithm_Sha3_512 + | Crypto_HashAlgorithm_Sha3_256 + | Crypto_HashAlgorithm_Sha2_512 + | Crypto_HashAlgorithm_Sha2_256 + | Crypto_HashAlgorithm_Sha1 + | Crypto_HashAlgorithm_Blake2b_512 + | Crypto_HashAlgorithm_Blake2b_256 + | Crypto_HashAlgorithm_Blake2s_256 + | Crypto_HashAlgorithm_Md5 + | Crypto_hashBytes + | Crypto_hmacBytes + | Crypto_hash + | Crypto_hmac + | Crypto_Ed25519_sign_impl + | Crypto_Ed25519_verify_impl + | Crypto_Rsa_sign_impl + | Crypto_Rsa_verify_impl + | Universal_murmurHash + | IO_randomBytes + | Bytes_zlib_compress + | Bytes_gzip_compress + | Bytes_zlib_decompress + | Bytes_gzip_decompress + | Bytes_toBase16 + | Bytes_toBase32 + | Bytes_toBase64 + | Bytes_toBase64UrlUnpadded + | Bytes_fromBase16 + | Bytes_fromBase32 + | Bytes_fromBase64 + | Bytes_fromBase64UrlUnpadded + | Bytes_decodeNat64be + | Bytes_decodeNat64le + | Bytes_decodeNat32be + | Bytes_decodeNat32le + | Bytes_decodeNat16be + | Bytes_decodeNat16le + | Bytes_encodeNat64be + | Bytes_encodeNat64le + | Bytes_encodeNat32be + | Bytes_encodeNat32le + | Bytes_encodeNat16be + | Bytes_encodeNat16le + | MutableArray_copyTo_force + | MutableByteArray_copyTo_force + | ImmutableArray_copyTo_force + | ImmutableArray_size + | MutableArray_size + | ImmutableByteArray_size + | MutableByteArray_size + | ImmutableByteArray_copyTo_force + | MutableArray_read + | MutableByteArray_read8 + | MutableByteArray_read16be + | MutableByteArray_read24be + | MutableByteArray_read32be + | MutableByteArray_read40be + | MutableByteArray_read64be + | MutableArray_write + | MutableByteArray_write8 + | MutableByteArray_write16be + | MutableByteArray_write32be + | MutableByteArray_write64be + | ImmutableArray_read + | ImmutableByteArray_read8 + | ImmutableByteArray_read16be + | ImmutableByteArray_read24be + | ImmutableByteArray_read32be + | ImmutableByteArray_read40be + | ImmutableByteArray_read64be + | MutableByteArray_freeze_force + | MutableArray_freeze_force + | MutableByteArray_freeze + | MutableArray_freeze + | MutableByteArray_length + | ImmutableByteArray_length + | IO_array + | IO_arrayOf + | IO_bytearray + | IO_bytearrayOf + | Scope_array + | Scope_arrayOf + | Scope_bytearray + | Scope_bytearrayOf + | Text_patterns_literal + | Text_patterns_digit + | Text_patterns_letter + | Text_patterns_space + | Text_patterns_punctuation + | Text_patterns_anyChar + | Text_patterns_eof + | Text_patterns_charRange + | Text_patterns_notCharRange + | Text_patterns_charIn + | Text_patterns_notCharIn + | Pattern_many + | Pattern_many_corrected + | Pattern_capture + | Pattern_captureAs + | Pattern_join + | Pattern_or + | Pattern_replicate + | Pattern_run + | Pattern_isMatch + | Char_Class_any + | Char_Class_not + | Char_Class_and + | Char_Class_or + | Char_Class_range + | Char_Class_anyOf + | Char_Class_alphanumeric + | Char_Class_upper + | Char_Class_lower + | Char_Class_whitespace + | Char_Class_control + | Char_Class_printable + | Char_Class_mark + | Char_Class_number + | Char_Class_punctuation + | Char_Class_symbol + | Char_Class_separator + | Char_Class_letter + | Char_Class_is + | Text_patterns_char + -- Foreign functions operating on stacks data ForeignFunc where FF :: From 1444456119ac18a4a726c7991e9d1c49fa9b8de5 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 4 Dec 2024 15:33:57 -0800 Subject: [PATCH 05/36] Implement a bunch of builtin impls --- unison-runtime/src/Unison/Runtime/Builtin.hs | 534 ++++---------- .../src/Unison/Runtime/Foreign/Function.hs | 249 ------- .../src/Unison/Runtime/Foreign/Impl.hs | 679 ++++++++++++++++++ unison-runtime/src/Unison/Runtime/MCode.hs | 256 +++++++ unison-runtime/src/Unison/Runtime/Machine.hs | 31 +- unison-runtime/unison-runtime.cabal | 1 + 6 files changed, 1088 insertions(+), 662 deletions(-) create mode 100644 unison-runtime/src/Unison/Runtime/Foreign/Impl.hs diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 9ee5f04904..2a015691d0 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -20,6 +20,7 @@ module Unison.Runtime.Builtin numberedTermLookup, Sandbox (..), baseSandboxInfo, + unitValue, ) where @@ -1837,6 +1838,9 @@ builtinLookup = type FDecl v = ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc))) +type FDecl' v = + ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc'))) + -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked -- means that the sandboxing check will by default consider them @@ -2114,17 +2118,22 @@ declareForeign sand name op func0 = do code = (name, (sand, uncurry Lambda (op w))) in (w + 1, code : codes, mapInsert w (name, func) funcs) -mkForeignIOF :: - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) - where - tryIOE :: IO a -> IO (Either Failure a) - tryIOE = fmap handleIOE . try - handleIOE :: Either IOException a -> Either Failure a - handleIOE (Left e) = Left $ Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue - handleIOE (Right a) = Right a +declareForeign' :: + Sandbox -> + Data.Text.Text -> + ForeignOp -> + ForeignFunc' -> + FDecl' Symbol () +declareForeign' sand name op func0 = do + sanitize <- ask + modify $ \(w, codes, funcs) -> + let func + | sanitize, + Tracked <- sand = + error "TODO: fill in sandboxing error" + | otherwise = func0 + code = (name, (sand, uncurry Lambda (op w))) + in (w + 1, code : codes, mapInsert w (name, func) funcs) unitValue :: Val unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) @@ -2132,471 +2141,196 @@ unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) natValue :: Word64 -> Val natValue w = NatVal w -mkForeignTls :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) - where - tryIO1 :: IO r -> IO (Either TLS.TLSException r) - tryIO1 = try - tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) - tryIO2 = try - flatten :: Either IOException (Either TLS.TLSException r) -> Either (Failure) r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Right a)) = Right a - -mkForeignTlsE :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO (Either Failure r)) -> - ForeignFunc -mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) - where - tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) - tryIO1 = try - tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r))) - tryIO2 = try - flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Right (Left e))) = Left e - flatten (Right (Right (Right a))) = Right a - -declareUdpForeigns :: FDecl Symbol () +declareUdpForeigns :: FDecl' Symbol () declareUdpForeigns = do - declareForeign Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF - . mkForeignIOF - $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> - let hostStr = Util.Text.toString host - portStr = Util.Text.toString port - in UDP.clientSocket hostStr portStr True - - declareForeign Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF - . mkForeignIOF - $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock - - declareForeign Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 - . mkForeignIOF - $ \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> - UDP.send sock (Bytes.toArray bytes) - - declareForeign Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 - . mkForeignIOF - $ \(sock :: UDPSocket) -> UDP.close sock - - declareForeign Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 - . mkForeignIOF - $ \(sock :: ListenSocket) -> UDP.stop sock - - declareForeign Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) - . mkForeign - $ \(sock :: UDPSocket) -> pure $ show sock - - declareForeign Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF - . mkForeignIOF - $ \(ip :: Util.Text.Text, port :: Util.Text.Text) -> - let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP - maybePort = readMaybe $ Util.Text.toString port :: Maybe PortNumber - in case (maybeIp, maybePort) of - (Nothing, _) -> fail "Invalid IP Address" - (_, Nothing) -> fail "Invalid Port Number" - (Just ip, Just pt) -> UDP.serverSocket (ip, pt) - - declareForeign Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) - . mkForeign - $ \(sock :: ListenSocket) -> pure $ show sock - - declareForeign Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup - . mkForeignIOF - $ fmap (first Bytes.fromArray) <$> UDP.recvFrom - - declareForeign Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) - . mkForeign - $ \(sock :: ClientSockAddr) -> pure $ show sock - - declareForeign Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 - . mkForeignIOF - $ \(socket :: ListenSocket, bytes :: Bytes.Bytes, addr :: ClientSockAddr) -> - UDP.sendTo socket (Bytes.toArray bytes) addr - -declareForeigns :: FDecl Symbol () -declareForeigns = do - declareUdpForeigns - declareForeign Tracked "IO.openFile.impl.v3" argIomrToEF $ - mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) -> - let fname = Util.Text.toString fnameText - mode = case n of - 0 -> ReadMode - 1 -> WriteMode - 2 -> AppendMode - _ -> ReadWriteMode - in openFile fname mode - - declareForeign Tracked "IO.closeFile.impl.v3" argToEF0 $ mkForeignIOF hClose - declareForeign Tracked "IO.isFileEOF.impl.v3" argToEFBool $ mkForeignIOF hIsEOF - declareForeign Tracked "IO.isFileOpen.impl.v3" argToEFBool $ mkForeignIOF hIsOpen - declareForeign Tracked "IO.getEcho.impl.v1" argToEFBool $ mkForeignIOF hGetEcho - declareForeign Tracked "IO.ready.impl.v1" argToEFBool $ mkForeignIOF hReady - declareForeign Tracked "IO.getChar.impl.v1" argToEFChar $ mkForeignIOF hGetChar - declareForeign Tracked "IO.isSeekable.impl.v3" argToEFBool $ mkForeignIOF hIsSeekable - - declareForeign Tracked "IO.seekHandle.impl.v3" seek'handle - . mkForeignIOF - $ \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) - - declareForeign Tracked "IO.handlePosition.impl.v3" argToEFNat - -- TODO: truncating integer - . mkForeignIOF - $ \h -> fromInteger @Word64 <$> hTell h - - declareForeign Tracked "IO.getBuffering.impl.v3" get'buffering $ - mkForeignIOF hGetBuffering - - declareForeign Tracked "IO.setBuffering.impl.v3" set'buffering - . mkForeignIOF - $ uncurry hSetBuffering - - declareForeign Tracked "IO.setEcho.impl.v1" set'echo . mkForeignIOF $ uncurry hSetEcho - - declareForeign Tracked "IO.getLine.impl.v1" argToEF $ - mkForeignIOF $ - fmap Util.Text.fromText . Text.IO.hGetLine + declareForeign' Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF IO_UDP_clientSocket_impl_v1 - declareForeign Tracked "IO.getBytes.impl.v3" arg2ToEF . mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGet h n + declareForeign' Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF IO_UDP_UDPSocket_recv_impl_v1 - declareForeign Tracked "IO.getSomeBytes.impl.v1" arg2ToEF . mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGetSome h n + declareForeign' Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 + declareForeign' Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 IO_UDP_UDPSocket_close_impl_v1 - declareForeign Tracked "IO.putBytes.impl.v3" arg2ToEF0 . mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) + declareForeign' Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 IO_UDP_ListenSocket_close_impl_v1 - declareForeign Tracked "IO.systemTime.impl.v3" unitToEF $ - mkForeignIOF $ - \() -> getPOSIXTime + declareForeign' Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 - declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToR $ - mkForeign $ - \() -> fmap (1e6 *) getPOSIXTime + declareForeign' Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF IO_UDP_serverSocket_impl_v1 - declareForeign Tracked "Clock.internals.monotonic.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime Monotonic + declareForeign' Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 - declareForeign Tracked "Clock.internals.realtime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime Realtime + declareForeign' Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 - declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime ProcessCPUTime + declareForeign' Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 - declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime ThreadCPUTime + declareForeign' Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 - declareForeign Tracked "Clock.internals.sec.v1" (argNDirect 1) $ - mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) +declareForeigns :: FDecl' Symbol () +declareForeigns = do + declareUdpForeigns + declareForeign' Tracked "IO.openFile.impl.v3" argIomrToEF IO_openFile_impl_v3 - -- A TimeSpec that comes from getTime never has negative nanos, - -- so we can safely cast to Nat - declareForeign Tracked "Clock.internals.nsec.v1" (argNDirect 1) $ - mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) - - declareForeign Tracked "Clock.internals.systemTimeZone.v1" time'zone $ - mkForeign - ( \secs -> do - TimeZone offset summer name <- getTimeZone (posixSecondsToUTCTime (fromIntegral (secs :: Int))) - pure (offset :: Int, summer, name) - ) + declareForeign' Tracked "IO.closeFile.impl.v3" argToEF0 IO_closeFile_impl_v3 + declareForeign' Tracked "IO.isFileEOF.impl.v3" argToEFBool IO_isFileEOF_impl_v3 + declareForeign' Tracked "IO.isFileOpen.impl.v3" argToEFBool IO_isFileOpen_impl_v3 + declareForeign' Tracked "IO.getEcho.impl.v1" argToEFBool IO_getEcho_impl_v1 + declareForeign' Tracked "IO.ready.impl.v1" argToEFBool IO_ready_impl_v1 + declareForeign' Tracked "IO.getChar.impl.v1" argToEFChar IO_getChar_impl_v1 + declareForeign' Tracked "IO.isSeekable.impl.v3" argToEFBool IO_isSeekable_impl_v3 - let chop = reverse . dropWhile isPathSeparator . reverse + declareForeign' Tracked "IO.seekHandle.impl.v3" seek'handle IO_seekHandle_impl_v3 - declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEF $ - mkForeignIOF $ - \() -> chop <$> getTemporaryDirectory + declareForeign' Tracked "IO.handlePosition.impl.v3" argToEFNat IO_handlePosition_impl_v3 - declareForeign Tracked "IO.createTempDirectory.impl.v3" argToEF $ - mkForeignIOF $ \prefix -> do - temp <- getTemporaryDirectory - chop <$> createTempDirectory temp prefix + declareForeign' Tracked "IO.getBuffering.impl.v3" get'buffering IO_getBuffering_impl_v3 - declareForeign Tracked "IO.getCurrentDirectory.impl.v3" unitToEF - . mkForeignIOF - $ \() -> getCurrentDirectory + declareForeign' Tracked "IO.setBuffering.impl.v3" set'buffering IO_setBuffering_impl_v3 - declareForeign Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 $ - mkForeignIOF setCurrentDirectory + declareForeign' Tracked "IO.setEcho.impl.v1" set'echo IO_setEcho_impl_v1 - declareForeign Tracked "IO.fileExists.impl.v3" argToEFBool $ - mkForeignIOF doesPathExist + declareForeign' Tracked "IO.getLine.impl.v1" argToEF IO_getLine_impl_v1 - declareForeign Tracked "IO.getEnv.impl.v1" argToEF $ - mkForeignIOF getEnv + declareForeign' Tracked "IO.getBytes.impl.v3" arg2ToEF IO_getBytes_impl_v3 + declareForeign' Tracked "IO.getSomeBytes.impl.v1" arg2ToEF IO_getSomeBytes_impl_v1 + declareForeign' Tracked "IO.putBytes.impl.v3" arg2ToEF0 IO_putBytes_impl_v3 + declareForeign' Tracked "IO.systemTime.impl.v3" unitToEF IO_systemTime_impl_v3 - declareForeign Tracked "IO.getArgs.impl.v1" unitToEF $ - mkForeignIOF $ - \() -> fmap Util.Text.pack <$> SYS.getArgs + declareForeign' Tracked "IO.systemTimeMicroseconds.v1" unitToR IO_systemTimeMicroseconds_v1 - declareForeign Tracked "IO.isDirectory.impl.v3" argToEFBool $ - mkForeignIOF doesDirectoryExist + declareForeign' Tracked "Clock.internals.monotonic.v1" unitToEF Clock_internals_monotonic_v1 - declareForeign Tracked "IO.createDirectory.impl.v3" argToEF0 $ - mkForeignIOF $ - createDirectoryIfMissing True + declareForeign' Tracked "Clock.internals.realtime.v1" unitToEF Clock_internals_realtime_v1 - declareForeign Tracked "IO.removeDirectory.impl.v3" argToEF0 $ - mkForeignIOF removeDirectoryRecursive + declareForeign' Tracked "Clock.internals.processCPUTime.v1" unitToEF Clock_internals_processCPUTime_v1 - declareForeign Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 $ - mkForeignIOF $ - uncurry renameDirectory + declareForeign' Tracked "Clock.internals.threadCPUTime.v1" unitToEF Clock_internals_threadCPUTime_v1 - declareForeign Tracked "IO.directoryContents.impl.v3" argToEF $ - mkForeignIOF $ - (fmap Util.Text.pack <$>) . getDirectoryContents + declareForeign' Tracked "Clock.internals.sec.v1" (argNDirect 1) Clock_internals_sec_v1 - declareForeign Tracked "IO.removeFile.impl.v3" argToEF0 $ - mkForeignIOF removeFile + -- A TimeSpec that comes from getTime never has negative nanos, + -- so we can safely cast to Nat + declareForeign' Tracked "Clock.internals.nsec.v1" (argNDirect 1) Clock_internals_nsec_v1 - declareForeign Tracked "IO.renameFile.impl.v3" arg2ToEF0 $ - mkForeignIOF $ - uncurry renameFile + declareForeign' Tracked "Clock.internals.systemTimeZone.v1" time'zone Clock_internals_systemTimeZone_v1 - declareForeign Tracked "IO.getFileTimestamp.impl.v3" argToEFNat - . mkForeignIOF - $ fmap utcTimeToPOSIXSeconds . getModificationTime + declareForeign' Tracked "IO.getTempDirectory.impl.v3" unitToEF IO_getTempDirectory_impl_v3 - declareForeign Tracked "IO.getFileSize.impl.v3" argToEFNat - -- TODO: truncating integer - . mkForeignIOF - $ \fp -> fromInteger @Word64 <$> getFileSize fp + declareForeign' Tracked "IO.createTempDirectory.impl.v3" argToEF IO_createTempDirectory_impl_v3 - declareForeign Tracked "IO.serverSocket.impl.v3" maybeToEF - . mkForeignIOF - $ \( mhst :: Maybe Util.Text.Text, - port - ) -> - fst <$> SYS.bindSock (hostPreference mhst) port + declareForeign' Tracked "IO.getCurrentDirectory.impl.v3" unitToEF IO_getCurrentDirectory_impl_v3 - declareForeign Tracked "Socket.toText" (argNDirect 1) - . mkForeign - $ \(sock :: Socket) -> pure $ show sock + declareForeign' Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 IO_setCurrentDirectory_impl_v3 - declareForeign Tracked "Handle.toText" (argNDirect 1) - . mkForeign - $ \(hand :: Handle) -> pure $ show hand + declareForeign' Tracked "IO.fileExists.impl.v3" argToEFBool IO_fileExists_impl_v3 - declareForeign Tracked "ThreadId.toText" (argNDirect 1) - . mkForeign - $ \(threadId :: ThreadId) -> pure $ show threadId + declareForeign' Tracked "IO.getEnv.impl.v1" argToEF IO_getEnv_impl_v1 - declareForeign Tracked "IO.socketPort.impl.v3" argToEFNat - . mkForeignIOF - $ \(handle :: Socket) -> do - n <- SYS.socketPort handle - return (fromIntegral n :: Word64) + declareForeign' Tracked "IO.getArgs.impl.v1" unitToEF IO_getArgs_impl_v1 - declareForeign Tracked "IO.listen.impl.v3" argToEF0 - . mkForeignIOF - $ \sk -> SYS.listenSock sk 2048 + declareForeign' Tracked "IO.isDirectory.impl.v3" argToEFBool IO_isDirectory_impl_v3 - declareForeign Tracked "IO.clientSocket.impl.v3" arg2ToEF - . mkForeignIOF - $ fmap fst . uncurry SYS.connectSock + declareForeign' Tracked "IO.createDirectory.impl.v3" argToEF0 IO_createDirectory_impl_v3 - declareForeign Tracked "IO.closeSocket.impl.v3" argToEF0 $ - mkForeignIOF SYS.closeSock + declareForeign' Tracked "IO.removeDirectory.impl.v3" argToEF0 IO_removeDirectory_impl_v3 - declareForeign Tracked "IO.socketAccept.impl.v3" argToEF - . mkForeignIOF - $ fmap fst . SYS.accept + declareForeign' Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 IO_renameDirectory_impl_v3 - declareForeign Tracked "IO.socketSend.impl.v3" arg2ToEF0 - . mkForeignIOF - $ \(sk, bs) -> SYS.send sk (Bytes.toArray bs) + declareForeign' Tracked "IO.directoryContents.impl.v3" argToEF IO_directoryContents_impl_v3 - declareForeign Tracked "IO.socketReceive.impl.v3" arg2ToEF - . mkForeignIOF - $ \(hs, n) -> - maybe mempty Bytes.fromArray <$> SYS.recv hs n + declareForeign' Tracked "IO.removeFile.impl.v3" argToEF0 IO_removeFile_impl_v3 - declareForeign Tracked "IO.kill.impl.v3" argToEF0 $ mkForeignIOF killThread + declareForeign' Tracked "IO.renameFile.impl.v3" arg2ToEF0 IO_renameFile_impl_v3 - let mx :: Word64 - mx = fromIntegral (maxBound :: Int) + declareForeign' Tracked "IO.getFileTimestamp.impl.v3" argToEFNat IO_getFileTimestamp_impl_v3 - customDelay :: Word64 -> IO () - customDelay n - | n < mx = threadDelay (fromIntegral n) - | otherwise = threadDelay maxBound >> customDelay (n - mx) + declareForeign' Tracked "IO.getFileSize.impl.v3" argToEFNat IO_getFileSize_impl_v3 - declareForeign Tracked "IO.delay.impl.v3" argToEFUnit $ - mkForeignIOF customDelay + declareForeign' Tracked "IO.serverSocket.impl.v3" maybeToEF IO_serverSocket_impl_v3 - declareForeign Tracked "IO.stdHandle" standard'handle - . mkForeign - $ \(n :: Int) -> case n of - 0 -> pure SYS.stdin - 1 -> pure SYS.stdout - 2 -> pure SYS.stderr - _ -> die "IO.stdHandle: invalid input." + declareForeign' Tracked "Socket.toText" (argNDirect 1) Socket_toText - let exitDecode ExitSuccess = 0 - exitDecode (ExitFailure n) = n + declareForeign' Tracked "Handle.toText" (argNDirect 1) Handle_toText - declareForeign Tracked "IO.process.call" (argNDirect 2) . mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - withCreateProcess (proc exe args) $ \_ _ _ p -> - exitDecode <$> waitForProcess p + declareForeign' Tracked "ThreadId.toText" (argNDirect 1) ThreadId_toText - declareForeign Tracked "IO.process.start" start'process . mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - runInteractiveProcess exe args Nothing Nothing + declareForeign' Tracked "IO.socketPort.impl.v3" argToEFNat IO_socketPort_impl_v3 - declareForeign Tracked "IO.process.kill" argToUnit . mkForeign $ - terminateProcess + declareForeign' Tracked "IO.listen.impl.v3" argToEF0 IO_listen_impl_v3 - declareForeign Tracked "IO.process.wait" (argNDirect 1) . mkForeign $ - \ph -> exitDecode <$> waitForProcess ph + declareForeign' Tracked "IO.clientSocket.impl.v3" arg2ToEF IO_clientSocket_impl_v3 - declareForeign Tracked "IO.process.exitCode" argToMaybe . mkForeign $ - fmap (fmap exitDecode) . getProcessExitCode + declareForeign' Tracked "IO.closeSocket.impl.v3" argToEF0 IO_closeSocket_impl_v3 - declareForeign Tracked "MVar.new" (argNDirect 1) - . mkForeign - $ \(c :: Val) -> newMVar c + declareForeign' Tracked "IO.socketAccept.impl.v3" argToEF IO_socketAccept_impl_v3 - declareForeign Tracked "MVar.newEmpty.v2" unitDirect - . mkForeign - $ \() -> newEmptyMVar @Val + declareForeign' Tracked "IO.socketSend.impl.v3" arg2ToEF0 IO_socketSend_impl_v3 - declareForeign Tracked "MVar.take.impl.v3" argToEF - . mkForeignIOF - $ \(mv :: MVar Val) -> takeMVar mv + declareForeign' Tracked "IO.socketReceive.impl.v3" arg2ToEF IO_socketReceive_impl_v3 - declareForeign Tracked "MVar.tryTake" argToMaybe - . mkForeign - $ \(mv :: MVar Val) -> tryTakeMVar mv + declareForeign' Tracked "IO.kill.impl.v3" argToEF0 IO_kill_impl_v3 - declareForeign Tracked "MVar.put.impl.v3" arg2ToEF0 - . mkForeignIOF - $ \(mv :: MVar Val, x) -> putMVar mv x + declareForeign' Tracked "IO.delay.impl.v3" argToEFUnit IO_delay_impl_v3 - declareForeign Tracked "MVar.tryPut.impl.v3" arg2ToEFBool - . mkForeignIOF - $ \(mv :: MVar Val, x) -> tryPutMVar mv x + declareForeign' Tracked "IO.stdHandle" standard'handle IO_stdHandle - declareForeign Tracked "MVar.swap.impl.v3" arg2ToEF - . mkForeignIOF - $ \(mv :: MVar Val, x) -> swapMVar mv x + declareForeign' Tracked "IO.process.call" (argNDirect 2) IO_process_call - declareForeign Tracked "MVar.isEmpty" (argNDirect 1) - . mkForeign - $ \(mv :: MVar Val) -> isEmptyMVar mv - - declareForeign Tracked "MVar.read.impl.v3" argToEF - . mkForeignIOF - $ \(mv :: MVar Val) -> readMVar mv - - declareForeign Tracked "MVar.tryRead.impl.v3" argToEFM - . mkForeignIOF - $ \(mv :: MVar Val) -> tryReadMVar mv - - declareForeign Untracked "Char.toText" (argNDirect 1) . mkForeign $ - \(ch :: Char) -> pure (Util.Text.singleton ch) + declareForeign' Tracked "IO.process.start" start'process IO_process_start - declareForeign Untracked "Text.repeat" (argNDirect 2) . mkForeign $ - \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) + declareForeign' Tracked "IO.process.kill" argToUnit IO_process_kill - declareForeign Untracked "Text.reverse" (argNDirect 1) . mkForeign $ - pure . Util.Text.reverse + declareForeign' Tracked "IO.process.wait" (argNDirect 1) IO_process_wait - declareForeign Untracked "Text.toUppercase" (argNDirect 1) . mkForeign $ - pure . Util.Text.toUppercase + declareForeign' Tracked "IO.process.exitCode" argToMaybe IO_process_exitCode + declareForeign' Tracked "MVar.new" (argNDirect 1) MVar_new - declareForeign Untracked "Text.toLowercase" (argNDirect 1) . mkForeign $ - pure . Util.Text.toLowercase + declareForeign' Tracked "MVar.newEmpty.v2" unitDirect MVar_newEmpty_v2 - declareForeign Untracked "Text.toUtf8" (argNDirect 1) . mkForeign $ - pure . Util.Text.toUtf8 - - declareForeign Untracked "Text.fromUtf8.impl.v3" argToEF . mkForeign $ - pure . mapLeft (\t -> Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 - - declareForeign Tracked "Tls.ClientConfig.default" (argNDirect 2) . mkForeign $ - \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> - fmap - ( \store -> - (defaultParamsClient (Util.Text.unpack hostName) (Bytes.toArray serverId)) - { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, - TLS.clientShared = def {TLS.sharedCAStore = store} - } - ) - X.getSystemCertificateStore + declareForeign' Tracked "MVar.take.impl.v3" argToEF MVar_take_impl_v3 - declareForeign Tracked "Tls.ServerConfig.default" (argNDirect 2) $ - mkForeign $ - \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> - pure $ - (def :: TLS.ServerParams) - { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, - TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]} - } + declareForeign' Tracked "MVar.tryTake" argToMaybe MVar_tryTake - let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams - updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} - in declareForeign Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) . mkForeign $ - \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params + declareForeign' Tracked "MVar.put.impl.v3" arg2ToEF0 MVar_put_impl_v3 - let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams - updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} - in declareForeign Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) . mkForeign $ - \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params + declareForeign' Tracked "MVar.tryPut.impl.v3" arg2ToEFBool MVar_tryPut_impl_v3 - declareForeign Tracked "TVar.new" (argNDirect 1) . mkForeign $ - \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c + declareForeign' Tracked "MVar.swap.impl.v3" arg2ToEF MVar_swap_impl_v3 - declareForeign Tracked "TVar.read" (argNDirect 1) . mkForeign $ - \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v + declareForeign' Tracked "MVar.isEmpty" (argNDirect 1) MVar_isEmpty - declareForeign Tracked "TVar.write" arg2To0 . mkForeign $ - \(v :: STM.TVar Val, c :: Val) -> - unsafeSTMToIO $ STM.writeTVar v c + declareForeign' Tracked "MVar.read.impl.v3" argToEF MVar_read_impl_v3 - declareForeign Tracked "TVar.newIO" (argNDirect 1) . mkForeign $ - \(c :: Val) -> STM.newTVarIO c + declareForeign' Tracked "MVar.tryRead.impl.v3" argToEFM MVar_tryRead_impl_v3 - declareForeign Tracked "TVar.readIO" (argNDirect 1) . mkForeign $ - \(v :: STM.TVar Val) -> STM.readTVarIO v + declareForeign' Untracked "Char.toText" (argNDirect 1) Char_toText + declareForeign' Untracked "Text.repeat" (argNDirect 2) Text_repeat + declareForeign' Untracked "Text.reverse" (argNDirect 1) Text_reverse + declareForeign' Untracked "Text.toUppercase" (argNDirect 1) Text_toUppercase + declareForeign' Untracked "Text.toLowercase" (argNDirect 1) Text_toLowercase + declareForeign' Untracked "Text.toUtf8" (argNDirect 1) Text_toUtf8 + declareForeign' Untracked "Text.fromUtf8.impl.v3" argToEF Text_fromUtf8_impl_v3 + declareForeign' Tracked "Tls.ClientConfig.default" (argNDirect 2) Tls_ClientConfig_default + declareForeign' Tracked "Tls.ServerConfig.default" (argNDirect 2) Tls_ServerConfig_default + declareForeign' Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) Tls_ClientConfig_certificates_set - declareForeign Tracked "TVar.swap" (argNDirect 2) . mkForeign $ - \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c + declareForeign' Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) Tls_ServerConfig_certificates_set - declareForeign Tracked "STM.retry" unitDirect . mkForeign $ - \() -> unsafeSTMToIO STM.retry :: IO Val + declareForeign' Tracked "TVar.new" (argNDirect 1) TVar_new - declareForeign Tracked "Promise.new" unitDirect . mkForeign $ - \() -> newPromise @Val + declareForeign' Tracked "TVar.read" (argNDirect 1) TVar_read + declareForeign' Tracked "TVar.write" arg2To0 TVar_write + declareForeign' Tracked "TVar.newIO" (argNDirect 1) TVar_newIO + declareForeign' Tracked "TVar.readIO" (argNDirect 1) TVar_readIO + declareForeign' Tracked "TVar.swap" (argNDirect 2) TVar_swap + declareForeign' Tracked "STM.retry" unitDirect STM_retry + declareForeign' Tracked "Promise.new" unitDirect Promise_new -- the only exceptions from Promise.read are async and shouldn't be caught - declareForeign Tracked "Promise.read" (argNDirect 1) . mkForeign $ - \(p :: Promise Val) -> readPromise p + declareForeign' Tracked "Promise.read" (argNDirect 1) Promise_read + declareForeign' Tracked "Promise.tryRead" argToMaybe Promise_tryRead - declareForeign Tracked "Promise.tryRead" argToMaybe . mkForeign $ - \(p :: Promise Val) -> tryReadPromise p - - declareForeign Tracked "Promise.write" (argNDirect 2) . mkForeign $ - \(p :: Promise Val, a :: Val) -> writePromise p a - - declareForeign Tracked "Tls.newClient.impl.v3" arg2ToEF . mkForeignTls $ - \( config :: TLS.ClientParams, - socket :: SYS.Socket - ) -> TLS.contextNew socket config - - declareForeign Tracked "Tls.newServer.impl.v3" arg2ToEF . mkForeignTls $ + declareForeign' Tracked "Promise.write" (argNDirect 2) Promise_write + declareForeign' Tracked "Tls.newClient.impl.v3" arg2ToEF Tls_newClient_impl_v3 + declareForeign' Tracked "Tls.newServer.impl.v3" arg2ToEF . mkForeignTls $ \( config :: TLS.ServerParams, socket :: SYS.Socket ) -> TLS.contextNew socket config @@ -3325,10 +3059,6 @@ checkBoundsPrim name isz off esz act bsz = fromIntegral isz w = off + esz -hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference -hostPreference Nothing = SYS.HostAny -hostPreference (Just host) = SYS.Host $ Util.Text.unpack host - signEd25519Wrapper :: (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes signEd25519Wrapper (secret0, public0, msg0) = case validated of diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 654ca70f32..e16b548d69 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -51,255 +51,6 @@ import Unison.Util.Bytes (Bytes) import Unison.Util.RefPromise (Promise) import Unison.Util.Text (Text, pack, unpack) --- | Enum representing every foreign call. -data ForeignFunc' - = IO_UDP_clientSocket_impl_v1 - | IO_UDP_UDPSocket_recv_impl_v1 - | IO_UDP_UDPSocket_send_impl_v1 - | IO_UDP_UDPSocket_close_impl_v1 - | IO_UDP_ListenSocket_close_impl_v1 - | IO_UDP_UDPSocket_toText_impl_v1 - | IO_UDP_serverSocket_impl_v1 - | IO_UDP_ListenSocket_toText_impl_v1 - | IO_UDP_ListenSocket_recvFrom_impl_v1 - | IO_UDP_ClientSockAddr_toText_v1 - | IO_UDP_ListenSocket_sendTo_impl_v1 - | IO_openFile_impl_v3 - | IO_closeFile_impl_v3 - | IO_isFileEOF_impl_v3 - | IO_isFileOpen_impl_v3 - | IO_getEcho_impl_v1 - | IO_ready_impl_v1 - | IO_getChar_impl_v1 - | IO_isSeekable_impl_v3 - | IO_seekHandle_impl_v3 - | IO_handlePosition_impl_v3 - | IO_getBuffering_impl_v3 - | IO_setBuffering_impl_v3 - | IO_setEcho_impl_v1 - | IO_getLine_impl_v1 - | IO_getBytes_impl_v3 - | IO_getSomeBytes_impl_v1 - | IO_putBytes_impl_v3 - | IO_systemTime_impl_v3 - | IO_systemTimeMicroseconds_v1 - | Clock_internals_monotonic_v1 - | Clock_internals_realtime_v1 - | Clock_internals_processCPUTime_v1 - | Clock_internals_threadCPUTime_v1 - | Clock_internals_sec_v1 - | Clock_internals_nsec_v1 - | Clock_internals_systemTimeZone_v1 - | IO_getTempDirectory_impl_v3 - | IO_createTempDirectory_impl_v3 - | IO_getCurrentDirectory_impl_v3 - | IO_setCurrentDirectory_impl_v3 - | IO_fileExists_impl_v3 - | IO_getEnv_impl_v1 - | IO_getArgs_impl_v1 - | IO_isDirectory_impl_v3 - | IO_createDirectory_impl_v3 - | IO_removeDirectory_impl_v3 - | IO_renameDirectory_impl_v3 - | IO_directoryContents_impl_v3 - | IO_removeFile_impl_v3 - | IO_renameFile_impl_v3 - | IO_getFileTimestamp_impl_v3 - | IO_getFileSize_impl_v3 - | IO_serverSocket_impl_v3 - | Socket_toText - | Handle_toText - | ThreadId_toText - | IO_socketPort_impl_v3 - | IO_listen_impl_v3 - | IO_clientSocket_impl_v3 - | IO_closeSocket_impl_v3 - | IO_socketAccept_impl_v3 - | IO_socketSend_impl_v3 - | IO_socketReceive_impl_v3 - | IO_kill_impl_v3 - | IO_delay_impl_v3 - | IO_stdHandle - | IO_process_call - | IO_process_start - | IO_process_kill - | IO_process_wait - | IO_process_exitCode - | MVar_new - | MVar_newEmpty_v2 - | MVar_take_impl_v3 - | MVar_tryTake - | MVar_put_impl_v3 - | MVar_tryPut_impl_v3 - | MVar_swap_impl_v3 - | MVar_isEmpty - | MVar_read_impl_v3 - | MVar_tryRead_impl_v3 - | Char_toText - | Text_repeat - | Text_reverse - | Text_toUppercase - | Text_toLowercase - | Text_toUtf8 - | Text_fromUtf8_impl_v3 - | Tls_ClientConfig_default - | Tls_ServerConfig_default - | Tls_ClientConfig_certificates_set - | Tls_ServerConfig_certificates_set - | TVar_new - | TVar_read - | TVar_write - | TVar_newIO - | TVar_readIO - | TVar_swap - | STM_retry - | Promise_new - | Promise_read - | Promise_tryRead - | Promise_write - | Tls_newClient_impl_v3 - | Tls_newServer_impl_v3 - | Tls_handshake_impl_v3 - | Tls_send_impl_v3 - | Tls_decodeCert_impl_v3 - | Tls_encodeCert - | Tls_decodePrivateKey - | Tls_encodePrivateKey - | Tls_receive_impl_v3 - | Tls_terminate_impl_v3 - | Code_validateLinks - | Code_dependencies - | Code_serialize - | Code_deserialize - | Code_display - | Value_dependencies - | Value_serialize - | Value_deserialize - | Crypto_HashAlgorithm_Sha3_512 - | Crypto_HashAlgorithm_Sha3_256 - | Crypto_HashAlgorithm_Sha2_512 - | Crypto_HashAlgorithm_Sha2_256 - | Crypto_HashAlgorithm_Sha1 - | Crypto_HashAlgorithm_Blake2b_512 - | Crypto_HashAlgorithm_Blake2b_256 - | Crypto_HashAlgorithm_Blake2s_256 - | Crypto_HashAlgorithm_Md5 - | Crypto_hashBytes - | Crypto_hmacBytes - | Crypto_hash - | Crypto_hmac - | Crypto_Ed25519_sign_impl - | Crypto_Ed25519_verify_impl - | Crypto_Rsa_sign_impl - | Crypto_Rsa_verify_impl - | Universal_murmurHash - | IO_randomBytes - | Bytes_zlib_compress - | Bytes_gzip_compress - | Bytes_zlib_decompress - | Bytes_gzip_decompress - | Bytes_toBase16 - | Bytes_toBase32 - | Bytes_toBase64 - | Bytes_toBase64UrlUnpadded - | Bytes_fromBase16 - | Bytes_fromBase32 - | Bytes_fromBase64 - | Bytes_fromBase64UrlUnpadded - | Bytes_decodeNat64be - | Bytes_decodeNat64le - | Bytes_decodeNat32be - | Bytes_decodeNat32le - | Bytes_decodeNat16be - | Bytes_decodeNat16le - | Bytes_encodeNat64be - | Bytes_encodeNat64le - | Bytes_encodeNat32be - | Bytes_encodeNat32le - | Bytes_encodeNat16be - | Bytes_encodeNat16le - | MutableArray_copyTo_force - | MutableByteArray_copyTo_force - | ImmutableArray_copyTo_force - | ImmutableArray_size - | MutableArray_size - | ImmutableByteArray_size - | MutableByteArray_size - | ImmutableByteArray_copyTo_force - | MutableArray_read - | MutableByteArray_read8 - | MutableByteArray_read16be - | MutableByteArray_read24be - | MutableByteArray_read32be - | MutableByteArray_read40be - | MutableByteArray_read64be - | MutableArray_write - | MutableByteArray_write8 - | MutableByteArray_write16be - | MutableByteArray_write32be - | MutableByteArray_write64be - | ImmutableArray_read - | ImmutableByteArray_read8 - | ImmutableByteArray_read16be - | ImmutableByteArray_read24be - | ImmutableByteArray_read32be - | ImmutableByteArray_read40be - | ImmutableByteArray_read64be - | MutableByteArray_freeze_force - | MutableArray_freeze_force - | MutableByteArray_freeze - | MutableArray_freeze - | MutableByteArray_length - | ImmutableByteArray_length - | IO_array - | IO_arrayOf - | IO_bytearray - | IO_bytearrayOf - | Scope_array - | Scope_arrayOf - | Scope_bytearray - | Scope_bytearrayOf - | Text_patterns_literal - | Text_patterns_digit - | Text_patterns_letter - | Text_patterns_space - | Text_patterns_punctuation - | Text_patterns_anyChar - | Text_patterns_eof - | Text_patterns_charRange - | Text_patterns_notCharRange - | Text_patterns_charIn - | Text_patterns_notCharIn - | Pattern_many - | Pattern_many_corrected - | Pattern_capture - | Pattern_captureAs - | Pattern_join - | Pattern_or - | Pattern_replicate - | Pattern_run - | Pattern_isMatch - | Char_Class_any - | Char_Class_not - | Char_Class_and - | Char_Class_or - | Char_Class_range - | Char_Class_anyOf - | Char_Class_alphanumeric - | Char_Class_upper - | Char_Class_lower - | Char_Class_whitespace - | Char_Class_control - | Char_Class_printable - | Char_Class_mark - | Char_Class_number - | Char_Class_punctuation - | Char_Class_symbol - | Char_Class_separator - | Char_Class_letter - | Char_Class_is - | Text_patterns_char - -- Foreign functions operating on stacks data ForeignFunc where FF :: diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs new file mode 100644 index 0000000000..d7b58b54eb --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -0,0 +1,679 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Unison.Runtime.Foreign.Impl (foreignCall) where + +import Control.Concurrent (ThreadId) +import Control.Concurrent as SYS + ( killThread, + threadDelay, + ) +import Control.Concurrent.MVar as SYS +import Control.Concurrent.STM qualified as STM +import Control.DeepSeq (NFData) +import Control.Exception +import Control.Exception (evaluate) +import Control.Exception.Safe qualified as Exception +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Primitive qualified as PA +import Control.Monad.Reader (ReaderT (..), ask, runReaderT) +import Control.Monad.State.Strict (State, execState, modify) +import Crypto.Error (CryptoError (..), CryptoFailable (..)) +import Crypto.Hash qualified as Hash +import Crypto.MAC.HMAC qualified as HMAC +import Crypto.PubKey.Ed25519 qualified as Ed25519 +import Crypto.PubKey.RSA.PKCS15 qualified as RSA +import Crypto.Random (getRandomBytes) +import Data.Bits (shiftL, shiftR, (.|.)) +import Data.ByteArray qualified as BA +import Data.ByteString (hGet, hGetSome, hPut) +import Data.ByteString.Lazy qualified as L +import Data.Default (def) +import Data.Digest.Murmur64 (asWord64, hash64) +import Data.IP (IP) +import Data.Map qualified as Map +import Data.PEM (PEM, pemContent, pemParseLBS) +import Data.Set (insert) +import Data.Set qualified as Set +import Data.Text qualified +import Data.Text.IO qualified as Text.IO +import Data.Time.Clock.POSIX as SYS + ( getPOSIXTime, + posixSecondsToUTCTime, + utcTimeToPOSIXSeconds, + ) +import Data.Time.LocalTime (TimeZone (..), getTimeZone) +import Data.X509 qualified as X +import Data.X509.CertificateStore qualified as X +import Data.X509.Memory qualified as X +import GHC.Conc qualified as STM +import GHC.IO (IO (IO)) +import Network.Simple.TCP as SYS + ( HostPreference (..), + bindSock, + closeSock, + connectSock, + listenSock, + recv, + send, + ) +import Network.Socket as SYS + ( PortNumber, + Socket, + accept, + socketPort, + ) +import Network.TLS as TLS +import Network.TLS.Extra.Cipher as Cipher +import Network.UDP as UDP + ( ClientSockAddr, + ListenSocket, + UDPSocket (..), + clientSocket, + close, + recv, + recvFrom, + send, + sendTo, + serverSocket, + stop, + ) +import System.Clock (Clock (..), getTime, nsec, sec) +import System.Directory as SYS + ( createDirectoryIfMissing, + doesDirectoryExist, + doesPathExist, + getCurrentDirectory, + getDirectoryContents, + getFileSize, + getModificationTime, + getTemporaryDirectory, + removeDirectoryRecursive, + removeFile, + renameDirectory, + renameFile, + setCurrentDirectory, + ) +import System.Environment as SYS + ( getArgs, + getEnv, + ) +import System.Exit as SYS (ExitCode (..)) +import System.FilePath (isPathSeparator) +import System.IO (Handle) +import System.IO as SYS + ( IOMode (..), + hClose, + hGetBuffering, + hGetChar, + hGetEcho, + hIsEOF, + hIsOpen, + hIsSeekable, + hReady, + hSeek, + hSetBuffering, + hSetEcho, + hTell, + openFile, + stderr, + stdin, + stdout, + ) +import System.IO.Temp (createTempDirectory) +import System.Process as SYS + ( getProcessExitCode, + proc, + runInteractiveProcess, + terminateProcess, + waitForProcess, + withCreateProcess, + ) +import System.X509 qualified as X +import Unison.ABT.Normalized hiding (TTm) +import Unison.Builtin.Decls qualified as Ty +import Unison.Prelude hiding (Text, some) +import Unison.Reference +import Unison.Referent (Referent, pattern Ref) +import Unison.Runtime.ANF as ANF +import Unison.Runtime.ANF.Rehash (checkGroupHashes) +import Unison.Runtime.ANF.Serialize as ANF +import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Builtin +import Unison.Runtime.Builtin.Types +import Unison.Runtime.Crypto.Rsa as Rsa +import Unison.Runtime.Exception (die) +import Unison.Runtime.Foreign +import Unison.Runtime.Foreign + ( Foreign (Wrap), + HashAlgorithm (..), + pattern Failure, + ) +import Unison.Runtime.Foreign qualified as F +import Unison.Runtime.Foreign.Function hiding (mkForeign) +import Unison.Runtime.MCode +import Unison.Runtime.Stack +import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), emptyVal, unboxedTypeTagToInt) +import Unison.Runtime.Stack qualified as Closure +import Unison.Symbol +import Unison.Type qualified as Ty +import Unison.Util.Bytes qualified as Bytes +import Unison.Util.EnumContainers as EC +import Unison.Util.RefPromise + ( Promise, + newPromise, + readPromise, + tryReadPromise, + writePromise, + ) +import Unison.Util.Text (Text) +import Unison.Util.Text qualified as Util.Text +import Unison.Util.Text.Pattern qualified as TPat +import Unison.Var +import UnliftIO qualified + +foreignCall :: ForeignFunc' -> Args -> Stack -> IO Stack +foreignCall = \case + IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> + let hostStr = Util.Text.toString host + portStr = Util.Text.toString port + in UDP.clientSocket hostStr portStr True + IO_UDP_UDPSocket_recv_impl_v1 -> mkForeignIOF $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock + IO_UDP_UDPSocket_send_impl_v1 -> mkForeignIOF $ + \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> + UDP.send sock (Bytes.toArray bytes) + IO_UDP_UDPSocket_close_impl_v1 -> mkForeignIOF $ + \(sock :: UDPSocket) -> UDP.close sock + IO_UDP_ListenSocket_close_impl_v1 -> mkForeignIOF $ + \(sock :: ListenSocket) -> UDP.stop sock + IO_UDP_UDPSocket_toText_impl_v1 -> mkForeign $ + \(sock :: UDPSocket) -> pure $ show sock + IO_UDP_serverSocket_impl_v1 -> mkForeignIOF $ + \(ip :: Util.Text.Text, port :: Util.Text.Text) -> + let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP + maybePort = readMaybe $ Util.Text.toString port :: Maybe PortNumber + in case (maybeIp, maybePort) of + (Nothing, _) -> fail "Invalid IP Address" + (_, Nothing) -> fail "Invalid Port Number" + (Just ip, Just pt) -> UDP.serverSocket (ip, pt) + IO_UDP_ListenSocket_toText_impl_v1 -> mkForeign $ + \(sock :: ListenSocket) -> pure $ show sock + IO_UDP_ListenSocket_recvFrom_impl_v1 -> + mkForeignIOF $ + fmap (first Bytes.fromArray) <$> UDP.recvFrom + IO_UDP_ClientSockAddr_toText_v1 -> mkForeign $ + \(sock :: ClientSockAddr) -> pure $ show sock + 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) -> + 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 + IO_isFileOpen_impl_v3 -> mkForeignIOF hIsOpen + IO_getEcho_impl_v1 -> mkForeignIOF hGetEcho + IO_ready_impl_v1 -> mkForeignIOF hReady + IO_getChar_impl_v1 -> mkForeignIOF hGetChar + IO_isSeekable_impl_v3 -> mkForeignIOF hIsSeekable + IO_seekHandle_impl_v3 -> mkForeignIOF $ + \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) + IO_handlePosition_impl_v3 -> + -- TODO: truncating integer + mkForeignIOF $ + \h -> fromInteger @Word64 <$> hTell h + IO_getBuffering_impl_v3 -> mkForeignIOF hGetBuffering + IO_setBuffering_impl_v3 -> + mkForeignIOF $ + uncurry hSetBuffering + IO_setEcho_impl_v1 -> mkForeignIOF $ uncurry hSetEcho + IO_getLine_impl_v1 -> + mkForeignIOF $ + fmap Util.Text.fromText . Text.IO.hGetLine + IO_getBytes_impl_v3 -> mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGet h n + IO_getSomeBytes_impl_v1 -> mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGetSome h n + IO_putBytes_impl_v3 -> mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) + IO_systemTime_impl_v3 -> mkForeignIOF $ + \() -> getPOSIXTime + IO_systemTimeMicroseconds_v1 -> mkForeign $ + \() -> fmap (1e6 *) getPOSIXTime + Clock_internals_monotonic_v1 -> mkForeignIOF $ + \() -> getTime Monotonic + Clock_internals_realtime_v1 -> mkForeignIOF $ + \() -> getTime Realtime + Clock_internals_processCPUTime_v1 -> mkForeignIOF $ + \() -> getTime ProcessCPUTime + Clock_internals_threadCPUTime_v1 -> mkForeignIOF $ + \() -> getTime ThreadCPUTime + Clock_internals_sec_v1 -> mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) + Clock_internals_nsec_v1 -> mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) + Clock_internals_systemTimeZone_v1 -> + mkForeign + ( \secs -> do + TimeZone offset summer name <- getTimeZone (posixSecondsToUTCTime (fromIntegral (secs :: Int))) + pure (offset :: Int, summer, name) + ) + IO_getTempDirectory_impl_v3 -> + mkForeignIOF $ + \() -> chop <$> getTemporaryDirectory + IO_createTempDirectory_impl_v3 -> mkForeignIOF $ \prefix -> do + temp <- getTemporaryDirectory + chop <$> createTempDirectory temp prefix + IO_getCurrentDirectory_impl_v3 -> mkForeignIOF $ + \() -> getCurrentDirectory + IO_setCurrentDirectory_impl_v3 -> mkForeignIOF setCurrentDirectory + IO_fileExists_impl_v3 -> mkForeignIOF doesPathExist + IO_getEnv_impl_v1 -> mkForeignIOF getEnv + IO_getArgs_impl_v1 -> mkForeignIOF $ + \() -> fmap Util.Text.pack <$> SYS.getArgs + IO_isDirectory_impl_v3 -> mkForeignIOF doesDirectoryExist + IO_createDirectory_impl_v3 -> + mkForeignIOF $ + createDirectoryIfMissing True + IO_removeDirectory_impl_v3 -> mkForeignIOF removeDirectoryRecursive + IO_renameDirectory_impl_v3 -> + mkForeignIOF $ + uncurry renameDirectory + IO_directoryContents_impl_v3 -> + mkForeignIOF $ + (fmap Util.Text.pack <$>) . getDirectoryContents + IO_removeFile_impl_v3 -> mkForeignIOF removeFile + IO_renameFile_impl_v3 -> + mkForeignIOF $ + uncurry renameFile + IO_getFileTimestamp_impl_v3 -> + mkForeignIOF $ + fmap utcTimeToPOSIXSeconds . getModificationTime + IO_getFileSize_impl_v3 -> + -- TODO: truncating integer + mkForeignIOF $ + \fp -> fromInteger @Word64 <$> getFileSize fp + IO_serverSocket_impl_v3 -> + mkForeignIOF $ + \( mhst :: Maybe Util.Text.Text, + port + ) -> + fst <$> SYS.bindSock (hostPreference mhst) port + Socket_toText -> mkForeign $ + \(sock :: Socket) -> pure $ show sock + Handle_toText -> mkForeign $ + \(hand :: Handle) -> pure $ show hand + ThreadId_toText -> mkForeign $ + \(threadId :: ThreadId) -> pure $ show threadId + IO_socketPort_impl_v3 -> mkForeignIOF $ + \(handle :: Socket) -> do + n <- SYS.socketPort handle + return (fromIntegral n :: Word64) + IO_listen_impl_v3 -> mkForeignIOF $ + \sk -> SYS.listenSock sk 2048 + IO_clientSocket_impl_v3 -> + mkForeignIOF $ + fmap fst . uncurry SYS.connectSock + IO_closeSocket_impl_v3 -> mkForeignIOF SYS.closeSock + IO_socketAccept_impl_v3 -> + mkForeignIOF $ + fmap fst . SYS.accept + IO_socketSend_impl_v3 -> mkForeignIOF $ + \(sk, bs) -> SYS.send sk (Bytes.toArray bs) + IO_socketReceive_impl_v3 -> mkForeignIOF $ + \(hs, n) -> + maybe mempty Bytes.fromArray <$> SYS.recv hs n + 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." + IO_process_call -> mkForeign $ + \(exe, map Util.Text.unpack -> args) -> + withCreateProcess (proc exe args) $ \_ _ _ p -> + exitDecode <$> waitForProcess p + IO_process_start -> mkForeign $ \(exe, map Util.Text.unpack -> args) -> + runInteractiveProcess exe args Nothing Nothing + IO_process_kill -> mkForeign $ terminateProcess + IO_process_wait -> mkForeign $ + \ph -> exitDecode <$> waitForProcess ph + IO_process_exitCode -> + mkForeign $ + fmap (fmap exitDecode) . getProcessExitCode + MVar_new -> mkForeign $ + \(c :: Val) -> newMVar c + MVar_newEmpty_v2 -> mkForeign $ + \() -> newEmptyMVar @Val + MVar_take_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> takeMVar mv + MVar_tryTake -> mkForeign $ + \(mv :: MVar Val) -> tryTakeMVar mv + MVar_put_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> putMVar mv x + MVar_tryPut_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> tryPutMVar mv x + MVar_swap_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> swapMVar mv x + MVar_isEmpty -> mkForeign $ + \(mv :: MVar Val) -> isEmptyMVar mv + MVar_read_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> readMVar mv + MVar_tryRead_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> tryReadMVar mv + Char_toText -> mkForeign $ + \(ch :: Char) -> pure (Util.Text.singleton ch) + Text_repeat -> mkForeign $ + \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) + Text_reverse -> + mkForeign $ + pure . Util.Text.reverse + Text_toUppercase -> + mkForeign $ + pure . Util.Text.toUppercase + Text_toLowercase -> + mkForeign $ + pure . Util.Text.toLowercase + Text_toUtf8 -> + mkForeign $ + pure . Util.Text.toUtf8 + Text_fromUtf8_impl_v3 -> + mkForeign $ + pure . mapLeft (\t -> Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 + Tls_ClientConfig_default -> mkForeign $ + \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> + fmap + ( \store -> + (defaultParamsClient (Util.Text.unpack hostName) (Bytes.toArray serverId)) + { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, + TLS.clientShared = def {TLS.sharedCAStore = store} + } + ) + X.getSystemCertificateStore + Tls_ServerConfig_default -> + mkForeign $ + \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> + pure $ + (def :: TLS.ServerParams) + { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, + TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]} + } + Tls_ClientConfig_certificates_set -> + let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams + updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} + in mkForeign $ + \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params + Tls_ServerConfig_certificates_set -> + let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams + updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} + in mkForeign $ + \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params + TVar_new -> mkForeign $ + \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c + TVar_read -> mkForeign $ + \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v + TVar_write -> mkForeign $ + \(v :: STM.TVar Val, c :: Val) -> + unsafeSTMToIO $ STM.writeTVar v c + TVar_newIO -> mkForeign $ + \(c :: Val) -> STM.newTVarIO c + TVar_readIO -> mkForeign $ + \(v :: STM.TVar Val) -> STM.readTVarIO v + TVar_swap -> mkForeign $ + \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c + STM_retry -> mkForeign $ + \() -> unsafeSTMToIO STM.retry :: IO Val + Promise_new -> mkForeign $ + \() -> newPromise @Val + Promise_read -> mkForeign $ + \(p :: Promise Val) -> readPromise p + Promise_tryRead -> mkForeign $ + \(p :: Promise Val) -> tryReadPromise p + Promise_write -> mkForeign $ + \(p :: Promise Val, a :: Val) -> writePromise p a + Tls_newClient_impl_v3 -> + mkForeignTls $ + \( config :: TLS.ClientParams, + socket :: SYS.Socket + ) -> TLS.contextNew socket config + Tls_newServer_impl_v3 -> + mkForeignTls $ + \( config :: TLS.ServerParams, + socket :: SYS.Socket + ) -> TLS.contextNew socket config + Tls_handshake_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> TLS.handshake tls + Tls_send_impl_v3 -> + mkForeignTls $ + \( tls :: TLS.Context, + bytes :: Bytes.Bytes + ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) + Tls_decodeCert_impl_v3 -> undefined + Tls_encodeCert -> undefined + Tls_decodePrivateKey -> undefined + Tls_encodePrivateKey -> undefined + Tls_receive_impl_v3 -> undefined + Tls_terminate_impl_v3 -> undefined + Code_validateLinks -> undefined + Code_dependencies -> undefined + Code_serialize -> undefined + Code_deserialize -> undefined + Code_display -> undefined + Value_dependencies -> undefined + Value_serialize -> undefined + Value_deserialize -> undefined + Crypto_HashAlgorithm_Sha3_512 -> undefined + Crypto_HashAlgorithm_Sha3_256 -> undefined + Crypto_HashAlgorithm_Sha2_512 -> undefined + Crypto_HashAlgorithm_Sha2_256 -> undefined + Crypto_HashAlgorithm_Sha1 -> undefined + Crypto_HashAlgorithm_Blake2b_512 -> undefined + Crypto_HashAlgorithm_Blake2b_256 -> undefined + Crypto_HashAlgorithm_Blake2s_256 -> undefined + Crypto_HashAlgorithm_Md5 -> undefined + Crypto_hashBytes -> undefined + Crypto_hmacBytes -> undefined + Crypto_hash -> undefined + Crypto_hmac -> undefined + Crypto_Ed25519_sign_impl -> undefined + Crypto_Ed25519_verify_impl -> undefined + Crypto_Rsa_sign_impl -> undefined + Crypto_Rsa_verify_impl -> undefined + Universal_murmurHash -> undefined + IO_randomBytes -> undefined + Bytes_zlib_compress -> undefined + Bytes_gzip_compress -> undefined + Bytes_zlib_decompress -> undefined + Bytes_gzip_decompress -> undefined + Bytes_toBase16 -> undefined + Bytes_toBase32 -> undefined + Bytes_toBase64 -> undefined + Bytes_toBase64UrlUnpadded -> undefined + Bytes_fromBase16 -> undefined + Bytes_fromBase32 -> undefined + Bytes_fromBase64 -> undefined + Bytes_fromBase64UrlUnpadded -> undefined + Bytes_decodeNat64be -> undefined + Bytes_decodeNat64le -> undefined + Bytes_decodeNat32be -> undefined + Bytes_decodeNat32le -> undefined + Bytes_decodeNat16be -> undefined + Bytes_decodeNat16le -> undefined + Bytes_encodeNat64be -> undefined + Bytes_encodeNat64le -> undefined + Bytes_encodeNat32be -> undefined + Bytes_encodeNat32le -> undefined + Bytes_encodeNat16be -> undefined + Bytes_encodeNat16le -> undefined + MutableArray_copyTo_force -> undefined + MutableByteArray_copyTo_force -> undefined + ImmutableArray_copyTo_force -> undefined + ImmutableArray_size -> undefined + MutableArray_size -> undefined + ImmutableByteArray_size -> undefined + MutableByteArray_size -> undefined + ImmutableByteArray_copyTo_force -> undefined + MutableArray_read -> undefined + MutableByteArray_read8 -> undefined + MutableByteArray_read16be -> undefined + MutableByteArray_read24be -> undefined + MutableByteArray_read32be -> undefined + MutableByteArray_read40be -> undefined + MutableByteArray_read64be -> undefined + MutableArray_write -> undefined + MutableByteArray_write8 -> undefined + MutableByteArray_write16be -> undefined + MutableByteArray_write32be -> undefined + MutableByteArray_write64be -> undefined + ImmutableArray_read -> undefined + ImmutableByteArray_read8 -> undefined + ImmutableByteArray_read16be -> undefined + ImmutableByteArray_read24be -> undefined + ImmutableByteArray_read32be -> undefined + ImmutableByteArray_read40be -> undefined + ImmutableByteArray_read64be -> undefined + MutableByteArray_freeze_force -> undefined + MutableArray_freeze_force -> undefined + MutableByteArray_freeze -> undefined + MutableArray_freeze -> undefined + MutableByteArray_length -> undefined + ImmutableByteArray_length -> undefined + IO_array -> undefined + IO_arrayOf -> undefined + IO_bytearray -> undefined + IO_bytearrayOf -> undefined + Scope_array -> undefined + Scope_arrayOf -> undefined + Scope_bytearray -> undefined + Scope_bytearrayOf -> undefined + Text_patterns_literal -> undefined + Text_patterns_digit -> undefined + Text_patterns_letter -> undefined + Text_patterns_space -> undefined + Text_patterns_punctuation -> undefined + Text_patterns_anyChar -> undefined + Text_patterns_eof -> undefined + Text_patterns_charRange -> undefined + Text_patterns_notCharRange -> undefined + Text_patterns_charIn -> undefined + Text_patterns_notCharIn -> undefined + Pattern_many -> undefined + Pattern_many_corrected -> undefined + Pattern_capture -> undefined + Pattern_captureAs -> undefined + Pattern_join -> undefined + Pattern_or -> undefined + Pattern_replicate -> undefined + Pattern_run -> undefined + Pattern_isMatch -> undefined + Char_Class_any -> undefined + Char_Class_not -> undefined + Char_Class_and -> undefined + Char_Class_or -> undefined + Char_Class_range -> undefined + Char_Class_anyOf -> undefined + Char_Class_alphanumeric -> undefined + Char_Class_upper -> undefined + Char_Class_lower -> undefined + Char_Class_whitespace -> undefined + Char_Class_control -> undefined + Char_Class_printable -> undefined + Char_Class_mark -> undefined + Char_Class_number -> undefined + Char_Class_punctuation -> undefined + Char_Class_symbol -> undefined + Char_Class_separator -> undefined + Char_Class_letter -> undefined + Char_Class_is -> undefined + Text_patterns_char -> undefined + where + chop = reverse . dropWhile isPathSeparator . reverse + + hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference + hostPreference Nothing = SYS.HostAny + hostPreference (Just host) = SYS.Host $ Util.Text.unpack host + + mx :: Word64 + mx = fromIntegral (maxBound :: Int) + + customDelay :: Word64 -> IO () + customDelay n + | n < mx = threadDelay (fromIntegral n) + | otherwise = threadDelay maxBound >> customDelay (n - mx) + + exitDecode ExitSuccess = 0 + exitDecode (ExitFailure n) = n +{-# INLINE foreignCall #-} + +mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack +mkForeign f args stk = do + args <- decodeArgs args stk + res <- f args + writeForeign stk res + where + decodeArgs :: (ForeignConvention x) => Args -> Stack -> IO x + decodeArgs args stk = + readForeign (argsToLists args) stk >>= \case + ([], a) -> pure a + _ -> + error + "mkForeign: too many arguments for foreign function" +{-# INLINE mkForeign #-} + +mkForeignIOF :: + (ForeignConvention a, ForeignConvention r) => + (a -> IO r) -> + Args -> + Stack -> + IO Stack +mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) + where + tryIOE :: IO a -> IO (Either (F.Failure Val) a) + tryIOE = fmap handleIOE . UnliftIO.try + handleIOE :: Either IOException a -> Either (F.Failure Val) a + handleIOE (Left e) = Left $ Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue + handleIOE (Right a) = Right a +{-# INLINE mkForeignIOF #-} + +mkForeignTls :: + forall a r. + (ForeignConvention a, ForeignConvention r) => + (a -> IO r) -> + Args -> + Stack -> + IO Stack +mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO r -> IO (Either TLS.TLSException r) + tryIO1 = UnliftIO.try + tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) + tryIO2 = UnliftIO.try + flatten :: Either IOException (Either TLS.TLSException r) -> Either ((F.Failure Val)) r + flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Right a)) = Right a + +mkForeignTlsE :: + forall a r. + (ForeignConvention a, ForeignConvention r) => + (a -> IO (Either (F.Failure Val) r)) -> + Args -> + Stack -> + IO Stack +mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO (Either (F.Failure Val) r) -> IO (Either TLS.TLSException (Either (F.Failure Val) r)) + tryIO1 = UnliftIO.try + tryIO2 :: IO (Either TLS.TLSException (Either (F.Failure Val) r)) -> IO (Either IOException (Either TLS.TLSException (Either (F.Failure Val) r))) + tryIO2 = UnliftIO.try + flatten :: Either IOException (Either TLS.TLSException (Either (F.Failure Val) r)) -> Either (F.Failure Val) r + flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Right (Left e))) = Left e + flatten (Right (Right (Right a))) = Right a + +unsafeSTMToIO :: STM.STM a -> IO a +unsafeSTMToIO (STM.STM m) = IO m diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index b307c8a935..010513d481 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -35,6 +35,7 @@ module Unison.Runtime.MCode GBranch (..), Branch, RBranch, + ForeignFunc' (..), emitCombs, emitComb, resolveCombs, @@ -459,6 +460,256 @@ data BPrim2 | REFW -- Ref.write deriving (Show, Eq, Ord, Enum, Bounded) +-- | Enum representing every foreign call. +data ForeignFunc' + = IO_UDP_clientSocket_impl_v1 + | IO_UDP_UDPSocket_recv_impl_v1 + | IO_UDP_UDPSocket_send_impl_v1 + | IO_UDP_UDPSocket_close_impl_v1 + | IO_UDP_ListenSocket_close_impl_v1 + | IO_UDP_UDPSocket_toText_impl_v1 + | IO_UDP_serverSocket_impl_v1 + | IO_UDP_ListenSocket_toText_impl_v1 + | IO_UDP_ListenSocket_recvFrom_impl_v1 + | IO_UDP_ClientSockAddr_toText_v1 + | IO_UDP_ListenSocket_sendTo_impl_v1 + | IO_openFile_impl_v3 + | IO_closeFile_impl_v3 + | IO_isFileEOF_impl_v3 + | IO_isFileOpen_impl_v3 + | IO_getEcho_impl_v1 + | IO_ready_impl_v1 + | IO_getChar_impl_v1 + | IO_isSeekable_impl_v3 + | IO_seekHandle_impl_v3 + | IO_handlePosition_impl_v3 + | IO_getBuffering_impl_v3 + | IO_setBuffering_impl_v3 + | IO_setEcho_impl_v1 + | IO_getLine_impl_v1 + | IO_getBytes_impl_v3 + | IO_getSomeBytes_impl_v1 + | IO_putBytes_impl_v3 + | IO_systemTime_impl_v3 + | IO_systemTimeMicroseconds_v1 + | Clock_internals_monotonic_v1 + | Clock_internals_realtime_v1 + | Clock_internals_processCPUTime_v1 + | Clock_internals_threadCPUTime_v1 + | Clock_internals_sec_v1 + | Clock_internals_nsec_v1 + | Clock_internals_systemTimeZone_v1 + | IO_getTempDirectory_impl_v3 + | IO_createTempDirectory_impl_v3 + | IO_getCurrentDirectory_impl_v3 + | IO_setCurrentDirectory_impl_v3 + | IO_fileExists_impl_v3 + | IO_getEnv_impl_v1 + | IO_getArgs_impl_v1 + | IO_isDirectory_impl_v3 + | IO_createDirectory_impl_v3 + | IO_removeDirectory_impl_v3 + | IO_renameDirectory_impl_v3 + | IO_directoryContents_impl_v3 + | IO_removeFile_impl_v3 + | IO_renameFile_impl_v3 + | IO_getFileTimestamp_impl_v3 + | IO_getFileSize_impl_v3 + | IO_serverSocket_impl_v3 + | Socket_toText + | Handle_toText + | ThreadId_toText + | IO_socketPort_impl_v3 + | IO_listen_impl_v3 + | IO_clientSocket_impl_v3 + | IO_closeSocket_impl_v3 + | IO_socketAccept_impl_v3 + | IO_socketSend_impl_v3 + | IO_socketReceive_impl_v3 + | IO_kill_impl_v3 + | IO_delay_impl_v3 + | IO_stdHandle + | IO_process_call + | IO_process_start + | IO_process_kill + | IO_process_wait + | IO_process_exitCode + | MVar_new + | MVar_newEmpty_v2 + | MVar_take_impl_v3 + | MVar_tryTake + | MVar_put_impl_v3 + | MVar_tryPut_impl_v3 + | MVar_swap_impl_v3 + | MVar_isEmpty + | MVar_read_impl_v3 + | MVar_tryRead_impl_v3 + | Char_toText + | Text_repeat + | Text_reverse + | Text_toUppercase + | Text_toLowercase + | Text_toUtf8 + | Text_fromUtf8_impl_v3 + | Tls_ClientConfig_default + | Tls_ServerConfig_default + | Tls_ClientConfig_certificates_set + | Tls_ServerConfig_certificates_set + | TVar_new + | TVar_read + | TVar_write + | TVar_newIO + | TVar_readIO + | TVar_swap + | STM_retry + | Promise_new + | Promise_read + | Promise_tryRead + | Promise_write + | Tls_newClient_impl_v3 + | Tls_newServer_impl_v3 + | Tls_handshake_impl_v3 + | Tls_send_impl_v3 + | Tls_decodeCert_impl_v3 + | Tls_encodeCert + | Tls_decodePrivateKey + | Tls_encodePrivateKey + | Tls_receive_impl_v3 + | Tls_terminate_impl_v3 + | Code_validateLinks + | Code_dependencies + | Code_serialize + | Code_deserialize + | Code_display + | Value_dependencies + | Value_serialize + | Value_deserialize + | Crypto_HashAlgorithm_Sha3_512 + | Crypto_HashAlgorithm_Sha3_256 + | Crypto_HashAlgorithm_Sha2_512 + | Crypto_HashAlgorithm_Sha2_256 + | Crypto_HashAlgorithm_Sha1 + | Crypto_HashAlgorithm_Blake2b_512 + | Crypto_HashAlgorithm_Blake2b_256 + | Crypto_HashAlgorithm_Blake2s_256 + | Crypto_HashAlgorithm_Md5 + | Crypto_hashBytes + | Crypto_hmacBytes + | Crypto_hash + | Crypto_hmac + | Crypto_Ed25519_sign_impl + | Crypto_Ed25519_verify_impl + | Crypto_Rsa_sign_impl + | Crypto_Rsa_verify_impl + | Universal_murmurHash + | IO_randomBytes + | Bytes_zlib_compress + | Bytes_gzip_compress + | Bytes_zlib_decompress + | Bytes_gzip_decompress + | Bytes_toBase16 + | Bytes_toBase32 + | Bytes_toBase64 + | Bytes_toBase64UrlUnpadded + | Bytes_fromBase16 + | Bytes_fromBase32 + | Bytes_fromBase64 + | Bytes_fromBase64UrlUnpadded + | Bytes_decodeNat64be + | Bytes_decodeNat64le + | Bytes_decodeNat32be + | Bytes_decodeNat32le + | Bytes_decodeNat16be + | Bytes_decodeNat16le + | Bytes_encodeNat64be + | Bytes_encodeNat64le + | Bytes_encodeNat32be + | Bytes_encodeNat32le + | Bytes_encodeNat16be + | Bytes_encodeNat16le + | MutableArray_copyTo_force + | MutableByteArray_copyTo_force + | ImmutableArray_copyTo_force + | ImmutableArray_size + | MutableArray_size + | ImmutableByteArray_size + | MutableByteArray_size + | ImmutableByteArray_copyTo_force + | MutableArray_read + | MutableByteArray_read8 + | MutableByteArray_read16be + | MutableByteArray_read24be + | MutableByteArray_read32be + | MutableByteArray_read40be + | MutableByteArray_read64be + | MutableArray_write + | MutableByteArray_write8 + | MutableByteArray_write16be + | MutableByteArray_write32be + | MutableByteArray_write64be + | ImmutableArray_read + | ImmutableByteArray_read8 + | ImmutableByteArray_read16be + | ImmutableByteArray_read24be + | ImmutableByteArray_read32be + | ImmutableByteArray_read40be + | ImmutableByteArray_read64be + | MutableByteArray_freeze_force + | MutableArray_freeze_force + | MutableByteArray_freeze + | MutableArray_freeze + | MutableByteArray_length + | ImmutableByteArray_length + | IO_array + | IO_arrayOf + | IO_bytearray + | IO_bytearrayOf + | Scope_array + | Scope_arrayOf + | Scope_bytearray + | Scope_bytearrayOf + | Text_patterns_literal + | Text_patterns_digit + | Text_patterns_letter + | Text_patterns_space + | Text_patterns_punctuation + | Text_patterns_anyChar + | Text_patterns_eof + | Text_patterns_charRange + | Text_patterns_notCharRange + | Text_patterns_charIn + | Text_patterns_notCharIn + | Pattern_many + | Pattern_many_corrected + | Pattern_capture + | Pattern_captureAs + | Pattern_join + | Pattern_or + | Pattern_replicate + | Pattern_run + | Pattern_isMatch + | Char_Class_any + | Char_Class_not + | Char_Class_and + | Char_Class_or + | Char_Class_range + | Char_Class_anyOf + | Char_Class_alphanumeric + | Char_Class_upper + | Char_Class_lower + | Char_Class_whitespace + | Char_Class_control + | Char_Class_printable + | Char_Class_mark + | Char_Class_number + | Char_Class_punctuation + | Char_Class_symbol + | Char_Class_separator + | Char_Class_letter + | Char_Class_is + | Text_patterns_char + deriving (Show, Eq, Ord, Enum, Bounded) + data MLit = MI !Int | MN !Word64 @@ -503,6 +754,11 @@ data GInstr comb !Bool -- catch exceptions !Word64 -- FFI call !Args -- arguments + | -- Call out to a Haskell function. + ForeignCall' + !Bool -- catch exceptions + !ForeignFunc' -- FFI call + !Args -- arguments | -- Set the value of a dynamic reference SetDyn !Word64 -- the prompt tag of the reference diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 596f355353..b6f6cf66b3 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -24,6 +24,7 @@ import Data.Traversable import GHC.Conc as STM (unsafeIOToSTM) import Unison.Builtin.Decls (exceptionRef, ioFailureRef) import Unison.Builtin.Decls qualified as Rf +import Unison.Builtin.Decls qualified as Ty import Unison.ConstructorReference qualified as CR import Unison.Prelude hiding (Text) import Unison.Reference @@ -51,6 +52,7 @@ import Unison.Runtime.Array as PA import Unison.Runtime.Builtin import Unison.Runtime.Exception import Unison.Runtime.Foreign +import Unison.Runtime.Foreign qualified as F import Unison.Runtime.Foreign.Function import Unison.Runtime.MCode import Unison.Runtime.Stack @@ -289,8 +291,13 @@ jump0 !callback !env !activeThreads !clo = do where k0 = CB (Hook callback) -unitValue :: Closure -unitValue = Enum Rf.unitRef TT.unitTag +unitValue :: Val +unitValue = BoxedVal $ unitClosure +{-# NOINLINE unitValue #-} + +unitClosure :: Closure +unitClosure = Enum Ty.unitRef (PackedTag 0) +{-# NOINLINE unitClosure #-} lookupDenv :: Word64 -> DEnv -> Val lookupDenv p denv = fromMaybe (BoxedVal BlackHole) $ EC.lookup p denv @@ -601,6 +608,8 @@ exec !env !denv !_activeThreads !stk !k _ (ForeignCall _ w args) <$> (arg stk args >>= ev >>= res stk) | otherwise = die $ "reference to unknown foreign function: " ++ show w +exec !_env !denv !_activeThreads !stk !k _ (ForeignCall' _ func args) = + (denv,,k) <$> foreignCall args func stk exec !env !denv !activeThreads !stk !k _ (Fork i) | sandboxed env = die "attempted to use sandboxed operation: fork" | otherwise = do @@ -648,22 +657,22 @@ encodeExn stk exc = do disp e = Util.Text.pack $ show e (link, msg, extra) | Just (ioe :: IOException) <- fromException exn = - (Rf.ioFailureRef, disp ioe, boxedVal unitValue) + (Rf.ioFailureRef, disp ioe, unitValue) | Just re <- fromException exn = case re of PE _stk msg -> - (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, boxedVal unitValue) + (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, unitValue) BU _ tx val -> (Rf.runtimeFailureRef, Util.Text.fromText tx, val) | Just (ae :: ArithException) <- fromException exn = - (Rf.arithmeticFailureRef, disp ae, boxedVal unitValue) + (Rf.arithmeticFailureRef, disp ae, unitValue) | Just (nae :: NestedAtomically) <- fromException exn = - (Rf.stmFailureRef, disp nae, boxedVal unitValue) + (Rf.stmFailureRef, disp nae, unitValue) | Just (be :: BlockedIndefinitelyOnSTM) <- fromException exn = - (Rf.stmFailureRef, disp be, boxedVal unitValue) + (Rf.stmFailureRef, disp be, unitValue) | Just (be :: BlockedIndefinitelyOnMVar) <- fromException exn = - (Rf.ioFailureRef, disp be, boxedVal unitValue) + (Rf.ioFailureRef, disp be, unitValue) | Just (ie :: AsyncException) <- fromException exn = - (Rf.threadKilledFailureRef, disp ie, boxedVal unitValue) - | otherwise = (Rf.miscFailureRef, disp exn, boxedVal unitValue) + (Rf.threadKilledFailureRef, disp ie, unitValue) + | otherwise = (Rf.miscFailureRef, disp exn, unitValue) numValue :: Maybe Reference -> Val -> IO Word64 numValue _ (UnboxedVal v _) = pure (fromIntegral @Int @Word64 v) @@ -1937,7 +1946,7 @@ bprim2 !stk REFW i j = do v <- peekOff stk j IORef.writeIORef ref v stk <- bump stk - bpoke stk unitValue + bpoke stk unitClosure pure stk bprim2 !stk THRO _ _ = pure stk -- impossible bprim2 !stk TRCE _ _ = pure stk -- impossible diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index a23132a3f9..7b1eb787b3 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -44,6 +44,7 @@ library Unison.Runtime.Exception Unison.Runtime.Foreign Unison.Runtime.Foreign.Function + Unison.Runtime.Foreign.Impl Unison.Runtime.Interface Unison.Runtime.IOSource Unison.Runtime.Machine From cae64d7f0850848f70eab6d9b2a20ce7e1ab3d17 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 4 Dec 2024 22:32:56 -0800 Subject: [PATCH 06/36] Finish porting over foreign calls --- unison-runtime/src/Unison/Runtime/Builtin.hs | 699 ++++--------- .../src/Unison/Runtime/Foreign/Impl.hs | 915 +++++++++++++++--- 2 files changed, 940 insertions(+), 674 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 2a015691d0..1a65902dd9 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -21,6 +21,8 @@ module Unison.Runtime.Builtin Sandbox (..), baseSandboxInfo, unitValue, + natValue, + builtinForeignNames, ) where @@ -2330,462 +2332,180 @@ declareForeigns = do declareForeign' Tracked "Promise.write" (argNDirect 2) Promise_write declareForeign' Tracked "Tls.newClient.impl.v3" arg2ToEF Tls_newClient_impl_v3 - declareForeign' Tracked "Tls.newServer.impl.v3" arg2ToEF . mkForeignTls $ - \( config :: TLS.ServerParams, - socket :: SYS.Socket - ) -> TLS.contextNew socket config - - declareForeign Tracked "Tls.handshake.impl.v3" argToEF0 . mkForeignTls $ - \(tls :: TLS.Context) -> TLS.handshake tls - - declareForeign Tracked "Tls.send.impl.v3" arg2ToEF0 . mkForeignTls $ - \( tls :: TLS.Context, - bytes :: Bytes.Bytes - ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) - - let wrapFailure t = Failure Ty.tlsFailureRef (Util.Text.pack t) unitValue - decoded :: Bytes.Bytes -> Either String PEM - decoded bytes = case pemParseLBS $ Bytes.toLazyByteString bytes of - Right (pem : _) -> Right pem - Right [] -> Left "no PEM found" - Left l -> Left l - asCert :: PEM -> Either String X.SignedCertificate - asCert pem = X.decodeSignedCertificate $ pemContent pem - in declareForeign Tracked "Tls.decodeCert.impl.v3" argToEF . mkForeignTlsE $ - \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes - - declareForeign Tracked "Tls.encodeCert" (argNDirect 1) . mkForeign $ - \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert - - declareForeign Tracked "Tls.decodePrivateKey" (argNDirect 1) . mkForeign $ - \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes - - declareForeign Tracked "Tls.encodePrivateKey" (argNDirect 1) . mkForeign $ - \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey - - declareForeign Tracked "Tls.receive.impl.v3" argToEF . mkForeignTls $ - \(tls :: TLS.Context) -> do - bs <- TLS.recvData tls - pure $ Bytes.fromArray bs - - declareForeign Tracked "Tls.terminate.impl.v3" argToEF0 . mkForeignTls $ - \(tls :: TLS.Context) -> TLS.bye tls - - declareForeign Untracked "Code.validateLinks" argToExnE - . mkForeign - $ \(lsgs0 :: [(Referent, Code)]) -> do - let f (msg, rs) = - Failure Ty.miscFailureRef (Util.Text.fromText msg) rs - pure . first f $ checkGroupHashes lsgs0 - declareForeign Untracked "Code.dependencies" (argNDirect 1) - . mkForeign - $ \(CodeRep sg _) -> - pure $ Wrap Ty.termLinkRef . Ref <$> groupTermLinks sg - declareForeign Untracked "Code.serialize" (argNDirect 1) - . mkForeign - $ \(co :: Code) -> - pure . Bytes.fromArray $ serializeCode builtinForeignNames co - declareForeign Untracked "Code.deserialize" argToEither - . mkForeign - $ pure . deserializeCode . Bytes.toArray - declareForeign Untracked "Code.display" (argNDirect 2) . mkForeign $ - \(nm, (CodeRep sg _)) -> - pure $ prettyGroup @Symbol (Util.Text.unpack nm) sg "" - declareForeign Untracked "Value.dependencies" (argNDirect 1) - . mkForeign - $ pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks - declareForeign Untracked "Value.serialize" (argNDirect 1) - . mkForeign - $ pure . Bytes.fromArray . serializeValue - declareForeign Untracked "Value.deserialize" argToEither - . mkForeign - $ pure . deserializeValue . Bytes.toArray + declareForeign' Tracked "Tls.newServer.impl.v3" arg2ToEF Tls_newServer_impl_v3 + declareForeign' Tracked "Tls.handshake.impl.v3" argToEF0 Tls_handshake_impl_v3 + declareForeign' Tracked "Tls.send.impl.v3" arg2ToEF0 Tls_send_impl_v3 + declareForeign' Tracked "Tls.decodeCert.impl.v3" argToEF Tls_decodeCert_impl_v3 + + declareForeign' Tracked "Tls.encodeCert" (argNDirect 1) Tls_encodeCert + + declareForeign' Tracked "Tls.decodePrivateKey" (argNDirect 1) Tls_decodePrivateKey + declareForeign' Tracked "Tls.encodePrivateKey" (argNDirect 1) Tls_encodePrivateKey + + declareForeign' Tracked "Tls.receive.impl.v3" argToEF Tls_receive_impl_v3 + + declareForeign' Tracked "Tls.terminate.impl.v3" argToEF0 Tls_terminate_impl_v3 + declareForeign' Untracked "Code.validateLinks" argToExnE Code_validateLinks + declareForeign' Untracked "Code.dependencies" (argNDirect 1) Code_dependencies + declareForeign' Untracked "Code.serialize" (argNDirect 1) Code_serialize + declareForeign' Untracked "Code.deserialize" argToEither Code_deserialize + declareForeign' Untracked "Code.display" (argNDirect 2) Code_display + declareForeign' Untracked "Value.dependencies" (argNDirect 1) Value_dependencies + declareForeign' Untracked "Value.serialize" (argNDirect 1) Value_serialize + declareForeign' Untracked "Value.deserialize" argToEither Value_deserialize -- Hashing functions - let declareHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> FDecl Symbol () - declareHashAlgorithm txt alg = do - let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) - declareForeign Untracked ("crypto.HashAlgorithm." <> txt) direct . mkForeign $ \() -> - pure (HashAlgorithm algoRef alg) - - declareHashAlgorithm "Sha3_512" Hash.SHA3_512 - declareHashAlgorithm "Sha3_256" Hash.SHA3_256 - declareHashAlgorithm "Sha2_512" Hash.SHA512 - declareHashAlgorithm "Sha2_256" Hash.SHA256 - declareHashAlgorithm "Sha1" Hash.SHA1 - declareHashAlgorithm "Blake2b_512" Hash.Blake2b_512 - declareHashAlgorithm "Blake2b_256" Hash.Blake2b_256 - declareHashAlgorithm "Blake2s_256" Hash.Blake2s_256 - declareHashAlgorithm "Md5" Hash.MD5 - - declareForeign Untracked "crypto.hashBytes" (argNDirect 2) . mkForeign $ - \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> - let ctx = Hash.hashInitWith alg - in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) - - declareForeign Untracked "crypto.hmacBytes" (argNDirect 3) - . mkForeign - $ \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> - let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) - u :: a -> HMAC.HMAC a -> HMAC.HMAC a - u _ h = h -- to help typechecker along - in pure $ Bytes.fromArray out - - declareForeign Untracked "crypto.hash" crypto'hash . mkForeign $ - \(HashAlgorithm _ alg, x) -> - let hashlazy :: - (Hash.HashAlgorithm a) => - a -> - L.ByteString -> - Hash.Digest a - hashlazy _ l = Hash.hashlazy l - in pure . Bytes.fromArray . hashlazy alg $ serializeValueForHash x - - declareForeign Untracked "crypto.hmac" crypto'hmac . mkForeign $ - \(HashAlgorithm _ alg, key, x) -> - let hmac :: - (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a - hmac _ s = - HMAC.finalize - . HMAC.updates - (HMAC.initialize $ Bytes.toArray @BA.Bytes key) - $ L.toChunks s - in pure . Bytes.fromArray . hmac alg $ serializeValueForHash x - - declareForeign Untracked "crypto.Ed25519.sign.impl" arg3ToEF - . mkForeign - $ pure . signEd25519Wrapper - - declareForeign Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool - . mkForeign - $ pure . verifyEd25519Wrapper - - declareForeign Untracked "crypto.Rsa.sign.impl" arg2ToEF - . mkForeign - $ pure . signRsaWrapper - - declareForeign Untracked "crypto.Rsa.verify.impl" arg3ToEFBool - . mkForeign - $ pure . verifyRsaWrapper - - let catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) - catchAll e = do - e <- Exception.tryAnyDeep e - pure $ case e of - Left se -> Left (Util.Text.pack (show se)) - Right a -> Right a - - declareForeign Untracked "Universal.murmurHash" murmur'hash . mkForeign $ - pure . asWord64 . hash64 . serializeValueForHash - - declareForeign Tracked "IO.randomBytes" (argNDirect 1) . mkForeign $ - \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n - - declareForeign Untracked "Bytes.zlib.compress" (argNDirect 1) . mkForeign $ pure . Bytes.zlibCompress - declareForeign Untracked "Bytes.gzip.compress" (argNDirect 1) . mkForeign $ pure . Bytes.gzipCompress - declareForeign Untracked "Bytes.zlib.decompress" argToEither . mkForeign $ \bs -> - catchAll (pure (Bytes.zlibDecompress bs)) - declareForeign Untracked "Bytes.gzip.decompress" argToEither . mkForeign $ \bs -> - catchAll (pure (Bytes.gzipDecompress bs)) - - declareForeign Untracked "Bytes.toBase16" (argNDirect 1) . mkForeign $ pure . Bytes.toBase16 - declareForeign Untracked "Bytes.toBase32" (argNDirect 1) . mkForeign $ pure . Bytes.toBase32 - declareForeign Untracked "Bytes.toBase64" (argNDirect 1) . mkForeign $ pure . Bytes.toBase64 - declareForeign Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) . mkForeign $ pure . Bytes.toBase64UrlUnpadded - - declareForeign Untracked "Bytes.fromBase16" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase16 - declareForeign Untracked "Bytes.fromBase32" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase32 - declareForeign Untracked "Bytes.fromBase64" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase64 - declareForeign Untracked "Bytes.fromBase64UrlUnpadded" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded - - declareForeign Untracked "Bytes.decodeNat64be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64be - declareForeign Untracked "Bytes.decodeNat64le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64le - declareForeign Untracked "Bytes.decodeNat32be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32be - declareForeign Untracked "Bytes.decodeNat32le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32le - declareForeign Untracked "Bytes.decodeNat16be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16be - declareForeign Untracked "Bytes.decodeNat16le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16le - - declareForeign Untracked "Bytes.encodeNat64be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat64be - declareForeign Untracked "Bytes.encodeNat64le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat64le - declareForeign Untracked "Bytes.encodeNat32be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat32be - declareForeign Untracked "Bytes.encodeNat32le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat32le - declareForeign Untracked "Bytes.encodeNat16be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat16be - declareForeign Untracked "Bytes.encodeNat16le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat16le - - declareForeign Untracked "MutableArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "MutableArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ - checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ - Right - <$> PA.copyMutableArray @IO @Val - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "MutableByteArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "MutableByteArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ - checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ - Right - <$> PA.copyMutableByteArray @IO - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "ImmutableArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "ImmutableArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ - checkBounds name (PA.sizeofArray src) (soff + l - 1) $ - Right - <$> PA.copyArray @IO @Val - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "ImmutableArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofArray @Val - declareForeign Untracked "MutableArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Val - declareForeign Untracked "ImmutableByteArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofByteArray - declareForeign Untracked "MutableByteArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld - - declareForeign Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "ImmutableByteArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ - checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ - Right - <$> PA.copyByteArray @IO - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "MutableArray.read" arg2ToExn - . mkForeign - $ checkedRead "MutableArray.read" - declareForeign Untracked "MutableByteArray.read8" arg2ToExn - . mkForeign - $ checkedRead8 "MutableByteArray.read8" - declareForeign Untracked "MutableByteArray.read16be" arg2ToExn - . mkForeign - $ checkedRead16 "MutableByteArray.read16be" - declareForeign Untracked "MutableByteArray.read24be" arg2ToExn - . mkForeign - $ checkedRead24 "MutableByteArray.read24be" - declareForeign Untracked "MutableByteArray.read32be" arg2ToExn - . mkForeign - $ checkedRead32 "MutableByteArray.read32be" - declareForeign Untracked "MutableByteArray.read40be" arg2ToExn - . mkForeign - $ checkedRead40 "MutableByteArray.read40be" - declareForeign Untracked "MutableByteArray.read64be" arg2ToExn - . mkForeign - $ checkedRead64 "MutableByteArray.read64be" - - declareForeign Untracked "MutableArray.write" arg3ToExnUnit - . mkForeign - $ checkedWrite "MutableArray.write" - declareForeign Untracked "MutableByteArray.write8" arg3ToExnUnit - . mkForeign - $ checkedWrite8 "MutableByteArray.write8" - declareForeign Untracked "MutableByteArray.write16be" arg3ToExnUnit - . mkForeign - $ checkedWrite16 "MutableByteArray.write16be" - declareForeign Untracked "MutableByteArray.write32be" arg3ToExnUnit - . mkForeign - $ checkedWrite32 "MutableByteArray.write32be" - declareForeign Untracked "MutableByteArray.write64be" arg3ToExnUnit - . mkForeign - $ checkedWrite64 "MutableByteArray.write64be" - - declareForeign Untracked "ImmutableArray.read" arg2ToExn - . mkForeign - $ checkedIndex "ImmutableArray.read" - declareForeign Untracked "ImmutableByteArray.read8" arg2ToExn - . mkForeign - $ checkedIndex8 "ImmutableByteArray.read8" - declareForeign Untracked "ImmutableByteArray.read16be" arg2ToExn - . mkForeign - $ checkedIndex16 "ImmutableByteArray.read16be" - declareForeign Untracked "ImmutableByteArray.read24be" arg2ToExn - . mkForeign - $ checkedIndex24 "ImmutableByteArray.read24be" - declareForeign Untracked "ImmutableByteArray.read32be" arg2ToExn - . mkForeign - $ checkedIndex32 "ImmutableByteArray.read32be" - declareForeign Untracked "ImmutableByteArray.read40be" arg2ToExn - . mkForeign - $ checkedIndex40 "ImmutableByteArray.read40be" - declareForeign Untracked "ImmutableByteArray.read64be" arg2ToExn - . mkForeign - $ checkedIndex64 "ImmutableByteArray.read64be" - - declareForeign Untracked "MutableByteArray.freeze!" (argNDirect 1) . mkForeign $ - PA.unsafeFreezeByteArray - declareForeign Untracked "MutableArray.freeze!" (argNDirect 1) . mkForeign $ - PA.unsafeFreezeArray @IO @Val - - declareForeign Untracked "MutableByteArray.freeze" arg3ToExn . mkForeign $ - \(src, off, len) -> - if len == 0 - then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 - else - checkBoundsPrim - "MutableByteArray.freeze" - (PA.sizeofMutableByteArray src) - (off + len) - 0 - $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) - - declareForeign Untracked "MutableArray.freeze" arg3ToExn . mkForeign $ - \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> - if len == 0 - then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal - else - checkBounds - "MutableArray.freeze" - (PA.sizeofMutableArray src) - (off + len - 1) - $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) - - declareForeign Untracked "MutableByteArray.length" (argNDirect 1) . mkForeign $ - pure . PA.sizeofMutableByteArray @PA.RealWorld - - declareForeign Untracked "ImmutableByteArray.length" (argNDirect 1) . mkForeign $ - pure . PA.sizeofByteArray - - declareForeign Tracked "IO.array" (argNDirect 1) . mkForeign $ - \n -> PA.newArray n emptyVal - declareForeign Tracked "IO.arrayOf" (argNDirect 2) . mkForeign $ - \(v :: Val, n) -> PA.newArray n v - declareForeign Tracked "IO.bytearray" (argNDirect 1) . mkForeign $ PA.newByteArray - declareForeign Tracked "IO.bytearrayOf" (argNDirect 2) - . mkForeign - $ \(init, sz) -> do - arr <- PA.newByteArray sz - PA.fillByteArray arr 0 sz init - pure arr - - declareForeign Untracked "Scope.array" (argNDirect 1) . mkForeign $ - \n -> PA.newArray n emptyVal - declareForeign Untracked "Scope.arrayOf" (argNDirect 2) . mkForeign $ - \(v :: Val, n) -> PA.newArray n v - declareForeign Untracked "Scope.bytearray" (argNDirect 1) . mkForeign $ PA.newByteArray - declareForeign Untracked "Scope.bytearrayOf" (argNDirect 2) - . mkForeign - $ \(init, sz) -> do - arr <- PA.newByteArray sz - PA.fillByteArray arr 0 sz init - pure arr - - declareForeign Untracked "Text.patterns.literal" (argNDirect 1) . mkForeign $ - \txt -> evaluate . TPat.cpattern $ TPat.Literal txt - declareForeign Untracked "Text.patterns.digit" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v - declareForeign Untracked "Text.patterns.letter" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Letter)) in \() -> pure v - declareForeign Untracked "Text.patterns.space" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Whitespace)) in \() -> pure v - declareForeign Untracked "Text.patterns.punctuation" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Punctuation)) in \() -> pure v - declareForeign Untracked "Text.patterns.anyChar" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v - declareForeign Untracked "Text.patterns.eof" direct . mkForeign $ - let v = TPat.cpattern TPat.Eof in \() -> pure v - declareForeign Untracked "Text.patterns.charRange" (argNDirect 2) . mkForeign $ - \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end - declareForeign Untracked "Text.patterns.notCharRange" (argNDirect 2) . mkForeign $ - \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end - declareForeign Untracked "Text.patterns.charIn" (argNDirect 1) . mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.charIn: non-character closure" - evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs - declareForeign Untracked "Text.patterns.notCharIn" (argNDirect 1) . mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.notCharIn: non-character closure" - evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs - declareForeign Untracked "Pattern.many" (argNDirect 1) . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p - declareForeign Untracked "Pattern.many.corrected" (argNDirect 1) . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p - declareForeign Untracked "Pattern.capture" (argNDirect 1) . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p - declareForeign Untracked "Pattern.captureAs" (argNDirect 2) . mkForeign $ - \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p - declareForeign Untracked "Pattern.join" (argNDirect 1) . mkForeign $ \ps -> - evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps - declareForeign Untracked "Pattern.or" (argNDirect 2) . mkForeign $ - \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r - declareForeign Untracked "Pattern.replicate" (argNDirect 3) . mkForeign $ - \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> - let m = fromIntegral m0; n = fromIntegral n0 - in evaluate . TPat.cpattern $ TPat.Replicate m n p - - declareForeign Untracked "Pattern.run" arg2ToMaybeTup . mkForeign $ - \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input - - declareForeign Untracked "Pattern.isMatch" (argNDirect 2) . mkForeign $ - \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input - - declareForeign Untracked "Char.Class.any" direct . mkForeign $ \() -> pure TPat.Any - declareForeign Untracked "Char.Class.not" (argNDirect 1) . mkForeign $ pure . TPat.Not - declareForeign Untracked "Char.Class.and" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.Intersect a b - declareForeign Untracked "Char.Class.or" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.Union a b - declareForeign Untracked "Char.Class.range" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.CharRange a b - declareForeign Untracked "Char.Class.anyOf" (argNDirect 1) . mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.charIn: non-character closure" - evaluate $ TPat.CharSet cs - declareForeign Untracked "Char.Class.alphanumeric" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) - declareForeign Untracked "Char.Class.upper" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Upper) - declareForeign Untracked "Char.Class.lower" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Lower) - declareForeign Untracked "Char.Class.whitespace" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Whitespace) - declareForeign Untracked "Char.Class.control" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Control) - declareForeign Untracked "Char.Class.printable" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Printable) - declareForeign Untracked "Char.Class.mark" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.MarkChar) - declareForeign Untracked "Char.Class.number" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Number) - declareForeign Untracked "Char.Class.punctuation" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Punctuation) - declareForeign Untracked "Char.Class.symbol" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) - declareForeign Untracked "Char.Class.separator" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) - declareForeign Untracked "Char.Class.letter" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) - declareForeign Untracked "Char.Class.is" (argNDirect 2) . mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c - declareForeign Untracked "Text.patterns.char" (argNDirect 1) . mkForeign $ \c -> - let v = TPat.cpattern (TPat.Char c) in pure v + declareForeign' Untracked "crypto.HashAlgorithm.Sha3_512" direct Crypto_HashAlgorithm_Sha3_512 + declareForeign' Untracked "crypto.HashAlgorithm.Sha3_256" direct Crypto_HashAlgorithm_Sha3_256 + declareForeign' Untracked "crypto.HashAlgorithm.Sha2_512" direct Crypto_HashAlgorithm_Sha2_512 + declareForeign' Untracked "crypto.HashAlgorithm.Sha2_256" direct Crypto_HashAlgorithm_Sha2_256 + declareForeign' Untracked "crypto.HashAlgorithm.Sha1" direct Crypto_HashAlgorithm_Sha1 + declareForeign' Untracked "crypto.HashAlgorithm.Blake2b_512" direct Crypto_HashAlgorithm_Blake2b_512 + declareForeign' Untracked "crypto.HashAlgorithm.Blake2b_256" direct Crypto_HashAlgorithm_Blake2b_256 + declareForeign' Untracked "crypto.HashAlgorithm.Blake2s_256" direct Crypto_HashAlgorithm_Blake2s_256 + declareForeign' Untracked "crypto.HashAlgorithm.Md5" direct Crypto_HashAlgorithm_Md5 + + declareForeign' Untracked "crypto.hashBytes" (argNDirect 2) Crypto_hashBytes + declareForeign' Untracked "crypto.hmacBytes" (argNDirect 3) Crypto_hmacBytes + + declareForeign' Untracked "crypto.hash" crypto'hash Crypto_hash + declareForeign' Untracked "crypto.hmac" crypto'hmac Crypto_hmac + declareForeign' Untracked "crypto.Ed25519.sign.impl" arg3ToEF Crypto_Ed25519_sign_impl + + declareForeign' Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool Crypto_Ed25519_verify_impl + + declareForeign' Untracked "crypto.Rsa.sign.impl" arg2ToEF Crypto_Rsa_sign_impl + + declareForeign' Untracked "crypto.Rsa.verify.impl" arg3ToEFBool Crypto_Rsa_verify_impl + + declareForeign' Untracked "Universal.murmurHash" murmur'hash Universal_murmurHash + declareForeign' Tracked "IO.randomBytes" (argNDirect 1) IO_randomBytes + declareForeign' Untracked "Bytes.zlib.compress" (argNDirect 1) Bytes_zlib_compress + declareForeign' Untracked "Bytes.gzip.compress" (argNDirect 1) Bytes_gzip_compress + declareForeign' Untracked "Bytes.zlib.decompress" argToEither Bytes_zlib_decompress + declareForeign' Untracked "Bytes.gzip.decompress" argToEither Bytes_gzip_decompress + + declareForeign' Untracked "Bytes.toBase16" (argNDirect 1) Bytes_toBase16 + declareForeign' Untracked "Bytes.toBase32" (argNDirect 1) Bytes_toBase32 + declareForeign' Untracked "Bytes.toBase64" (argNDirect 1) Bytes_toBase64 + declareForeign' Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) Bytes_toBase64UrlUnpadded + + declareForeign' Untracked "Bytes.fromBase16" argToEither Bytes_fromBase16 + declareForeign' Untracked "Bytes.fromBase32" argToEither Bytes_fromBase32 + declareForeign' Untracked "Bytes.fromBase64" argToEither Bytes_fromBase64 + declareForeign' Untracked "Bytes.fromBase64UrlUnpadded" argToEither Bytes_fromBase64UrlUnpadded + + declareForeign' Untracked "Bytes.decodeNat64be" argToMaybeNTup Bytes_decodeNat64be + declareForeign' Untracked "Bytes.decodeNat64le" argToMaybeNTup Bytes_decodeNat64le + declareForeign' Untracked "Bytes.decodeNat32be" argToMaybeNTup Bytes_decodeNat32be + declareForeign' Untracked "Bytes.decodeNat32le" argToMaybeNTup Bytes_decodeNat32le + declareForeign' Untracked "Bytes.decodeNat16be" argToMaybeNTup Bytes_decodeNat16be + declareForeign' Untracked "Bytes.decodeNat16le" argToMaybeNTup Bytes_decodeNat16le + + declareForeign' Untracked "Bytes.encodeNat64be" (argNDirect 1) Bytes_encodeNat64be + declareForeign' Untracked "Bytes.encodeNat64le" (argNDirect 1) Bytes_encodeNat64le + declareForeign' Untracked "Bytes.encodeNat32be" (argNDirect 1) Bytes_encodeNat32be + declareForeign' Untracked "Bytes.encodeNat32le" (argNDirect 1) Bytes_encodeNat32le + declareForeign' Untracked "Bytes.encodeNat16be" (argNDirect 1) Bytes_encodeNat16be + declareForeign' Untracked "Bytes.encodeNat16le" (argNDirect 1) Bytes_encodeNat16le + + declareForeign' Untracked "MutableArray.copyTo!" arg5ToExnUnit MutableArray_copyTo_force + + declareForeign' Untracked "MutableByteArray.copyTo!" arg5ToExnUnit MutableByteArray_copyTo_force + + declareForeign' Untracked "ImmutableArray.copyTo!" arg5ToExnUnit ImmutableArray_copyTo_force + + declareForeign' Untracked "ImmutableArray.size" (argNDirect 1) ImmutableArray_size + declareForeign' Untracked "MutableArray.size" (argNDirect 1) MutableArray_size + declareForeign' Untracked "ImmutableByteArray.size" (argNDirect 1) ImmutableByteArray_size + declareForeign' Untracked "MutableByteArray.size" (argNDirect 1) MutableByteArray_size + + declareForeign' Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit ImmutableByteArray_copyTo_force + + declareForeign' Untracked "MutableArray.read" arg2ToExn MutableArray_read + declareForeign' Untracked "MutableByteArray.read8" arg2ToExn MutableByteArray_read8 + declareForeign' Untracked "MutableByteArray.read16be" arg2ToExn MutableByteArray_read16be + declareForeign' Untracked "MutableByteArray.read24be" arg2ToExn MutableByteArray_read24be + declareForeign' Untracked "MutableByteArray.read32be" arg2ToExn MutableByteArray_read32be + declareForeign' Untracked "MutableByteArray.read40be" arg2ToExn MutableByteArray_read40be + declareForeign' Untracked "MutableByteArray.read64be" arg2ToExn MutableByteArray_read64be + + declareForeign' Untracked "MutableArray.write" arg3ToExnUnit MutableArray_write + declareForeign' Untracked "MutableByteArray.write8" arg3ToExnUnit MutableByteArray_write8 + declareForeign' Untracked "MutableByteArray.write16be" arg3ToExnUnit MutableByteArray_write16be + declareForeign' Untracked "MutableByteArray.write32be" arg3ToExnUnit MutableByteArray_write32be + declareForeign' Untracked "MutableByteArray.write64be" arg3ToExnUnit MutableByteArray_write64be + + declareForeign' Untracked "ImmutableArray.read" arg2ToExn ImmutableArray_read + declareForeign' Untracked "ImmutableByteArray.read8" arg2ToExn ImmutableByteArray_read8 + declareForeign' Untracked "ImmutableByteArray.read16be" arg2ToExn ImmutableByteArray_read16be + declareForeign' Untracked "ImmutableByteArray.read24be" arg2ToExn ImmutableByteArray_read24be + declareForeign' Untracked "ImmutableByteArray.read32be" arg2ToExn ImmutableByteArray_read32be + declareForeign' Untracked "ImmutableByteArray.read40be" arg2ToExn ImmutableByteArray_read40be + declareForeign' Untracked "ImmutableByteArray.read64be" arg2ToExn ImmutableByteArray_read64be + + declareForeign' Untracked "MutableByteArray.freeze!" (argNDirect 1) MutableByteArray_freeze_force + declareForeign' Untracked "MutableArray.freeze!" (argNDirect 1) MutableArray_freeze_force + + declareForeign' Untracked "MutableByteArray.freeze" arg3ToExn MutableByteArray_freeze + declareForeign' Untracked "MutableArray.freeze" arg3ToExn MutableArray_freeze + + declareForeign' Untracked "MutableByteArray.length" (argNDirect 1) MutableByteArray_length + + declareForeign' Untracked "ImmutableByteArray.length" (argNDirect 1) ImmutableByteArray_length + + declareForeign' Tracked "IO.array" (argNDirect 1) IO_array + declareForeign' Tracked "IO.arrayOf" (argNDirect 2) IO_arrayOf + declareForeign' Tracked "IO.bytearray" (argNDirect 1) IO_bytearray + declareForeign' Tracked "IO.bytearrayOf" (argNDirect 2) IO_bytearrayOf + + declareForeign' Untracked "Scope.array" (argNDirect 1) Scope_array + declareForeign' Untracked "Scope.arrayOf" (argNDirect 2) Scope_arrayOf + declareForeign' Untracked "Scope.bytearray" (argNDirect 1) Scope_bytearray + declareForeign' Untracked "Scope.bytearrayOf" (argNDirect 2) Scope_bytearrayOf + + declareForeign' Untracked "Text.patterns.literal" (argNDirect 1) Text_patterns_literal + declareForeign' Untracked "Text.patterns.digit" direct Text_patterns_digit + declareForeign' Untracked "Text.patterns.letter" direct Text_patterns_letter + declareForeign' Untracked "Text.patterns.space" direct Text_patterns_space + declareForeign' Untracked "Text.patterns.punctuation" direct Text_patterns_punctuation + declareForeign' Untracked "Text.patterns.anyChar" direct Text_patterns_anyChar + declareForeign' Untracked "Text.patterns.eof" direct Text_patterns_eof + declareForeign' Untracked "Text.patterns.charRange" (argNDirect 2) Text_patterns_charRange + declareForeign' Untracked "Text.patterns.notCharRange" (argNDirect 2) Text_patterns_notCharRange + declareForeign' Untracked "Text.patterns.charIn" (argNDirect 1) Text_patterns_charIn + declareForeign' Untracked "Text.patterns.notCharIn" (argNDirect 1) Text_patterns_notCharIn + declareForeign' Untracked "Pattern.many" (argNDirect 1) Pattern_many + declareForeign' Untracked "Pattern.many.corrected" (argNDirect 1) Pattern_many_corrected + declareForeign' Untracked "Pattern.capture" (argNDirect 1) Pattern_capture + declareForeign' Untracked "Pattern.captureAs" (argNDirect 2) Pattern_captureAs + declareForeign' Untracked "Pattern.join" (argNDirect 1) Pattern_join + declareForeign' Untracked "Pattern.or" (argNDirect 2) Pattern_or + declareForeign' Untracked "Pattern.replicate" (argNDirect 3) Pattern_replicate + + declareForeign' Untracked "Pattern.run" arg2ToMaybeTup Pattern_run + + declareForeign' Untracked "Pattern.isMatch" (argNDirect 2) Pattern_isMatch + + declareForeign' Untracked "Char.Class.any" direct Char_Class_any + declareForeign' Untracked "Char.Class.not" (argNDirect 1) Char_Class_not + declareForeign' Untracked "Char.Class.and" (argNDirect 2) Char_Class_and + declareForeign' Untracked "Char.Class.or" (argNDirect 2) Char_Class_or + declareForeign' Untracked "Char.Class.range" (argNDirect 2) Char_Class_range + declareForeign' Untracked "Char.Class.anyOf" (argNDirect 1) Char_Class_anyOf + declareForeign' Untracked "Char.Class.alphanumeric" direct Char_Class_alphanumeric + declareForeign' Untracked "Char.Class.upper" direct Char_Class_upper + declareForeign' Untracked "Char.Class.lower" direct Char_Class_lower + declareForeign' Untracked "Char.Class.whitespace" direct Char_Class_whitespace + declareForeign' Untracked "Char.Class.control" direct Char_Class_control + declareForeign' Untracked "Char.Class.printable" direct Char_Class_printable + declareForeign' Untracked "Char.Class.mark" direct Char_Class_mark + declareForeign' Untracked "Char.Class.number" direct Char_Class_number + declareForeign' Untracked "Char.Class.punctuation" direct Char_Class_punctuation + declareForeign' Untracked "Char.Class.symbol" direct Char_Class_symbol + declareForeign' Untracked "Char.Class.separator" direct Char_Class_separator + declareForeign' Untracked "Char.Class.letter" direct Char_Class_letter + declareForeign' Untracked "Char.Class.is" (argNDirect 2) Char_Class_is + declareForeign' Untracked "Text.patterns.char" (argNDirect 1) Text_patterns_char type RW = PA.PrimState IO @@ -3059,75 +2779,6 @@ checkBoundsPrim name isz off esz act bsz = fromIntegral isz w = off + esz -signEd25519Wrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes -signEd25519Wrapper (secret0, public0, msg0) = case validated of - CryptoFailed err -> - Left (Failure Ty.cryptoFailureRef (errMsg err) unitValue) - CryptoPassed (secret, public) -> - Right . Bytes.fromArray $ Ed25519.sign secret public msg - where - msg = Bytes.toArray msg0 :: ByteString - validated = - (,) - <$> Ed25519.secretKey (Bytes.toArray secret0 :: ByteString) - <*> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) - - errMsg CryptoError_PublicKeySizeInvalid = - "ed25519: Public key size invalid" - errMsg CryptoError_SecretKeySizeInvalid = - "ed25519: Secret key size invalid" - errMsg CryptoError_SecretKeyStructureInvalid = - "ed25519: Secret key structure invalid" - errMsg _ = "ed25519: unexpected error" - -verifyEd25519Wrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool -verifyEd25519Wrapper (public0, msg0, sig0) = case validated of - CryptoFailed err -> - Left $ Failure Ty.cryptoFailureRef (errMsg err) unitValue - CryptoPassed (public, sig) -> - Right $ Ed25519.verify public msg sig - where - msg = Bytes.toArray msg0 :: ByteString - validated = - (,) - <$> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) - <*> Ed25519.signature (Bytes.toArray sig0 :: ByteString) - - errMsg CryptoError_PublicKeySizeInvalid = - "ed25519: Public key size invalid" - errMsg CryptoError_SecretKeySizeInvalid = - "ed25519: Secret key size invalid" - errMsg CryptoError_SecretKeyStructureInvalid = - "ed25519: Secret key structure invalid" - errMsg _ = "ed25519: unexpected error" - -signRsaWrapper :: - (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes -signRsaWrapper (secret0, msg0) = case validated of - Left err -> - Left (Failure Ty.cryptoFailureRef err unitValue) - Right secret -> - case RSA.sign Nothing (Just Hash.SHA256) secret msg of - Left err -> Left (Failure Ty.cryptoFailureRef (Rsa.rsaErrorToText err) unitValue) - Right signature -> Right $ Bytes.fromByteString signature - where - msg = Bytes.toArray msg0 :: ByteString - validated = Rsa.parseRsaPrivateKey (Bytes.toArray secret0 :: ByteString) - -verifyRsaWrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool -verifyRsaWrapper (public0, msg0, sig0) = case validated of - Left err -> - Left $ Failure Ty.cryptoFailureRef err unitValue - Right public -> - Right $ RSA.verify (Just Hash.SHA256) public msg sig - where - msg = Bytes.toArray msg0 :: ByteString - sig = Bytes.toArray sig0 :: ByteString - validated = Rsa.parseRsaPublicKey (Bytes.toArray public0 :: ByteString) - foreignDeclResults :: Bool -> (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) foreignDeclResults sanitize = diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs index d7b58b54eb..f22a6ebcd4 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -142,12 +142,11 @@ import Unison.Runtime.Builtin import Unison.Runtime.Builtin.Types import Unison.Runtime.Crypto.Rsa as Rsa import Unison.Runtime.Exception (die) -import Unison.Runtime.Foreign import Unison.Runtime.Foreign ( Foreign (Wrap), HashAlgorithm (..), - pattern Failure, ) +import Unison.Runtime.Foreign hiding (Failure) import Unison.Runtime.Foreign qualified as F import Unison.Runtime.Foreign.Function hiding (mkForeign) import Unison.Runtime.MCode @@ -382,7 +381,7 @@ foreignCall = \case pure . Util.Text.toUtf8 Text_fromUtf8_impl_v3 -> mkForeign $ - pure . mapLeft (\t -> Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 + pure . mapLeft (\t -> F.Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 Tls_ClientConfig_default -> mkForeign $ \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> fmap @@ -451,144 +450,405 @@ foreignCall = \case \( tls :: TLS.Context, bytes :: Bytes.Bytes ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) - Tls_decodeCert_impl_v3 -> undefined - Tls_encodeCert -> undefined - Tls_decodePrivateKey -> undefined - Tls_encodePrivateKey -> undefined - Tls_receive_impl_v3 -> undefined - Tls_terminate_impl_v3 -> undefined - Code_validateLinks -> undefined - Code_dependencies -> undefined - Code_serialize -> undefined - Code_deserialize -> undefined - Code_display -> undefined - Value_dependencies -> undefined - Value_serialize -> undefined - Value_deserialize -> undefined - Crypto_HashAlgorithm_Sha3_512 -> undefined - Crypto_HashAlgorithm_Sha3_256 -> undefined - Crypto_HashAlgorithm_Sha2_512 -> undefined - Crypto_HashAlgorithm_Sha2_256 -> undefined - Crypto_HashAlgorithm_Sha1 -> undefined - Crypto_HashAlgorithm_Blake2b_512 -> undefined - Crypto_HashAlgorithm_Blake2b_256 -> undefined - Crypto_HashAlgorithm_Blake2s_256 -> undefined - Crypto_HashAlgorithm_Md5 -> undefined - Crypto_hashBytes -> undefined - Crypto_hmacBytes -> undefined - Crypto_hash -> undefined - Crypto_hmac -> undefined - Crypto_Ed25519_sign_impl -> undefined - Crypto_Ed25519_verify_impl -> undefined - Crypto_Rsa_sign_impl -> undefined - Crypto_Rsa_verify_impl -> undefined - Universal_murmurHash -> undefined - IO_randomBytes -> undefined - Bytes_zlib_compress -> undefined - Bytes_gzip_compress -> undefined - Bytes_zlib_decompress -> undefined - Bytes_gzip_decompress -> undefined - Bytes_toBase16 -> undefined - Bytes_toBase32 -> undefined - Bytes_toBase64 -> undefined - Bytes_toBase64UrlUnpadded -> undefined - Bytes_fromBase16 -> undefined - Bytes_fromBase32 -> undefined - Bytes_fromBase64 -> undefined - Bytes_fromBase64UrlUnpadded -> undefined - Bytes_decodeNat64be -> undefined - Bytes_decodeNat64le -> undefined - Bytes_decodeNat32be -> undefined - Bytes_decodeNat32le -> undefined - Bytes_decodeNat16be -> undefined - Bytes_decodeNat16le -> undefined - Bytes_encodeNat64be -> undefined - Bytes_encodeNat64le -> undefined - Bytes_encodeNat32be -> undefined - Bytes_encodeNat32le -> undefined - Bytes_encodeNat16be -> undefined - Bytes_encodeNat16le -> undefined - MutableArray_copyTo_force -> undefined - MutableByteArray_copyTo_force -> undefined - ImmutableArray_copyTo_force -> undefined - ImmutableArray_size -> undefined - MutableArray_size -> undefined - ImmutableByteArray_size -> undefined - MutableByteArray_size -> undefined - ImmutableByteArray_copyTo_force -> undefined - MutableArray_read -> undefined - MutableByteArray_read8 -> undefined - MutableByteArray_read16be -> undefined - MutableByteArray_read24be -> undefined - MutableByteArray_read32be -> undefined - MutableByteArray_read40be -> undefined - MutableByteArray_read64be -> undefined - MutableArray_write -> undefined - MutableByteArray_write8 -> undefined - MutableByteArray_write16be -> undefined - MutableByteArray_write32be -> undefined - MutableByteArray_write64be -> undefined - ImmutableArray_read -> undefined - ImmutableByteArray_read8 -> undefined - ImmutableByteArray_read16be -> undefined - ImmutableByteArray_read24be -> undefined - ImmutableByteArray_read32be -> undefined - ImmutableByteArray_read40be -> undefined - ImmutableByteArray_read64be -> undefined - MutableByteArray_freeze_force -> undefined - MutableArray_freeze_force -> undefined - MutableByteArray_freeze -> undefined - MutableArray_freeze -> undefined - MutableByteArray_length -> undefined - ImmutableByteArray_length -> undefined - IO_array -> undefined - IO_arrayOf -> undefined - IO_bytearray -> undefined - IO_bytearrayOf -> undefined - Scope_array -> undefined - Scope_arrayOf -> undefined - Scope_bytearray -> undefined - Scope_bytearrayOf -> undefined - Text_patterns_literal -> undefined - Text_patterns_digit -> undefined - Text_patterns_letter -> undefined - Text_patterns_space -> undefined - Text_patterns_punctuation -> undefined - Text_patterns_anyChar -> undefined - Text_patterns_eof -> undefined - Text_patterns_charRange -> undefined - Text_patterns_notCharRange -> undefined - Text_patterns_charIn -> undefined - Text_patterns_notCharIn -> undefined - Pattern_many -> undefined - Pattern_many_corrected -> undefined - Pattern_capture -> undefined - Pattern_captureAs -> undefined - Pattern_join -> undefined - Pattern_or -> undefined - Pattern_replicate -> undefined - Pattern_run -> undefined - Pattern_isMatch -> undefined - Char_Class_any -> undefined - Char_Class_not -> undefined - Char_Class_and -> undefined - Char_Class_or -> undefined - Char_Class_range -> undefined - Char_Class_anyOf -> undefined - Char_Class_alphanumeric -> undefined - Char_Class_upper -> undefined - Char_Class_lower -> undefined - Char_Class_whitespace -> undefined - Char_Class_control -> undefined - Char_Class_printable -> undefined - Char_Class_mark -> undefined - Char_Class_number -> undefined - Char_Class_punctuation -> undefined - Char_Class_symbol -> undefined - Char_Class_separator -> undefined - Char_Class_letter -> undefined - Char_Class_is -> undefined - Text_patterns_char -> undefined + Tls_decodeCert_impl_v3 -> + let wrapFailure t = F.Failure Ty.tlsFailureRef (Util.Text.pack t) unitValue + decoded :: Bytes.Bytes -> Either String PEM + decoded bytes = case pemParseLBS $ Bytes.toLazyByteString bytes of + Right (pem : _) -> Right pem + Right [] -> Left "no PEM found" + Left l -> Left l + asCert :: PEM -> Either String X.SignedCertificate + asCert pem = X.decodeSignedCertificate $ pemContent pem + in mkForeignTlsE $ + \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes + Tls_encodeCert -> mkForeign $ + \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert + Tls_decodePrivateKey -> mkForeign $ + \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes + Tls_encodePrivateKey -> mkForeign $ + \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey + Tls_receive_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> do + bs <- TLS.recvData tls + pure $ Bytes.fromArray bs + Tls_terminate_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> TLS.bye tls + Code_validateLinks -> mkForeign $ + \(lsgs0 :: [(Referent, Code)]) -> do + let f (msg, rs) = + F.Failure Ty.miscFailureRef (Util.Text.fromText msg) rs + pure . first f $ checkGroupHashes lsgs0 + Code_dependencies -> mkForeign $ + \(CodeRep sg _) -> + pure $ Wrap Ty.termLinkRef . Ref <$> groupTermLinks sg + Code_serialize -> mkForeign $ + \(co :: Code) -> + pure . Bytes.fromArray $ serializeCode builtinForeignNames co + Code_deserialize -> + mkForeign $ + pure . deserializeCode . Bytes.toArray + Code_display -> mkForeign $ + \(nm, (CodeRep sg _)) -> + pure $ prettyGroup @Symbol (Util.Text.unpack nm) sg "" + Value_dependencies -> + mkForeign $ + pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks + Value_serialize -> + mkForeign $ + pure . Bytes.fromArray . serializeValue + Value_deserialize -> + mkForeign $ + pure . deserializeValue . Bytes.toArray + Crypto_HashAlgorithm_Sha3_512 -> mkHashAlgorithm "Sha3_512" Hash.SHA3_512 + Crypto_HashAlgorithm_Sha3_256 -> mkHashAlgorithm "Sha3_256" Hash.SHA3_256 + Crypto_HashAlgorithm_Sha2_512 -> mkHashAlgorithm "Sha2_512" Hash.SHA512 + Crypto_HashAlgorithm_Sha2_256 -> mkHashAlgorithm "Sha2_256" Hash.SHA256 + Crypto_HashAlgorithm_Sha1 -> mkHashAlgorithm "Sha1" Hash.SHA1 + Crypto_HashAlgorithm_Blake2b_512 -> mkHashAlgorithm "Blake2b_512" Hash.Blake2b_512 + Crypto_HashAlgorithm_Blake2b_256 -> mkHashAlgorithm "Blake2b_256" Hash.Blake2b_256 + Crypto_HashAlgorithm_Blake2s_256 -> mkHashAlgorithm "Blake2s_256" Hash.Blake2s_256 + Crypto_HashAlgorithm_Md5 -> mkHashAlgorithm "Md5" Hash.MD5 + Crypto_hashBytes -> mkForeign $ + \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> + let ctx = Hash.hashInitWith alg + in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) + Crypto_hmacBytes -> mkForeign $ + \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> + let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) + u :: a -> HMAC.HMAC a -> HMAC.HMAC a + u _ h = h -- to help typechecker along + in pure $ Bytes.fromArray out + Crypto_hash -> mkForeign $ + \(HashAlgorithm _ alg, x) -> + let hashlazy :: + (Hash.HashAlgorithm a) => + a -> + L.ByteString -> + Hash.Digest a + hashlazy _ l = Hash.hashlazy l + in pure . Bytes.fromArray . hashlazy alg $ serializeValueForHash x + Crypto_hmac -> mkForeign $ + \(HashAlgorithm _ alg, key, x) -> + let hmac :: + (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a + hmac _ s = + HMAC.finalize + . HMAC.updates + (HMAC.initialize $ Bytes.toArray @BA.Bytes key) + $ L.toChunks s + in pure . Bytes.fromArray . hmac alg $ serializeValueForHash x + Crypto_Ed25519_sign_impl -> + mkForeign $ + pure . signEd25519Wrapper + Crypto_Ed25519_verify_impl -> + mkForeign $ + pure . verifyEd25519Wrapper + Crypto_Rsa_sign_impl -> + mkForeign $ + pure . signRsaWrapper + Crypto_Rsa_verify_impl -> + mkForeign $ + pure . verifyRsaWrapper + Universal_murmurHash -> + mkForeign $ + pure . asWord64 . hash64 . serializeValueForHash + IO_randomBytes -> mkForeign $ + \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n + Bytes_zlib_compress -> mkForeign $ pure . Bytes.zlibCompress + Bytes_gzip_compress -> mkForeign $ pure . Bytes.gzipCompress + Bytes_zlib_decompress -> mkForeign $ \bs -> + catchAll (pure (Bytes.zlibDecompress bs)) + Bytes_gzip_decompress -> mkForeign $ \bs -> + catchAll (pure (Bytes.gzipDecompress bs)) + Bytes_toBase16 -> mkForeign $ pure . Bytes.toBase16 + Bytes_toBase32 -> mkForeign $ pure . Bytes.toBase32 + Bytes_toBase64 -> mkForeign $ pure . Bytes.toBase64 + Bytes_toBase64UrlUnpadded -> mkForeign $ pure . Bytes.toBase64UrlUnpadded + Bytes_fromBase16 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase16 + Bytes_fromBase32 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase32 + Bytes_fromBase64 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase64 + Bytes_fromBase64UrlUnpadded -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded + Bytes_decodeNat64be -> mkForeign $ pure . Bytes.decodeNat64be + Bytes_decodeNat64le -> mkForeign $ pure . Bytes.decodeNat64le + Bytes_decodeNat32be -> mkForeign $ pure . Bytes.decodeNat32be + Bytes_decodeNat32le -> mkForeign $ pure . Bytes.decodeNat32le + Bytes_decodeNat16be -> mkForeign $ pure . Bytes.decodeNat16be + Bytes_decodeNat16le -> mkForeign $ pure . Bytes.decodeNat16le + Bytes_encodeNat64be -> mkForeign $ pure . Bytes.encodeNat64be + Bytes_encodeNat64le -> mkForeign $ pure . Bytes.encodeNat64le + Bytes_encodeNat32be -> mkForeign $ pure . Bytes.encodeNat32be + Bytes_encodeNat32le -> mkForeign $ pure . Bytes.encodeNat32le + Bytes_encodeNat16be -> mkForeign $ pure . Bytes.encodeNat16be + Bytes_encodeNat16le -> mkForeign $ pure . Bytes.encodeNat16le + MutableArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "MutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ + Right + <$> PA.copyMutableArray @IO @Val + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + MutableByteArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "MutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ + Right + <$> PA.copyMutableByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + ImmutableArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "ImmutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofArray src) (soff + l - 1) $ + Right + <$> PA.copyArray @IO @Val + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + ImmutableArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofArray @Val + MutableArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Val + ImmutableByteArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofByteArray + MutableByteArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld + ImmutableByteArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "ImmutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ + Right + <$> PA.copyByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + MutableArray_read -> + mkForeign $ + checkedRead "MutableArray.read" + MutableByteArray_read8 -> + mkForeign $ + checkedRead8 "MutableByteArray.read8" + MutableByteArray_read16be -> + mkForeign $ + checkedRead16 "MutableByteArray.read16be" + MutableByteArray_read24be -> + mkForeign $ + checkedRead24 "MutableByteArray.read24be" + MutableByteArray_read32be -> + mkForeign $ + checkedRead32 "MutableByteArray.read32be" + MutableByteArray_read40be -> + mkForeign $ + checkedRead40 "MutableByteArray.read40be" + MutableByteArray_read64be -> + mkForeign $ + checkedRead64 "MutableByteArray.read64be" + MutableArray_write -> + mkForeign $ + checkedWrite "MutableArray.write" + MutableByteArray_write8 -> + mkForeign $ + checkedWrite8 "MutableByteArray.write8" + MutableByteArray_write16be -> + mkForeign $ + checkedWrite16 "MutableByteArray.write16be" + MutableByteArray_write32be -> + mkForeign $ + checkedWrite32 "MutableByteArray.write32be" + MutableByteArray_write64be -> + mkForeign $ + checkedWrite64 "MutableByteArray.write64be" + ImmutableArray_read -> + mkForeign $ + checkedIndex "ImmutableArray.read" + ImmutableByteArray_read8 -> + mkForeign $ + checkedIndex8 "ImmutableByteArray.read8" + ImmutableByteArray_read16be -> + mkForeign $ + checkedIndex16 "ImmutableByteArray.read16be" + ImmutableByteArray_read24be -> + mkForeign $ + checkedIndex24 "ImmutableByteArray.read24be" + ImmutableByteArray_read32be -> + mkForeign $ + checkedIndex32 "ImmutableByteArray.read32be" + ImmutableByteArray_read40be -> + mkForeign $ + checkedIndex40 "ImmutableByteArray.read40be" + ImmutableByteArray_read64be -> + mkForeign $ + checkedIndex64 "ImmutableByteArray.read64be" + MutableByteArray_freeze_force -> + mkForeign $ + PA.unsafeFreezeByteArray + MutableArray_freeze_force -> + mkForeign $ + PA.unsafeFreezeArray @IO @Val + MutableByteArray_freeze -> mkForeign $ + \(src, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 + else + checkBoundsPrim + "MutableByteArray.freeze" + (PA.sizeofMutableByteArray src) + (off + len) + 0 + $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) + MutableArray_freeze -> mkForeign $ + \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal + else + checkBounds + "MutableArray.freeze" + (PA.sizeofMutableArray src) + (off + len - 1) + $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) + MutableByteArray_length -> + mkForeign $ + pure . PA.sizeofMutableByteArray @PA.RealWorld + ImmutableByteArray_length -> + mkForeign $ + pure . PA.sizeofByteArray + IO_array -> mkForeign $ + \n -> PA.newArray n emptyVal + IO_arrayOf -> mkForeign $ + \(v :: Val, n) -> PA.newArray n v + IO_bytearray -> mkForeign $ PA.newByteArray + IO_bytearrayOf -> mkForeign $ + \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + Scope_array -> mkForeign $ + \n -> PA.newArray n emptyVal + Scope_arrayOf -> mkForeign $ + \(v :: Val, n) -> PA.newArray n v + Scope_bytearray -> mkForeign $ PA.newByteArray + Scope_bytearrayOf -> mkForeign $ + \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + Text_patterns_literal -> mkForeign $ + \txt -> evaluate . TPat.cpattern $ TPat.Literal txt + Text_patterns_digit -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v + Text_patterns_letter -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Letter)) in \() -> pure v + Text_patterns_space -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Whitespace)) in \() -> pure v + Text_patterns_punctuation -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Punctuation)) in \() -> pure v + Text_patterns_anyChar -> + mkForeign $ + let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v + Text_patterns_eof -> + mkForeign $ + let v = TPat.cpattern TPat.Eof in \() -> pure v + Text_patterns_charRange -> mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end + Text_patterns_notCharRange -> mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end + Text_patterns_charIn -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.charIn: non-character closure" + evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs + Text_patterns_notCharIn -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.notCharIn: non-character closure" + evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs + Pattern_many -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p + Pattern_many_corrected -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p + Pattern_capture -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p + Pattern_captureAs -> mkForeign $ + \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p + Pattern_join -> mkForeign $ \ps -> + evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps + Pattern_or -> mkForeign $ + \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r + Pattern_replicate -> mkForeign $ + \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> + let m = fromIntegral m0; n = fromIntegral n0 + in evaluate . TPat.cpattern $ TPat.Replicate m n p + Pattern_run -> mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input + Pattern_isMatch -> mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input + Char_Class_any -> mkForeign $ \() -> pure TPat.Any + Char_Class_not -> mkForeign $ pure . TPat.Not + Char_Class_and -> mkForeign $ \(a, b) -> pure $ TPat.Intersect a b + Char_Class_or -> mkForeign $ \(a, b) -> pure $ TPat.Union a b + Char_Class_range -> mkForeign $ \(a, b) -> pure $ TPat.CharRange a b + Char_Class_anyOf -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.charIn: non-character closure" + evaluate $ TPat.CharSet cs + Char_Class_alphanumeric -> mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) + Char_Class_upper -> mkForeign $ \() -> pure (TPat.CharClass TPat.Upper) + Char_Class_lower -> mkForeign $ \() -> pure (TPat.CharClass TPat.Lower) + Char_Class_whitespace -> mkForeign $ \() -> pure (TPat.CharClass TPat.Whitespace) + Char_Class_control -> mkForeign $ \() -> pure (TPat.CharClass TPat.Control) + Char_Class_printable -> mkForeign $ \() -> pure (TPat.CharClass TPat.Printable) + Char_Class_mark -> mkForeign $ \() -> pure (TPat.CharClass TPat.MarkChar) + Char_Class_number -> mkForeign $ \() -> pure (TPat.CharClass TPat.Number) + Char_Class_punctuation -> mkForeign $ \() -> pure (TPat.CharClass TPat.Punctuation) + Char_Class_symbol -> mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) + Char_Class_separator -> mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) + Char_Class_letter -> mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) + Char_Class_is -> mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c + Text_patterns_char -> mkForeign $ \c -> + let v = TPat.cpattern (TPat.Char c) in pure v where chop = reverse . dropWhile isPathSeparator . reverse @@ -606,6 +866,18 @@ foreignCall = \case exitDecode ExitSuccess = 0 exitDecode (ExitFailure n) = n + + mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO Stack + mkHashAlgorithm txt alg = + let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) + in mkForeign $ \() -> pure (HashAlgorithm algoRef alg) + + catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) + catchAll e = do + e <- Exception.tryAnyDeep e + pure $ case e of + Left se -> Left (Util.Text.pack (show se)) + Right a -> Right a {-# INLINE foreignCall #-} mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack @@ -634,7 +906,7 @@ mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) tryIOE :: IO a -> IO (Either (F.Failure Val) a) tryIOE = fmap handleIOE . UnliftIO.try handleIOE :: Either IOException a -> Either (F.Failure Val) a - handleIOE (Left e) = Left $ Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue + handleIOE (Left e) = Left $ F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue handleIOE (Right a) = Right a {-# INLINE mkForeignIOF #-} @@ -652,28 +924,371 @@ mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) tryIO2 = UnliftIO.try flatten :: Either IOException (Either TLS.TLSException r) -> Either ((F.Failure Val)) r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) flatten (Right (Right a)) = Right a mkForeignTlsE :: forall a r. (ForeignConvention a, ForeignConvention r) => - (a -> IO (Either (F.Failure Val) r)) -> + (a -> IO (Either Failure r)) -> Args -> Stack -> IO Stack mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) where - tryIO1 :: IO (Either (F.Failure Val) r) -> IO (Either TLS.TLSException (Either (F.Failure Val) r)) + tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) tryIO1 = UnliftIO.try - tryIO2 :: IO (Either TLS.TLSException (Either (F.Failure Val) r)) -> IO (Either IOException (Either TLS.TLSException (Either (F.Failure Val) r))) + tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r))) tryIO2 = UnliftIO.try - flatten :: Either IOException (Either TLS.TLSException (Either (F.Failure Val) r)) -> Either (F.Failure Val) r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r + flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) flatten (Right (Right (Left e))) = Left e flatten (Right (Right (Right a))) = Right a unsafeSTMToIO :: STM.STM a -> IO a unsafeSTMToIO (STM.STM m) = IO m + +signEd25519Wrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes +signEd25519Wrapper (secret0, public0, msg0) = case validated of + CryptoFailed err -> + Left (F.Failure Ty.cryptoFailureRef (errMsg err) unitValue) + CryptoPassed (secret, public) -> + Right . Bytes.fromArray $ Ed25519.sign secret public msg + where + msg = Bytes.toArray msg0 :: ByteString + validated = + (,) + <$> Ed25519.secretKey (Bytes.toArray secret0 :: ByteString) + <*> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) + + errMsg CryptoError_PublicKeySizeInvalid = + "ed25519: Public key size invalid" + errMsg CryptoError_SecretKeySizeInvalid = + "ed25519: Secret key size invalid" + errMsg CryptoError_SecretKeyStructureInvalid = + "ed25519: Secret key structure invalid" + errMsg _ = "ed25519: unexpected error" + +verifyEd25519Wrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool +verifyEd25519Wrapper (public0, msg0, sig0) = case validated of + CryptoFailed err -> + Left $ F.Failure Ty.cryptoFailureRef (errMsg err) unitValue + CryptoPassed (public, sig) -> + Right $ Ed25519.verify public msg sig + where + msg = Bytes.toArray msg0 :: ByteString + validated = + (,) + <$> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) + <*> Ed25519.signature (Bytes.toArray sig0 :: ByteString) + + errMsg CryptoError_PublicKeySizeInvalid = + "ed25519: Public key size invalid" + errMsg CryptoError_SecretKeySizeInvalid = + "ed25519: Secret key size invalid" + errMsg CryptoError_SecretKeyStructureInvalid = + "ed25519: Secret key structure invalid" + errMsg _ = "ed25519: unexpected error" + +signRsaWrapper :: + (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes +signRsaWrapper (secret0, msg0) = case validated of + Left err -> + Left (F.Failure Ty.cryptoFailureRef err unitValue) + Right secret -> + case RSA.sign Nothing (Just Hash.SHA256) secret msg of + Left err -> Left (F.Failure Ty.cryptoFailureRef (Rsa.rsaErrorToText err) unitValue) + Right signature -> Right $ Bytes.fromByteString signature + where + msg = Bytes.toArray msg0 :: ByteString + validated = Rsa.parseRsaPrivateKey (Bytes.toArray secret0 :: ByteString) + +verifyRsaWrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool +verifyRsaWrapper (public0, msg0, sig0) = case validated of + Left err -> + Left $ F.Failure Ty.cryptoFailureRef err unitValue + Right public -> + Right $ RSA.verify (Just Hash.SHA256) public msg sig + where + msg = Bytes.toArray msg0 :: ByteString + sig = Bytes.toArray sig0 :: ByteString + validated = Rsa.parseRsaPublicKey (Bytes.toArray public0 :: ByteString) + +type Failure = F.Failure Val + +checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBounds name l w act + | w < fromIntegral l = act + | otherwise = pure $ Left err + where + msg = name <> ": array index out of bounds" + err = F.Failure Ty.arrayFailureRef msg (natValue w) + +-- Performs a bounds check on a byte array. Strategy is as follows: +-- +-- isz = signed array size-in-bytes +-- off = unsigned byte offset into the array +-- esz = unsigned number of bytes to be read +-- +-- 1. Turn the signed size-in-bytes of the array unsigned +-- 2. Add the offset to the to-be-read number to get the maximum size needed +-- 3. Check that the actual array size is at least as big as the needed size +-- 4. Check that the offset is less than the size +-- +-- Step 4 ensures that step 3 has not overflowed. Since an actual array size can +-- only be 63 bits (since it is signed), the only way for 3 to overflow is if +-- the offset is larger than a possible array size, since it would need to be +-- 2^64-k, where k is the small (<=8) number of bytes to be read. +checkBoundsPrim :: + Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBoundsPrim name isz off esz act + | w > bsz || off > bsz = pure $ Left err + | otherwise = act + where + msg = name <> ": array index out of bounds" + err = F.Failure Ty.arrayFailureRef msg (natValue off) + + bsz = fromIntegral isz + w = off + esz + +type RW = PA.PrimState IO + +checkedRead :: + Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val) +checkedRead name (arr, w) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.readArray arr (fromIntegral w)) + +checkedWrite :: + Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ()) +checkedWrite name (arr, w, v) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.writeArray arr (fromIntegral w) v) + +checkedIndex :: + Text -> (PA.Array Val, Word64) -> IO (Either Failure Val) +checkedIndex name (arr, w) = + checkBounds + name + (PA.sizeofArray arr) + w + (Right <$> PA.indexArrayM arr (fromIntegral w)) + +checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead8 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ + (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j + where + j = fromIntegral i + +checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead16 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ + mk16 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + where + j = fromIntegral i + +checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead24 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ + mk24 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + where + j = fromIntegral i + +checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead32 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ + mk32 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + where + j = fromIntegral i + +checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead40 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ + mk40 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + where + j = fromIntegral i + +checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead64 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ + mk64 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + <*> PA.readByteArray @Word8 arr (j + 5) + <*> PA.readByteArray @Word8 arr (j + 6) + <*> PA.readByteArray @Word8 arr (j + 7) + where + j = fromIntegral i + +mk16 :: Word8 -> Word8 -> Either Failure Word64 +mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) + +mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk24 b0 b1 b2 = + Right $ + (fromIntegral b0 `shiftL` 16) + .|. (fromIntegral b1 `shiftL` 8) + .|. (fromIntegral b2) + +mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk32 b0 b1 b2 b3 = + Right $ + (fromIntegral b0 `shiftL` 24) + .|. (fromIntegral b1 `shiftL` 16) + .|. (fromIntegral b2 `shiftL` 8) + .|. (fromIntegral b3) + +mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk40 b0 b1 b2 b3 b4 = + Right $ + (fromIntegral b0 `shiftL` 32) + .|. (fromIntegral b1 `shiftL` 24) + .|. (fromIntegral b2 `shiftL` 16) + .|. (fromIntegral b3 `shiftL` 8) + .|. (fromIntegral b4) + +mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk64 b0 b1 b2 b3 b4 b5 b6 b7 = + Right $ + (fromIntegral b0 `shiftL` 56) + .|. (fromIntegral b1 `shiftL` 48) + .|. (fromIntegral b2 `shiftL` 40) + .|. (fromIntegral b3 `shiftL` 32) + .|. (fromIntegral b4 `shiftL` 24) + .|. (fromIntegral b5 `shiftL` 16) + .|. (fromIntegral b6 `shiftL` 8) + .|. (fromIntegral b7) + +checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite8 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do + PA.writeByteArray arr j (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite16 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite32 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite64 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) + PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +-- index single byte +checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex8 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ + let j = fromIntegral i + in Right . fromIntegral $ PA.indexByteArray @Word8 arr j + +-- index 16 big-endian +checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex16 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ + let j = fromIntegral i + in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) + +-- index 32 big-endian +checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex24 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ + let j = fromIntegral i + in mk24 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + +-- index 32 big-endian +checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex32 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ + let j = fromIntegral i + in mk32 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + +-- index 40 big-endian +checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex40 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ + let j = fromIntegral i + in mk40 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + +-- index 64 big-endian +checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex64 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ + let j = fromIntegral i + in mk64 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + (PA.indexByteArray arr (j + 5)) + (PA.indexByteArray arr (j + 6)) + (PA.indexByteArray arr (j + 7)) From 12dbac8f26c6448bd087458638b5032cccfb592c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 4 Dec 2024 22:56:36 -0800 Subject: [PATCH 07/36] WIP on switching from numbered foreign funcs --- unison-runtime/src/Unison/Runtime/ANF.hs | 261 +++- .../src/Unison/Runtime/ANF/Serialize.hs | 18 +- unison-runtime/src/Unison/Runtime/Builtin.hs | 1273 ++++------------- .../src/Unison/Runtime/Foreign/Function.hs | 36 +- .../src/Unison/Runtime/Foreign/Impl.hs | 56 +- unison-runtime/src/Unison/Runtime/MCode.hs | 267 +++- unison-runtime/src/Unison/Runtime/Machine.hs | 21 +- 7 files changed, 840 insertions(+), 1092 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs index 259987f07c..b2350e5bf0 100644 --- a/unison-runtime/src/Unison/Runtime/ANF.hs +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -42,7 +42,7 @@ module Unison.Runtime.ANF SuperGroup (..), arities, POp (..), - FOp, + ForeignFunc(..), close, saturate, float, @@ -1030,12 +1030,12 @@ pattern TPrm :: ABTN.Term ANormalF v pattern TPrm p args = TApp (FPrim (Left p)) args -pattern AFOp :: FOp -> [v] -> ANormalF v e +pattern AFOp :: ForeignFunc -> [v] -> ANormalF v e pattern AFOp p args = AApp (FPrim (Right p)) args pattern TFOp :: (ABT.Var v) => - FOp -> + ForeignFunc -> [v] -> ABTN.Term ANormalF v pattern TFOp p args = TApp (FPrim (Right p)) args @@ -1232,9 +1232,6 @@ instance Semigroup (BranchAccum v) where instance Monoid (BranchAccum e) where mempty = AccumEmpty --- Foreign operation, indexed by words -type FOp = Word64 - data Func v = -- variable FVar v @@ -1247,7 +1244,7 @@ data Func v | -- ability request FReq !Reference !CTag | -- prim op - FPrim (Either POp FOp) + FPrim (Either POp ForeignFunc) deriving (Show, Eq, Functor, Foldable, Traversable) data Lit @@ -1439,6 +1436,256 @@ data POp | IORB -- or deriving (Show, Eq, Ord, Enum, Bounded) +-- | Enum representing every foreign call. +data ForeignFunc + = IO_UDP_clientSocket_impl_v1 + | IO_UDP_UDPSocket_recv_impl_v1 + | IO_UDP_UDPSocket_send_impl_v1 + | IO_UDP_UDPSocket_close_impl_v1 + | IO_UDP_ListenSocket_close_impl_v1 + | IO_UDP_UDPSocket_toText_impl_v1 + | IO_UDP_serverSocket_impl_v1 + | IO_UDP_ListenSocket_toText_impl_v1 + | IO_UDP_ListenSocket_recvFrom_impl_v1 + | IO_UDP_ClientSockAddr_toText_v1 + | IO_UDP_ListenSocket_sendTo_impl_v1 + | IO_openFile_impl_v3 + | IO_closeFile_impl_v3 + | IO_isFileEOF_impl_v3 + | IO_isFileOpen_impl_v3 + | IO_getEcho_impl_v1 + | IO_ready_impl_v1 + | IO_getChar_impl_v1 + | IO_isSeekable_impl_v3 + | IO_seekHandle_impl_v3 + | IO_handlePosition_impl_v3 + | IO_getBuffering_impl_v3 + | IO_setBuffering_impl_v3 + | IO_setEcho_impl_v1 + | IO_getLine_impl_v1 + | IO_getBytes_impl_v3 + | IO_getSomeBytes_impl_v1 + | IO_putBytes_impl_v3 + | IO_systemTime_impl_v3 + | IO_systemTimeMicroseconds_v1 + | Clock_internals_monotonic_v1 + | Clock_internals_realtime_v1 + | Clock_internals_processCPUTime_v1 + | Clock_internals_threadCPUTime_v1 + | Clock_internals_sec_v1 + | Clock_internals_nsec_v1 + | Clock_internals_systemTimeZone_v1 + | IO_getTempDirectory_impl_v3 + | IO_createTempDirectory_impl_v3 + | IO_getCurrentDirectory_impl_v3 + | IO_setCurrentDirectory_impl_v3 + | IO_fileExists_impl_v3 + | IO_getEnv_impl_v1 + | IO_getArgs_impl_v1 + | IO_isDirectory_impl_v3 + | IO_createDirectory_impl_v3 + | IO_removeDirectory_impl_v3 + | IO_renameDirectory_impl_v3 + | IO_directoryContents_impl_v3 + | IO_removeFile_impl_v3 + | IO_renameFile_impl_v3 + | IO_getFileTimestamp_impl_v3 + | IO_getFileSize_impl_v3 + | IO_serverSocket_impl_v3 + | Socket_toText + | Handle_toText + | ThreadId_toText + | IO_socketPort_impl_v3 + | IO_listen_impl_v3 + | IO_clientSocket_impl_v3 + | IO_closeSocket_impl_v3 + | IO_socketAccept_impl_v3 + | IO_socketSend_impl_v3 + | IO_socketReceive_impl_v3 + | IO_kill_impl_v3 + | IO_delay_impl_v3 + | IO_stdHandle + | IO_process_call + | IO_process_start + | IO_process_kill + | IO_process_wait + | IO_process_exitCode + | MVar_new + | MVar_newEmpty_v2 + | MVar_take_impl_v3 + | MVar_tryTake + | MVar_put_impl_v3 + | MVar_tryPut_impl_v3 + | MVar_swap_impl_v3 + | MVar_isEmpty + | MVar_read_impl_v3 + | MVar_tryRead_impl_v3 + | Char_toText + | Text_repeat + | Text_reverse + | Text_toUppercase + | Text_toLowercase + | Text_toUtf8 + | Text_fromUtf8_impl_v3 + | Tls_ClientConfig_default + | Tls_ServerConfig_default + | Tls_ClientConfig_certificates_set + | Tls_ServerConfig_certificates_set + | TVar_new + | TVar_read + | TVar_write + | TVar_newIO + | TVar_readIO + | TVar_swap + | STM_retry + | Promise_new + | Promise_read + | Promise_tryRead + | Promise_write + | Tls_newClient_impl_v3 + | Tls_newServer_impl_v3 + | Tls_handshake_impl_v3 + | Tls_send_impl_v3 + | Tls_decodeCert_impl_v3 + | Tls_encodeCert + | Tls_decodePrivateKey + | Tls_encodePrivateKey + | Tls_receive_impl_v3 + | Tls_terminate_impl_v3 + | Code_validateLinks + | Code_dependencies + | Code_serialize + | Code_deserialize + | Code_display + | Value_dependencies + | Value_serialize + | Value_deserialize + | Crypto_HashAlgorithm_Sha3_512 + | Crypto_HashAlgorithm_Sha3_256 + | Crypto_HashAlgorithm_Sha2_512 + | Crypto_HashAlgorithm_Sha2_256 + | Crypto_HashAlgorithm_Sha1 + | Crypto_HashAlgorithm_Blake2b_512 + | Crypto_HashAlgorithm_Blake2b_256 + | Crypto_HashAlgorithm_Blake2s_256 + | Crypto_HashAlgorithm_Md5 + | Crypto_hashBytes + | Crypto_hmacBytes + | Crypto_hash + | Crypto_hmac + | Crypto_Ed25519_sign_impl + | Crypto_Ed25519_verify_impl + | Crypto_Rsa_sign_impl + | Crypto_Rsa_verify_impl + | Universal_murmurHash + | IO_randomBytes + | Bytes_zlib_compress + | Bytes_gzip_compress + | Bytes_zlib_decompress + | Bytes_gzip_decompress + | Bytes_toBase16 + | Bytes_toBase32 + | Bytes_toBase64 + | Bytes_toBase64UrlUnpadded + | Bytes_fromBase16 + | Bytes_fromBase32 + | Bytes_fromBase64 + | Bytes_fromBase64UrlUnpadded + | Bytes_decodeNat64be + | Bytes_decodeNat64le + | Bytes_decodeNat32be + | Bytes_decodeNat32le + | Bytes_decodeNat16be + | Bytes_decodeNat16le + | Bytes_encodeNat64be + | Bytes_encodeNat64le + | Bytes_encodeNat32be + | Bytes_encodeNat32le + | Bytes_encodeNat16be + | Bytes_encodeNat16le + | MutableArray_copyTo_force + | MutableByteArray_copyTo_force + | ImmutableArray_copyTo_force + | ImmutableArray_size + | MutableArray_size + | ImmutableByteArray_size + | MutableByteArray_size + | ImmutableByteArray_copyTo_force + | MutableArray_read + | MutableByteArray_read8 + | MutableByteArray_read16be + | MutableByteArray_read24be + | MutableByteArray_read32be + | MutableByteArray_read40be + | MutableByteArray_read64be + | MutableArray_write + | MutableByteArray_write8 + | MutableByteArray_write16be + | MutableByteArray_write32be + | MutableByteArray_write64be + | ImmutableArray_read + | ImmutableByteArray_read8 + | ImmutableByteArray_read16be + | ImmutableByteArray_read24be + | ImmutableByteArray_read32be + | ImmutableByteArray_read40be + | ImmutableByteArray_read64be + | MutableByteArray_freeze_force + | MutableArray_freeze_force + | MutableByteArray_freeze + | MutableArray_freeze + | MutableByteArray_length + | ImmutableByteArray_length + | IO_array + | IO_arrayOf + | IO_bytearray + | IO_bytearrayOf + | Scope_array + | Scope_arrayOf + | Scope_bytearray + | Scope_bytearrayOf + | Text_patterns_literal + | Text_patterns_digit + | Text_patterns_letter + | Text_patterns_space + | Text_patterns_punctuation + | Text_patterns_anyChar + | Text_patterns_eof + | Text_patterns_charRange + | Text_patterns_notCharRange + | Text_patterns_charIn + | Text_patterns_notCharIn + | Pattern_many + | Pattern_many_corrected + | Pattern_capture + | Pattern_captureAs + | Pattern_join + | Pattern_or + | Pattern_replicate + | Pattern_run + | Pattern_isMatch + | Char_Class_any + | Char_Class_not + | Char_Class_and + | Char_Class_or + | Char_Class_range + | Char_Class_anyOf + | Char_Class_alphanumeric + | Char_Class_upper + | Char_Class_lower + | Char_Class_whitespace + | Char_Class_control + | Char_Class_printable + | Char_Class_mark + | Char_Class_number + | Char_Class_punctuation + | Char_Class_symbol + | Char_Class_separator + | Char_Class_letter + | Char_Class_is + | Text_patterns_char + deriving (Show, Eq, Ord, Enum, Bounded) + type ANormal = ABTN.Term ANormalF type Cte v = CTE v (ANormal v) diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index 9b6c575232..fd223aba71 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -317,7 +317,7 @@ putGroup :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> SuperGroup v -> m () putGroup refrep fops (Rec bs e) = @@ -338,7 +338,7 @@ getGroup = do cs <- replicateM l (getComb ctx n) Rec (zip vs cs) <$> getComb ctx n -putCode :: (MonadPut m) => EC.EnumMap FOp Text -> Code -> m () +putCode :: (MonadPut m) => EC.EnumMap ForeignFunc Text -> Code -> m () putCode fops (CodeRep g c) = putGroup mempty fops g *> putCacheability c getCode :: (MonadGet m) => Word32 -> m Code @@ -363,7 +363,7 @@ putComb :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> [v] -> SuperNormal v -> m () @@ -384,7 +384,7 @@ putNormal :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> [v] -> ANormal v -> m () @@ -482,7 +482,7 @@ putFunc :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> [v] -> Func v -> m () @@ -757,7 +757,7 @@ putBranches :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> [v] -> Branched (ANormal v) -> m () @@ -825,7 +825,7 @@ putCase :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> [v] -> ([Mem], ANormal v) -> m () @@ -997,7 +997,7 @@ deserializeCode bs = runGetS (getVersion >>= getCode) bs n | 1 <= n && n <= 3 -> pure n n -> fail $ "deserializeGroup: unknown version: " ++ show n -serializeCode :: EC.EnumMap FOp Text -> Code -> ByteString +serializeCode :: EC.EnumMap ForeignFunc Text -> Code -> ByteString serializeCode fops co = runPutS (putVersion *> putCode fops co) where putVersion = putWord32be codeVersion @@ -1023,7 +1023,7 @@ serializeCode fops co = runPutS (putVersion *> putCode fops co) -- shouldn't be subject to rehashing. serializeGroupForRehash :: (Var v) => - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> Reference -> SuperGroup v -> L.ByteString diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 1a65902dd9..6ef8783946 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -8,8 +8,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Unison.Runtime.Builtin - ( builtinLookup, - builtinTermNumbering, + ( builtinTermNumbering, builtinTypeNumbering, builtinTermBackref, builtinTypeBackref, @@ -26,171 +25,31 @@ module Unison.Runtime.Builtin ) where -import Control.Concurrent (ThreadId) -import Control.Concurrent as SYS - ( killThread, - threadDelay, - ) -import Control.Concurrent.MVar as SYS import Control.Concurrent.STM qualified as STM -import Control.DeepSeq (NFData) -import Control.Exception (evaluate) -import Control.Exception.Safe qualified as Exception -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Primitive qualified as PA import Control.Monad.Reader (ReaderT (..), ask, runReaderT) import Control.Monad.State.Strict (State, execState, modify) -import Crypto.Error (CryptoError (..), CryptoFailable (..)) -import Crypto.Hash qualified as Hash -import Crypto.MAC.HMAC qualified as HMAC -import Crypto.PubKey.Ed25519 qualified as Ed25519 -import Crypto.PubKey.RSA.PKCS15 qualified as RSA -import Crypto.Random (getRandomBytes) -import Data.Bits (shiftL, shiftR, (.|.)) -import Data.ByteArray qualified as BA -import Data.ByteString (hGet, hGetSome, hPut) -import Data.ByteString.Lazy qualified as L -import Data.Default (def) -import Data.Digest.Murmur64 (asWord64, hash64) -import Data.IP (IP) import Data.Map qualified as Map -import Data.PEM (PEM, pemContent, pemParseLBS) import Data.Set (insert) import Data.Set qualified as Set import Data.Text qualified -import Data.Text.IO qualified as Text.IO -import Data.Time.Clock.POSIX as SYS - ( getPOSIXTime, - posixSecondsToUTCTime, - utcTimeToPOSIXSeconds, - ) -import Data.Time.LocalTime (TimeZone (..), getTimeZone) -import Data.X509 qualified as X -import Data.X509.CertificateStore qualified as X -import Data.X509.Memory qualified as X import GHC.Conc qualified as STM import GHC.IO (IO (IO)) -import Network.Simple.TCP as SYS - ( HostPreference (..), - bindSock, - closeSock, - connectSock, - listenSock, - recv, - send, - ) -import Network.Socket as SYS - ( PortNumber, - Socket, - accept, - socketPort, - ) -import Network.TLS as TLS -import Network.TLS.Extra.Cipher as Cipher -import Network.UDP as UDP - ( ClientSockAddr, - ListenSocket, - UDPSocket (..), - clientSocket, - close, - recv, - recvFrom, - send, - sendTo, - serverSocket, - stop, - ) -import System.Clock (Clock (..), getTime, nsec, sec) -import System.Directory as SYS - ( createDirectoryIfMissing, - doesDirectoryExist, - doesPathExist, - getCurrentDirectory, - getDirectoryContents, - getFileSize, - getModificationTime, - getTemporaryDirectory, - removeDirectoryRecursive, - removeFile, - renameDirectory, - renameFile, - setCurrentDirectory, - ) -import System.Environment as SYS - ( getArgs, - getEnv, - ) -import System.Exit as SYS (ExitCode (..)) -import System.FilePath (isPathSeparator) -import System.IO (Handle) -import System.IO as SYS - ( IOMode (..), - hClose, - hGetBuffering, - hGetChar, - hGetEcho, - hIsEOF, - hIsOpen, - hIsSeekable, - hReady, - hSeek, - hSetBuffering, - hSetEcho, - hTell, - openFile, - stderr, - stdin, - stdout, - ) -import System.IO.Temp (createTempDirectory) -import System.Process as SYS - ( getProcessExitCode, - proc, - runInteractiveProcess, - terminateProcess, - waitForProcess, - withCreateProcess, - ) -import System.X509 qualified as X import Unison.ABT.Normalized hiding (TTm) import Unison.Builtin.Decls qualified as Ty import Unison.Prelude hiding (Text, some) import Unison.Reference -import Unison.Referent (Referent, pattern Ref) import Unison.Runtime.ANF as ANF -import Unison.Runtime.ANF.Rehash (checkGroupHashes) -import Unison.Runtime.ANF.Serialize as ANF -import Unison.Runtime.Array qualified as PA import Unison.Runtime.Builtin.Types -import Unison.Runtime.Crypto.Rsa as Rsa import Unison.Runtime.Exception (die) -import Unison.Runtime.Foreign - ( Foreign (Wrap), - HashAlgorithm (..), - pattern Failure, - ) import Unison.Runtime.Foreign qualified as F -import Unison.Runtime.Foreign.Function -import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), emptyVal, unboxedTypeTagToInt) +import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), unboxedTypeTagToInt) import Unison.Runtime.Stack qualified as Closure import Unison.Symbol import Unison.Type qualified as Ty -import Unison.Util.Bytes qualified as Bytes import Unison.Util.EnumContainers as EC -import Unison.Util.RefPromise - ( Promise, - newPromise, - readPromise, - tryReadPromise, - writePromise, - ) -import Unison.Util.Text (Text) import Unison.Util.Text qualified as Util.Text -import Unison.Util.Text.Pattern qualified as TPat import Unison.Var -type Failure = F.Failure Val - freshes :: (Var v) => Int -> [v] freshes = freshes' mempty @@ -890,7 +749,7 @@ stm'atomic = where (act, unit, lz) = fresh -type ForeignOp = FOp -> ([Mem], ANormal Symbol) +type ForeignOp = ForeignFunc -> ([Mem], ANormal Symbol) standard'handle :: ForeignOp standard'handle instr = @@ -1119,30 +978,30 @@ crypto'hmac instr = -- -- () -> ... -inUnit :: forall v. (Var v) => v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +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 -> FOp -> ([Mem], ANormal v) +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 -> FOp -> ([Mem], ANormal v) +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 -> FOp -> ([Mem], ANormal v) +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 -> FOp -> ([Mem], ANormal v) +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 -> FOp -> ([Mem], ANormal v) +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] @@ -1169,7 +1028,7 @@ set'echo instr = (arg1, arg2, bol, stack1, stack2, stack3, unit, fail, result) = fresh -- a -> IOMode -> ... -inIomr :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +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] @@ -1838,10 +1697,7 @@ builtinLookup = ++ foreignWrappers type FDecl v = - ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc))) - -type FDecl' v = - ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc'))) + ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], Map Word64 (Data.Text.Text, ForeignFunc))) -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked @@ -1850,255 +1706,6 @@ type FDecl' v = data Sandbox = Tracked | Untracked deriving (Eq, Ord, Show, Read, Enum, Bounded) -foreignFuncTracking :: ForeignFunc' -> Sandbox -foreignFuncTracking = \case - IO_UDP_clientSocket_impl_v1 -> Tracked - IO_UDP_UDPSocket_recv_impl_v1 -> Tracked - IO_UDP_UDPSocket_send_impl_v1 -> Tracked - IO_UDP_UDPSocket_close_impl_v1 -> Tracked - IO_UDP_ListenSocket_close_impl_v1 -> Tracked - IO_UDP_UDPSocket_toText_impl_v1 -> Tracked - IO_UDP_serverSocket_impl_v1 -> Tracked - IO_UDP_ListenSocket_toText_impl_v1 -> Tracked - IO_UDP_ListenSocket_recvFrom_impl_v1 -> Tracked - IO_UDP_ClientSockAddr_toText_v1 -> Tracked - IO_UDP_ListenSocket_sendTo_impl_v1 -> Tracked - IO_openFile_impl_v3 -> Tracked - IO_closeFile_impl_v3 -> Tracked - IO_isFileEOF_impl_v3 -> Tracked - IO_isFileOpen_impl_v3 -> Tracked - IO_getEcho_impl_v1 -> Tracked - IO_ready_impl_v1 -> Tracked - IO_getChar_impl_v1 -> Tracked - IO_isSeekable_impl_v3 -> Tracked - IO_seekHandle_impl_v3 -> Tracked - IO_handlePosition_impl_v3 -> Tracked - IO_getBuffering_impl_v3 -> Tracked - IO_setBuffering_impl_v3 -> Tracked - IO_setEcho_impl_v1 -> Tracked - IO_getLine_impl_v1 -> Tracked - IO_getBytes_impl_v3 -> Tracked - IO_getSomeBytes_impl_v1 -> Tracked - IO_putBytes_impl_v3 -> Tracked - IO_systemTime_impl_v3 -> Tracked - IO_systemTimeMicroseconds_v1 -> Tracked - Clock_internals_monotonic_v1 -> Tracked - Clock_internals_realtime_v1 -> Tracked - Clock_internals_processCPUTime_v1 -> Tracked - Clock_internals_threadCPUTime_v1 -> Tracked - Clock_internals_sec_v1 -> Tracked - Clock_internals_nsec_v1 -> Tracked - Clock_internals_systemTimeZone_v1 -> Tracked - IO_getTempDirectory_impl_v3 -> Tracked - IO_createTempDirectory_impl_v3 -> Tracked - IO_getCurrentDirectory_impl_v3 -> Tracked - IO_setCurrentDirectory_impl_v3 -> Tracked - IO_fileExists_impl_v3 -> Tracked - IO_getEnv_impl_v1 -> Tracked - IO_getArgs_impl_v1 -> Tracked - IO_isDirectory_impl_v3 -> Tracked - IO_createDirectory_impl_v3 -> Tracked - IO_removeDirectory_impl_v3 -> Tracked - IO_renameDirectory_impl_v3 -> Tracked - IO_directoryContents_impl_v3 -> Tracked - IO_removeFile_impl_v3 -> Tracked - IO_renameFile_impl_v3 -> Tracked - IO_getFileTimestamp_impl_v3 -> Tracked - IO_getFileSize_impl_v3 -> Tracked - IO_serverSocket_impl_v3 -> Tracked - Socket_toText -> Tracked - Handle_toText -> Tracked - ThreadId_toText -> Tracked - IO_socketPort_impl_v3 -> Tracked - IO_listen_impl_v3 -> Tracked - IO_clientSocket_impl_v3 -> Tracked - IO_closeSocket_impl_v3 -> Tracked - IO_socketAccept_impl_v3 -> Tracked - IO_socketSend_impl_v3 -> Tracked - IO_socketReceive_impl_v3 -> Tracked - IO_kill_impl_v3 -> Tracked - IO_delay_impl_v3 -> Tracked - IO_stdHandle -> Tracked - IO_process_call -> Tracked - IO_process_start -> Tracked - IO_process_kill -> Tracked - IO_process_wait -> Tracked - IO_process_exitCode -> Tracked - MVar_new -> Tracked - MVar_newEmpty_v2 -> Tracked - MVar_take_impl_v3 -> Tracked - MVar_tryTake -> Tracked - MVar_put_impl_v3 -> Tracked - MVar_tryPut_impl_v3 -> Tracked - MVar_swap_impl_v3 -> Tracked - MVar_isEmpty -> Tracked - MVar_read_impl_v3 -> Tracked - MVar_tryRead_impl_v3 -> Tracked - Char_toText -> Untracked - Text_repeat -> Untracked - Text_reverse -> Untracked - Text_toUppercase -> Untracked - Text_toLowercase -> Untracked - Text_toUtf8 -> Untracked - Text_fromUtf8_impl_v3 -> Untracked - Tls_ClientConfig_default -> Tracked - Tls_ServerConfig_default -> Tracked - Tls_ClientConfig_certificates_set -> Tracked - Tls_ServerConfig_certificates_set -> Tracked - TVar_new -> Tracked - TVar_read -> Tracked - TVar_write -> Tracked - TVar_newIO -> Tracked - TVar_readIO -> Tracked - TVar_swap -> Tracked - STM_retry -> Tracked - Promise_new -> Tracked - Promise_read -> Tracked - Promise_tryRead -> Tracked - Promise_write -> Tracked - Tls_newClient_impl_v3 -> Tracked - Tls_newServer_impl_v3 -> Tracked - Tls_handshake_impl_v3 -> Tracked - Tls_send_impl_v3 -> Tracked - Tls_decodeCert_impl_v3 -> Tracked - Tls_encodeCert -> Tracked - Tls_decodePrivateKey -> Tracked - Tls_encodePrivateKey -> Tracked - Tls_receive_impl_v3 -> Tracked - Tls_terminate_impl_v3 -> Tracked - Code_validateLinks -> Untracked - Code_dependencies -> Untracked - Code_serialize -> Untracked - Code_deserialize -> Untracked - Code_display -> Untracked - Value_dependencies -> Untracked - Value_serialize -> Untracked - Value_deserialize -> Untracked - Crypto_HashAlgorithm_Sha3_512 -> Untracked - Crypto_HashAlgorithm_Sha3_256 -> Untracked - Crypto_HashAlgorithm_Sha2_512 -> Untracked - Crypto_HashAlgorithm_Sha2_256 -> Untracked - Crypto_HashAlgorithm_Sha1 -> Untracked - Crypto_HashAlgorithm_Blake2b_512 -> Untracked - Crypto_HashAlgorithm_Blake2b_256 -> Untracked - Crypto_HashAlgorithm_Blake2s_256 -> Untracked - Crypto_HashAlgorithm_Md5 -> Untracked - Crypto_hashBytes -> Untracked - Crypto_hmacBytes -> Untracked - Crypto_hash -> Untracked - Crypto_hmac -> Untracked - Crypto_Ed25519_sign_impl -> Untracked - Crypto_Ed25519_verify_impl -> Untracked - Crypto_Rsa_sign_impl -> Untracked - Crypto_Rsa_verify_impl -> Untracked - Universal_murmurHash -> Untracked - IO_randomBytes -> Tracked - Bytes_zlib_compress -> Untracked - Bytes_gzip_compress -> Untracked - Bytes_zlib_decompress -> Untracked - Bytes_gzip_decompress -> Untracked - Bytes_toBase16 -> Untracked - Bytes_toBase32 -> Untracked - Bytes_toBase64 -> Untracked - Bytes_toBase64UrlUnpadded -> Untracked - Bytes_fromBase16 -> Untracked - Bytes_fromBase32 -> Untracked - Bytes_fromBase64 -> Untracked - Bytes_fromBase64UrlUnpadded -> Untracked - Bytes_decodeNat64be -> Untracked - Bytes_decodeNat64le -> Untracked - Bytes_decodeNat32be -> Untracked - Bytes_decodeNat32le -> Untracked - Bytes_decodeNat16be -> Untracked - Bytes_decodeNat16le -> Untracked - Bytes_encodeNat64be -> Untracked - Bytes_encodeNat64le -> Untracked - Bytes_encodeNat32be -> Untracked - Bytes_encodeNat32le -> Untracked - Bytes_encodeNat16be -> Untracked - Bytes_encodeNat16le -> Untracked - MutableArray_copyTo_force -> Untracked - MutableByteArray_copyTo_force -> Untracked - ImmutableArray_copyTo_force -> Untracked - ImmutableArray_size -> Untracked - MutableArray_size -> Untracked - ImmutableByteArray_size -> Untracked - MutableByteArray_size -> Untracked - ImmutableByteArray_copyTo_force -> Untracked - MutableArray_read -> Untracked - MutableByteArray_read8 -> Untracked - MutableByteArray_read16be -> Untracked - MutableByteArray_read24be -> Untracked - MutableByteArray_read32be -> Untracked - MutableByteArray_read40be -> Untracked - MutableByteArray_read64be -> Untracked - MutableArray_write -> Untracked - MutableByteArray_write8 -> Untracked - MutableByteArray_write16be -> Untracked - MutableByteArray_write32be -> Untracked - MutableByteArray_write64be -> Untracked - ImmutableArray_read -> Untracked - ImmutableByteArray_read8 -> Untracked - ImmutableByteArray_read16be -> Untracked - ImmutableByteArray_read24be -> Untracked - ImmutableByteArray_read32be -> Untracked - ImmutableByteArray_read40be -> Untracked - ImmutableByteArray_read64be -> Untracked - MutableByteArray_freeze_force -> Untracked - MutableArray_freeze_force -> Untracked - MutableByteArray_freeze -> Untracked - MutableArray_freeze -> Untracked - MutableByteArray_length -> Untracked - ImmutableByteArray_length -> Untracked - IO_array -> Tracked - IO_arrayOf -> Tracked - IO_bytearray -> Tracked - IO_bytearrayOf -> Tracked - Scope_array -> Untracked - Scope_arrayOf -> Untracked - Scope_bytearray -> Untracked - Scope_bytearrayOf -> Untracked - Text_patterns_literal -> Untracked - Text_patterns_digit -> Untracked - Text_patterns_letter -> Untracked - Text_patterns_space -> Untracked - Text_patterns_punctuation -> Untracked - Text_patterns_anyChar -> Untracked - Text_patterns_eof -> Untracked - Text_patterns_charRange -> Untracked - Text_patterns_notCharRange -> Untracked - Text_patterns_charIn -> Untracked - Text_patterns_notCharIn -> Untracked - Pattern_many -> Untracked - Pattern_many_corrected -> Untracked - Pattern_capture -> Untracked - Pattern_captureAs -> Untracked - Pattern_join -> Untracked - Pattern_or -> Untracked - Pattern_replicate -> Untracked - Pattern_run -> Untracked - Pattern_isMatch -> Untracked - Char_Class_any -> Untracked - Char_Class_not -> Untracked - Char_Class_and -> Untracked - Char_Class_or -> Untracked - Char_Class_range -> Untracked - Char_Class_anyOf -> Untracked - Char_Class_alphanumeric -> Untracked - Char_Class_upper -> Untracked - Char_Class_lower -> Untracked - Char_Class_whitespace -> Untracked - Char_Class_control -> Untracked - Char_Class_printable -> Untracked - Char_Class_mark -> Untracked - Char_Class_number -> Untracked - Char_Class_punctuation -> Untracked - Char_Class_symbol -> Untracked - Char_Class_separator -> Untracked - Char_Class_letter -> Untracked - Char_Class_is -> Untracked - Text_patterns_char -> Untracked - bomb :: Data.Text.Text -> a -> IO r bomb name _ = die $ "attempted to use sandboxed operation: " ++ Data.Text.unpack name @@ -2109,24 +1716,6 @@ declareForeign :: ForeignFunc -> FDecl Symbol () declareForeign sand name op func0 = do - sanitize <- ask - modify $ \(w, codes, funcs) -> - let func - | sanitize, - Tracked <- sand, - FF r w _ <- func0 = - FF r w (bomb name) - | otherwise = func0 - code = (name, (sand, uncurry Lambda (op w))) - in (w + 1, code : codes, mapInsert w (name, func) funcs) - -declareForeign' :: - Sandbox -> - Data.Text.Text -> - ForeignOp -> - ForeignFunc' -> - FDecl' Symbol () -declareForeign' sand name op func0 = do sanitize <- ask modify $ \(w, codes, funcs) -> let func @@ -2143,641 +1732,369 @@ unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) natValue :: Word64 -> Val natValue w = NatVal w -declareUdpForeigns :: FDecl' Symbol () +declareUdpForeigns :: FDecl Symbol () declareUdpForeigns = do - declareForeign' Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF IO_UDP_clientSocket_impl_v1 + declareForeign Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF IO_UDP_clientSocket_impl_v1 - declareForeign' Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF IO_UDP_UDPSocket_recv_impl_v1 + declareForeign Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF IO_UDP_UDPSocket_recv_impl_v1 - declareForeign' Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 - declareForeign' Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 IO_UDP_UDPSocket_close_impl_v1 + declareForeign Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 + declareForeign Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 IO_UDP_UDPSocket_close_impl_v1 - declareForeign' Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 IO_UDP_ListenSocket_close_impl_v1 + declareForeign Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 IO_UDP_ListenSocket_close_impl_v1 - declareForeign' Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 + declareForeign Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 - declareForeign' Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF IO_UDP_serverSocket_impl_v1 + declareForeign Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF IO_UDP_serverSocket_impl_v1 - declareForeign' Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 + declareForeign Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 - declareForeign' Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 + declareForeign Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 - declareForeign' Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 + declareForeign Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 - declareForeign' Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 + declareForeign Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 -declareForeigns :: FDecl' Symbol () +declareForeigns :: FDecl Symbol () declareForeigns = do declareUdpForeigns - declareForeign' Tracked "IO.openFile.impl.v3" argIomrToEF IO_openFile_impl_v3 + declareForeign Tracked "IO.openFile.impl.v3" argIomrToEF IO_openFile_impl_v3 - declareForeign' Tracked "IO.closeFile.impl.v3" argToEF0 IO_closeFile_impl_v3 - declareForeign' Tracked "IO.isFileEOF.impl.v3" argToEFBool IO_isFileEOF_impl_v3 - declareForeign' Tracked "IO.isFileOpen.impl.v3" argToEFBool IO_isFileOpen_impl_v3 - declareForeign' Tracked "IO.getEcho.impl.v1" argToEFBool IO_getEcho_impl_v1 - declareForeign' Tracked "IO.ready.impl.v1" argToEFBool IO_ready_impl_v1 - declareForeign' Tracked "IO.getChar.impl.v1" argToEFChar IO_getChar_impl_v1 - declareForeign' Tracked "IO.isSeekable.impl.v3" argToEFBool IO_isSeekable_impl_v3 + declareForeign Tracked "IO.closeFile.impl.v3" argToEF0 IO_closeFile_impl_v3 + declareForeign Tracked "IO.isFileEOF.impl.v3" argToEFBool IO_isFileEOF_impl_v3 + declareForeign Tracked "IO.isFileOpen.impl.v3" argToEFBool IO_isFileOpen_impl_v3 + declareForeign Tracked "IO.getEcho.impl.v1" argToEFBool IO_getEcho_impl_v1 + declareForeign Tracked "IO.ready.impl.v1" argToEFBool IO_ready_impl_v1 + declareForeign Tracked "IO.getChar.impl.v1" argToEFChar IO_getChar_impl_v1 + declareForeign Tracked "IO.isSeekable.impl.v3" argToEFBool IO_isSeekable_impl_v3 - declareForeign' Tracked "IO.seekHandle.impl.v3" seek'handle IO_seekHandle_impl_v3 + declareForeign Tracked "IO.seekHandle.impl.v3" seek'handle IO_seekHandle_impl_v3 - declareForeign' Tracked "IO.handlePosition.impl.v3" argToEFNat IO_handlePosition_impl_v3 + declareForeign Tracked "IO.handlePosition.impl.v3" argToEFNat IO_handlePosition_impl_v3 - declareForeign' Tracked "IO.getBuffering.impl.v3" get'buffering IO_getBuffering_impl_v3 + declareForeign Tracked "IO.getBuffering.impl.v3" get'buffering IO_getBuffering_impl_v3 - declareForeign' Tracked "IO.setBuffering.impl.v3" set'buffering IO_setBuffering_impl_v3 + declareForeign Tracked "IO.setBuffering.impl.v3" set'buffering IO_setBuffering_impl_v3 - declareForeign' Tracked "IO.setEcho.impl.v1" set'echo IO_setEcho_impl_v1 + declareForeign Tracked "IO.setEcho.impl.v1" set'echo IO_setEcho_impl_v1 - declareForeign' Tracked "IO.getLine.impl.v1" argToEF IO_getLine_impl_v1 + declareForeign Tracked "IO.getLine.impl.v1" argToEF IO_getLine_impl_v1 - declareForeign' Tracked "IO.getBytes.impl.v3" arg2ToEF IO_getBytes_impl_v3 - declareForeign' Tracked "IO.getSomeBytes.impl.v1" arg2ToEF IO_getSomeBytes_impl_v1 - declareForeign' Tracked "IO.putBytes.impl.v3" arg2ToEF0 IO_putBytes_impl_v3 - declareForeign' Tracked "IO.systemTime.impl.v3" unitToEF IO_systemTime_impl_v3 + declareForeign Tracked "IO.getBytes.impl.v3" arg2ToEF IO_getBytes_impl_v3 + declareForeign Tracked "IO.getSomeBytes.impl.v1" arg2ToEF IO_getSomeBytes_impl_v1 + declareForeign Tracked "IO.putBytes.impl.v3" arg2ToEF0 IO_putBytes_impl_v3 + declareForeign Tracked "IO.systemTime.impl.v3" unitToEF IO_systemTime_impl_v3 - declareForeign' Tracked "IO.systemTimeMicroseconds.v1" unitToR IO_systemTimeMicroseconds_v1 + declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToR IO_systemTimeMicroseconds_v1 - declareForeign' Tracked "Clock.internals.monotonic.v1" unitToEF Clock_internals_monotonic_v1 + declareForeign Tracked "Clock.internals.monotonic.v1" unitToEF Clock_internals_monotonic_v1 - declareForeign' Tracked "Clock.internals.realtime.v1" unitToEF Clock_internals_realtime_v1 + declareForeign Tracked "Clock.internals.realtime.v1" unitToEF Clock_internals_realtime_v1 - declareForeign' Tracked "Clock.internals.processCPUTime.v1" unitToEF Clock_internals_processCPUTime_v1 + declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEF Clock_internals_processCPUTime_v1 - declareForeign' Tracked "Clock.internals.threadCPUTime.v1" unitToEF Clock_internals_threadCPUTime_v1 + declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEF Clock_internals_threadCPUTime_v1 - declareForeign' Tracked "Clock.internals.sec.v1" (argNDirect 1) Clock_internals_sec_v1 + declareForeign Tracked "Clock.internals.sec.v1" (argNDirect 1) Clock_internals_sec_v1 -- A TimeSpec that comes from getTime never has negative nanos, -- so we can safely cast to Nat - declareForeign' Tracked "Clock.internals.nsec.v1" (argNDirect 1) Clock_internals_nsec_v1 + declareForeign Tracked "Clock.internals.nsec.v1" (argNDirect 1) Clock_internals_nsec_v1 - declareForeign' Tracked "Clock.internals.systemTimeZone.v1" time'zone Clock_internals_systemTimeZone_v1 + declareForeign Tracked "Clock.internals.systemTimeZone.v1" time'zone Clock_internals_systemTimeZone_v1 - declareForeign' Tracked "IO.getTempDirectory.impl.v3" unitToEF IO_getTempDirectory_impl_v3 + declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEF IO_getTempDirectory_impl_v3 - declareForeign' Tracked "IO.createTempDirectory.impl.v3" argToEF IO_createTempDirectory_impl_v3 + declareForeign Tracked "IO.createTempDirectory.impl.v3" argToEF IO_createTempDirectory_impl_v3 - declareForeign' Tracked "IO.getCurrentDirectory.impl.v3" unitToEF IO_getCurrentDirectory_impl_v3 + declareForeign Tracked "IO.getCurrentDirectory.impl.v3" unitToEF IO_getCurrentDirectory_impl_v3 - declareForeign' Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 IO_setCurrentDirectory_impl_v3 + declareForeign Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 IO_setCurrentDirectory_impl_v3 - declareForeign' Tracked "IO.fileExists.impl.v3" argToEFBool IO_fileExists_impl_v3 + declareForeign Tracked "IO.fileExists.impl.v3" argToEFBool IO_fileExists_impl_v3 - declareForeign' Tracked "IO.getEnv.impl.v1" argToEF IO_getEnv_impl_v1 + declareForeign Tracked "IO.getEnv.impl.v1" argToEF IO_getEnv_impl_v1 - declareForeign' Tracked "IO.getArgs.impl.v1" unitToEF IO_getArgs_impl_v1 + declareForeign Tracked "IO.getArgs.impl.v1" unitToEF IO_getArgs_impl_v1 - declareForeign' Tracked "IO.isDirectory.impl.v3" argToEFBool IO_isDirectory_impl_v3 + declareForeign Tracked "IO.isDirectory.impl.v3" argToEFBool IO_isDirectory_impl_v3 - declareForeign' Tracked "IO.createDirectory.impl.v3" argToEF0 IO_createDirectory_impl_v3 + declareForeign Tracked "IO.createDirectory.impl.v3" argToEF0 IO_createDirectory_impl_v3 - declareForeign' Tracked "IO.removeDirectory.impl.v3" argToEF0 IO_removeDirectory_impl_v3 + declareForeign Tracked "IO.removeDirectory.impl.v3" argToEF0 IO_removeDirectory_impl_v3 - declareForeign' Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 IO_renameDirectory_impl_v3 + declareForeign Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 IO_renameDirectory_impl_v3 - declareForeign' Tracked "IO.directoryContents.impl.v3" argToEF IO_directoryContents_impl_v3 + declareForeign Tracked "IO.directoryContents.impl.v3" argToEF IO_directoryContents_impl_v3 - declareForeign' Tracked "IO.removeFile.impl.v3" argToEF0 IO_removeFile_impl_v3 + declareForeign Tracked "IO.removeFile.impl.v3" argToEF0 IO_removeFile_impl_v3 - declareForeign' Tracked "IO.renameFile.impl.v3" arg2ToEF0 IO_renameFile_impl_v3 + declareForeign Tracked "IO.renameFile.impl.v3" arg2ToEF0 IO_renameFile_impl_v3 - declareForeign' Tracked "IO.getFileTimestamp.impl.v3" argToEFNat IO_getFileTimestamp_impl_v3 + declareForeign Tracked "IO.getFileTimestamp.impl.v3" argToEFNat IO_getFileTimestamp_impl_v3 - declareForeign' Tracked "IO.getFileSize.impl.v3" argToEFNat IO_getFileSize_impl_v3 + declareForeign Tracked "IO.getFileSize.impl.v3" argToEFNat IO_getFileSize_impl_v3 - declareForeign' Tracked "IO.serverSocket.impl.v3" maybeToEF IO_serverSocket_impl_v3 + declareForeign Tracked "IO.serverSocket.impl.v3" maybeToEF IO_serverSocket_impl_v3 - declareForeign' Tracked "Socket.toText" (argNDirect 1) Socket_toText + declareForeign Tracked "Socket.toText" (argNDirect 1) Socket_toText - declareForeign' Tracked "Handle.toText" (argNDirect 1) Handle_toText + declareForeign Tracked "Handle.toText" (argNDirect 1) Handle_toText - declareForeign' Tracked "ThreadId.toText" (argNDirect 1) ThreadId_toText + declareForeign Tracked "ThreadId.toText" (argNDirect 1) ThreadId_toText - declareForeign' Tracked "IO.socketPort.impl.v3" argToEFNat IO_socketPort_impl_v3 + declareForeign Tracked "IO.socketPort.impl.v3" argToEFNat IO_socketPort_impl_v3 - declareForeign' Tracked "IO.listen.impl.v3" argToEF0 IO_listen_impl_v3 + declareForeign Tracked "IO.listen.impl.v3" argToEF0 IO_listen_impl_v3 - declareForeign' Tracked "IO.clientSocket.impl.v3" arg2ToEF IO_clientSocket_impl_v3 + declareForeign Tracked "IO.clientSocket.impl.v3" arg2ToEF IO_clientSocket_impl_v3 - declareForeign' Tracked "IO.closeSocket.impl.v3" argToEF0 IO_closeSocket_impl_v3 + declareForeign Tracked "IO.closeSocket.impl.v3" argToEF0 IO_closeSocket_impl_v3 - declareForeign' Tracked "IO.socketAccept.impl.v3" argToEF IO_socketAccept_impl_v3 + declareForeign Tracked "IO.socketAccept.impl.v3" argToEF IO_socketAccept_impl_v3 - declareForeign' Tracked "IO.socketSend.impl.v3" arg2ToEF0 IO_socketSend_impl_v3 + declareForeign Tracked "IO.socketSend.impl.v3" arg2ToEF0 IO_socketSend_impl_v3 - declareForeign' Tracked "IO.socketReceive.impl.v3" arg2ToEF IO_socketReceive_impl_v3 + declareForeign Tracked "IO.socketReceive.impl.v3" arg2ToEF IO_socketReceive_impl_v3 - declareForeign' Tracked "IO.kill.impl.v3" argToEF0 IO_kill_impl_v3 + declareForeign Tracked "IO.kill.impl.v3" argToEF0 IO_kill_impl_v3 - declareForeign' Tracked "IO.delay.impl.v3" argToEFUnit IO_delay_impl_v3 + declareForeign Tracked "IO.delay.impl.v3" argToEFUnit IO_delay_impl_v3 - declareForeign' Tracked "IO.stdHandle" standard'handle IO_stdHandle + declareForeign Tracked "IO.stdHandle" standard'handle IO_stdHandle - declareForeign' Tracked "IO.process.call" (argNDirect 2) IO_process_call + declareForeign Tracked "IO.process.call" (argNDirect 2) IO_process_call - declareForeign' Tracked "IO.process.start" start'process IO_process_start + declareForeign Tracked "IO.process.start" start'process IO_process_start - declareForeign' Tracked "IO.process.kill" argToUnit IO_process_kill + declareForeign Tracked "IO.process.kill" argToUnit IO_process_kill - declareForeign' Tracked "IO.process.wait" (argNDirect 1) IO_process_wait + declareForeign Tracked "IO.process.wait" (argNDirect 1) IO_process_wait - declareForeign' Tracked "IO.process.exitCode" argToMaybe IO_process_exitCode - declareForeign' Tracked "MVar.new" (argNDirect 1) MVar_new + declareForeign Tracked "IO.process.exitCode" argToMaybe IO_process_exitCode + declareForeign Tracked "MVar.new" (argNDirect 1) MVar_new - declareForeign' Tracked "MVar.newEmpty.v2" unitDirect MVar_newEmpty_v2 + declareForeign Tracked "MVar.newEmpty.v2" unitDirect MVar_newEmpty_v2 - declareForeign' Tracked "MVar.take.impl.v3" argToEF MVar_take_impl_v3 + declareForeign Tracked "MVar.take.impl.v3" argToEF MVar_take_impl_v3 - declareForeign' Tracked "MVar.tryTake" argToMaybe MVar_tryTake + declareForeign Tracked "MVar.tryTake" argToMaybe MVar_tryTake - declareForeign' Tracked "MVar.put.impl.v3" arg2ToEF0 MVar_put_impl_v3 + declareForeign Tracked "MVar.put.impl.v3" arg2ToEF0 MVar_put_impl_v3 - declareForeign' Tracked "MVar.tryPut.impl.v3" arg2ToEFBool MVar_tryPut_impl_v3 + declareForeign Tracked "MVar.tryPut.impl.v3" arg2ToEFBool MVar_tryPut_impl_v3 - declareForeign' Tracked "MVar.swap.impl.v3" arg2ToEF MVar_swap_impl_v3 + declareForeign Tracked "MVar.swap.impl.v3" arg2ToEF MVar_swap_impl_v3 - declareForeign' Tracked "MVar.isEmpty" (argNDirect 1) MVar_isEmpty + declareForeign Tracked "MVar.isEmpty" (argNDirect 1) MVar_isEmpty - declareForeign' Tracked "MVar.read.impl.v3" argToEF MVar_read_impl_v3 + declareForeign Tracked "MVar.read.impl.v3" argToEF MVar_read_impl_v3 - declareForeign' Tracked "MVar.tryRead.impl.v3" argToEFM MVar_tryRead_impl_v3 + declareForeign Tracked "MVar.tryRead.impl.v3" argToEFM MVar_tryRead_impl_v3 - declareForeign' Untracked "Char.toText" (argNDirect 1) Char_toText - declareForeign' Untracked "Text.repeat" (argNDirect 2) Text_repeat - declareForeign' Untracked "Text.reverse" (argNDirect 1) Text_reverse - declareForeign' Untracked "Text.toUppercase" (argNDirect 1) Text_toUppercase - declareForeign' Untracked "Text.toLowercase" (argNDirect 1) Text_toLowercase - declareForeign' Untracked "Text.toUtf8" (argNDirect 1) Text_toUtf8 - declareForeign' Untracked "Text.fromUtf8.impl.v3" argToEF Text_fromUtf8_impl_v3 - declareForeign' Tracked "Tls.ClientConfig.default" (argNDirect 2) Tls_ClientConfig_default - declareForeign' Tracked "Tls.ServerConfig.default" (argNDirect 2) Tls_ServerConfig_default - declareForeign' Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) Tls_ClientConfig_certificates_set + declareForeign Untracked "Char.toText" (argNDirect 1) Char_toText + declareForeign Untracked "Text.repeat" (argNDirect 2) Text_repeat + declareForeign Untracked "Text.reverse" (argNDirect 1) Text_reverse + declareForeign Untracked "Text.toUppercase" (argNDirect 1) Text_toUppercase + declareForeign Untracked "Text.toLowercase" (argNDirect 1) Text_toLowercase + declareForeign Untracked "Text.toUtf8" (argNDirect 1) Text_toUtf8 + declareForeign Untracked "Text.fromUtf8.impl.v3" argToEF Text_fromUtf8_impl_v3 + declareForeign Tracked "Tls.ClientConfig.default" (argNDirect 2) Tls_ClientConfig_default + declareForeign Tracked "Tls.ServerConfig.default" (argNDirect 2) Tls_ServerConfig_default + declareForeign Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) Tls_ClientConfig_certificates_set - declareForeign' Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) Tls_ServerConfig_certificates_set + declareForeign Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) Tls_ServerConfig_certificates_set - declareForeign' Tracked "TVar.new" (argNDirect 1) TVar_new + declareForeign Tracked "TVar.new" (argNDirect 1) TVar_new - declareForeign' Tracked "TVar.read" (argNDirect 1) TVar_read - declareForeign' Tracked "TVar.write" arg2To0 TVar_write - declareForeign' Tracked "TVar.newIO" (argNDirect 1) TVar_newIO + declareForeign Tracked "TVar.read" (argNDirect 1) TVar_read + declareForeign Tracked "TVar.write" arg2To0 TVar_write + declareForeign Tracked "TVar.newIO" (argNDirect 1) TVar_newIO - declareForeign' Tracked "TVar.readIO" (argNDirect 1) TVar_readIO - declareForeign' Tracked "TVar.swap" (argNDirect 2) TVar_swap - declareForeign' Tracked "STM.retry" unitDirect STM_retry - declareForeign' Tracked "Promise.new" unitDirect Promise_new + declareForeign Tracked "TVar.readIO" (argNDirect 1) TVar_readIO + declareForeign Tracked "TVar.swap" (argNDirect 2) TVar_swap + declareForeign Tracked "STM.retry" unitDirect STM_retry + declareForeign Tracked "Promise.new" unitDirect Promise_new -- the only exceptions from Promise.read are async and shouldn't be caught - declareForeign' Tracked "Promise.read" (argNDirect 1) Promise_read - declareForeign' Tracked "Promise.tryRead" argToMaybe Promise_tryRead - - declareForeign' Tracked "Promise.write" (argNDirect 2) Promise_write - declareForeign' Tracked "Tls.newClient.impl.v3" arg2ToEF Tls_newClient_impl_v3 - declareForeign' Tracked "Tls.newServer.impl.v3" arg2ToEF Tls_newServer_impl_v3 - declareForeign' Tracked "Tls.handshake.impl.v3" argToEF0 Tls_handshake_impl_v3 - declareForeign' Tracked "Tls.send.impl.v3" arg2ToEF0 Tls_send_impl_v3 - declareForeign' Tracked "Tls.decodeCert.impl.v3" argToEF Tls_decodeCert_impl_v3 - - declareForeign' Tracked "Tls.encodeCert" (argNDirect 1) Tls_encodeCert - - declareForeign' Tracked "Tls.decodePrivateKey" (argNDirect 1) Tls_decodePrivateKey - declareForeign' Tracked "Tls.encodePrivateKey" (argNDirect 1) Tls_encodePrivateKey - - declareForeign' Tracked "Tls.receive.impl.v3" argToEF Tls_receive_impl_v3 - - declareForeign' Tracked "Tls.terminate.impl.v3" argToEF0 Tls_terminate_impl_v3 - declareForeign' Untracked "Code.validateLinks" argToExnE Code_validateLinks - declareForeign' Untracked "Code.dependencies" (argNDirect 1) Code_dependencies - declareForeign' Untracked "Code.serialize" (argNDirect 1) Code_serialize - declareForeign' Untracked "Code.deserialize" argToEither Code_deserialize - declareForeign' Untracked "Code.display" (argNDirect 2) Code_display - declareForeign' Untracked "Value.dependencies" (argNDirect 1) Value_dependencies - declareForeign' Untracked "Value.serialize" (argNDirect 1) Value_serialize - declareForeign' Untracked "Value.deserialize" argToEither Value_deserialize + declareForeign Tracked "Promise.read" (argNDirect 1) Promise_read + declareForeign Tracked "Promise.tryRead" argToMaybe Promise_tryRead + + declareForeign Tracked "Promise.write" (argNDirect 2) Promise_write + declareForeign Tracked "Tls.newClient.impl.v3" arg2ToEF Tls_newClient_impl_v3 + declareForeign Tracked "Tls.newServer.impl.v3" arg2ToEF Tls_newServer_impl_v3 + declareForeign Tracked "Tls.handshake.impl.v3" argToEF0 Tls_handshake_impl_v3 + declareForeign Tracked "Tls.send.impl.v3" arg2ToEF0 Tls_send_impl_v3 + declareForeign Tracked "Tls.decodeCert.impl.v3" argToEF Tls_decodeCert_impl_v3 + + declareForeign Tracked "Tls.encodeCert" (argNDirect 1) Tls_encodeCert + + declareForeign Tracked "Tls.decodePrivateKey" (argNDirect 1) Tls_decodePrivateKey + declareForeign Tracked "Tls.encodePrivateKey" (argNDirect 1) Tls_encodePrivateKey + + declareForeign Tracked "Tls.receive.impl.v3" argToEF Tls_receive_impl_v3 + + declareForeign Tracked "Tls.terminate.impl.v3" argToEF0 Tls_terminate_impl_v3 + declareForeign Untracked "Code.validateLinks" argToExnE Code_validateLinks + declareForeign Untracked "Code.dependencies" (argNDirect 1) Code_dependencies + declareForeign Untracked "Code.serialize" (argNDirect 1) Code_serialize + declareForeign Untracked "Code.deserialize" argToEither Code_deserialize + declareForeign Untracked "Code.display" (argNDirect 2) Code_display + declareForeign Untracked "Value.dependencies" (argNDirect 1) Value_dependencies + declareForeign Untracked "Value.serialize" (argNDirect 1) Value_serialize + declareForeign Untracked "Value.deserialize" argToEither Value_deserialize -- Hashing functions - declareForeign' Untracked "crypto.HashAlgorithm.Sha3_512" direct Crypto_HashAlgorithm_Sha3_512 - declareForeign' Untracked "crypto.HashAlgorithm.Sha3_256" direct Crypto_HashAlgorithm_Sha3_256 - declareForeign' Untracked "crypto.HashAlgorithm.Sha2_512" direct Crypto_HashAlgorithm_Sha2_512 - declareForeign' Untracked "crypto.HashAlgorithm.Sha2_256" direct Crypto_HashAlgorithm_Sha2_256 - declareForeign' Untracked "crypto.HashAlgorithm.Sha1" direct Crypto_HashAlgorithm_Sha1 - declareForeign' Untracked "crypto.HashAlgorithm.Blake2b_512" direct Crypto_HashAlgorithm_Blake2b_512 - declareForeign' Untracked "crypto.HashAlgorithm.Blake2b_256" direct Crypto_HashAlgorithm_Blake2b_256 - declareForeign' Untracked "crypto.HashAlgorithm.Blake2s_256" direct Crypto_HashAlgorithm_Blake2s_256 - declareForeign' Untracked "crypto.HashAlgorithm.Md5" direct Crypto_HashAlgorithm_Md5 - - declareForeign' Untracked "crypto.hashBytes" (argNDirect 2) Crypto_hashBytes - declareForeign' Untracked "crypto.hmacBytes" (argNDirect 3) Crypto_hmacBytes - - declareForeign' Untracked "crypto.hash" crypto'hash Crypto_hash - declareForeign' Untracked "crypto.hmac" crypto'hmac Crypto_hmac - declareForeign' Untracked "crypto.Ed25519.sign.impl" arg3ToEF Crypto_Ed25519_sign_impl - - declareForeign' Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool Crypto_Ed25519_verify_impl - - declareForeign' Untracked "crypto.Rsa.sign.impl" arg2ToEF Crypto_Rsa_sign_impl - - declareForeign' Untracked "crypto.Rsa.verify.impl" arg3ToEFBool Crypto_Rsa_verify_impl - - declareForeign' Untracked "Universal.murmurHash" murmur'hash Universal_murmurHash - declareForeign' Tracked "IO.randomBytes" (argNDirect 1) IO_randomBytes - declareForeign' Untracked "Bytes.zlib.compress" (argNDirect 1) Bytes_zlib_compress - declareForeign' Untracked "Bytes.gzip.compress" (argNDirect 1) Bytes_gzip_compress - declareForeign' Untracked "Bytes.zlib.decompress" argToEither Bytes_zlib_decompress - declareForeign' Untracked "Bytes.gzip.decompress" argToEither Bytes_gzip_decompress - - declareForeign' Untracked "Bytes.toBase16" (argNDirect 1) Bytes_toBase16 - declareForeign' Untracked "Bytes.toBase32" (argNDirect 1) Bytes_toBase32 - declareForeign' Untracked "Bytes.toBase64" (argNDirect 1) Bytes_toBase64 - declareForeign' Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) Bytes_toBase64UrlUnpadded - - declareForeign' Untracked "Bytes.fromBase16" argToEither Bytes_fromBase16 - declareForeign' Untracked "Bytes.fromBase32" argToEither Bytes_fromBase32 - declareForeign' Untracked "Bytes.fromBase64" argToEither Bytes_fromBase64 - declareForeign' Untracked "Bytes.fromBase64UrlUnpadded" argToEither Bytes_fromBase64UrlUnpadded - - declareForeign' Untracked "Bytes.decodeNat64be" argToMaybeNTup Bytes_decodeNat64be - declareForeign' Untracked "Bytes.decodeNat64le" argToMaybeNTup Bytes_decodeNat64le - declareForeign' Untracked "Bytes.decodeNat32be" argToMaybeNTup Bytes_decodeNat32be - declareForeign' Untracked "Bytes.decodeNat32le" argToMaybeNTup Bytes_decodeNat32le - declareForeign' Untracked "Bytes.decodeNat16be" argToMaybeNTup Bytes_decodeNat16be - declareForeign' Untracked "Bytes.decodeNat16le" argToMaybeNTup Bytes_decodeNat16le - - declareForeign' Untracked "Bytes.encodeNat64be" (argNDirect 1) Bytes_encodeNat64be - declareForeign' Untracked "Bytes.encodeNat64le" (argNDirect 1) Bytes_encodeNat64le - declareForeign' Untracked "Bytes.encodeNat32be" (argNDirect 1) Bytes_encodeNat32be - declareForeign' Untracked "Bytes.encodeNat32le" (argNDirect 1) Bytes_encodeNat32le - declareForeign' Untracked "Bytes.encodeNat16be" (argNDirect 1) Bytes_encodeNat16be - declareForeign' Untracked "Bytes.encodeNat16le" (argNDirect 1) Bytes_encodeNat16le - - declareForeign' Untracked "MutableArray.copyTo!" arg5ToExnUnit MutableArray_copyTo_force - - declareForeign' Untracked "MutableByteArray.copyTo!" arg5ToExnUnit MutableByteArray_copyTo_force - - declareForeign' Untracked "ImmutableArray.copyTo!" arg5ToExnUnit ImmutableArray_copyTo_force - - declareForeign' Untracked "ImmutableArray.size" (argNDirect 1) ImmutableArray_size - declareForeign' Untracked "MutableArray.size" (argNDirect 1) MutableArray_size - declareForeign' Untracked "ImmutableByteArray.size" (argNDirect 1) ImmutableByteArray_size - declareForeign' Untracked "MutableByteArray.size" (argNDirect 1) MutableByteArray_size - - declareForeign' Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit ImmutableByteArray_copyTo_force - - declareForeign' Untracked "MutableArray.read" arg2ToExn MutableArray_read - declareForeign' Untracked "MutableByteArray.read8" arg2ToExn MutableByteArray_read8 - declareForeign' Untracked "MutableByteArray.read16be" arg2ToExn MutableByteArray_read16be - declareForeign' Untracked "MutableByteArray.read24be" arg2ToExn MutableByteArray_read24be - declareForeign' Untracked "MutableByteArray.read32be" arg2ToExn MutableByteArray_read32be - declareForeign' Untracked "MutableByteArray.read40be" arg2ToExn MutableByteArray_read40be - declareForeign' Untracked "MutableByteArray.read64be" arg2ToExn MutableByteArray_read64be - - declareForeign' Untracked "MutableArray.write" arg3ToExnUnit MutableArray_write - declareForeign' Untracked "MutableByteArray.write8" arg3ToExnUnit MutableByteArray_write8 - declareForeign' Untracked "MutableByteArray.write16be" arg3ToExnUnit MutableByteArray_write16be - declareForeign' Untracked "MutableByteArray.write32be" arg3ToExnUnit MutableByteArray_write32be - declareForeign' Untracked "MutableByteArray.write64be" arg3ToExnUnit MutableByteArray_write64be - - declareForeign' Untracked "ImmutableArray.read" arg2ToExn ImmutableArray_read - declareForeign' Untracked "ImmutableByteArray.read8" arg2ToExn ImmutableByteArray_read8 - declareForeign' Untracked "ImmutableByteArray.read16be" arg2ToExn ImmutableByteArray_read16be - declareForeign' Untracked "ImmutableByteArray.read24be" arg2ToExn ImmutableByteArray_read24be - declareForeign' Untracked "ImmutableByteArray.read32be" arg2ToExn ImmutableByteArray_read32be - declareForeign' Untracked "ImmutableByteArray.read40be" arg2ToExn ImmutableByteArray_read40be - declareForeign' Untracked "ImmutableByteArray.read64be" arg2ToExn ImmutableByteArray_read64be - - declareForeign' Untracked "MutableByteArray.freeze!" (argNDirect 1) MutableByteArray_freeze_force - declareForeign' Untracked "MutableArray.freeze!" (argNDirect 1) MutableArray_freeze_force - - declareForeign' Untracked "MutableByteArray.freeze" arg3ToExn MutableByteArray_freeze - declareForeign' Untracked "MutableArray.freeze" arg3ToExn MutableArray_freeze - - declareForeign' Untracked "MutableByteArray.length" (argNDirect 1) MutableByteArray_length - - declareForeign' Untracked "ImmutableByteArray.length" (argNDirect 1) ImmutableByteArray_length - - declareForeign' Tracked "IO.array" (argNDirect 1) IO_array - declareForeign' Tracked "IO.arrayOf" (argNDirect 2) IO_arrayOf - declareForeign' Tracked "IO.bytearray" (argNDirect 1) IO_bytearray - declareForeign' Tracked "IO.bytearrayOf" (argNDirect 2) IO_bytearrayOf - - declareForeign' Untracked "Scope.array" (argNDirect 1) Scope_array - declareForeign' Untracked "Scope.arrayOf" (argNDirect 2) Scope_arrayOf - declareForeign' Untracked "Scope.bytearray" (argNDirect 1) Scope_bytearray - declareForeign' Untracked "Scope.bytearrayOf" (argNDirect 2) Scope_bytearrayOf - - declareForeign' Untracked "Text.patterns.literal" (argNDirect 1) Text_patterns_literal - declareForeign' Untracked "Text.patterns.digit" direct Text_patterns_digit - declareForeign' Untracked "Text.patterns.letter" direct Text_patterns_letter - declareForeign' Untracked "Text.patterns.space" direct Text_patterns_space - declareForeign' Untracked "Text.patterns.punctuation" direct Text_patterns_punctuation - declareForeign' Untracked "Text.patterns.anyChar" direct Text_patterns_anyChar - declareForeign' Untracked "Text.patterns.eof" direct Text_patterns_eof - declareForeign' Untracked "Text.patterns.charRange" (argNDirect 2) Text_patterns_charRange - declareForeign' Untracked "Text.patterns.notCharRange" (argNDirect 2) Text_patterns_notCharRange - declareForeign' Untracked "Text.patterns.charIn" (argNDirect 1) Text_patterns_charIn - declareForeign' Untracked "Text.patterns.notCharIn" (argNDirect 1) Text_patterns_notCharIn - declareForeign' Untracked "Pattern.many" (argNDirect 1) Pattern_many - declareForeign' Untracked "Pattern.many.corrected" (argNDirect 1) Pattern_many_corrected - declareForeign' Untracked "Pattern.capture" (argNDirect 1) Pattern_capture - declareForeign' Untracked "Pattern.captureAs" (argNDirect 2) Pattern_captureAs - declareForeign' Untracked "Pattern.join" (argNDirect 1) Pattern_join - declareForeign' Untracked "Pattern.or" (argNDirect 2) Pattern_or - declareForeign' Untracked "Pattern.replicate" (argNDirect 3) Pattern_replicate - - declareForeign' Untracked "Pattern.run" arg2ToMaybeTup Pattern_run - - declareForeign' Untracked "Pattern.isMatch" (argNDirect 2) Pattern_isMatch - - declareForeign' Untracked "Char.Class.any" direct Char_Class_any - declareForeign' Untracked "Char.Class.not" (argNDirect 1) Char_Class_not - declareForeign' Untracked "Char.Class.and" (argNDirect 2) Char_Class_and - declareForeign' Untracked "Char.Class.or" (argNDirect 2) Char_Class_or - declareForeign' Untracked "Char.Class.range" (argNDirect 2) Char_Class_range - declareForeign' Untracked "Char.Class.anyOf" (argNDirect 1) Char_Class_anyOf - declareForeign' Untracked "Char.Class.alphanumeric" direct Char_Class_alphanumeric - declareForeign' Untracked "Char.Class.upper" direct Char_Class_upper - declareForeign' Untracked "Char.Class.lower" direct Char_Class_lower - declareForeign' Untracked "Char.Class.whitespace" direct Char_Class_whitespace - declareForeign' Untracked "Char.Class.control" direct Char_Class_control - declareForeign' Untracked "Char.Class.printable" direct Char_Class_printable - declareForeign' Untracked "Char.Class.mark" direct Char_Class_mark - declareForeign' Untracked "Char.Class.number" direct Char_Class_number - declareForeign' Untracked "Char.Class.punctuation" direct Char_Class_punctuation - declareForeign' Untracked "Char.Class.symbol" direct Char_Class_symbol - declareForeign' Untracked "Char.Class.separator" direct Char_Class_separator - declareForeign' Untracked "Char.Class.letter" direct Char_Class_letter - declareForeign' Untracked "Char.Class.is" (argNDirect 2) Char_Class_is - declareForeign' Untracked "Text.patterns.char" (argNDirect 1) Text_patterns_char - -type RW = PA.PrimState IO - -checkedRead :: - Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val) -checkedRead name (arr, w) = - checkBounds - name - (PA.sizeofMutableArray arr) - w - (Right <$> PA.readArray arr (fromIntegral w)) - -checkedWrite :: - Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ()) -checkedWrite name (arr, w, v) = - checkBounds - name - (PA.sizeofMutableArray arr) - w - (Right <$> PA.writeArray arr (fromIntegral w) v) - -checkedIndex :: - Text -> (PA.Array Val, Word64) -> IO (Either Failure Val) -checkedIndex name (arr, w) = - checkBounds - name - (PA.sizeofArray arr) - w - (Right <$> PA.indexArrayM arr (fromIntegral w)) - -checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead8 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ - (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j - where - j = fromIntegral i - -checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead16 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ - mk16 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - where - j = fromIntegral i - -checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead24 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ - mk24 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - where - j = fromIntegral i - -checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead32 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ - mk32 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - where - j = fromIntegral i - -checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead40 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ - mk40 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - <*> PA.readByteArray @Word8 arr (j + 4) - where - j = fromIntegral i - -checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead64 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ - mk64 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - <*> PA.readByteArray @Word8 arr (j + 4) - <*> PA.readByteArray @Word8 arr (j + 5) - <*> PA.readByteArray @Word8 arr (j + 6) - <*> PA.readByteArray @Word8 arr (j + 7) - where - j = fromIntegral i - -mk16 :: Word8 -> Word8 -> Either Failure Word64 -mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) - -mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk24 b0 b1 b2 = - Right $ - (fromIntegral b0 `shiftL` 16) - .|. (fromIntegral b1 `shiftL` 8) - .|. (fromIntegral b2) - -mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk32 b0 b1 b2 b3 = - Right $ - (fromIntegral b0 `shiftL` 24) - .|. (fromIntegral b1 `shiftL` 16) - .|. (fromIntegral b2 `shiftL` 8) - .|. (fromIntegral b3) - -mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk40 b0 b1 b2 b3 b4 = - Right $ - (fromIntegral b0 `shiftL` 32) - .|. (fromIntegral b1 `shiftL` 24) - .|. (fromIntegral b2 `shiftL` 16) - .|. (fromIntegral b3 `shiftL` 8) - .|. (fromIntegral b4) - -mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk64 b0 b1 b2 b3 b4 b5 b6 b7 = - Right $ - (fromIntegral b0 `shiftL` 56) - .|. (fromIntegral b1 `shiftL` 48) - .|. (fromIntegral b2 `shiftL` 40) - .|. (fromIntegral b3 `shiftL` 32) - .|. (fromIntegral b4 `shiftL` 24) - .|. (fromIntegral b5 `shiftL` 16) - .|. (fromIntegral b6 `shiftL` 8) - .|. (fromIntegral b7) - -checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite8 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do - PA.writeByteArray arr j (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite16 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite32 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) - PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite64 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) - PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) - PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) - PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) - PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) - PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - --- index single byte -checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex8 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ - let j = fromIntegral i - in Right . fromIntegral $ PA.indexByteArray @Word8 arr j - --- index 16 big-endian -checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex16 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ - let j = fromIntegral i - in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) - --- index 32 big-endian -checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex24 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ - let j = fromIntegral i - in mk24 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - --- index 32 big-endian -checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex32 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ - let j = fromIntegral i - in mk32 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - --- index 40 big-endian -checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex40 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ - let j = fromIntegral i - in mk40 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - (PA.indexByteArray arr (j + 4)) - --- index 64 big-endian -checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex64 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ - let j = fromIntegral i - in mk64 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - (PA.indexByteArray arr (j + 4)) - (PA.indexByteArray arr (j + 5)) - (PA.indexByteArray arr (j + 6)) - (PA.indexByteArray arr (j + 7)) - -checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) -checkBounds name l w act - | w < fromIntegral l = act - | otherwise = pure $ Left err - where - msg = name <> ": array index out of bounds" - err = Failure Ty.arrayFailureRef msg (natValue w) - --- Performs a bounds check on a byte array. Strategy is as follows: --- --- isz = signed array size-in-bytes --- off = unsigned byte offset into the array --- esz = unsigned number of bytes to be read --- --- 1. Turn the signed size-in-bytes of the array unsigned --- 2. Add the offset to the to-be-read number to get the maximum size needed --- 3. Check that the actual array size is at least as big as the needed size --- 4. Check that the offset is less than the size --- --- Step 4 ensures that step 3 has not overflowed. Since an actual array size can --- only be 63 bits (since it is signed), the only way for 3 to overflow is if --- the offset is larger than a possible array size, since it would need to be --- 2^64-k, where k is the small (<=8) number of bytes to be read. -checkBoundsPrim :: - Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) -checkBoundsPrim name isz off esz act - | w > bsz || off > bsz = pure $ Left err - | otherwise = act - where - msg = name <> ": array index out of bounds" - err = Failure Ty.arrayFailureRef msg (natValue off) - - bsz = fromIntegral isz - w = off + esz + declareForeign Untracked "crypto.HashAlgorithm.Sha3_512" direct Crypto_HashAlgorithm_Sha3_512 + declareForeign Untracked "crypto.HashAlgorithm.Sha3_256" direct Crypto_HashAlgorithm_Sha3_256 + declareForeign Untracked "crypto.HashAlgorithm.Sha2_512" direct Crypto_HashAlgorithm_Sha2_512 + declareForeign Untracked "crypto.HashAlgorithm.Sha2_256" direct Crypto_HashAlgorithm_Sha2_256 + declareForeign Untracked "crypto.HashAlgorithm.Sha1" direct Crypto_HashAlgorithm_Sha1 + declareForeign Untracked "crypto.HashAlgorithm.Blake2b_512" direct Crypto_HashAlgorithm_Blake2b_512 + declareForeign Untracked "crypto.HashAlgorithm.Blake2b_256" direct Crypto_HashAlgorithm_Blake2b_256 + declareForeign Untracked "crypto.HashAlgorithm.Blake2s_256" direct Crypto_HashAlgorithm_Blake2s_256 + declareForeign Untracked "crypto.HashAlgorithm.Md5" direct Crypto_HashAlgorithm_Md5 + + declareForeign Untracked "crypto.hashBytes" (argNDirect 2) Crypto_hashBytes + declareForeign Untracked "crypto.hmacBytes" (argNDirect 3) Crypto_hmacBytes + + declareForeign Untracked "crypto.hash" crypto'hash Crypto_hash + declareForeign Untracked "crypto.hmac" crypto'hmac Crypto_hmac + declareForeign Untracked "crypto.Ed25519.sign.impl" arg3ToEF Crypto_Ed25519_sign_impl + + declareForeign Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool Crypto_Ed25519_verify_impl + + declareForeign Untracked "crypto.Rsa.sign.impl" arg2ToEF Crypto_Rsa_sign_impl + + declareForeign Untracked "crypto.Rsa.verify.impl" arg3ToEFBool Crypto_Rsa_verify_impl + + declareForeign Untracked "Universal.murmurHash" murmur'hash Universal_murmurHash + declareForeign Tracked "IO.randomBytes" (argNDirect 1) IO_randomBytes + declareForeign Untracked "Bytes.zlib.compress" (argNDirect 1) Bytes_zlib_compress + declareForeign Untracked "Bytes.gzip.compress" (argNDirect 1) Bytes_gzip_compress + declareForeign Untracked "Bytes.zlib.decompress" argToEither Bytes_zlib_decompress + declareForeign Untracked "Bytes.gzip.decompress" argToEither Bytes_gzip_decompress + + declareForeign Untracked "Bytes.toBase16" (argNDirect 1) Bytes_toBase16 + declareForeign Untracked "Bytes.toBase32" (argNDirect 1) Bytes_toBase32 + declareForeign Untracked "Bytes.toBase64" (argNDirect 1) Bytes_toBase64 + declareForeign Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) Bytes_toBase64UrlUnpadded + + declareForeign Untracked "Bytes.fromBase16" argToEither Bytes_fromBase16 + declareForeign Untracked "Bytes.fromBase32" argToEither Bytes_fromBase32 + declareForeign Untracked "Bytes.fromBase64" argToEither Bytes_fromBase64 + declareForeign Untracked "Bytes.fromBase64UrlUnpadded" argToEither Bytes_fromBase64UrlUnpadded + + declareForeign Untracked "Bytes.decodeNat64be" argToMaybeNTup Bytes_decodeNat64be + declareForeign Untracked "Bytes.decodeNat64le" argToMaybeNTup Bytes_decodeNat64le + declareForeign Untracked "Bytes.decodeNat32be" argToMaybeNTup Bytes_decodeNat32be + declareForeign Untracked "Bytes.decodeNat32le" argToMaybeNTup Bytes_decodeNat32le + declareForeign Untracked "Bytes.decodeNat16be" argToMaybeNTup Bytes_decodeNat16be + declareForeign Untracked "Bytes.decodeNat16le" argToMaybeNTup Bytes_decodeNat16le + + declareForeign Untracked "Bytes.encodeNat64be" (argNDirect 1) Bytes_encodeNat64be + declareForeign Untracked "Bytes.encodeNat64le" (argNDirect 1) Bytes_encodeNat64le + declareForeign Untracked "Bytes.encodeNat32be" (argNDirect 1) Bytes_encodeNat32be + declareForeign Untracked "Bytes.encodeNat32le" (argNDirect 1) Bytes_encodeNat32le + declareForeign Untracked "Bytes.encodeNat16be" (argNDirect 1) Bytes_encodeNat16be + declareForeign Untracked "Bytes.encodeNat16le" (argNDirect 1) Bytes_encodeNat16le + + declareForeign Untracked "MutableArray.copyTo!" arg5ToExnUnit MutableArray_copyTo_force + + declareForeign Untracked "MutableByteArray.copyTo!" arg5ToExnUnit MutableByteArray_copyTo_force + + declareForeign Untracked "ImmutableArray.copyTo!" arg5ToExnUnit ImmutableArray_copyTo_force + + declareForeign Untracked "ImmutableArray.size" (argNDirect 1) ImmutableArray_size + declareForeign Untracked "MutableArray.size" (argNDirect 1) MutableArray_size + declareForeign Untracked "ImmutableByteArray.size" (argNDirect 1) ImmutableByteArray_size + declareForeign Untracked "MutableByteArray.size" (argNDirect 1) MutableByteArray_size + + declareForeign Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit ImmutableByteArray_copyTo_force + + declareForeign Untracked "MutableArray.read" arg2ToExn MutableArray_read + declareForeign Untracked "MutableByteArray.read8" arg2ToExn MutableByteArray_read8 + declareForeign Untracked "MutableByteArray.read16be" arg2ToExn MutableByteArray_read16be + declareForeign Untracked "MutableByteArray.read24be" arg2ToExn MutableByteArray_read24be + declareForeign Untracked "MutableByteArray.read32be" arg2ToExn MutableByteArray_read32be + declareForeign Untracked "MutableByteArray.read40be" arg2ToExn MutableByteArray_read40be + declareForeign Untracked "MutableByteArray.read64be" arg2ToExn MutableByteArray_read64be + + declareForeign Untracked "MutableArray.write" arg3ToExnUnit MutableArray_write + declareForeign Untracked "MutableByteArray.write8" arg3ToExnUnit MutableByteArray_write8 + declareForeign Untracked "MutableByteArray.write16be" arg3ToExnUnit MutableByteArray_write16be + declareForeign Untracked "MutableByteArray.write32be" arg3ToExnUnit MutableByteArray_write32be + declareForeign Untracked "MutableByteArray.write64be" arg3ToExnUnit MutableByteArray_write64be + + declareForeign Untracked "ImmutableArray.read" arg2ToExn ImmutableArray_read + declareForeign Untracked "ImmutableByteArray.read8" arg2ToExn ImmutableByteArray_read8 + declareForeign Untracked "ImmutableByteArray.read16be" arg2ToExn ImmutableByteArray_read16be + declareForeign Untracked "ImmutableByteArray.read24be" arg2ToExn ImmutableByteArray_read24be + declareForeign Untracked "ImmutableByteArray.read32be" arg2ToExn ImmutableByteArray_read32be + declareForeign Untracked "ImmutableByteArray.read40be" arg2ToExn ImmutableByteArray_read40be + declareForeign Untracked "ImmutableByteArray.read64be" arg2ToExn ImmutableByteArray_read64be + + declareForeign Untracked "MutableByteArray.freeze!" (argNDirect 1) MutableByteArray_freeze_force + declareForeign Untracked "MutableArray.freeze!" (argNDirect 1) MutableArray_freeze_force + + declareForeign Untracked "MutableByteArray.freeze" arg3ToExn MutableByteArray_freeze + declareForeign Untracked "MutableArray.freeze" arg3ToExn MutableArray_freeze + + declareForeign Untracked "MutableByteArray.length" (argNDirect 1) MutableByteArray_length + + declareForeign Untracked "ImmutableByteArray.length" (argNDirect 1) ImmutableByteArray_length + + declareForeign Tracked "IO.array" (argNDirect 1) IO_array + declareForeign Tracked "IO.arrayOf" (argNDirect 2) IO_arrayOf + declareForeign Tracked "IO.bytearray" (argNDirect 1) IO_bytearray + declareForeign Tracked "IO.bytearrayOf" (argNDirect 2) IO_bytearrayOf + + declareForeign Untracked "Scope.array" (argNDirect 1) Scope_array + declareForeign Untracked "Scope.arrayOf" (argNDirect 2) Scope_arrayOf + declareForeign Untracked "Scope.bytearray" (argNDirect 1) Scope_bytearray + declareForeign Untracked "Scope.bytearrayOf" (argNDirect 2) Scope_bytearrayOf + + declareForeign Untracked "Text.patterns.literal" (argNDirect 1) Text_patterns_literal + declareForeign Untracked "Text.patterns.digit" direct Text_patterns_digit + declareForeign Untracked "Text.patterns.letter" direct Text_patterns_letter + declareForeign Untracked "Text.patterns.space" direct Text_patterns_space + declareForeign Untracked "Text.patterns.punctuation" direct Text_patterns_punctuation + declareForeign Untracked "Text.patterns.anyChar" direct Text_patterns_anyChar + declareForeign Untracked "Text.patterns.eof" direct Text_patterns_eof + declareForeign Untracked "Text.patterns.charRange" (argNDirect 2) Text_patterns_charRange + declareForeign Untracked "Text.patterns.notCharRange" (argNDirect 2) Text_patterns_notCharRange + declareForeign Untracked "Text.patterns.charIn" (argNDirect 1) Text_patterns_charIn + declareForeign Untracked "Text.patterns.notCharIn" (argNDirect 1) Text_patterns_notCharIn + declareForeign Untracked "Pattern.many" (argNDirect 1) Pattern_many + declareForeign Untracked "Pattern.many.corrected" (argNDirect 1) Pattern_many_corrected + declareForeign Untracked "Pattern.capture" (argNDirect 1) Pattern_capture + declareForeign Untracked "Pattern.captureAs" (argNDirect 2) Pattern_captureAs + declareForeign Untracked "Pattern.join" (argNDirect 1) Pattern_join + declareForeign Untracked "Pattern.or" (argNDirect 2) Pattern_or + declareForeign Untracked "Pattern.replicate" (argNDirect 3) Pattern_replicate + + declareForeign Untracked "Pattern.run" arg2ToMaybeTup Pattern_run + + declareForeign Untracked "Pattern.isMatch" (argNDirect 2) Pattern_isMatch + + declareForeign Untracked "Char.Class.any" direct Char_Class_any + declareForeign Untracked "Char.Class.not" (argNDirect 1) Char_Class_not + declareForeign Untracked "Char.Class.and" (argNDirect 2) Char_Class_and + declareForeign Untracked "Char.Class.or" (argNDirect 2) Char_Class_or + declareForeign Untracked "Char.Class.range" (argNDirect 2) Char_Class_range + declareForeign Untracked "Char.Class.anyOf" (argNDirect 1) Char_Class_anyOf + declareForeign Untracked "Char.Class.alphanumeric" direct Char_Class_alphanumeric + declareForeign Untracked "Char.Class.upper" direct Char_Class_upper + declareForeign Untracked "Char.Class.lower" direct Char_Class_lower + declareForeign Untracked "Char.Class.whitespace" direct Char_Class_whitespace + declareForeign Untracked "Char.Class.control" direct Char_Class_control + declareForeign Untracked "Char.Class.printable" direct Char_Class_printable + declareForeign Untracked "Char.Class.mark" direct Char_Class_mark + declareForeign Untracked "Char.Class.number" direct Char_Class_number + declareForeign Untracked "Char.Class.punctuation" direct Char_Class_punctuation + declareForeign Untracked "Char.Class.symbol" direct Char_Class_symbol + declareForeign Untracked "Char.Class.separator" direct Char_Class_separator + declareForeign Untracked "Char.Class.letter" direct Char_Class_letter + declareForeign Untracked "Char.Class.is" (argNDirect 2) Char_Class_is + declareForeign Untracked "Text.patterns.char" (argNDirect 1) Text_patterns_char foreignDeclResults :: Bool -> (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) @@ -2805,8 +2122,10 @@ builtinForeigns | (_, _, m) <- foreignDeclResults False = snd <$> m sandboxedForeigns :: EnumMap Word64 ForeignFunc sandboxedForeigns | (_, _, m) <- foreignDeclResults True = snd <$> m -builtinForeignNames :: EnumMap Word64 Data.Text.Text -builtinForeignNames | (_, _, m) <- foreignDeclResults False = fst <$> m +builtinForeignNames :: Map ANF.ForeignFunc Data.Text.Text +builtinForeignNames + | (_, _, m) <- foreignDeclResults False = + m -- Bootstrapping for sandbox check. The eventual map will be one with -- associations `r -> s` where `s` is all the 'sensitive' base diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index e16b548d69..44b3566530 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -6,10 +6,7 @@ {-# LANGUAGE ViewPatterns #-} module Unison.Runtime.Foreign.Function - ( ForeignFunc (..), - ForeignConvention (..), - ForeignFunc' (..), - mkForeign, + ( ForeignConvention (..), ) where @@ -33,7 +30,6 @@ import Unison.Runtime.ANF (Code, PackedTag (..), Value, 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, @@ -51,42 +47,12 @@ import Unison.Util.Bytes (Bytes) import Unison.Util.RefPromise (Promise) import Unison.Util.Text (Text, pack, unpack) --- Foreign functions operating on stacks -data ForeignFunc where - FF :: - (Stack -> Args -> IO a) -> - (Stack -> r -> IO Stack) -> - (a -> IO r) -> - ForeignFunc - -instance Show ForeignFunc where - show _ = "ForeignFunc" - -instance Eq ForeignFunc where - _ == _ = internalBug "Eq ForeignFunc" - -instance Ord ForeignFunc where - compare _ _ = internalBug "Ord ForeignFunc" - class ForeignConvention a where readForeign :: [Int] -> Stack -> IO ([Int], a) writeForeign :: Stack -> a -> IO Stack -mkForeign :: - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeign ev = FF readArgs writeForeign ev - where - readArgs stk (argsToLists -> args) = - readForeign args stk >>= \case - ([], a) -> pure a - _ -> - internalBug - "mkForeign: too many arguments for foreign function" - instance ForeignConvention Int where readForeign (i : args) stk = (args,) <$> peekOffI stk i readForeign [] _ = foreignCCError "Int" diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs index f22a6ebcd4..23d2a2e49e 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} - module Unison.Runtime.Foreign.Impl (foreignCall) where import Control.Concurrent (ThreadId) @@ -11,12 +9,9 @@ import Control.Concurrent.MVar as SYS import Control.Concurrent.STM qualified as STM import Control.DeepSeq (NFData) import Control.Exception -import Control.Exception (evaluate) import Control.Exception.Safe qualified as Exception import Control.Monad.Catch (MonadCatch) import Control.Monad.Primitive qualified as PA -import Control.Monad.Reader (ReaderT (..), ask, runReaderT) -import Control.Monad.State.Strict (State, execState, modify) import Crypto.Error (CryptoError (..), CryptoFailable (..)) import Crypto.Hash qualified as Hash import Crypto.MAC.HMAC qualified as HMAC @@ -30,10 +25,7 @@ import Data.ByteString.Lazy qualified as L import Data.Default (def) import Data.Digest.Murmur64 (asWord64, hash64) import Data.IP (IP) -import Data.Map qualified as Map import Data.PEM (PEM, pemContent, pemParseLBS) -import Data.Set (insert) -import Data.Set qualified as Set import Data.Text qualified import Data.Text.IO qualified as Text.IO import Data.Time.Clock.POSIX as SYS @@ -129,34 +121,25 @@ import System.Process as SYS withCreateProcess, ) import System.X509 qualified as X -import Unison.ABT.Normalized hiding (TTm) import Unison.Builtin.Decls qualified as Ty import Unison.Prelude hiding (Text, some) import Unison.Reference import Unison.Referent (Referent, pattern Ref) -import Unison.Runtime.ANF as ANF +import Unison.Runtime.ANF qualified as ANF import Unison.Runtime.ANF.Rehash (checkGroupHashes) -import Unison.Runtime.ANF.Serialize as ANF +import Unison.Runtime.ANF.Serialize qualified as ANF import Unison.Runtime.Array qualified as PA import Unison.Runtime.Builtin -import Unison.Runtime.Builtin.Types -import Unison.Runtime.Crypto.Rsa as Rsa +import Unison.Runtime.Crypto.Rsa qualified as Rsa import Unison.Runtime.Exception (die) -import Unison.Runtime.Foreign - ( Foreign (Wrap), - HashAlgorithm (..), - ) import Unison.Runtime.Foreign hiding (Failure) import Unison.Runtime.Foreign qualified as F -import Unison.Runtime.Foreign.Function hiding (mkForeign) +import Unison.Runtime.Foreign.Function (ForeignConvention (..)) import Unison.Runtime.MCode import Unison.Runtime.Stack -import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), emptyVal, unboxedTypeTagToInt) -import Unison.Runtime.Stack qualified as Closure import Unison.Symbol import Unison.Type qualified as Ty import Unison.Util.Bytes qualified as Bytes -import Unison.Util.EnumContainers as EC import Unison.Util.RefPromise ( Promise, newPromise, @@ -167,10 +150,9 @@ import Unison.Util.RefPromise import Unison.Util.Text (Text) import Unison.Util.Text qualified as Util.Text import Unison.Util.Text.Pattern qualified as TPat -import Unison.Var import UnliftIO qualified -foreignCall :: ForeignFunc' -> Args -> Stack -> IO Stack +foreignCall :: MForeignFunc -> Args -> Stack -> IO Stack foreignCall = \case IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> let hostStr = Util.Text.toString host @@ -474,31 +456,31 @@ foreignCall = \case Tls_terminate_impl_v3 -> mkForeignTls $ \(tls :: TLS.Context) -> TLS.bye tls Code_validateLinks -> mkForeign $ - \(lsgs0 :: [(Referent, Code)]) -> do + \(lsgs0 :: [(Referent, ANF.Code)]) -> do let f (msg, rs) = F.Failure Ty.miscFailureRef (Util.Text.fromText msg) rs pure . first f $ checkGroupHashes lsgs0 Code_dependencies -> mkForeign $ - \(CodeRep sg _) -> - pure $ Wrap Ty.termLinkRef . Ref <$> groupTermLinks sg + \(ANF.CodeRep sg _) -> + pure $ Wrap Ty.termLinkRef . Ref <$> ANF.groupTermLinks sg Code_serialize -> mkForeign $ - \(co :: Code) -> - pure . Bytes.fromArray $ serializeCode builtinForeignNames co + \(co :: ANF.Code) -> + pure . Bytes.fromArray $ ANF.serializeCode builtinForeignNames co Code_deserialize -> mkForeign $ - pure . deserializeCode . Bytes.toArray + pure . ANF.deserializeCode . Bytes.toArray Code_display -> mkForeign $ - \(nm, (CodeRep sg _)) -> - pure $ prettyGroup @Symbol (Util.Text.unpack nm) sg "" + \(nm, (ANF.CodeRep sg _)) -> + pure $ ANF.prettyGroup @Symbol (Util.Text.unpack nm) sg "" Value_dependencies -> mkForeign $ - pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks + pure . fmap (Wrap Ty.termLinkRef . Ref) . ANF.valueTermLinks Value_serialize -> mkForeign $ - pure . Bytes.fromArray . serializeValue + pure . Bytes.fromArray . ANF.serializeValue Value_deserialize -> mkForeign $ - pure . deserializeValue . Bytes.toArray + pure . ANF.deserializeValue . Bytes.toArray Crypto_HashAlgorithm_Sha3_512 -> mkHashAlgorithm "Sha3_512" Hash.SHA3_512 Crypto_HashAlgorithm_Sha3_256 -> mkHashAlgorithm "Sha3_256" Hash.SHA3_256 Crypto_HashAlgorithm_Sha2_512 -> mkHashAlgorithm "Sha2_512" Hash.SHA512 @@ -526,7 +508,7 @@ foreignCall = \case L.ByteString -> Hash.Digest a hashlazy _ l = Hash.hashlazy l - in pure . Bytes.fromArray . hashlazy alg $ serializeValueForHash x + in pure . Bytes.fromArray . hashlazy alg $ ANF.serializeValueForHash x Crypto_hmac -> mkForeign $ \(HashAlgorithm _ alg, key, x) -> let hmac :: @@ -536,7 +518,7 @@ foreignCall = \case . HMAC.updates (HMAC.initialize $ Bytes.toArray @BA.Bytes key) $ L.toChunks s - in pure . Bytes.fromArray . hmac alg $ serializeValueForHash x + in pure . Bytes.fromArray . hmac alg $ ANF.serializeValueForHash x Crypto_Ed25519_sign_impl -> mkForeign $ pure . signEd25519Wrapper @@ -551,7 +533,7 @@ foreignCall = \case pure . verifyRsaWrapper Universal_murmurHash -> mkForeign $ - pure . asWord64 . hash64 . serializeValueForHash + pure . asWord64 . hash64 . ANF.serializeValueForHash IO_randomBytes -> mkForeign $ \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n Bytes_zlib_compress -> mkForeign $ pure . Bytes.zlibCompress diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 010513d481..83e9d5aa7b 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -35,7 +35,7 @@ module Unison.Runtime.MCode GBranch (..), Branch, RBranch, - ForeignFunc' (..), + MForeignFunc (..), emitCombs, emitComb, resolveCombs, @@ -461,7 +461,7 @@ data BPrim2 deriving (Show, Eq, Ord, Enum, Bounded) -- | Enum representing every foreign call. -data ForeignFunc' +data MForeignFunc = IO_UDP_clientSocket_impl_v1 | IO_UDP_UDPSocket_recv_impl_v1 | IO_UDP_UDPSocket_send_impl_v1 @@ -748,16 +748,10 @@ data GInstr comb | -- Use a check-and-set ticket to update a reference -- (ref stack index, ticket stack index, new value stack index) RefCAS !Int !Int !Int - | -- Call out to a Haskell function. This is considerably slower - -- for very simple operations, hence the primops. - ForeignCall - !Bool -- catch exceptions - !Word64 -- FFI call - !Args -- arguments | -- Call out to a Haskell function. - ForeignCall' + ForeignCall !Bool -- catch exceptions - !ForeignFunc' -- FFI call + !MForeignFunc -- FFI call !Args -- arguments | -- Set the value of a dynamic reference SetDyn @@ -1649,8 +1643,257 @@ emitPOp ANF.TFRC = \case -- to 'foreing function' calls, but there is a special case for the -- standard handle access function, because it does not yield an -- explicit error. -emitFOp :: ANF.FOp -> Args -> Instr -emitFOp fop = ForeignCall True (fromIntegral $ fromEnum fop) +emitFOp :: ANF.ForeignFunc -> Args -> Instr +emitFOp fop = ForeignCall True (convertFF fop) + where + convertFF :: ANF.ForeignFunc -> MForeignFunc + convertFF = \case + ANF.IO_UDP_clientSocket_impl_v1 -> IO_UDP_clientSocket_impl_v1 + ANF.IO_UDP_UDPSocket_recv_impl_v1 -> IO_UDP_UDPSocket_recv_impl_v1 + ANF.IO_UDP_UDPSocket_send_impl_v1 -> IO_UDP_UDPSocket_send_impl_v1 + ANF.IO_UDP_UDPSocket_close_impl_v1 -> IO_UDP_UDPSocket_close_impl_v1 + ANF.IO_UDP_ListenSocket_close_impl_v1 -> IO_UDP_ListenSocket_close_impl_v1 + ANF.IO_UDP_UDPSocket_toText_impl_v1 -> IO_UDP_UDPSocket_toText_impl_v1 + ANF.IO_UDP_serverSocket_impl_v1 -> IO_UDP_serverSocket_impl_v1 + ANF.IO_UDP_ListenSocket_toText_impl_v1 -> IO_UDP_ListenSocket_toText_impl_v1 + ANF.IO_UDP_ListenSocket_recvFrom_impl_v1 -> IO_UDP_ListenSocket_recvFrom_impl_v1 + ANF.IO_UDP_ClientSockAddr_toText_v1 -> IO_UDP_ClientSockAddr_toText_v1 + ANF.IO_UDP_ListenSocket_sendTo_impl_v1 -> IO_UDP_ListenSocket_sendTo_impl_v1 + ANF.IO_openFile_impl_v3 -> IO_openFile_impl_v3 + ANF.IO_closeFile_impl_v3 -> IO_closeFile_impl_v3 + ANF.IO_isFileEOF_impl_v3 -> IO_isFileEOF_impl_v3 + ANF.IO_isFileOpen_impl_v3 -> IO_isFileOpen_impl_v3 + ANF.IO_getEcho_impl_v1 -> IO_getEcho_impl_v1 + ANF.IO_ready_impl_v1 -> IO_ready_impl_v1 + ANF.IO_getChar_impl_v1 -> IO_getChar_impl_v1 + ANF.IO_isSeekable_impl_v3 -> IO_isSeekable_impl_v3 + ANF.IO_seekHandle_impl_v3 -> IO_seekHandle_impl_v3 + ANF.IO_handlePosition_impl_v3 -> IO_handlePosition_impl_v3 + ANF.IO_getBuffering_impl_v3 -> IO_getBuffering_impl_v3 + ANF.IO_setBuffering_impl_v3 -> IO_setBuffering_impl_v3 + ANF.IO_setEcho_impl_v1 -> IO_setEcho_impl_v1 + ANF.IO_getLine_impl_v1 -> IO_getLine_impl_v1 + ANF.IO_getBytes_impl_v3 -> IO_getBytes_impl_v3 + ANF.IO_getSomeBytes_impl_v1 -> IO_getSomeBytes_impl_v1 + ANF.IO_putBytes_impl_v3 -> IO_putBytes_impl_v3 + ANF.IO_systemTime_impl_v3 -> IO_systemTime_impl_v3 + ANF.IO_systemTimeMicroseconds_v1 -> IO_systemTimeMicroseconds_v1 + ANF.Clock_internals_monotonic_v1 -> Clock_internals_monotonic_v1 + ANF.Clock_internals_realtime_v1 -> Clock_internals_realtime_v1 + ANF.Clock_internals_processCPUTime_v1 -> Clock_internals_processCPUTime_v1 + ANF.Clock_internals_threadCPUTime_v1 -> Clock_internals_threadCPUTime_v1 + ANF.Clock_internals_sec_v1 -> Clock_internals_sec_v1 + ANF.Clock_internals_nsec_v1 -> Clock_internals_nsec_v1 + ANF.Clock_internals_systemTimeZone_v1 -> Clock_internals_systemTimeZone_v1 + ANF.IO_getTempDirectory_impl_v3 -> IO_getTempDirectory_impl_v3 + ANF.IO_createTempDirectory_impl_v3 -> IO_createTempDirectory_impl_v3 + ANF.IO_getCurrentDirectory_impl_v3 -> IO_getCurrentDirectory_impl_v3 + ANF.IO_setCurrentDirectory_impl_v3 -> IO_setCurrentDirectory_impl_v3 + ANF.IO_fileExists_impl_v3 -> IO_fileExists_impl_v3 + ANF.IO_getEnv_impl_v1 -> IO_getEnv_impl_v1 + ANF.IO_getArgs_impl_v1 -> IO_getArgs_impl_v1 + ANF.IO_isDirectory_impl_v3 -> IO_isDirectory_impl_v3 + ANF.IO_createDirectory_impl_v3 -> IO_createDirectory_impl_v3 + ANF.IO_removeDirectory_impl_v3 -> IO_removeDirectory_impl_v3 + ANF.IO_renameDirectory_impl_v3 -> IO_renameDirectory_impl_v3 + ANF.IO_directoryContents_impl_v3 -> IO_directoryContents_impl_v3 + ANF.IO_removeFile_impl_v3 -> IO_removeFile_impl_v3 + ANF.IO_renameFile_impl_v3 -> IO_renameFile_impl_v3 + ANF.IO_getFileTimestamp_impl_v3 -> IO_getFileTimestamp_impl_v3 + ANF.IO_getFileSize_impl_v3 -> IO_getFileSize_impl_v3 + ANF.IO_serverSocket_impl_v3 -> IO_serverSocket_impl_v3 + ANF.Socket_toText -> Socket_toText + ANF.Handle_toText -> Handle_toText + ANF.ThreadId_toText -> ThreadId_toText + ANF.IO_socketPort_impl_v3 -> IO_socketPort_impl_v3 + ANF.IO_listen_impl_v3 -> IO_listen_impl_v3 + ANF.IO_clientSocket_impl_v3 -> IO_clientSocket_impl_v3 + ANF.IO_closeSocket_impl_v3 -> IO_closeSocket_impl_v3 + ANF.IO_socketAccept_impl_v3 -> IO_socketAccept_impl_v3 + ANF.IO_socketSend_impl_v3 -> IO_socketSend_impl_v3 + ANF.IO_socketReceive_impl_v3 -> IO_socketReceive_impl_v3 + ANF.IO_kill_impl_v3 -> IO_kill_impl_v3 + ANF.IO_delay_impl_v3 -> IO_delay_impl_v3 + ANF.IO_stdHandle -> IO_stdHandle + ANF.IO_process_call -> IO_process_call + ANF.IO_process_start -> IO_process_start + ANF.IO_process_kill -> IO_process_kill + ANF.IO_process_wait -> IO_process_wait + ANF.IO_process_exitCode -> IO_process_exitCode + ANF.MVar_new -> MVar_new + ANF.MVar_newEmpty_v2 -> MVar_newEmpty_v2 + ANF.MVar_take_impl_v3 -> MVar_take_impl_v3 + ANF.MVar_tryTake -> MVar_tryTake + ANF.MVar_put_impl_v3 -> MVar_put_impl_v3 + ANF.MVar_tryPut_impl_v3 -> MVar_tryPut_impl_v3 + ANF.MVar_swap_impl_v3 -> MVar_swap_impl_v3 + ANF.MVar_isEmpty -> MVar_isEmpty + ANF.MVar_read_impl_v3 -> MVar_read_impl_v3 + ANF.MVar_tryRead_impl_v3 -> MVar_tryRead_impl_v3 + ANF.Char_toText -> Char_toText + ANF.Text_repeat -> Text_repeat + ANF.Text_reverse -> Text_reverse + ANF.Text_toUppercase -> Text_toUppercase + ANF.Text_toLowercase -> Text_toLowercase + ANF.Text_toUtf8 -> Text_toUtf8 + ANF.Text_fromUtf8_impl_v3 -> Text_fromUtf8_impl_v3 + ANF.Tls_ClientConfig_default -> Tls_ClientConfig_default + ANF.Tls_ServerConfig_default -> Tls_ServerConfig_default + ANF.Tls_ClientConfig_certificates_set -> Tls_ClientConfig_certificates_set + ANF.Tls_ServerConfig_certificates_set -> Tls_ServerConfig_certificates_set + ANF.TVar_new -> TVar_new + ANF.TVar_read -> TVar_read + ANF.TVar_write -> TVar_write + ANF.TVar_newIO -> TVar_newIO + ANF.TVar_readIO -> TVar_readIO + ANF.TVar_swap -> TVar_swap + ANF.STM_retry -> STM_retry + ANF.Promise_new -> Promise_new + ANF.Promise_read -> Promise_read + ANF.Promise_tryRead -> Promise_tryRead + ANF.Promise_write -> Promise_write + ANF.Tls_newClient_impl_v3 -> Tls_newClient_impl_v3 + ANF.Tls_newServer_impl_v3 -> Tls_newServer_impl_v3 + ANF.Tls_handshake_impl_v3 -> Tls_handshake_impl_v3 + ANF.Tls_send_impl_v3 -> Tls_send_impl_v3 + ANF.Tls_decodeCert_impl_v3 -> Tls_decodeCert_impl_v3 + ANF.Tls_encodeCert -> Tls_encodeCert + ANF.Tls_decodePrivateKey -> Tls_decodePrivateKey + ANF.Tls_encodePrivateKey -> Tls_encodePrivateKey + ANF.Tls_receive_impl_v3 -> Tls_receive_impl_v3 + ANF.Tls_terminate_impl_v3 -> Tls_terminate_impl_v3 + ANF.Code_validateLinks -> Code_validateLinks + ANF.Code_dependencies -> Code_dependencies + ANF.Code_serialize -> Code_serialize + ANF.Code_deserialize -> Code_deserialize + ANF.Code_display -> Code_display + ANF.Value_dependencies -> Value_dependencies + ANF.Value_serialize -> Value_serialize + ANF.Value_deserialize -> Value_deserialize + ANF.Crypto_HashAlgorithm_Sha3_512 -> Crypto_HashAlgorithm_Sha3_512 + ANF.Crypto_HashAlgorithm_Sha3_256 -> Crypto_HashAlgorithm_Sha3_256 + ANF.Crypto_HashAlgorithm_Sha2_512 -> Crypto_HashAlgorithm_Sha2_512 + ANF.Crypto_HashAlgorithm_Sha2_256 -> Crypto_HashAlgorithm_Sha2_256 + ANF.Crypto_HashAlgorithm_Sha1 -> Crypto_HashAlgorithm_Sha1 + ANF.Crypto_HashAlgorithm_Blake2b_512 -> Crypto_HashAlgorithm_Blake2b_512 + ANF.Crypto_HashAlgorithm_Blake2b_256 -> Crypto_HashAlgorithm_Blake2b_256 + ANF.Crypto_HashAlgorithm_Blake2s_256 -> Crypto_HashAlgorithm_Blake2s_256 + ANF.Crypto_HashAlgorithm_Md5 -> Crypto_HashAlgorithm_Md5 + ANF.Crypto_hashBytes -> Crypto_hashBytes + ANF.Crypto_hmacBytes -> Crypto_hmacBytes + ANF.Crypto_hash -> Crypto_hash + ANF.Crypto_hmac -> Crypto_hmac + ANF.Crypto_Ed25519_sign_impl -> Crypto_Ed25519_sign_impl + ANF.Crypto_Ed25519_verify_impl -> Crypto_Ed25519_verify_impl + ANF.Crypto_Rsa_sign_impl -> Crypto_Rsa_sign_impl + ANF.Crypto_Rsa_verify_impl -> Crypto_Rsa_verify_impl + ANF.Universal_murmurHash -> Universal_murmurHash + ANF.IO_randomBytes -> IO_randomBytes + ANF.Bytes_zlib_compress -> Bytes_zlib_compress + ANF.Bytes_gzip_compress -> Bytes_gzip_compress + ANF.Bytes_zlib_decompress -> Bytes_zlib_decompress + ANF.Bytes_gzip_decompress -> Bytes_gzip_decompress + ANF.Bytes_toBase16 -> Bytes_toBase16 + ANF.Bytes_toBase32 -> Bytes_toBase32 + ANF.Bytes_toBase64 -> Bytes_toBase64 + ANF.Bytes_toBase64UrlUnpadded -> Bytes_toBase64UrlUnpadded + ANF.Bytes_fromBase16 -> Bytes_fromBase16 + ANF.Bytes_fromBase32 -> Bytes_fromBase32 + ANF.Bytes_fromBase64 -> Bytes_fromBase64 + ANF.Bytes_fromBase64UrlUnpadded -> Bytes_fromBase64UrlUnpadded + ANF.Bytes_decodeNat64be -> Bytes_decodeNat64be + ANF.Bytes_decodeNat64le -> Bytes_decodeNat64le + ANF.Bytes_decodeNat32be -> Bytes_decodeNat32be + ANF.Bytes_decodeNat32le -> Bytes_decodeNat32le + ANF.Bytes_decodeNat16be -> Bytes_decodeNat16be + ANF.Bytes_decodeNat16le -> Bytes_decodeNat16le + ANF.Bytes_encodeNat64be -> Bytes_encodeNat64be + ANF.Bytes_encodeNat64le -> Bytes_encodeNat64le + ANF.Bytes_encodeNat32be -> Bytes_encodeNat32be + ANF.Bytes_encodeNat32le -> Bytes_encodeNat32le + ANF.Bytes_encodeNat16be -> Bytes_encodeNat16be + ANF.Bytes_encodeNat16le -> Bytes_encodeNat16le + ANF.MutableArray_copyTo_force -> MutableArray_copyTo_force + ANF.MutableByteArray_copyTo_force -> MutableByteArray_copyTo_force + ANF.ImmutableArray_copyTo_force -> ImmutableArray_copyTo_force + ANF.ImmutableArray_size -> ImmutableArray_size + ANF.MutableArray_size -> MutableArray_size + ANF.ImmutableByteArray_size -> ImmutableByteArray_size + ANF.MutableByteArray_size -> MutableByteArray_size + ANF.ImmutableByteArray_copyTo_force -> ImmutableByteArray_copyTo_force + ANF.MutableArray_read -> MutableArray_read + ANF.MutableByteArray_read8 -> MutableByteArray_read8 + ANF.MutableByteArray_read16be -> MutableByteArray_read16be + ANF.MutableByteArray_read24be -> MutableByteArray_read24be + ANF.MutableByteArray_read32be -> MutableByteArray_read32be + ANF.MutableByteArray_read40be -> MutableByteArray_read40be + ANF.MutableByteArray_read64be -> MutableByteArray_read64be + ANF.MutableArray_write -> MutableArray_write + ANF.MutableByteArray_write8 -> MutableByteArray_write8 + ANF.MutableByteArray_write16be -> MutableByteArray_write16be + ANF.MutableByteArray_write32be -> MutableByteArray_write32be + ANF.MutableByteArray_write64be -> MutableByteArray_write64be + ANF.ImmutableArray_read -> ImmutableArray_read + ANF.ImmutableByteArray_read8 -> ImmutableByteArray_read8 + ANF.ImmutableByteArray_read16be -> ImmutableByteArray_read16be + ANF.ImmutableByteArray_read24be -> ImmutableByteArray_read24be + ANF.ImmutableByteArray_read32be -> ImmutableByteArray_read32be + ANF.ImmutableByteArray_read40be -> ImmutableByteArray_read40be + ANF.ImmutableByteArray_read64be -> ImmutableByteArray_read64be + ANF.MutableByteArray_freeze_force -> MutableByteArray_freeze_force + ANF.MutableArray_freeze_force -> MutableArray_freeze_force + ANF.MutableByteArray_freeze -> MutableByteArray_freeze + ANF.MutableArray_freeze -> MutableArray_freeze + ANF.MutableByteArray_length -> MutableByteArray_length + ANF.ImmutableByteArray_length -> ImmutableByteArray_length + ANF.IO_array -> IO_array + ANF.IO_arrayOf -> IO_arrayOf + ANF.IO_bytearray -> IO_bytearray + ANF.IO_bytearrayOf -> IO_bytearrayOf + ANF.Scope_array -> Scope_array + ANF.Scope_arrayOf -> Scope_arrayOf + ANF.Scope_bytearray -> Scope_bytearray + ANF.Scope_bytearrayOf -> Scope_bytearrayOf + ANF.Text_patterns_literal -> Text_patterns_literal + ANF.Text_patterns_digit -> Text_patterns_digit + ANF.Text_patterns_letter -> Text_patterns_letter + ANF.Text_patterns_space -> Text_patterns_space + ANF.Text_patterns_punctuation -> Text_patterns_punctuation + ANF.Text_patterns_anyChar -> Text_patterns_anyChar + ANF.Text_patterns_eof -> Text_patterns_eof + ANF.Text_patterns_charRange -> Text_patterns_charRange + ANF.Text_patterns_notCharRange -> Text_patterns_notCharRange + ANF.Text_patterns_charIn -> Text_patterns_charIn + ANF.Text_patterns_notCharIn -> Text_patterns_notCharIn + ANF.Pattern_many -> Pattern_many + ANF.Pattern_many_corrected -> Pattern_many_corrected + ANF.Pattern_capture -> Pattern_capture + ANF.Pattern_captureAs -> Pattern_captureAs + ANF.Pattern_join -> Pattern_join + ANF.Pattern_or -> Pattern_or + ANF.Pattern_replicate -> Pattern_replicate + ANF.Pattern_run -> Pattern_run + ANF.Pattern_isMatch -> Pattern_isMatch + ANF.Char_Class_any -> Char_Class_any + ANF.Char_Class_not -> Char_Class_not + ANF.Char_Class_and -> Char_Class_and + ANF.Char_Class_or -> Char_Class_or + ANF.Char_Class_range -> Char_Class_range + ANF.Char_Class_anyOf -> Char_Class_anyOf + ANF.Char_Class_alphanumeric -> Char_Class_alphanumeric + ANF.Char_Class_upper -> Char_Class_upper + ANF.Char_Class_lower -> Char_Class_lower + ANF.Char_Class_whitespace -> Char_Class_whitespace + ANF.Char_Class_control -> Char_Class_control + ANF.Char_Class_printable -> Char_Class_printable + ANF.Char_Class_mark -> Char_Class_mark + ANF.Char_Class_number -> Char_Class_number + ANF.Char_Class_punctuation -> Char_Class_punctuation + ANF.Char_Class_symbol -> Char_Class_symbol + ANF.Char_Class_separator -> Char_Class_separator + ANF.Char_Class_letter -> Char_Class_letter + ANF.Char_Class_is -> Char_Class_is + ANF.Text_patterns_char -> Text_patterns_char -- Helper functions for packing the variable argument representation -- into the indexes stored in prim op instructions diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index b6f6cf66b3..f8cc373541 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -49,11 +49,10 @@ import Unison.Runtime.ANF as ANF ) import Unison.Runtime.ANF qualified as ANF import Unison.Runtime.Array as PA -import Unison.Runtime.Builtin +import Unison.Runtime.Builtin hiding (unitValue) import Unison.Runtime.Exception import Unison.Runtime.Foreign -import Unison.Runtime.Foreign qualified as F -import Unison.Runtime.Foreign.Function +import Unison.Runtime.Foreign.Impl (foreignCall) import Unison.Runtime.MCode import Unison.Runtime.Stack import Unison.Runtime.TypeTags qualified as TT @@ -110,8 +109,7 @@ data Tracer -- code caching environment data CCache = CCache - { foreignFuncs :: EnumMap Word64 ForeignFunc, - sandboxed :: Bool, + { sandboxed :: Bool, tracer :: Bool -> Val -> Tracer, -- Combinators in their original form, where they're easier to serialize into SCache srcCombs :: TVar (EnumMap Word64 Combs), @@ -151,7 +149,7 @@ refNumTy' cc r = M.lookup r <$> refNumsTy cc baseCCache :: Bool -> IO CCache baseCCache sandboxed = do - CCache ffuncs sandboxed noTrace + CCache sandboxed noTrace <$> newTVarIO srcCombs <*> newTVarIO combs <*> newTVarIO builtinTermBackref @@ -165,7 +163,6 @@ baseCCache sandboxed = do <*> newTVarIO baseSandboxInfo where cacheableCombs = mempty - ffuncs | sandboxed = sandboxedForeigns | otherwise = builtinForeigns noTrace _ _ = NoTrace ftm = 1 + maximum builtinTermNumbering fty = 1 + maximum builtinTypeNumbering @@ -602,14 +599,8 @@ exec !_ !denv !_activeThreads !stk !k _ (Seq as) = do stk <- bump stk pokeS stk $ Sq.fromList l pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (ForeignCall _ w args) - | Just (FF arg res ev) <- EC.lookup w (foreignFuncs env) = - (denv,,k) - <$> (arg stk args >>= ev >>= res stk) - | otherwise = - die $ "reference to unknown foreign function: " ++ show w -exec !_env !denv !_activeThreads !stk !k _ (ForeignCall' _ func args) = - (denv,,k) <$> foreignCall args func stk +exec !_env !denv !_activeThreads !stk !k _ (ForeignCall _ func args) = + (denv,,k) <$> foreignCall func args stk exec !env !denv !activeThreads !stk !k _ (Fork i) | sandboxed env = die "attempted to use sandboxed operation: fork" | otherwise = do From d53b00b52be5d849cf49bb3250fe4a55f05951ac Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 5 Dec 2024 11:39:16 -0800 Subject: [PATCH 08/36] Remove all the old sandboxing --- .../src/Unison/Runtime/ANF/Serialize.hs | 21 ++++---- unison-runtime/src/Unison/Runtime/Builtin.hs | 52 +++++-------------- .../src/Unison/Runtime/Interface.hs | 2 +- unison-runtime/src/Unison/Runtime/MCode.hs | 7 ++- .../src/Unison/Runtime/MCode/Serialize.hs | 18 ++++++- unison-runtime/src/Unison/Runtime/Machine.hs | 2 + 6 files changed, 47 insertions(+), 55 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index fd223aba71..9ce7c5db50 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -26,7 +26,6 @@ import Unison.Reference (Reference, Reference' (Builtin), pattern Derived) import Unison.Runtime.ANF as ANF hiding (Tag) import Unison.Runtime.Exception import Unison.Runtime.Serialize -import Unison.Util.EnumContainers qualified as EC import Unison.Util.Text qualified as Util.Text import Unison.Var (Type (ANFBlank), Var (..)) import Prelude hiding (getChar, putChar) @@ -317,7 +316,7 @@ putGroup :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> SuperGroup v -> m () putGroup refrep fops (Rec bs e) = @@ -338,7 +337,7 @@ getGroup = do cs <- replicateM l (getComb ctx n) Rec (zip vs cs) <$> getComb ctx n -putCode :: (MonadPut m) => EC.EnumMap ForeignFunc Text -> Code -> m () +putCode :: (MonadPut m) => Map ForeignFunc Text -> Code -> m () putCode fops (CodeRep g c) = putGroup mempty fops g *> putCacheability c getCode :: (MonadGet m) => Word32 -> m Code @@ -363,7 +362,7 @@ putComb :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> [v] -> SuperNormal v -> m () @@ -384,7 +383,7 @@ putNormal :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> [v] -> ANormal v -> m () @@ -482,7 +481,7 @@ putFunc :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> [v] -> Func v -> m () @@ -496,7 +495,7 @@ putFunc refrep fops ctx f = case f of FReq r c -> putTag FReqT *> putReference r *> putCTag c FPrim (Left p) -> putTag FPrimT *> putPOp p FPrim (Right f) - | Just nm <- EC.lookup f fops -> + | Just nm <- Map.lookup f fops -> putTag FForeignT *> putText nm | otherwise -> exn $ "putFunc: could not serialize foreign operation: " ++ show f @@ -757,7 +756,7 @@ putBranches :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> [v] -> Branched (ANormal v) -> m () @@ -825,7 +824,7 @@ putCase :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> [v] -> ([Mem], ANormal v) -> m () @@ -997,7 +996,7 @@ deserializeCode bs = runGetS (getVersion >>= getCode) bs n | 1 <= n && n <= 3 -> pure n n -> fail $ "deserializeGroup: unknown version: " ++ show n -serializeCode :: EC.EnumMap ForeignFunc Text -> Code -> ByteString +serializeCode :: Map ForeignFunc Text -> Code -> ByteString serializeCode fops co = runPutS (putVersion *> putCode fops co) where putVersion = putWord32be codeVersion @@ -1023,7 +1022,7 @@ serializeCode fops co = runPutS (putVersion *> putCode fops co) -- shouldn't be subject to rehashing. serializeGroupForRehash :: (Var v) => - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> Reference -> SuperGroup v -> L.ByteString diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 6ef8783946..261318fe54 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -12,10 +12,8 @@ module Unison.Runtime.Builtin builtinTypeNumbering, builtinTermBackref, builtinTypeBackref, - builtinForeigns, builtinArities, builtinInlineInfo, - sandboxedForeigns, numberedTermLookup, Sandbox (..), baseSandboxInfo, @@ -25,23 +23,17 @@ module Unison.Runtime.Builtin ) where -import Control.Concurrent.STM qualified as STM -import Control.Monad.Reader (ReaderT (..), ask, runReaderT) import Control.Monad.State.Strict (State, execState, modify) import Data.Map qualified as Map import Data.Set (insert) import Data.Set qualified as Set import Data.Text qualified -import GHC.Conc qualified as STM -import GHC.IO (IO (IO)) import Unison.ABT.Normalized hiding (TTm) import Unison.Builtin.Decls qualified as Ty import Unison.Prelude hiding (Text, some) import Unison.Reference import Unison.Runtime.ANF as ANF import Unison.Runtime.Builtin.Types -import Unison.Runtime.Exception (die) -import Unison.Runtime.Foreign qualified as F import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), unboxedTypeTagToInt) import Unison.Runtime.Stack qualified as Closure import Unison.Symbol @@ -1696,8 +1688,7 @@ builtinLookup = ] ++ foreignWrappers -type FDecl v = - ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], Map Word64 (Data.Text.Text, ForeignFunc))) +type FDecl v = State (Map ForeignFunc (Sandbox, SuperNormal v, Data.Text.Text)) -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked @@ -1706,25 +1697,16 @@ type FDecl v = data Sandbox = Tracked | Untracked deriving (Eq, Ord, Show, Read, Enum, Bounded) -bomb :: Data.Text.Text -> a -> IO r -bomb name _ = die $ "attempted to use sandboxed operation: " ++ Data.Text.unpack name - declareForeign :: Sandbox -> Data.Text.Text -> ForeignOp -> ForeignFunc -> FDecl Symbol () -declareForeign sand name op func0 = do - sanitize <- ask - modify $ \(w, codes, funcs) -> - let func - | sanitize, - Tracked <- sand = - error "TODO: fill in sandboxing error" - | otherwise = func0 - code = (name, (sand, uncurry Lambda (op w))) - in (w + 1, code : codes, mapInsert w (name, func) funcs) +declareForeign sand name op func = do + modify $ \funcs -> + let code = uncurry Lambda (op func) + in (Map.insert func (sand, code, name) funcs) unitValue :: Val unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) @@ -2096,13 +2078,14 @@ declareForeigns = do declareForeign Untracked "Char.Class.is" (argNDirect 2) Char_Class_is declareForeign Untracked "Text.patterns.char" (argNDirect 1) Text_patterns_char -foreignDeclResults :: - Bool -> (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) -foreignDeclResults sanitize = - execState (runReaderT declareForeigns sanitize) (0, [], mempty) +foreignDeclResults :: (Map ForeignFunc (Sandbox, SuperNormal Symbol, Data.Text.Text)) +foreignDeclResults = + execState declareForeigns mempty foreignWrappers :: [(Data.Text.Text, (Sandbox, SuperNormal Symbol))] -foreignWrappers | (_, l, _) <- foreignDeclResults False = reverse l +foreignWrappers = + Map.elems foreignDeclResults + <&> \(sand, code, name) -> (name, (sand, code)) numberedTermLookup :: EnumMap Word64 (SuperNormal Symbol) numberedTermLookup = @@ -2116,16 +2099,8 @@ builtinTermBackref :: EnumMap Word64 Reference builtinTermBackref = mapFromList . zip [1 ..] . Map.keys $ builtinLookup -builtinForeigns :: EnumMap Word64 ForeignFunc -builtinForeigns | (_, _, m) <- foreignDeclResults False = snd <$> m - -sandboxedForeigns :: EnumMap Word64 ForeignFunc -sandboxedForeigns | (_, _, m) <- foreignDeclResults True = snd <$> m - builtinForeignNames :: Map ANF.ForeignFunc Data.Text.Text -builtinForeignNames - | (_, _, m) <- foreignDeclResults False = - m +builtinForeignNames = foreignDeclResults <&> \(_, _, n) -> n -- Bootstrapping for sandbox check. The eventual map will be one with -- associations `r -> s` where `s` is all the 'sensitive' base @@ -2146,6 +2121,3 @@ builtinArities = builtinInlineInfo :: Map Reference (Int, ANormal Symbol) builtinInlineInfo = ANF.buildInlineMap $ fmap (Rec [] . snd) builtinLookup - -unsafeSTMToIO :: STM.STM a -> IO a -unsafeSTMToIO (STM.STM m) = IO m diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index a9103e1ec4..bf353baf93 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -1321,7 +1321,7 @@ tabulateErrors errs = restoreCache :: StoredCache -> IO CCache restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do cc <- - CCache builtinForeigns False debugText + CCache False debugText <$> newTVarIO srcCombs <*> newTVarIO combs <*> newTVarIO (crs <> builtinTermBackref) diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 83e9d5aa7b..977107613d 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -60,7 +60,7 @@ import Data.Functor ((<&>)) import Data.Map.Strict qualified as M import Data.Primitive.PrimArray import Data.Primitive.PrimArray qualified as PA -import Data.Text as Text (unpack) +import Data.Text qualified as Text import Data.Void (Void, absurd) import Data.Word (Word16, Word64) import GHC.Stack (HasCallStack) @@ -254,6 +254,9 @@ import Unison.Var (Var) -- certain recursive, 'deep' handlers, since those can operate -- more like stateful code than control operators. +data Sandboxed = Tracked | Untracked + deriving (Show, Eq, Ord) + data Args' = Arg1 !Int | Arg2 !Int !Int @@ -787,6 +790,8 @@ data GInstr comb Seq !Args | -- Force a delayed expression, catching any runtime exceptions involved TryForce !Int + | -- Attempted to use a builtin that was not allowed in the current sandboxing context. + SandboxingFailure !Text.Text -- The name of the builtin which failed was sandboxed. deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) type Section = GSection CombIx diff --git a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs index 5d35608810..2b0fd4aa81 100644 --- a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs @@ -54,6 +54,13 @@ getComb = Lam <$> gInt <*> gInt <*> getSection CachedClosureT -> error "getComb: Unexpected serialized Cached Closure" +getMForeignFunc :: (MonadGet m) => m MForeignFunc +getMForeignFunc = do + toEnum <$> gInt + +putMForeignFunc :: (MonadPut m) => MForeignFunc -> m () +putMForeignFunc = pInt . fromEnum + data SectionT = AppT | CallT @@ -161,6 +168,7 @@ data InstrT | SeqT | TryForceT | RefCAST + | SandboxingFailureT instance Tag InstrT where tag2word UPrim1T = 0 @@ -181,6 +189,7 @@ instance Tag InstrT where tag2word SeqT = 15 tag2word TryForceT = 16 tag2word RefCAST = 17 + tag2word SandboxingFailureT = 18 word2tag 0 = pure UPrim1T word2tag 1 = pure UPrim2T @@ -200,6 +209,7 @@ instance Tag InstrT where word2tag 15 = pure SeqT word2tag 16 = pure TryForceT word2tag 17 = pure RefCAST + word2tag 18 = pure SandboxingFailureT word2tag n = unknownTag "InstrT" n putInstr :: (MonadPut m) => GInstr cix -> m () @@ -209,7 +219,7 @@ putInstr = \case (BPrim1 bp i) -> putTag BPrim1T *> putTag bp *> pInt i (BPrim2 bp i j) -> putTag BPrim2T *> putTag bp *> pInt i *> pInt j (RefCAS i j k) -> putTag RefCAST *> pInt i *> pInt j *> pInt k - (ForeignCall b w a) -> putTag ForeignCallT *> serialize b *> pWord w *> putArgs a + (ForeignCall b ff a) -> putTag ForeignCallT *> serialize b *> putMForeignFunc ff *> putArgs a (SetDyn w i) -> putTag SetDynT *> pWord w *> pInt i (Capture w) -> putTag CaptureT *> pWord w (Name r a) -> putTag NameT *> putRef r *> putArgs a @@ -222,6 +232,9 @@ putInstr = \case (Atomically i) -> putTag AtomicallyT *> pInt i (Seq a) -> putTag SeqT *> putArgs a (TryForce i) -> putTag TryForceT *> pInt i + (SandboxingFailure {}) -> + -- Sandboxing failures should only exist in code we're actively running, it shouldn't be serialized. + error "putInstr: Unexpected serialized Sandboxing Failure" getInstr :: (MonadGet m) => m Instr getInstr = @@ -231,7 +244,7 @@ getInstr = BPrim1T -> BPrim1 <$> getTag <*> gInt BPrim2T -> BPrim2 <$> getTag <*> gInt <*> gInt RefCAST -> RefCAS <$> gInt <*> gInt <*> gInt - ForeignCallT -> ForeignCall <$> deserialize <*> gWord <*> getArgs + ForeignCallT -> ForeignCall <$> deserialize <*> getMForeignFunc <*> getArgs SetDynT -> SetDyn <$> gWord <*> gInt CaptureT -> Capture <$> gWord NameT -> Name <$> getRef <*> getArgs @@ -244,6 +257,7 @@ getInstr = AtomicallyT -> Atomically <$> gInt SeqT -> Seq <$> getArgs TryForceT -> TryForce <$> gInt + SandboxingFailureT -> error "getInstr: Unexpected serialized Sandboxing Failure" data ArgsT = ZArgsT diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index f8cc373541..94a075b6b5 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -623,6 +623,8 @@ exec !env !denv !activeThreads !stk !k _ (TryForce i) ev <- Control.Exception.try $ nestEval env activeThreads (poke stk) v stk <- encodeExn stk ev pure (denv, stk, k) +exec !_ !_ !_ !_ !_ _ (SandboxingFailure t) = do + die $ "Attempted to use disallowed builtin in sandboxed environment: " <> DTx.unpack t {-# INLINE exec #-} encodeExn :: From d3c9c691a02aff94dfb7ad747c938646af04b1c9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 6 Dec 2024 16:50:48 -0800 Subject: [PATCH 09/36] Sandbox foreigns with a preprocessing step. --- unison-cli/src/Unison/Main.hs | 2 +- unison-runtime/src/Unison/Runtime/ANF.hs | 252 +------- .../src/Unison/Runtime/ANF/Serialize.hs | 1 + unison-runtime/src/Unison/Runtime/Builtin.hs | 588 +++++++++--------- .../Unison/Runtime/Foreign/Function/Type.hs | 506 +++++++++++++++ .../src/Unison/Runtime/Foreign/Impl.hs | 3 +- .../src/Unison/Runtime/Interface.hs | 15 +- unison-runtime/src/Unison/Runtime/MCode.hs | 545 ++-------------- .../src/Unison/Runtime/MCode/Serialize.hs | 5 +- unison-runtime/src/Unison/Runtime/Machine.hs | 107 ++-- unison-runtime/unison-runtime.cabal | 1 + 11 files changed, 922 insertions(+), 1103 deletions(-) create mode 100644 unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 3624a50675..59845f0608 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -238,7 +238,7 @@ main version = do Right (Right (v, rf, combIx, sto)) | not vmatch -> mismatchMsg | otherwise -> - withArgs args (RTI.runStandalone sto combIx) >>= \case + withArgs args (RTI.runStandalone False sto combIx) >>= \case Left err -> exitError err Right () -> pure () where diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs index b2350e5bf0..539b6bcd66 100644 --- a/unison-runtime/src/Unison/Runtime/ANF.hs +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -42,7 +42,6 @@ module Unison.Runtime.ANF SuperGroup (..), arities, POp (..), - ForeignFunc(..), close, saturate, float, @@ -117,6 +116,7 @@ import Unison.Prelude import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId)) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) import Unison.Runtime.TypeTags (CTag (..), PackedTag (..), RTag (..), Tag (..), maskTags, packTags, unpackTags) import Unison.Symbol (Symbol) import Unison.Term hiding (List, Ref, Text, arity, float, fresh, resolve) @@ -1436,256 +1436,6 @@ data POp | IORB -- or deriving (Show, Eq, Ord, Enum, Bounded) --- | Enum representing every foreign call. -data ForeignFunc - = IO_UDP_clientSocket_impl_v1 - | IO_UDP_UDPSocket_recv_impl_v1 - | IO_UDP_UDPSocket_send_impl_v1 - | IO_UDP_UDPSocket_close_impl_v1 - | IO_UDP_ListenSocket_close_impl_v1 - | IO_UDP_UDPSocket_toText_impl_v1 - | IO_UDP_serverSocket_impl_v1 - | IO_UDP_ListenSocket_toText_impl_v1 - | IO_UDP_ListenSocket_recvFrom_impl_v1 - | IO_UDP_ClientSockAddr_toText_v1 - | IO_UDP_ListenSocket_sendTo_impl_v1 - | IO_openFile_impl_v3 - | IO_closeFile_impl_v3 - | IO_isFileEOF_impl_v3 - | IO_isFileOpen_impl_v3 - | IO_getEcho_impl_v1 - | IO_ready_impl_v1 - | IO_getChar_impl_v1 - | IO_isSeekable_impl_v3 - | IO_seekHandle_impl_v3 - | IO_handlePosition_impl_v3 - | IO_getBuffering_impl_v3 - | IO_setBuffering_impl_v3 - | IO_setEcho_impl_v1 - | IO_getLine_impl_v1 - | IO_getBytes_impl_v3 - | IO_getSomeBytes_impl_v1 - | IO_putBytes_impl_v3 - | IO_systemTime_impl_v3 - | IO_systemTimeMicroseconds_v1 - | Clock_internals_monotonic_v1 - | Clock_internals_realtime_v1 - | Clock_internals_processCPUTime_v1 - | Clock_internals_threadCPUTime_v1 - | Clock_internals_sec_v1 - | Clock_internals_nsec_v1 - | Clock_internals_systemTimeZone_v1 - | IO_getTempDirectory_impl_v3 - | IO_createTempDirectory_impl_v3 - | IO_getCurrentDirectory_impl_v3 - | IO_setCurrentDirectory_impl_v3 - | IO_fileExists_impl_v3 - | IO_getEnv_impl_v1 - | IO_getArgs_impl_v1 - | IO_isDirectory_impl_v3 - | IO_createDirectory_impl_v3 - | IO_removeDirectory_impl_v3 - | IO_renameDirectory_impl_v3 - | IO_directoryContents_impl_v3 - | IO_removeFile_impl_v3 - | IO_renameFile_impl_v3 - | IO_getFileTimestamp_impl_v3 - | IO_getFileSize_impl_v3 - | IO_serverSocket_impl_v3 - | Socket_toText - | Handle_toText - | ThreadId_toText - | IO_socketPort_impl_v3 - | IO_listen_impl_v3 - | IO_clientSocket_impl_v3 - | IO_closeSocket_impl_v3 - | IO_socketAccept_impl_v3 - | IO_socketSend_impl_v3 - | IO_socketReceive_impl_v3 - | IO_kill_impl_v3 - | IO_delay_impl_v3 - | IO_stdHandle - | IO_process_call - | IO_process_start - | IO_process_kill - | IO_process_wait - | IO_process_exitCode - | MVar_new - | MVar_newEmpty_v2 - | MVar_take_impl_v3 - | MVar_tryTake - | MVar_put_impl_v3 - | MVar_tryPut_impl_v3 - | MVar_swap_impl_v3 - | MVar_isEmpty - | MVar_read_impl_v3 - | MVar_tryRead_impl_v3 - | Char_toText - | Text_repeat - | Text_reverse - | Text_toUppercase - | Text_toLowercase - | Text_toUtf8 - | Text_fromUtf8_impl_v3 - | Tls_ClientConfig_default - | Tls_ServerConfig_default - | Tls_ClientConfig_certificates_set - | Tls_ServerConfig_certificates_set - | TVar_new - | TVar_read - | TVar_write - | TVar_newIO - | TVar_readIO - | TVar_swap - | STM_retry - | Promise_new - | Promise_read - | Promise_tryRead - | Promise_write - | Tls_newClient_impl_v3 - | Tls_newServer_impl_v3 - | Tls_handshake_impl_v3 - | Tls_send_impl_v3 - | Tls_decodeCert_impl_v3 - | Tls_encodeCert - | Tls_decodePrivateKey - | Tls_encodePrivateKey - | Tls_receive_impl_v3 - | Tls_terminate_impl_v3 - | Code_validateLinks - | Code_dependencies - | Code_serialize - | Code_deserialize - | Code_display - | Value_dependencies - | Value_serialize - | Value_deserialize - | Crypto_HashAlgorithm_Sha3_512 - | Crypto_HashAlgorithm_Sha3_256 - | Crypto_HashAlgorithm_Sha2_512 - | Crypto_HashAlgorithm_Sha2_256 - | Crypto_HashAlgorithm_Sha1 - | Crypto_HashAlgorithm_Blake2b_512 - | Crypto_HashAlgorithm_Blake2b_256 - | Crypto_HashAlgorithm_Blake2s_256 - | Crypto_HashAlgorithm_Md5 - | Crypto_hashBytes - | Crypto_hmacBytes - | Crypto_hash - | Crypto_hmac - | Crypto_Ed25519_sign_impl - | Crypto_Ed25519_verify_impl - | Crypto_Rsa_sign_impl - | Crypto_Rsa_verify_impl - | Universal_murmurHash - | IO_randomBytes - | Bytes_zlib_compress - | Bytes_gzip_compress - | Bytes_zlib_decompress - | Bytes_gzip_decompress - | Bytes_toBase16 - | Bytes_toBase32 - | Bytes_toBase64 - | Bytes_toBase64UrlUnpadded - | Bytes_fromBase16 - | Bytes_fromBase32 - | Bytes_fromBase64 - | Bytes_fromBase64UrlUnpadded - | Bytes_decodeNat64be - | Bytes_decodeNat64le - | Bytes_decodeNat32be - | Bytes_decodeNat32le - | Bytes_decodeNat16be - | Bytes_decodeNat16le - | Bytes_encodeNat64be - | Bytes_encodeNat64le - | Bytes_encodeNat32be - | Bytes_encodeNat32le - | Bytes_encodeNat16be - | Bytes_encodeNat16le - | MutableArray_copyTo_force - | MutableByteArray_copyTo_force - | ImmutableArray_copyTo_force - | ImmutableArray_size - | MutableArray_size - | ImmutableByteArray_size - | MutableByteArray_size - | ImmutableByteArray_copyTo_force - | MutableArray_read - | MutableByteArray_read8 - | MutableByteArray_read16be - | MutableByteArray_read24be - | MutableByteArray_read32be - | MutableByteArray_read40be - | MutableByteArray_read64be - | MutableArray_write - | MutableByteArray_write8 - | MutableByteArray_write16be - | MutableByteArray_write32be - | MutableByteArray_write64be - | ImmutableArray_read - | ImmutableByteArray_read8 - | ImmutableByteArray_read16be - | ImmutableByteArray_read24be - | ImmutableByteArray_read32be - | ImmutableByteArray_read40be - | ImmutableByteArray_read64be - | MutableByteArray_freeze_force - | MutableArray_freeze_force - | MutableByteArray_freeze - | MutableArray_freeze - | MutableByteArray_length - | ImmutableByteArray_length - | IO_array - | IO_arrayOf - | IO_bytearray - | IO_bytearrayOf - | Scope_array - | Scope_arrayOf - | Scope_bytearray - | Scope_bytearrayOf - | Text_patterns_literal - | Text_patterns_digit - | Text_patterns_letter - | Text_patterns_space - | Text_patterns_punctuation - | Text_patterns_anyChar - | Text_patterns_eof - | Text_patterns_charRange - | Text_patterns_notCharRange - | Text_patterns_charIn - | Text_patterns_notCharIn - | Pattern_many - | Pattern_many_corrected - | Pattern_capture - | Pattern_captureAs - | Pattern_join - | Pattern_or - | Pattern_replicate - | Pattern_run - | Pattern_isMatch - | Char_Class_any - | Char_Class_not - | Char_Class_and - | Char_Class_or - | Char_Class_range - | Char_Class_anyOf - | Char_Class_alphanumeric - | Char_Class_upper - | Char_Class_lower - | Char_Class_whitespace - | Char_Class_control - | Char_Class_printable - | Char_Class_mark - | Char_Class_number - | Char_Class_punctuation - | Char_Class_symbol - | Char_Class_separator - | Char_Class_letter - | Char_Class_is - | Text_patterns_char - deriving (Show, Eq, Ord, Enum, Bounded) - type ANormal = ABTN.Term ANormalF type Cte v = CTE v (ANormal v) diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index 9ce7c5db50..4b0759ad0f 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -25,6 +25,7 @@ import Unison.ABT.Normalized (Term (..)) import Unison.Reference (Reference, Reference' (Builtin), pattern Derived) import Unison.Runtime.ANF as ANF hiding (Tag) import Unison.Runtime.Exception +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) import Unison.Runtime.Serialize import Unison.Util.Text qualified as Util.Text import Unison.Var (Type (ANFBlank), Var (..)) diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 261318fe54..f6e610cdf7 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -20,6 +20,7 @@ module Unison.Runtime.Builtin unitValue, natValue, builtinForeignNames, + sandboxedForeignFuncs, ) where @@ -34,6 +35,7 @@ import Unison.Prelude hiding (Text, some) import Unison.Reference import Unison.Runtime.ANF as ANF import Unison.Runtime.Builtin.Types +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName) import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), unboxedTypeTagToInt) import Unison.Runtime.Stack qualified as Closure import Unison.Symbol @@ -1688,7 +1690,7 @@ builtinLookup = ] ++ foreignWrappers -type FDecl v = State (Map ForeignFunc (Sandbox, SuperNormal v, Data.Text.Text)) +type FDecl v = State (Map ForeignFunc (Sandbox, SuperNormal v)) -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked @@ -1699,14 +1701,13 @@ data Sandbox = Tracked | Untracked declareForeign :: Sandbox -> - Data.Text.Text -> ForeignOp -> ForeignFunc -> FDecl Symbol () -declareForeign sand name op func = do +declareForeign sand op func = do modify $ \funcs -> let code = uncurry Lambda (op func) - in (Map.insert func (sand, code, name) funcs) + in (Map.insert func (sand, code) funcs) unitValue :: Val unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) @@ -1716,376 +1717,376 @@ natValue w = NatVal w declareUdpForeigns :: FDecl Symbol () declareUdpForeigns = do - declareForeign Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF IO_UDP_clientSocket_impl_v1 + declareForeign Tracked arg2ToEF IO_UDP_clientSocket_impl_v1 - declareForeign Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF IO_UDP_UDPSocket_recv_impl_v1 + declareForeign Tracked argToEF IO_UDP_UDPSocket_recv_impl_v1 - declareForeign Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 - declareForeign Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 IO_UDP_UDPSocket_close_impl_v1 + declareForeign Tracked arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 + declareForeign Tracked argToEF0 IO_UDP_UDPSocket_close_impl_v1 - declareForeign Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 IO_UDP_ListenSocket_close_impl_v1 + declareForeign Tracked argToEF0 IO_UDP_ListenSocket_close_impl_v1 - declareForeign Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 + declareForeign Tracked (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 - declareForeign Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF IO_UDP_serverSocket_impl_v1 + declareForeign Tracked arg2ToEF IO_UDP_serverSocket_impl_v1 - declareForeign Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 + declareForeign Tracked (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 - declareForeign Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 + declareForeign Tracked argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 - declareForeign Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 + declareForeign Tracked (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 - declareForeign Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 + declareForeign Tracked arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 declareForeigns :: FDecl Symbol () declareForeigns = do declareUdpForeigns - declareForeign Tracked "IO.openFile.impl.v3" argIomrToEF IO_openFile_impl_v3 + declareForeign Tracked argIomrToEF IO_openFile_impl_v3 - declareForeign Tracked "IO.closeFile.impl.v3" argToEF0 IO_closeFile_impl_v3 - declareForeign Tracked "IO.isFileEOF.impl.v3" argToEFBool IO_isFileEOF_impl_v3 - declareForeign Tracked "IO.isFileOpen.impl.v3" argToEFBool IO_isFileOpen_impl_v3 - declareForeign Tracked "IO.getEcho.impl.v1" argToEFBool IO_getEcho_impl_v1 - declareForeign Tracked "IO.ready.impl.v1" argToEFBool IO_ready_impl_v1 - declareForeign Tracked "IO.getChar.impl.v1" argToEFChar IO_getChar_impl_v1 - declareForeign Tracked "IO.isSeekable.impl.v3" argToEFBool IO_isSeekable_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 "IO.seekHandle.impl.v3" seek'handle IO_seekHandle_impl_v3 + declareForeign Tracked seek'handle IO_seekHandle_impl_v3 - declareForeign Tracked "IO.handlePosition.impl.v3" argToEFNat IO_handlePosition_impl_v3 + declareForeign Tracked argToEFNat IO_handlePosition_impl_v3 - declareForeign Tracked "IO.getBuffering.impl.v3" get'buffering IO_getBuffering_impl_v3 + declareForeign Tracked get'buffering IO_getBuffering_impl_v3 - declareForeign Tracked "IO.setBuffering.impl.v3" set'buffering IO_setBuffering_impl_v3 + declareForeign Tracked set'buffering IO_setBuffering_impl_v3 - declareForeign Tracked "IO.setEcho.impl.v1" set'echo IO_setEcho_impl_v1 + declareForeign Tracked set'echo IO_setEcho_impl_v1 - declareForeign Tracked "IO.getLine.impl.v1" argToEF IO_getLine_impl_v1 + declareForeign Tracked argToEF IO_getLine_impl_v1 - declareForeign Tracked "IO.getBytes.impl.v3" arg2ToEF IO_getBytes_impl_v3 - declareForeign Tracked "IO.getSomeBytes.impl.v1" arg2ToEF IO_getSomeBytes_impl_v1 - declareForeign Tracked "IO.putBytes.impl.v3" arg2ToEF0 IO_putBytes_impl_v3 - declareForeign Tracked "IO.systemTime.impl.v3" unitToEF IO_systemTime_impl_v3 + 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 "IO.systemTimeMicroseconds.v1" unitToR IO_systemTimeMicroseconds_v1 + declareForeign Tracked unitToR IO_systemTimeMicroseconds_v1 - declareForeign Tracked "Clock.internals.monotonic.v1" unitToEF Clock_internals_monotonic_v1 + declareForeign Tracked unitToEF Clock_internals_monotonic_v1 - declareForeign Tracked "Clock.internals.realtime.v1" unitToEF Clock_internals_realtime_v1 + declareForeign Tracked unitToEF Clock_internals_realtime_v1 - declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEF Clock_internals_processCPUTime_v1 + declareForeign Tracked unitToEF Clock_internals_processCPUTime_v1 - declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEF Clock_internals_threadCPUTime_v1 + declareForeign Tracked unitToEF Clock_internals_threadCPUTime_v1 - declareForeign Tracked "Clock.internals.sec.v1" (argNDirect 1) Clock_internals_sec_v1 + declareForeign Tracked (argNDirect 1) Clock_internals_sec_v1 -- A TimeSpec that comes from getTime never has negative nanos, -- so we can safely cast to Nat - declareForeign Tracked "Clock.internals.nsec.v1" (argNDirect 1) Clock_internals_nsec_v1 + declareForeign Tracked (argNDirect 1) Clock_internals_nsec_v1 - declareForeign Tracked "Clock.internals.systemTimeZone.v1" time'zone Clock_internals_systemTimeZone_v1 + declareForeign Tracked time'zone Clock_internals_systemTimeZone_v1 - declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEF IO_getTempDirectory_impl_v3 + declareForeign Tracked unitToEF IO_getTempDirectory_impl_v3 - declareForeign Tracked "IO.createTempDirectory.impl.v3" argToEF IO_createTempDirectory_impl_v3 + declareForeign Tracked argToEF IO_createTempDirectory_impl_v3 - declareForeign Tracked "IO.getCurrentDirectory.impl.v3" unitToEF IO_getCurrentDirectory_impl_v3 + declareForeign Tracked unitToEF IO_getCurrentDirectory_impl_v3 - declareForeign Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 IO_setCurrentDirectory_impl_v3 + declareForeign Tracked argToEF0 IO_setCurrentDirectory_impl_v3 - declareForeign Tracked "IO.fileExists.impl.v3" argToEFBool IO_fileExists_impl_v3 + declareForeign Tracked argToEFBool IO_fileExists_impl_v3 - declareForeign Tracked "IO.getEnv.impl.v1" argToEF IO_getEnv_impl_v1 + declareForeign Tracked argToEF IO_getEnv_impl_v1 - declareForeign Tracked "IO.getArgs.impl.v1" unitToEF IO_getArgs_impl_v1 + declareForeign Tracked unitToEF IO_getArgs_impl_v1 - declareForeign Tracked "IO.isDirectory.impl.v3" argToEFBool IO_isDirectory_impl_v3 + declareForeign Tracked argToEFBool IO_isDirectory_impl_v3 - declareForeign Tracked "IO.createDirectory.impl.v3" argToEF0 IO_createDirectory_impl_v3 + declareForeign Tracked argToEF0 IO_createDirectory_impl_v3 - declareForeign Tracked "IO.removeDirectory.impl.v3" argToEF0 IO_removeDirectory_impl_v3 + declareForeign Tracked argToEF0 IO_removeDirectory_impl_v3 - declareForeign Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 IO_renameDirectory_impl_v3 + declareForeign Tracked arg2ToEF0 IO_renameDirectory_impl_v3 - declareForeign Tracked "IO.directoryContents.impl.v3" argToEF IO_directoryContents_impl_v3 + declareForeign Tracked argToEF IO_directoryContents_impl_v3 - declareForeign Tracked "IO.removeFile.impl.v3" argToEF0 IO_removeFile_impl_v3 + declareForeign Tracked argToEF0 IO_removeFile_impl_v3 - declareForeign Tracked "IO.renameFile.impl.v3" arg2ToEF0 IO_renameFile_impl_v3 + declareForeign Tracked arg2ToEF0 IO_renameFile_impl_v3 - declareForeign Tracked "IO.getFileTimestamp.impl.v3" argToEFNat IO_getFileTimestamp_impl_v3 + declareForeign Tracked argToEFNat IO_getFileTimestamp_impl_v3 - declareForeign Tracked "IO.getFileSize.impl.v3" argToEFNat IO_getFileSize_impl_v3 + declareForeign Tracked argToEFNat IO_getFileSize_impl_v3 - declareForeign Tracked "IO.serverSocket.impl.v3" maybeToEF IO_serverSocket_impl_v3 + declareForeign Tracked maybeToEF IO_serverSocket_impl_v3 - declareForeign Tracked "Socket.toText" (argNDirect 1) Socket_toText + declareForeign Tracked (argNDirect 1) Socket_toText - declareForeign Tracked "Handle.toText" (argNDirect 1) Handle_toText + declareForeign Tracked (argNDirect 1) Handle_toText - declareForeign Tracked "ThreadId.toText" (argNDirect 1) ThreadId_toText + declareForeign Tracked (argNDirect 1) ThreadId_toText - declareForeign Tracked "IO.socketPort.impl.v3" argToEFNat IO_socketPort_impl_v3 + declareForeign Tracked argToEFNat IO_socketPort_impl_v3 - declareForeign Tracked "IO.listen.impl.v3" argToEF0 IO_listen_impl_v3 + declareForeign Tracked argToEF0 IO_listen_impl_v3 - declareForeign Tracked "IO.clientSocket.impl.v3" arg2ToEF IO_clientSocket_impl_v3 + declareForeign Tracked arg2ToEF IO_clientSocket_impl_v3 - declareForeign Tracked "IO.closeSocket.impl.v3" argToEF0 IO_closeSocket_impl_v3 + declareForeign Tracked argToEF0 IO_closeSocket_impl_v3 - declareForeign Tracked "IO.socketAccept.impl.v3" argToEF IO_socketAccept_impl_v3 + declareForeign Tracked argToEF IO_socketAccept_impl_v3 - declareForeign Tracked "IO.socketSend.impl.v3" arg2ToEF0 IO_socketSend_impl_v3 + declareForeign Tracked arg2ToEF0 IO_socketSend_impl_v3 - declareForeign Tracked "IO.socketReceive.impl.v3" arg2ToEF IO_socketReceive_impl_v3 + declareForeign Tracked arg2ToEF IO_socketReceive_impl_v3 - declareForeign Tracked "IO.kill.impl.v3" argToEF0 IO_kill_impl_v3 + declareForeign Tracked argToEF0 IO_kill_impl_v3 - declareForeign Tracked "IO.delay.impl.v3" argToEFUnit IO_delay_impl_v3 + declareForeign Tracked argToEFUnit IO_delay_impl_v3 - declareForeign Tracked "IO.stdHandle" standard'handle IO_stdHandle + declareForeign Tracked standard'handle IO_stdHandle - declareForeign Tracked "IO.process.call" (argNDirect 2) IO_process_call + declareForeign Tracked (argNDirect 2) IO_process_call - declareForeign Tracked "IO.process.start" start'process IO_process_start + declareForeign Tracked start'process IO_process_start - declareForeign Tracked "IO.process.kill" argToUnit IO_process_kill + declareForeign Tracked argToUnit IO_process_kill - declareForeign Tracked "IO.process.wait" (argNDirect 1) IO_process_wait + declareForeign Tracked (argNDirect 1) IO_process_wait - declareForeign Tracked "IO.process.exitCode" argToMaybe IO_process_exitCode - declareForeign Tracked "MVar.new" (argNDirect 1) MVar_new + declareForeign Tracked argToMaybe IO_process_exitCode + declareForeign Tracked (argNDirect 1) MVar_new - declareForeign Tracked "MVar.newEmpty.v2" unitDirect MVar_newEmpty_v2 + declareForeign Tracked unitDirect MVar_newEmpty_v2 - declareForeign Tracked "MVar.take.impl.v3" argToEF MVar_take_impl_v3 + declareForeign Tracked argToEF MVar_take_impl_v3 - declareForeign Tracked "MVar.tryTake" argToMaybe MVar_tryTake + declareForeign Tracked argToMaybe MVar_tryTake - declareForeign Tracked "MVar.put.impl.v3" arg2ToEF0 MVar_put_impl_v3 + declareForeign Tracked arg2ToEF0 MVar_put_impl_v3 - declareForeign Tracked "MVar.tryPut.impl.v3" arg2ToEFBool MVar_tryPut_impl_v3 + declareForeign Tracked arg2ToEFBool MVar_tryPut_impl_v3 - declareForeign Tracked "MVar.swap.impl.v3" arg2ToEF MVar_swap_impl_v3 + declareForeign Tracked arg2ToEF MVar_swap_impl_v3 - declareForeign Tracked "MVar.isEmpty" (argNDirect 1) MVar_isEmpty + declareForeign Tracked (argNDirect 1) MVar_isEmpty - declareForeign Tracked "MVar.read.impl.v3" argToEF MVar_read_impl_v3 + declareForeign Tracked argToEF MVar_read_impl_v3 - declareForeign Tracked "MVar.tryRead.impl.v3" argToEFM MVar_tryRead_impl_v3 + declareForeign Tracked argToEFM MVar_tryRead_impl_v3 - declareForeign Untracked "Char.toText" (argNDirect 1) Char_toText - declareForeign Untracked "Text.repeat" (argNDirect 2) Text_repeat - declareForeign Untracked "Text.reverse" (argNDirect 1) Text_reverse - declareForeign Untracked "Text.toUppercase" (argNDirect 1) Text_toUppercase - declareForeign Untracked "Text.toLowercase" (argNDirect 1) Text_toLowercase - declareForeign Untracked "Text.toUtf8" (argNDirect 1) Text_toUtf8 - declareForeign Untracked "Text.fromUtf8.impl.v3" argToEF Text_fromUtf8_impl_v3 - declareForeign Tracked "Tls.ClientConfig.default" (argNDirect 2) Tls_ClientConfig_default - declareForeign Tracked "Tls.ServerConfig.default" (argNDirect 2) Tls_ServerConfig_default - declareForeign Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) Tls_ClientConfig_certificates_set + 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 Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) Tls_ServerConfig_certificates_set + declareForeign Tracked (argNDirect 2) Tls_ServerConfig_certificates_set - declareForeign Tracked "TVar.new" (argNDirect 1) TVar_new + declareForeign Tracked (argNDirect 1) TVar_new - declareForeign Tracked "TVar.read" (argNDirect 1) TVar_read - declareForeign Tracked "TVar.write" arg2To0 TVar_write - declareForeign Tracked "TVar.newIO" (argNDirect 1) TVar_newIO + declareForeign Tracked (argNDirect 1) TVar_read + declareForeign Tracked arg2To0 TVar_write + declareForeign Tracked (argNDirect 1) TVar_newIO - declareForeign Tracked "TVar.readIO" (argNDirect 1) TVar_readIO - declareForeign Tracked "TVar.swap" (argNDirect 2) TVar_swap - declareForeign Tracked "STM.retry" unitDirect STM_retry - declareForeign Tracked "Promise.new" unitDirect Promise_new + declareForeign Tracked (argNDirect 1) TVar_readIO + declareForeign Tracked (argNDirect 2) TVar_swap + declareForeign Tracked unitDirect STM_retry + declareForeign Tracked unitDirect Promise_new -- the only exceptions from Promise.read are async and shouldn't be caught - declareForeign Tracked "Promise.read" (argNDirect 1) Promise_read - declareForeign Tracked "Promise.tryRead" argToMaybe Promise_tryRead - - declareForeign Tracked "Promise.write" (argNDirect 2) Promise_write - declareForeign Tracked "Tls.newClient.impl.v3" arg2ToEF Tls_newClient_impl_v3 - declareForeign Tracked "Tls.newServer.impl.v3" arg2ToEF Tls_newServer_impl_v3 - declareForeign Tracked "Tls.handshake.impl.v3" argToEF0 Tls_handshake_impl_v3 - declareForeign Tracked "Tls.send.impl.v3" arg2ToEF0 Tls_send_impl_v3 - declareForeign Tracked "Tls.decodeCert.impl.v3" argToEF Tls_decodeCert_impl_v3 - - declareForeign Tracked "Tls.encodeCert" (argNDirect 1) Tls_encodeCert - - declareForeign Tracked "Tls.decodePrivateKey" (argNDirect 1) Tls_decodePrivateKey - declareForeign Tracked "Tls.encodePrivateKey" (argNDirect 1) Tls_encodePrivateKey - - declareForeign Tracked "Tls.receive.impl.v3" argToEF Tls_receive_impl_v3 - - declareForeign Tracked "Tls.terminate.impl.v3" argToEF0 Tls_terminate_impl_v3 - declareForeign Untracked "Code.validateLinks" argToExnE Code_validateLinks - declareForeign Untracked "Code.dependencies" (argNDirect 1) Code_dependencies - declareForeign Untracked "Code.serialize" (argNDirect 1) Code_serialize - declareForeign Untracked "Code.deserialize" argToEither Code_deserialize - declareForeign Untracked "Code.display" (argNDirect 2) Code_display - declareForeign Untracked "Value.dependencies" (argNDirect 1) Value_dependencies - declareForeign Untracked "Value.serialize" (argNDirect 1) Value_serialize - declareForeign Untracked "Value.deserialize" argToEither Value_deserialize + 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 -- Hashing functions - declareForeign Untracked "crypto.HashAlgorithm.Sha3_512" direct Crypto_HashAlgorithm_Sha3_512 - declareForeign Untracked "crypto.HashAlgorithm.Sha3_256" direct Crypto_HashAlgorithm_Sha3_256 - declareForeign Untracked "crypto.HashAlgorithm.Sha2_512" direct Crypto_HashAlgorithm_Sha2_512 - declareForeign Untracked "crypto.HashAlgorithm.Sha2_256" direct Crypto_HashAlgorithm_Sha2_256 - declareForeign Untracked "crypto.HashAlgorithm.Sha1" direct Crypto_HashAlgorithm_Sha1 - declareForeign Untracked "crypto.HashAlgorithm.Blake2b_512" direct Crypto_HashAlgorithm_Blake2b_512 - declareForeign Untracked "crypto.HashAlgorithm.Blake2b_256" direct Crypto_HashAlgorithm_Blake2b_256 - declareForeign Untracked "crypto.HashAlgorithm.Blake2s_256" direct Crypto_HashAlgorithm_Blake2s_256 - declareForeign Untracked "crypto.HashAlgorithm.Md5" direct Crypto_HashAlgorithm_Md5 - - declareForeign Untracked "crypto.hashBytes" (argNDirect 2) Crypto_hashBytes - declareForeign Untracked "crypto.hmacBytes" (argNDirect 3) Crypto_hmacBytes - - declareForeign Untracked "crypto.hash" crypto'hash Crypto_hash - declareForeign Untracked "crypto.hmac" crypto'hmac Crypto_hmac - declareForeign Untracked "crypto.Ed25519.sign.impl" arg3ToEF Crypto_Ed25519_sign_impl - - declareForeign Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool Crypto_Ed25519_verify_impl - - declareForeign Untracked "crypto.Rsa.sign.impl" arg2ToEF Crypto_Rsa_sign_impl - - declareForeign Untracked "crypto.Rsa.verify.impl" arg3ToEFBool Crypto_Rsa_verify_impl - - declareForeign Untracked "Universal.murmurHash" murmur'hash Universal_murmurHash - declareForeign Tracked "IO.randomBytes" (argNDirect 1) IO_randomBytes - declareForeign Untracked "Bytes.zlib.compress" (argNDirect 1) Bytes_zlib_compress - declareForeign Untracked "Bytes.gzip.compress" (argNDirect 1) Bytes_gzip_compress - declareForeign Untracked "Bytes.zlib.decompress" argToEither Bytes_zlib_decompress - declareForeign Untracked "Bytes.gzip.decompress" argToEither Bytes_gzip_decompress - - declareForeign Untracked "Bytes.toBase16" (argNDirect 1) Bytes_toBase16 - declareForeign Untracked "Bytes.toBase32" (argNDirect 1) Bytes_toBase32 - declareForeign Untracked "Bytes.toBase64" (argNDirect 1) Bytes_toBase64 - declareForeign Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) Bytes_toBase64UrlUnpadded - - declareForeign Untracked "Bytes.fromBase16" argToEither Bytes_fromBase16 - declareForeign Untracked "Bytes.fromBase32" argToEither Bytes_fromBase32 - declareForeign Untracked "Bytes.fromBase64" argToEither Bytes_fromBase64 - declareForeign Untracked "Bytes.fromBase64UrlUnpadded" argToEither Bytes_fromBase64UrlUnpadded - - declareForeign Untracked "Bytes.decodeNat64be" argToMaybeNTup Bytes_decodeNat64be - declareForeign Untracked "Bytes.decodeNat64le" argToMaybeNTup Bytes_decodeNat64le - declareForeign Untracked "Bytes.decodeNat32be" argToMaybeNTup Bytes_decodeNat32be - declareForeign Untracked "Bytes.decodeNat32le" argToMaybeNTup Bytes_decodeNat32le - declareForeign Untracked "Bytes.decodeNat16be" argToMaybeNTup Bytes_decodeNat16be - declareForeign Untracked "Bytes.decodeNat16le" argToMaybeNTup Bytes_decodeNat16le - - declareForeign Untracked "Bytes.encodeNat64be" (argNDirect 1) Bytes_encodeNat64be - declareForeign Untracked "Bytes.encodeNat64le" (argNDirect 1) Bytes_encodeNat64le - declareForeign Untracked "Bytes.encodeNat32be" (argNDirect 1) Bytes_encodeNat32be - declareForeign Untracked "Bytes.encodeNat32le" (argNDirect 1) Bytes_encodeNat32le - declareForeign Untracked "Bytes.encodeNat16be" (argNDirect 1) Bytes_encodeNat16be - declareForeign Untracked "Bytes.encodeNat16le" (argNDirect 1) Bytes_encodeNat16le - - declareForeign Untracked "MutableArray.copyTo!" arg5ToExnUnit MutableArray_copyTo_force - - declareForeign Untracked "MutableByteArray.copyTo!" arg5ToExnUnit MutableByteArray_copyTo_force - - declareForeign Untracked "ImmutableArray.copyTo!" arg5ToExnUnit ImmutableArray_copyTo_force - - declareForeign Untracked "ImmutableArray.size" (argNDirect 1) ImmutableArray_size - declareForeign Untracked "MutableArray.size" (argNDirect 1) MutableArray_size - declareForeign Untracked "ImmutableByteArray.size" (argNDirect 1) ImmutableByteArray_size - declareForeign Untracked "MutableByteArray.size" (argNDirect 1) MutableByteArray_size - - declareForeign Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit ImmutableByteArray_copyTo_force - - declareForeign Untracked "MutableArray.read" arg2ToExn MutableArray_read - declareForeign Untracked "MutableByteArray.read8" arg2ToExn MutableByteArray_read8 - declareForeign Untracked "MutableByteArray.read16be" arg2ToExn MutableByteArray_read16be - declareForeign Untracked "MutableByteArray.read24be" arg2ToExn MutableByteArray_read24be - declareForeign Untracked "MutableByteArray.read32be" arg2ToExn MutableByteArray_read32be - declareForeign Untracked "MutableByteArray.read40be" arg2ToExn MutableByteArray_read40be - declareForeign Untracked "MutableByteArray.read64be" arg2ToExn MutableByteArray_read64be - - declareForeign Untracked "MutableArray.write" arg3ToExnUnit MutableArray_write - declareForeign Untracked "MutableByteArray.write8" arg3ToExnUnit MutableByteArray_write8 - declareForeign Untracked "MutableByteArray.write16be" arg3ToExnUnit MutableByteArray_write16be - declareForeign Untracked "MutableByteArray.write32be" arg3ToExnUnit MutableByteArray_write32be - declareForeign Untracked "MutableByteArray.write64be" arg3ToExnUnit MutableByteArray_write64be - - declareForeign Untracked "ImmutableArray.read" arg2ToExn ImmutableArray_read - declareForeign Untracked "ImmutableByteArray.read8" arg2ToExn ImmutableByteArray_read8 - declareForeign Untracked "ImmutableByteArray.read16be" arg2ToExn ImmutableByteArray_read16be - declareForeign Untracked "ImmutableByteArray.read24be" arg2ToExn ImmutableByteArray_read24be - declareForeign Untracked "ImmutableByteArray.read32be" arg2ToExn ImmutableByteArray_read32be - declareForeign Untracked "ImmutableByteArray.read40be" arg2ToExn ImmutableByteArray_read40be - declareForeign Untracked "ImmutableByteArray.read64be" arg2ToExn ImmutableByteArray_read64be - - declareForeign Untracked "MutableByteArray.freeze!" (argNDirect 1) MutableByteArray_freeze_force - declareForeign Untracked "MutableArray.freeze!" (argNDirect 1) MutableArray_freeze_force - - declareForeign Untracked "MutableByteArray.freeze" arg3ToExn MutableByteArray_freeze - declareForeign Untracked "MutableArray.freeze" arg3ToExn MutableArray_freeze - - declareForeign Untracked "MutableByteArray.length" (argNDirect 1) MutableByteArray_length - - declareForeign Untracked "ImmutableByteArray.length" (argNDirect 1) ImmutableByteArray_length - - declareForeign Tracked "IO.array" (argNDirect 1) IO_array - declareForeign Tracked "IO.arrayOf" (argNDirect 2) IO_arrayOf - declareForeign Tracked "IO.bytearray" (argNDirect 1) IO_bytearray - declareForeign Tracked "IO.bytearrayOf" (argNDirect 2) IO_bytearrayOf - - declareForeign Untracked "Scope.array" (argNDirect 1) Scope_array - declareForeign Untracked "Scope.arrayOf" (argNDirect 2) Scope_arrayOf - declareForeign Untracked "Scope.bytearray" (argNDirect 1) Scope_bytearray - declareForeign Untracked "Scope.bytearrayOf" (argNDirect 2) Scope_bytearrayOf - - declareForeign Untracked "Text.patterns.literal" (argNDirect 1) Text_patterns_literal - declareForeign Untracked "Text.patterns.digit" direct Text_patterns_digit - declareForeign Untracked "Text.patterns.letter" direct Text_patterns_letter - declareForeign Untracked "Text.patterns.space" direct Text_patterns_space - declareForeign Untracked "Text.patterns.punctuation" direct Text_patterns_punctuation - declareForeign Untracked "Text.patterns.anyChar" direct Text_patterns_anyChar - declareForeign Untracked "Text.patterns.eof" direct Text_patterns_eof - declareForeign Untracked "Text.patterns.charRange" (argNDirect 2) Text_patterns_charRange - declareForeign Untracked "Text.patterns.notCharRange" (argNDirect 2) Text_patterns_notCharRange - declareForeign Untracked "Text.patterns.charIn" (argNDirect 1) Text_patterns_charIn - declareForeign Untracked "Text.patterns.notCharIn" (argNDirect 1) Text_patterns_notCharIn - declareForeign Untracked "Pattern.many" (argNDirect 1) Pattern_many - declareForeign Untracked "Pattern.many.corrected" (argNDirect 1) Pattern_many_corrected - declareForeign Untracked "Pattern.capture" (argNDirect 1) Pattern_capture - declareForeign Untracked "Pattern.captureAs" (argNDirect 2) Pattern_captureAs - declareForeign Untracked "Pattern.join" (argNDirect 1) Pattern_join - declareForeign Untracked "Pattern.or" (argNDirect 2) Pattern_or - declareForeign Untracked "Pattern.replicate" (argNDirect 3) Pattern_replicate - - declareForeign Untracked "Pattern.run" arg2ToMaybeTup Pattern_run - - declareForeign Untracked "Pattern.isMatch" (argNDirect 2) Pattern_isMatch - - declareForeign Untracked "Char.Class.any" direct Char_Class_any - declareForeign Untracked "Char.Class.not" (argNDirect 1) Char_Class_not - declareForeign Untracked "Char.Class.and" (argNDirect 2) Char_Class_and - declareForeign Untracked "Char.Class.or" (argNDirect 2) Char_Class_or - declareForeign Untracked "Char.Class.range" (argNDirect 2) Char_Class_range - declareForeign Untracked "Char.Class.anyOf" (argNDirect 1) Char_Class_anyOf - declareForeign Untracked "Char.Class.alphanumeric" direct Char_Class_alphanumeric - declareForeign Untracked "Char.Class.upper" direct Char_Class_upper - declareForeign Untracked "Char.Class.lower" direct Char_Class_lower - declareForeign Untracked "Char.Class.whitespace" direct Char_Class_whitespace - declareForeign Untracked "Char.Class.control" direct Char_Class_control - declareForeign Untracked "Char.Class.printable" direct Char_Class_printable - declareForeign Untracked "Char.Class.mark" direct Char_Class_mark - declareForeign Untracked "Char.Class.number" direct Char_Class_number - declareForeign Untracked "Char.Class.punctuation" direct Char_Class_punctuation - declareForeign Untracked "Char.Class.symbol" direct Char_Class_symbol - declareForeign Untracked "Char.Class.separator" direct Char_Class_separator - declareForeign Untracked "Char.Class.letter" direct Char_Class_letter - declareForeign Untracked "Char.Class.is" (argNDirect 2) Char_Class_is - declareForeign Untracked "Text.patterns.char" (argNDirect 1) Text_patterns_char - -foreignDeclResults :: (Map ForeignFunc (Sandbox, SuperNormal Symbol, Data.Text.Text)) + 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 + +foreignDeclResults :: (Map ForeignFunc (Sandbox, SuperNormal Symbol)) foreignDeclResults = execState declareForeigns mempty foreignWrappers :: [(Data.Text.Text, (Sandbox, SuperNormal Symbol))] foreignWrappers = - Map.elems foreignDeclResults - <&> \(sand, code, name) -> (name, (sand, code)) + Map.toList foreignDeclResults + <&> \(ff, (sand, code)) -> (foreignFuncBuiltinName ff, (sand, code)) numberedTermLookup :: EnumMap Word64 (SuperNormal Symbol) numberedTermLookup = @@ -2099,8 +2100,12 @@ builtinTermBackref :: EnumMap Word64 Reference builtinTermBackref = mapFromList . zip [1 ..] . Map.keys $ builtinLookup -builtinForeignNames :: Map ANF.ForeignFunc Data.Text.Text -builtinForeignNames = foreignDeclResults <&> \(_, _, n) -> n +builtinForeignNames :: Map ForeignFunc Data.Text.Text +builtinForeignNames = + foreignDeclResults + & Map.keys + & map (\f -> (f, foreignFuncBuiltinName f)) + & Map.fromList -- Bootstrapping for sandbox check. The eventual map will be one with -- associations `r -> s` where `s` is all the 'sensitive' base @@ -2121,3 +2126,8 @@ builtinArities = builtinInlineInfo :: Map Reference (Int, ANormal Symbol) builtinInlineInfo = ANF.buildInlineMap $ fmap (Rec [] . snd) builtinLookup + +sandboxedForeignFuncs :: Set ForeignFunc +sandboxedForeignFuncs = + Map.keysSet $ + Map.filter (\(sb, _) -> sb == Tracked) foreignDeclResults diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs new file mode 100644 index 0000000000..97796223e9 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs @@ -0,0 +1,506 @@ +module Unison.Runtime.Foreign.Function.Type + ( ForeignFunc (..), + foreignFuncBuiltinName, + ) +where + +import Data.Text (Text) + +-- | Enum representing every foreign call. +data ForeignFunc + = IO_UDP_clientSocket_impl_v1 + | IO_UDP_UDPSocket_recv_impl_v1 + | IO_UDP_UDPSocket_send_impl_v1 + | IO_UDP_UDPSocket_close_impl_v1 + | IO_UDP_ListenSocket_close_impl_v1 + | IO_UDP_UDPSocket_toText_impl_v1 + | IO_UDP_serverSocket_impl_v1 + | IO_UDP_ListenSocket_toText_impl_v1 + | IO_UDP_ListenSocket_recvFrom_impl_v1 + | IO_UDP_ClientSockAddr_toText_v1 + | IO_UDP_ListenSocket_sendTo_impl_v1 + | IO_openFile_impl_v3 + | IO_closeFile_impl_v3 + | IO_isFileEOF_impl_v3 + | IO_isFileOpen_impl_v3 + | IO_getEcho_impl_v1 + | IO_ready_impl_v1 + | IO_getChar_impl_v1 + | IO_isSeekable_impl_v3 + | IO_seekHandle_impl_v3 + | IO_handlePosition_impl_v3 + | IO_getBuffering_impl_v3 + | IO_setBuffering_impl_v3 + | IO_setEcho_impl_v1 + | IO_getLine_impl_v1 + | IO_getBytes_impl_v3 + | IO_getSomeBytes_impl_v1 + | IO_putBytes_impl_v3 + | IO_systemTime_impl_v3 + | IO_systemTimeMicroseconds_v1 + | Clock_internals_monotonic_v1 + | Clock_internals_realtime_v1 + | Clock_internals_processCPUTime_v1 + | Clock_internals_threadCPUTime_v1 + | Clock_internals_sec_v1 + | Clock_internals_nsec_v1 + | Clock_internals_systemTimeZone_v1 + | IO_getTempDirectory_impl_v3 + | IO_createTempDirectory_impl_v3 + | IO_getCurrentDirectory_impl_v3 + | IO_setCurrentDirectory_impl_v3 + | IO_fileExists_impl_v3 + | IO_getEnv_impl_v1 + | IO_getArgs_impl_v1 + | IO_isDirectory_impl_v3 + | IO_createDirectory_impl_v3 + | IO_removeDirectory_impl_v3 + | IO_renameDirectory_impl_v3 + | IO_directoryContents_impl_v3 + | IO_removeFile_impl_v3 + | IO_renameFile_impl_v3 + | IO_getFileTimestamp_impl_v3 + | IO_getFileSize_impl_v3 + | IO_serverSocket_impl_v3 + | Socket_toText + | Handle_toText + | ThreadId_toText + | IO_socketPort_impl_v3 + | IO_listen_impl_v3 + | IO_clientSocket_impl_v3 + | IO_closeSocket_impl_v3 + | IO_socketAccept_impl_v3 + | IO_socketSend_impl_v3 + | IO_socketReceive_impl_v3 + | IO_kill_impl_v3 + | IO_delay_impl_v3 + | IO_stdHandle + | IO_process_call + | IO_process_start + | IO_process_kill + | IO_process_wait + | IO_process_exitCode + | MVar_new + | MVar_newEmpty_v2 + | MVar_take_impl_v3 + | MVar_tryTake + | MVar_put_impl_v3 + | MVar_tryPut_impl_v3 + | MVar_swap_impl_v3 + | MVar_isEmpty + | MVar_read_impl_v3 + | MVar_tryRead_impl_v3 + | Char_toText + | Text_repeat + | Text_reverse + | Text_toUppercase + | Text_toLowercase + | Text_toUtf8 + | Text_fromUtf8_impl_v3 + | Tls_ClientConfig_default + | Tls_ServerConfig_default + | Tls_ClientConfig_certificates_set + | Tls_ServerConfig_certificates_set + | TVar_new + | TVar_read + | TVar_write + | TVar_newIO + | TVar_readIO + | TVar_swap + | STM_retry + | Promise_new + | Promise_read + | Promise_tryRead + | Promise_write + | Tls_newClient_impl_v3 + | Tls_newServer_impl_v3 + | Tls_handshake_impl_v3 + | Tls_send_impl_v3 + | Tls_decodeCert_impl_v3 + | Tls_encodeCert + | Tls_decodePrivateKey + | Tls_encodePrivateKey + | Tls_receive_impl_v3 + | Tls_terminate_impl_v3 + | Code_validateLinks + | Code_dependencies + | Code_serialize + | Code_deserialize + | Code_display + | Value_dependencies + | Value_serialize + | Value_deserialize + | Crypto_HashAlgorithm_Sha3_512 + | Crypto_HashAlgorithm_Sha3_256 + | Crypto_HashAlgorithm_Sha2_512 + | Crypto_HashAlgorithm_Sha2_256 + | Crypto_HashAlgorithm_Sha1 + | Crypto_HashAlgorithm_Blake2b_512 + | Crypto_HashAlgorithm_Blake2b_256 + | Crypto_HashAlgorithm_Blake2s_256 + | Crypto_HashAlgorithm_Md5 + | Crypto_hashBytes + | Crypto_hmacBytes + | Crypto_hash + | Crypto_hmac + | Crypto_Ed25519_sign_impl + | Crypto_Ed25519_verify_impl + | Crypto_Rsa_sign_impl + | Crypto_Rsa_verify_impl + | Universal_murmurHash + | IO_randomBytes + | Bytes_zlib_compress + | Bytes_gzip_compress + | Bytes_zlib_decompress + | Bytes_gzip_decompress + | Bytes_toBase16 + | Bytes_toBase32 + | Bytes_toBase64 + | Bytes_toBase64UrlUnpadded + | Bytes_fromBase16 + | Bytes_fromBase32 + | Bytes_fromBase64 + | Bytes_fromBase64UrlUnpadded + | Bytes_decodeNat64be + | Bytes_decodeNat64le + | Bytes_decodeNat32be + | Bytes_decodeNat32le + | Bytes_decodeNat16be + | Bytes_decodeNat16le + | Bytes_encodeNat64be + | Bytes_encodeNat64le + | Bytes_encodeNat32be + | Bytes_encodeNat32le + | Bytes_encodeNat16be + | Bytes_encodeNat16le + | MutableArray_copyTo_force + | MutableByteArray_copyTo_force + | ImmutableArray_copyTo_force + | ImmutableArray_size + | MutableArray_size + | ImmutableByteArray_size + | MutableByteArray_size + | ImmutableByteArray_copyTo_force + | MutableArray_read + | MutableByteArray_read8 + | MutableByteArray_read16be + | MutableByteArray_read24be + | MutableByteArray_read32be + | MutableByteArray_read40be + | MutableByteArray_read64be + | MutableArray_write + | MutableByteArray_write8 + | MutableByteArray_write16be + | MutableByteArray_write32be + | MutableByteArray_write64be + | ImmutableArray_read + | ImmutableByteArray_read8 + | ImmutableByteArray_read16be + | ImmutableByteArray_read24be + | ImmutableByteArray_read32be + | ImmutableByteArray_read40be + | ImmutableByteArray_read64be + | MutableByteArray_freeze_force + | MutableArray_freeze_force + | MutableByteArray_freeze + | MutableArray_freeze + | MutableByteArray_length + | ImmutableByteArray_length + | IO_array + | IO_arrayOf + | IO_bytearray + | IO_bytearrayOf + | Scope_array + | Scope_arrayOf + | Scope_bytearray + | Scope_bytearrayOf + | Text_patterns_literal + | Text_patterns_digit + | Text_patterns_letter + | Text_patterns_space + | Text_patterns_punctuation + | Text_patterns_anyChar + | Text_patterns_eof + | Text_patterns_charRange + | Text_patterns_notCharRange + | Text_patterns_charIn + | Text_patterns_notCharIn + | Pattern_many + | Pattern_many_corrected + | Pattern_capture + | Pattern_captureAs + | Pattern_join + | Pattern_or + | Pattern_replicate + | Pattern_run + | Pattern_isMatch + | Char_Class_any + | Char_Class_not + | Char_Class_and + | Char_Class_or + | Char_Class_range + | Char_Class_anyOf + | Char_Class_alphanumeric + | Char_Class_upper + | Char_Class_lower + | Char_Class_whitespace + | Char_Class_control + | Char_Class_printable + | Char_Class_mark + | Char_Class_number + | Char_Class_punctuation + | Char_Class_symbol + | Char_Class_separator + | Char_Class_letter + | Char_Class_is + | Text_patterns_char + deriving (Show, Eq, Ord, Enum, Bounded) + +foreignFuncBuiltinName :: ForeignFunc -> Text +foreignFuncBuiltinName = \case + IO_UDP_clientSocket_impl_v1 -> "IO.UDP.clientSocket.impl.v1" + IO_UDP_UDPSocket_recv_impl_v1 -> "IO.UDP.UDPSocket.recv.impl.v1" + IO_UDP_UDPSocket_send_impl_v1 -> "IO.UDP.UDPSocket.send.impl.v1" + IO_UDP_UDPSocket_close_impl_v1 -> "IO.UDP.UDPSocket.close.impl.v1" + IO_UDP_ListenSocket_close_impl_v1 -> "IO.UDP.ListenSocket.close.impl.v1" + IO_UDP_UDPSocket_toText_impl_v1 -> "IO.UDP.UDPSocket.toText.impl.v1" + IO_UDP_serverSocket_impl_v1 -> "IO.UDP.serverSocket.impl.v1" + IO_UDP_ListenSocket_toText_impl_v1 -> "IO.UDP.ListenSocket.toText.impl.v1" + IO_UDP_ListenSocket_recvFrom_impl_v1 -> "IO.UDP.ListenSocket.recvFrom.impl.v1" + IO_UDP_ClientSockAddr_toText_v1 -> "IO.UDP.ClientSockAddr.toText.v1" + IO_UDP_ListenSocket_sendTo_impl_v1 -> "IO.UDP.ListenSocket.sendTo.impl.v1" + IO_openFile_impl_v3 -> "IO.openFile.impl.v3" + IO_closeFile_impl_v3 -> "IO.closeFile.impl.v3" + IO_isFileEOF_impl_v3 -> "IO.isFileEOF.impl.v3" + IO_isFileOpen_impl_v3 -> "IO.isFileOpen.impl.v3" + IO_getEcho_impl_v1 -> "IO.getEcho.impl.v1" + IO_ready_impl_v1 -> "IO.ready.impl.v1" + IO_getChar_impl_v1 -> "IO.getChar.impl.v1" + IO_isSeekable_impl_v3 -> "IO.isSeekable.impl.v3" + IO_seekHandle_impl_v3 -> "IO.seekHandle.impl.v3" + IO_handlePosition_impl_v3 -> "IO.handlePosition.impl.v3" + IO_getBuffering_impl_v3 -> "IO.getBuffering.impl.v3" + IO_setBuffering_impl_v3 -> "IO.setBuffering.impl.v3" + IO_setEcho_impl_v1 -> "IO.setEcho.impl.v1" + IO_getLine_impl_v1 -> "IO.getLine.impl.v1" + IO_getBytes_impl_v3 -> "IO.getBytes.impl.v3" + IO_getSomeBytes_impl_v1 -> "IO.getSomeBytes.impl.v1" + IO_putBytes_impl_v3 -> "IO.putBytes.impl.v3" + IO_systemTime_impl_v3 -> "IO.systemTime.impl.v3" + IO_systemTimeMicroseconds_v1 -> "IO.systemTimeMicroseconds.v1" + Clock_internals_monotonic_v1 -> "Clock.internals.monotonic.v1" + Clock_internals_realtime_v1 -> "Clock.internals.realtime.v1" + Clock_internals_processCPUTime_v1 -> "Clock.internals.processCPUTime.v1" + Clock_internals_threadCPUTime_v1 -> "Clock.internals.threadCPUTime.v1" + Clock_internals_sec_v1 -> "Clock.internals.sec.v1" + Clock_internals_nsec_v1 -> "Clock.internals.nsec.v1" + Clock_internals_systemTimeZone_v1 -> "Clock.internals.systemTimeZone.v1" + IO_getTempDirectory_impl_v3 -> "IO.getTempDirectory.impl.v3" + IO_createTempDirectory_impl_v3 -> "IO.createTempDirectory.impl.v3" + IO_getCurrentDirectory_impl_v3 -> "IO.getCurrentDirectory.impl.v3" + IO_setCurrentDirectory_impl_v3 -> "IO.setCurrentDirectory.impl.v3" + IO_fileExists_impl_v3 -> "IO.fileExists.impl.v3" + IO_getEnv_impl_v1 -> "IO.getEnv.impl.v1" + IO_getArgs_impl_v1 -> "IO.getArgs.impl.v1" + IO_isDirectory_impl_v3 -> "IO.isDirectory.impl.v3" + IO_createDirectory_impl_v3 -> "IO.createDirectory.impl.v3" + IO_removeDirectory_impl_v3 -> "IO.removeDirectory.impl.v3" + IO_renameDirectory_impl_v3 -> "IO.renameDirectory.impl.v3" + IO_directoryContents_impl_v3 -> "IO.directoryContents.impl.v3" + IO_removeFile_impl_v3 -> "IO.removeFile.impl.v3" + IO_renameFile_impl_v3 -> "IO.renameFile.impl.v3" + IO_getFileTimestamp_impl_v3 -> "IO.getFileTimestamp.impl.v3" + IO_getFileSize_impl_v3 -> "IO.getFileSize.impl.v3" + IO_serverSocket_impl_v3 -> "IO.serverSocket.impl.v3" + Socket_toText -> "Socket.toText" + Handle_toText -> "Handle.toText" + ThreadId_toText -> "ThreadId.toText" + IO_socketPort_impl_v3 -> "IO.socketPort.impl.v3" + IO_listen_impl_v3 -> "IO.listen.impl.v3" + IO_clientSocket_impl_v3 -> "IO.clientSocket.impl.v3" + IO_closeSocket_impl_v3 -> "IO.closeSocket.impl.v3" + IO_socketAccept_impl_v3 -> "IO.socketAccept.impl.v3" + IO_socketSend_impl_v3 -> "IO.socketSend.impl.v3" + IO_socketReceive_impl_v3 -> "IO.socketReceive.impl.v3" + IO_kill_impl_v3 -> "IO.kill.impl.v3" + IO_delay_impl_v3 -> "IO.delay.impl.v3" + IO_stdHandle -> "IO.stdHandle" + IO_process_call -> "IO.process.call" + IO_process_start -> "IO.process.start" + IO_process_kill -> "IO.process.kill" + IO_process_wait -> "IO.process.wait" + IO_process_exitCode -> "IO.process.exitCode" + MVar_new -> "MVar.new" + MVar_newEmpty_v2 -> "MVar.newEmpty.v2" + MVar_take_impl_v3 -> "MVar.take.impl.v3" + MVar_tryTake -> "MVar.tryTake" + MVar_put_impl_v3 -> "MVar.put.impl.v3" + MVar_tryPut_impl_v3 -> "MVar.tryPut.impl.v3" + MVar_swap_impl_v3 -> "MVar.swap.impl.v3" + MVar_isEmpty -> "MVar.isEmpty" + MVar_read_impl_v3 -> "MVar.read.impl.v3" + MVar_tryRead_impl_v3 -> "MVar.tryRead.impl.v3" + Char_toText -> "Char.toText" + Text_repeat -> "Text.repeat" + Text_reverse -> "Text.reverse" + Text_toUppercase -> "Text.toUppercase" + Text_toLowercase -> "Text.toLowercase" + Text_toUtf8 -> "Text.toUtf8" + Text_fromUtf8_impl_v3 -> "Text.fromUtf8.impl.v3" + Tls_ClientConfig_default -> "Tls.ClientConfig.default" + Tls_ServerConfig_default -> "Tls.ServerConfig.default" + Tls_ClientConfig_certificates_set -> "Tls.ClientConfig.certificates.set" + Tls_ServerConfig_certificates_set -> "Tls.ServerConfig.certificates.set" + TVar_new -> "TVar.new" + TVar_read -> "TVar.read" + TVar_write -> "TVar.write" + TVar_newIO -> "TVar.newIO" + TVar_readIO -> "TVar.readIO" + TVar_swap -> "TVar.swap" + STM_retry -> "STM.retry" + Promise_new -> "Promise.new" + Promise_read -> "Promise.read" + Promise_tryRead -> "Promise.tryRead" + Promise_write -> "Promise.write" + Tls_newClient_impl_v3 -> "Tls.newClient.impl.v3" + Tls_newServer_impl_v3 -> "Tls.newServer.impl.v3" + Tls_handshake_impl_v3 -> "Tls.handshake.impl.v3" + Tls_send_impl_v3 -> "Tls.send.impl.v3" + Tls_decodeCert_impl_v3 -> "Tls.decodeCert.impl.v3" + Tls_encodeCert -> "Tls.encodeCert" + Tls_decodePrivateKey -> "Tls.decodePrivateKey" + Tls_encodePrivateKey -> "Tls.encodePrivateKey" + Tls_receive_impl_v3 -> "Tls.receive.impl.v3" + Tls_terminate_impl_v3 -> "Tls.terminate.impl.v3" + Code_validateLinks -> "Code.validateLinks" + Code_dependencies -> "Code.dependencies" + Code_serialize -> "Code.serialize" + Code_deserialize -> "Code.deserialize" + Code_display -> "Code.display" + Value_dependencies -> "Value.dependencies" + Value_serialize -> "Value.serialize" + Value_deserialize -> "Value.deserialize" + Crypto_HashAlgorithm_Sha3_512 -> "crypto.HashAlgorithm.Sha3_512" + Crypto_HashAlgorithm_Sha3_256 -> "crypto.HashAlgorithm.Sha3_256" + Crypto_HashAlgorithm_Sha2_512 -> "crypto.HashAlgorithm.Sha2_512" + Crypto_HashAlgorithm_Sha2_256 -> "crypto.HashAlgorithm.Sha2_256" + Crypto_HashAlgorithm_Sha1 -> "crypto.HashAlgorithm.Sha1" + Crypto_HashAlgorithm_Blake2b_512 -> "crypto.HashAlgorithm.Blake2b_512" + Crypto_HashAlgorithm_Blake2b_256 -> "crypto.HashAlgorithm.Blake2b_256" + Crypto_HashAlgorithm_Blake2s_256 -> "crypto.HashAlgorithm.Blake2s_256" + Crypto_HashAlgorithm_Md5 -> "crypto.HashAlgorithm.Md5" + Crypto_hashBytes -> "crypto.hashBytes" + Crypto_hmacBytes -> "crypto.hmacBytes" + Crypto_hash -> "crypto.hash" + Crypto_hmac -> "crypto.hmac" + Crypto_Ed25519_sign_impl -> "crypto.Ed25519.sign.impl" + Crypto_Ed25519_verify_impl -> "crypto.Ed25519.verify.impl" + Crypto_Rsa_sign_impl -> "crypto.Rsa.sign.impl" + Crypto_Rsa_verify_impl -> "crypto.Rsa.verify.impl" + Universal_murmurHash -> "Universal.murmurHash" + IO_randomBytes -> "IO.randomBytes" + Bytes_zlib_compress -> "Bytes.zlib.compress" + Bytes_gzip_compress -> "Bytes.gzip.compress" + Bytes_zlib_decompress -> "Bytes.zlib.decompress" + Bytes_gzip_decompress -> "Bytes.gzip.decompress" + Bytes_toBase16 -> "Bytes.toBase16" + Bytes_toBase32 -> "Bytes.toBase32" + Bytes_toBase64 -> "Bytes.toBase64" + Bytes_toBase64UrlUnpadded -> "Bytes.toBase64UrlUnpadded" + Bytes_fromBase16 -> "Bytes.fromBase16" + Bytes_fromBase32 -> "Bytes.fromBase32" + Bytes_fromBase64 -> "Bytes.fromBase64" + Bytes_fromBase64UrlUnpadded -> "Bytes.fromBase64UrlUnpadded" + Bytes_decodeNat64be -> "Bytes.decodeNat64be" + Bytes_decodeNat64le -> "Bytes.decodeNat64le" + Bytes_decodeNat32be -> "Bytes.decodeNat32be" + Bytes_decodeNat32le -> "Bytes.decodeNat32le" + Bytes_decodeNat16be -> "Bytes.decodeNat16be" + Bytes_decodeNat16le -> "Bytes.decodeNat16le" + Bytes_encodeNat64be -> "Bytes.encodeNat64be" + Bytes_encodeNat64le -> "Bytes.encodeNat64le" + Bytes_encodeNat32be -> "Bytes.encodeNat32be" + Bytes_encodeNat32le -> "Bytes.encodeNat32le" + Bytes_encodeNat16be -> "Bytes.encodeNat16be" + Bytes_encodeNat16le -> "Bytes.encodeNat16le" + MutableArray_copyTo_force -> "MutableArray.copyTo!" + MutableByteArray_copyTo_force -> "MutableByteArray.copyTo!" + ImmutableArray_copyTo_force -> "ImmutableArray.copyTo!" + ImmutableArray_size -> "ImmutableArray.size" + MutableArray_size -> "MutableArray.size" + ImmutableByteArray_size -> "ImmutableByteArray.size" + MutableByteArray_size -> "MutableByteArray.size" + ImmutableByteArray_copyTo_force -> "ImmutableByteArray.copyTo!" + MutableArray_read -> "MutableArray.read" + MutableByteArray_read8 -> "MutableByteArray.read8" + MutableByteArray_read16be -> "MutableByteArray.read16be" + MutableByteArray_read24be -> "MutableByteArray.read24be" + MutableByteArray_read32be -> "MutableByteArray.read32be" + MutableByteArray_read40be -> "MutableByteArray.read40be" + MutableByteArray_read64be -> "MutableByteArray.read64be" + MutableArray_write -> "MutableArray.write" + MutableByteArray_write8 -> "MutableByteArray.write8" + MutableByteArray_write16be -> "MutableByteArray.write16be" + MutableByteArray_write32be -> "MutableByteArray.write32be" + MutableByteArray_write64be -> "MutableByteArray.write64be" + ImmutableArray_read -> "ImmutableArray.read" + ImmutableByteArray_read8 -> "ImmutableByteArray.read8" + ImmutableByteArray_read16be -> "ImmutableByteArray.read16be" + ImmutableByteArray_read24be -> "ImmutableByteArray.read24be" + ImmutableByteArray_read32be -> "ImmutableByteArray.read32be" + ImmutableByteArray_read40be -> "ImmutableByteArray.read40be" + ImmutableByteArray_read64be -> "ImmutableByteArray.read64be" + MutableByteArray_freeze_force -> "MutableByteArray.freeze!" + MutableArray_freeze_force -> "MutableArray.freeze!" + MutableByteArray_freeze -> "MutableByteArray.freeze" + MutableArray_freeze -> "MutableArray.freeze" + MutableByteArray_length -> "MutableByteArray.length" + ImmutableByteArray_length -> "ImmutableByteArray.length" + IO_array -> "IO.array" + IO_arrayOf -> "IO.arrayOf" + IO_bytearray -> "IO.bytearray" + IO_bytearrayOf -> "IO.bytearrayOf" + Scope_array -> "Scope.array" + Scope_arrayOf -> "Scope.arrayOf" + Scope_bytearray -> "Scope.bytearray" + Scope_bytearrayOf -> "Scope.bytearrayOf" + Text_patterns_literal -> "Text.patterns.literal" + Text_patterns_digit -> "Text.patterns.digit" + Text_patterns_letter -> "Text.patterns.letter" + Text_patterns_space -> "Text.patterns.space" + Text_patterns_punctuation -> "Text.patterns.punctuation" + Text_patterns_anyChar -> "Text.patterns.anyChar" + Text_patterns_eof -> "Text.patterns.eof" + Text_patterns_charRange -> "Text.patterns.charRange" + Text_patterns_notCharRange -> "Text.patterns.notCharRange" + Text_patterns_charIn -> "Text.patterns.charIn" + Text_patterns_notCharIn -> "Text.patterns.notCharIn" + Pattern_many -> "Pattern.many" + Pattern_many_corrected -> "Pattern.many.corrected" + Pattern_capture -> "Pattern.capture" + Pattern_captureAs -> "Pattern.captureAs" + Pattern_join -> "Pattern.join" + Pattern_or -> "Pattern.or" + Pattern_replicate -> "Pattern.replicate" + Pattern_run -> "Pattern.run" + Pattern_isMatch -> "Pattern.isMatch" + Char_Class_any -> "Char.Class.any" + Char_Class_not -> "Char.Class.not" + Char_Class_and -> "Char.Class.and" + Char_Class_or -> "Char.Class.or" + Char_Class_range -> "Char.Class.range" + Char_Class_anyOf -> "Char.Class.anyOf" + Char_Class_alphanumeric -> "Char.Class.alphanumeric" + Char_Class_upper -> "Char.Class.upper" + Char_Class_lower -> "Char.Class.lower" + Char_Class_whitespace -> "Char.Class.whitespace" + Char_Class_control -> "Char.Class.control" + Char_Class_printable -> "Char.Class.printable" + Char_Class_mark -> "Char.Class.mark" + Char_Class_number -> "Char.Class.number" + Char_Class_punctuation -> "Char.Class.punctuation" + Char_Class_symbol -> "Char.Class.symbol" + Char_Class_separator -> "Char.Class.separator" + Char_Class_letter -> "Char.Class.letter" + Char_Class_is -> "Char.Class.is" + Text_patterns_char -> "Text.patterns.char" diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs index 23d2a2e49e..e924243759 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -135,6 +135,7 @@ import Unison.Runtime.Exception (die) import Unison.Runtime.Foreign hiding (Failure) import Unison.Runtime.Foreign qualified as F import Unison.Runtime.Foreign.Function (ForeignConvention (..)) +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) import Unison.Runtime.MCode import Unison.Runtime.Stack import Unison.Symbol @@ -152,7 +153,7 @@ import Unison.Util.Text qualified as Util.Text import Unison.Util.Text.Pattern qualified as TPat import UnliftIO qualified -foreignCall :: MForeignFunc -> Args -> Stack -> IO Stack +foreignCall :: ForeignFunc -> Args -> Stack -> IO Stack foreignCall = \case IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> let hostStr = Util.Text.toString host diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index bf353baf93..c4deb3086f 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -119,6 +119,7 @@ import Unison.Runtime.MCode emitComb, emptyRNs, resolveCombs, + sanitizeCombs, ) import Unison.Runtime.MCode.Serialize import Unison.Runtime.Machine @@ -1254,9 +1255,9 @@ tryM = hRE (PE _ e) = pure $ Just e hRE (BU _ _ _) = pure $ Just "impossible" -runStandalone :: StoredCache -> CombIx -> IO (Either (Pretty ColorText) ()) -runStandalone sc init = - restoreCache sc >>= executeMainComb init +runStandalone :: Bool -> StoredCache -> CombIx -> IO (Either (Pretty ColorText) ()) +runStandalone sandboxed sc init = + restoreCache sandboxed sc >>= executeMainComb init -- | A version of the Code Cache designed to be serialized to disk as -- standalone bytecode. @@ -1318,10 +1319,10 @@ tabulateErrors errs = : P.wrap "The following errors occured while decompiling:" : (listErrors errs) -restoreCache :: StoredCache -> IO CCache -restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do +restoreCache :: Bool -> StoredCache -> IO CCache +restoreCache sandboxed (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do cc <- - CCache False debugText + CCache sandboxed debugText <$> newTVarIO srcCombs <*> newTVarIO combs <*> newTVarIO (crs <> builtinTermBackref) @@ -1335,6 +1336,7 @@ restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do <*> newTVarIO (sbs <> baseSandboxInfo) let (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = srcCombs + & sanitizeCombs sandboxed sandboxedForeignFuncs & absurdCombs & EC.mapToList & foldMap @@ -1368,6 +1370,7 @@ restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do combs :: EnumMap Word64 (RCombs Val) combs = srcCombs + & sanitizeCombs sandboxed sandboxedForeignFuncs & absurdCombs & resolveCombs Nothing diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 977107613d..ee3a682858 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -35,10 +35,10 @@ module Unison.Runtime.MCode GBranch (..), Branch, RBranch, - MForeignFunc (..), emitCombs, emitComb, resolveCombs, + sanitizeCombs, absurdCombs, emptyRNs, argsToLists, @@ -60,6 +60,8 @@ import Data.Functor ((<&>)) import Data.Map.Strict qualified as M import Data.Primitive.PrimArray import Data.Primitive.PrimArray qualified as PA +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text qualified as Text import Data.Void (Void, absurd) import Data.Word (Word16, Word64) @@ -93,6 +95,7 @@ import Unison.Runtime.ANF pattern TVar, ) import Unison.Runtime.ANF qualified as ANF +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName) import Unison.Util.EnumContainers as EC import Unison.Util.Text (Text) import Unison.Var (Var) @@ -463,256 +466,6 @@ data BPrim2 | REFW -- Ref.write deriving (Show, Eq, Ord, Enum, Bounded) --- | Enum representing every foreign call. -data MForeignFunc - = IO_UDP_clientSocket_impl_v1 - | IO_UDP_UDPSocket_recv_impl_v1 - | IO_UDP_UDPSocket_send_impl_v1 - | IO_UDP_UDPSocket_close_impl_v1 - | IO_UDP_ListenSocket_close_impl_v1 - | IO_UDP_UDPSocket_toText_impl_v1 - | IO_UDP_serverSocket_impl_v1 - | IO_UDP_ListenSocket_toText_impl_v1 - | IO_UDP_ListenSocket_recvFrom_impl_v1 - | IO_UDP_ClientSockAddr_toText_v1 - | IO_UDP_ListenSocket_sendTo_impl_v1 - | IO_openFile_impl_v3 - | IO_closeFile_impl_v3 - | IO_isFileEOF_impl_v3 - | IO_isFileOpen_impl_v3 - | IO_getEcho_impl_v1 - | IO_ready_impl_v1 - | IO_getChar_impl_v1 - | IO_isSeekable_impl_v3 - | IO_seekHandle_impl_v3 - | IO_handlePosition_impl_v3 - | IO_getBuffering_impl_v3 - | IO_setBuffering_impl_v3 - | IO_setEcho_impl_v1 - | IO_getLine_impl_v1 - | IO_getBytes_impl_v3 - | IO_getSomeBytes_impl_v1 - | IO_putBytes_impl_v3 - | IO_systemTime_impl_v3 - | IO_systemTimeMicroseconds_v1 - | Clock_internals_monotonic_v1 - | Clock_internals_realtime_v1 - | Clock_internals_processCPUTime_v1 - | Clock_internals_threadCPUTime_v1 - | Clock_internals_sec_v1 - | Clock_internals_nsec_v1 - | Clock_internals_systemTimeZone_v1 - | IO_getTempDirectory_impl_v3 - | IO_createTempDirectory_impl_v3 - | IO_getCurrentDirectory_impl_v3 - | IO_setCurrentDirectory_impl_v3 - | IO_fileExists_impl_v3 - | IO_getEnv_impl_v1 - | IO_getArgs_impl_v1 - | IO_isDirectory_impl_v3 - | IO_createDirectory_impl_v3 - | IO_removeDirectory_impl_v3 - | IO_renameDirectory_impl_v3 - | IO_directoryContents_impl_v3 - | IO_removeFile_impl_v3 - | IO_renameFile_impl_v3 - | IO_getFileTimestamp_impl_v3 - | IO_getFileSize_impl_v3 - | IO_serverSocket_impl_v3 - | Socket_toText - | Handle_toText - | ThreadId_toText - | IO_socketPort_impl_v3 - | IO_listen_impl_v3 - | IO_clientSocket_impl_v3 - | IO_closeSocket_impl_v3 - | IO_socketAccept_impl_v3 - | IO_socketSend_impl_v3 - | IO_socketReceive_impl_v3 - | IO_kill_impl_v3 - | IO_delay_impl_v3 - | IO_stdHandle - | IO_process_call - | IO_process_start - | IO_process_kill - | IO_process_wait - | IO_process_exitCode - | MVar_new - | MVar_newEmpty_v2 - | MVar_take_impl_v3 - | MVar_tryTake - | MVar_put_impl_v3 - | MVar_tryPut_impl_v3 - | MVar_swap_impl_v3 - | MVar_isEmpty - | MVar_read_impl_v3 - | MVar_tryRead_impl_v3 - | Char_toText - | Text_repeat - | Text_reverse - | Text_toUppercase - | Text_toLowercase - | Text_toUtf8 - | Text_fromUtf8_impl_v3 - | Tls_ClientConfig_default - | Tls_ServerConfig_default - | Tls_ClientConfig_certificates_set - | Tls_ServerConfig_certificates_set - | TVar_new - | TVar_read - | TVar_write - | TVar_newIO - | TVar_readIO - | TVar_swap - | STM_retry - | Promise_new - | Promise_read - | Promise_tryRead - | Promise_write - | Tls_newClient_impl_v3 - | Tls_newServer_impl_v3 - | Tls_handshake_impl_v3 - | Tls_send_impl_v3 - | Tls_decodeCert_impl_v3 - | Tls_encodeCert - | Tls_decodePrivateKey - | Tls_encodePrivateKey - | Tls_receive_impl_v3 - | Tls_terminate_impl_v3 - | Code_validateLinks - | Code_dependencies - | Code_serialize - | Code_deserialize - | Code_display - | Value_dependencies - | Value_serialize - | Value_deserialize - | Crypto_HashAlgorithm_Sha3_512 - | Crypto_HashAlgorithm_Sha3_256 - | Crypto_HashAlgorithm_Sha2_512 - | Crypto_HashAlgorithm_Sha2_256 - | Crypto_HashAlgorithm_Sha1 - | Crypto_HashAlgorithm_Blake2b_512 - | Crypto_HashAlgorithm_Blake2b_256 - | Crypto_HashAlgorithm_Blake2s_256 - | Crypto_HashAlgorithm_Md5 - | Crypto_hashBytes - | Crypto_hmacBytes - | Crypto_hash - | Crypto_hmac - | Crypto_Ed25519_sign_impl - | Crypto_Ed25519_verify_impl - | Crypto_Rsa_sign_impl - | Crypto_Rsa_verify_impl - | Universal_murmurHash - | IO_randomBytes - | Bytes_zlib_compress - | Bytes_gzip_compress - | Bytes_zlib_decompress - | Bytes_gzip_decompress - | Bytes_toBase16 - | Bytes_toBase32 - | Bytes_toBase64 - | Bytes_toBase64UrlUnpadded - | Bytes_fromBase16 - | Bytes_fromBase32 - | Bytes_fromBase64 - | Bytes_fromBase64UrlUnpadded - | Bytes_decodeNat64be - | Bytes_decodeNat64le - | Bytes_decodeNat32be - | Bytes_decodeNat32le - | Bytes_decodeNat16be - | Bytes_decodeNat16le - | Bytes_encodeNat64be - | Bytes_encodeNat64le - | Bytes_encodeNat32be - | Bytes_encodeNat32le - | Bytes_encodeNat16be - | Bytes_encodeNat16le - | MutableArray_copyTo_force - | MutableByteArray_copyTo_force - | ImmutableArray_copyTo_force - | ImmutableArray_size - | MutableArray_size - | ImmutableByteArray_size - | MutableByteArray_size - | ImmutableByteArray_copyTo_force - | MutableArray_read - | MutableByteArray_read8 - | MutableByteArray_read16be - | MutableByteArray_read24be - | MutableByteArray_read32be - | MutableByteArray_read40be - | MutableByteArray_read64be - | MutableArray_write - | MutableByteArray_write8 - | MutableByteArray_write16be - | MutableByteArray_write32be - | MutableByteArray_write64be - | ImmutableArray_read - | ImmutableByteArray_read8 - | ImmutableByteArray_read16be - | ImmutableByteArray_read24be - | ImmutableByteArray_read32be - | ImmutableByteArray_read40be - | ImmutableByteArray_read64be - | MutableByteArray_freeze_force - | MutableArray_freeze_force - | MutableByteArray_freeze - | MutableArray_freeze - | MutableByteArray_length - | ImmutableByteArray_length - | IO_array - | IO_arrayOf - | IO_bytearray - | IO_bytearrayOf - | Scope_array - | Scope_arrayOf - | Scope_bytearray - | Scope_bytearrayOf - | Text_patterns_literal - | Text_patterns_digit - | Text_patterns_letter - | Text_patterns_space - | Text_patterns_punctuation - | Text_patterns_anyChar - | Text_patterns_eof - | Text_patterns_charRange - | Text_patterns_notCharRange - | Text_patterns_charIn - | Text_patterns_notCharIn - | Pattern_many - | Pattern_many_corrected - | Pattern_capture - | Pattern_captureAs - | Pattern_join - | Pattern_or - | Pattern_replicate - | Pattern_run - | Pattern_isMatch - | Char_Class_any - | Char_Class_not - | Char_Class_and - | Char_Class_or - | Char_Class_range - | Char_Class_anyOf - | Char_Class_alphanumeric - | Char_Class_upper - | Char_Class_lower - | Char_Class_whitespace - | Char_Class_control - | Char_Class_printable - | Char_Class_mark - | Char_Class_number - | Char_Class_punctuation - | Char_Class_symbol - | Char_Class_separator - | Char_Class_letter - | Char_Class_is - | Text_patterns_char - deriving (Show, Eq, Ord, Enum, Bounded) - data MLit = MI !Int | MN !Word64 @@ -754,7 +507,7 @@ data GInstr comb | -- Call out to a Haskell function. ForeignCall !Bool -- catch exceptions - !MForeignFunc -- FFI call + !ForeignFunc -- FFI call !Args -- arguments | -- Set the value of a dynamic reference SetDyn @@ -1648,257 +1401,8 @@ emitPOp ANF.TFRC = \case -- to 'foreing function' calls, but there is a special case for the -- standard handle access function, because it does not yield an -- explicit error. -emitFOp :: ANF.ForeignFunc -> Args -> Instr -emitFOp fop = ForeignCall True (convertFF fop) - where - convertFF :: ANF.ForeignFunc -> MForeignFunc - convertFF = \case - ANF.IO_UDP_clientSocket_impl_v1 -> IO_UDP_clientSocket_impl_v1 - ANF.IO_UDP_UDPSocket_recv_impl_v1 -> IO_UDP_UDPSocket_recv_impl_v1 - ANF.IO_UDP_UDPSocket_send_impl_v1 -> IO_UDP_UDPSocket_send_impl_v1 - ANF.IO_UDP_UDPSocket_close_impl_v1 -> IO_UDP_UDPSocket_close_impl_v1 - ANF.IO_UDP_ListenSocket_close_impl_v1 -> IO_UDP_ListenSocket_close_impl_v1 - ANF.IO_UDP_UDPSocket_toText_impl_v1 -> IO_UDP_UDPSocket_toText_impl_v1 - ANF.IO_UDP_serverSocket_impl_v1 -> IO_UDP_serverSocket_impl_v1 - ANF.IO_UDP_ListenSocket_toText_impl_v1 -> IO_UDP_ListenSocket_toText_impl_v1 - ANF.IO_UDP_ListenSocket_recvFrom_impl_v1 -> IO_UDP_ListenSocket_recvFrom_impl_v1 - ANF.IO_UDP_ClientSockAddr_toText_v1 -> IO_UDP_ClientSockAddr_toText_v1 - ANF.IO_UDP_ListenSocket_sendTo_impl_v1 -> IO_UDP_ListenSocket_sendTo_impl_v1 - ANF.IO_openFile_impl_v3 -> IO_openFile_impl_v3 - ANF.IO_closeFile_impl_v3 -> IO_closeFile_impl_v3 - ANF.IO_isFileEOF_impl_v3 -> IO_isFileEOF_impl_v3 - ANF.IO_isFileOpen_impl_v3 -> IO_isFileOpen_impl_v3 - ANF.IO_getEcho_impl_v1 -> IO_getEcho_impl_v1 - ANF.IO_ready_impl_v1 -> IO_ready_impl_v1 - ANF.IO_getChar_impl_v1 -> IO_getChar_impl_v1 - ANF.IO_isSeekable_impl_v3 -> IO_isSeekable_impl_v3 - ANF.IO_seekHandle_impl_v3 -> IO_seekHandle_impl_v3 - ANF.IO_handlePosition_impl_v3 -> IO_handlePosition_impl_v3 - ANF.IO_getBuffering_impl_v3 -> IO_getBuffering_impl_v3 - ANF.IO_setBuffering_impl_v3 -> IO_setBuffering_impl_v3 - ANF.IO_setEcho_impl_v1 -> IO_setEcho_impl_v1 - ANF.IO_getLine_impl_v1 -> IO_getLine_impl_v1 - ANF.IO_getBytes_impl_v3 -> IO_getBytes_impl_v3 - ANF.IO_getSomeBytes_impl_v1 -> IO_getSomeBytes_impl_v1 - ANF.IO_putBytes_impl_v3 -> IO_putBytes_impl_v3 - ANF.IO_systemTime_impl_v3 -> IO_systemTime_impl_v3 - ANF.IO_systemTimeMicroseconds_v1 -> IO_systemTimeMicroseconds_v1 - ANF.Clock_internals_monotonic_v1 -> Clock_internals_monotonic_v1 - ANF.Clock_internals_realtime_v1 -> Clock_internals_realtime_v1 - ANF.Clock_internals_processCPUTime_v1 -> Clock_internals_processCPUTime_v1 - ANF.Clock_internals_threadCPUTime_v1 -> Clock_internals_threadCPUTime_v1 - ANF.Clock_internals_sec_v1 -> Clock_internals_sec_v1 - ANF.Clock_internals_nsec_v1 -> Clock_internals_nsec_v1 - ANF.Clock_internals_systemTimeZone_v1 -> Clock_internals_systemTimeZone_v1 - ANF.IO_getTempDirectory_impl_v3 -> IO_getTempDirectory_impl_v3 - ANF.IO_createTempDirectory_impl_v3 -> IO_createTempDirectory_impl_v3 - ANF.IO_getCurrentDirectory_impl_v3 -> IO_getCurrentDirectory_impl_v3 - ANF.IO_setCurrentDirectory_impl_v3 -> IO_setCurrentDirectory_impl_v3 - ANF.IO_fileExists_impl_v3 -> IO_fileExists_impl_v3 - ANF.IO_getEnv_impl_v1 -> IO_getEnv_impl_v1 - ANF.IO_getArgs_impl_v1 -> IO_getArgs_impl_v1 - ANF.IO_isDirectory_impl_v3 -> IO_isDirectory_impl_v3 - ANF.IO_createDirectory_impl_v3 -> IO_createDirectory_impl_v3 - ANF.IO_removeDirectory_impl_v3 -> IO_removeDirectory_impl_v3 - ANF.IO_renameDirectory_impl_v3 -> IO_renameDirectory_impl_v3 - ANF.IO_directoryContents_impl_v3 -> IO_directoryContents_impl_v3 - ANF.IO_removeFile_impl_v3 -> IO_removeFile_impl_v3 - ANF.IO_renameFile_impl_v3 -> IO_renameFile_impl_v3 - ANF.IO_getFileTimestamp_impl_v3 -> IO_getFileTimestamp_impl_v3 - ANF.IO_getFileSize_impl_v3 -> IO_getFileSize_impl_v3 - ANF.IO_serverSocket_impl_v3 -> IO_serverSocket_impl_v3 - ANF.Socket_toText -> Socket_toText - ANF.Handle_toText -> Handle_toText - ANF.ThreadId_toText -> ThreadId_toText - ANF.IO_socketPort_impl_v3 -> IO_socketPort_impl_v3 - ANF.IO_listen_impl_v3 -> IO_listen_impl_v3 - ANF.IO_clientSocket_impl_v3 -> IO_clientSocket_impl_v3 - ANF.IO_closeSocket_impl_v3 -> IO_closeSocket_impl_v3 - ANF.IO_socketAccept_impl_v3 -> IO_socketAccept_impl_v3 - ANF.IO_socketSend_impl_v3 -> IO_socketSend_impl_v3 - ANF.IO_socketReceive_impl_v3 -> IO_socketReceive_impl_v3 - ANF.IO_kill_impl_v3 -> IO_kill_impl_v3 - ANF.IO_delay_impl_v3 -> IO_delay_impl_v3 - ANF.IO_stdHandle -> IO_stdHandle - ANF.IO_process_call -> IO_process_call - ANF.IO_process_start -> IO_process_start - ANF.IO_process_kill -> IO_process_kill - ANF.IO_process_wait -> IO_process_wait - ANF.IO_process_exitCode -> IO_process_exitCode - ANF.MVar_new -> MVar_new - ANF.MVar_newEmpty_v2 -> MVar_newEmpty_v2 - ANF.MVar_take_impl_v3 -> MVar_take_impl_v3 - ANF.MVar_tryTake -> MVar_tryTake - ANF.MVar_put_impl_v3 -> MVar_put_impl_v3 - ANF.MVar_tryPut_impl_v3 -> MVar_tryPut_impl_v3 - ANF.MVar_swap_impl_v3 -> MVar_swap_impl_v3 - ANF.MVar_isEmpty -> MVar_isEmpty - ANF.MVar_read_impl_v3 -> MVar_read_impl_v3 - ANF.MVar_tryRead_impl_v3 -> MVar_tryRead_impl_v3 - ANF.Char_toText -> Char_toText - ANF.Text_repeat -> Text_repeat - ANF.Text_reverse -> Text_reverse - ANF.Text_toUppercase -> Text_toUppercase - ANF.Text_toLowercase -> Text_toLowercase - ANF.Text_toUtf8 -> Text_toUtf8 - ANF.Text_fromUtf8_impl_v3 -> Text_fromUtf8_impl_v3 - ANF.Tls_ClientConfig_default -> Tls_ClientConfig_default - ANF.Tls_ServerConfig_default -> Tls_ServerConfig_default - ANF.Tls_ClientConfig_certificates_set -> Tls_ClientConfig_certificates_set - ANF.Tls_ServerConfig_certificates_set -> Tls_ServerConfig_certificates_set - ANF.TVar_new -> TVar_new - ANF.TVar_read -> TVar_read - ANF.TVar_write -> TVar_write - ANF.TVar_newIO -> TVar_newIO - ANF.TVar_readIO -> TVar_readIO - ANF.TVar_swap -> TVar_swap - ANF.STM_retry -> STM_retry - ANF.Promise_new -> Promise_new - ANF.Promise_read -> Promise_read - ANF.Promise_tryRead -> Promise_tryRead - ANF.Promise_write -> Promise_write - ANF.Tls_newClient_impl_v3 -> Tls_newClient_impl_v3 - ANF.Tls_newServer_impl_v3 -> Tls_newServer_impl_v3 - ANF.Tls_handshake_impl_v3 -> Tls_handshake_impl_v3 - ANF.Tls_send_impl_v3 -> Tls_send_impl_v3 - ANF.Tls_decodeCert_impl_v3 -> Tls_decodeCert_impl_v3 - ANF.Tls_encodeCert -> Tls_encodeCert - ANF.Tls_decodePrivateKey -> Tls_decodePrivateKey - ANF.Tls_encodePrivateKey -> Tls_encodePrivateKey - ANF.Tls_receive_impl_v3 -> Tls_receive_impl_v3 - ANF.Tls_terminate_impl_v3 -> Tls_terminate_impl_v3 - ANF.Code_validateLinks -> Code_validateLinks - ANF.Code_dependencies -> Code_dependencies - ANF.Code_serialize -> Code_serialize - ANF.Code_deserialize -> Code_deserialize - ANF.Code_display -> Code_display - ANF.Value_dependencies -> Value_dependencies - ANF.Value_serialize -> Value_serialize - ANF.Value_deserialize -> Value_deserialize - ANF.Crypto_HashAlgorithm_Sha3_512 -> Crypto_HashAlgorithm_Sha3_512 - ANF.Crypto_HashAlgorithm_Sha3_256 -> Crypto_HashAlgorithm_Sha3_256 - ANF.Crypto_HashAlgorithm_Sha2_512 -> Crypto_HashAlgorithm_Sha2_512 - ANF.Crypto_HashAlgorithm_Sha2_256 -> Crypto_HashAlgorithm_Sha2_256 - ANF.Crypto_HashAlgorithm_Sha1 -> Crypto_HashAlgorithm_Sha1 - ANF.Crypto_HashAlgorithm_Blake2b_512 -> Crypto_HashAlgorithm_Blake2b_512 - ANF.Crypto_HashAlgorithm_Blake2b_256 -> Crypto_HashAlgorithm_Blake2b_256 - ANF.Crypto_HashAlgorithm_Blake2s_256 -> Crypto_HashAlgorithm_Blake2s_256 - ANF.Crypto_HashAlgorithm_Md5 -> Crypto_HashAlgorithm_Md5 - ANF.Crypto_hashBytes -> Crypto_hashBytes - ANF.Crypto_hmacBytes -> Crypto_hmacBytes - ANF.Crypto_hash -> Crypto_hash - ANF.Crypto_hmac -> Crypto_hmac - ANF.Crypto_Ed25519_sign_impl -> Crypto_Ed25519_sign_impl - ANF.Crypto_Ed25519_verify_impl -> Crypto_Ed25519_verify_impl - ANF.Crypto_Rsa_sign_impl -> Crypto_Rsa_sign_impl - ANF.Crypto_Rsa_verify_impl -> Crypto_Rsa_verify_impl - ANF.Universal_murmurHash -> Universal_murmurHash - ANF.IO_randomBytes -> IO_randomBytes - ANF.Bytes_zlib_compress -> Bytes_zlib_compress - ANF.Bytes_gzip_compress -> Bytes_gzip_compress - ANF.Bytes_zlib_decompress -> Bytes_zlib_decompress - ANF.Bytes_gzip_decompress -> Bytes_gzip_decompress - ANF.Bytes_toBase16 -> Bytes_toBase16 - ANF.Bytes_toBase32 -> Bytes_toBase32 - ANF.Bytes_toBase64 -> Bytes_toBase64 - ANF.Bytes_toBase64UrlUnpadded -> Bytes_toBase64UrlUnpadded - ANF.Bytes_fromBase16 -> Bytes_fromBase16 - ANF.Bytes_fromBase32 -> Bytes_fromBase32 - ANF.Bytes_fromBase64 -> Bytes_fromBase64 - ANF.Bytes_fromBase64UrlUnpadded -> Bytes_fromBase64UrlUnpadded - ANF.Bytes_decodeNat64be -> Bytes_decodeNat64be - ANF.Bytes_decodeNat64le -> Bytes_decodeNat64le - ANF.Bytes_decodeNat32be -> Bytes_decodeNat32be - ANF.Bytes_decodeNat32le -> Bytes_decodeNat32le - ANF.Bytes_decodeNat16be -> Bytes_decodeNat16be - ANF.Bytes_decodeNat16le -> Bytes_decodeNat16le - ANF.Bytes_encodeNat64be -> Bytes_encodeNat64be - ANF.Bytes_encodeNat64le -> Bytes_encodeNat64le - ANF.Bytes_encodeNat32be -> Bytes_encodeNat32be - ANF.Bytes_encodeNat32le -> Bytes_encodeNat32le - ANF.Bytes_encodeNat16be -> Bytes_encodeNat16be - ANF.Bytes_encodeNat16le -> Bytes_encodeNat16le - ANF.MutableArray_copyTo_force -> MutableArray_copyTo_force - ANF.MutableByteArray_copyTo_force -> MutableByteArray_copyTo_force - ANF.ImmutableArray_copyTo_force -> ImmutableArray_copyTo_force - ANF.ImmutableArray_size -> ImmutableArray_size - ANF.MutableArray_size -> MutableArray_size - ANF.ImmutableByteArray_size -> ImmutableByteArray_size - ANF.MutableByteArray_size -> MutableByteArray_size - ANF.ImmutableByteArray_copyTo_force -> ImmutableByteArray_copyTo_force - ANF.MutableArray_read -> MutableArray_read - ANF.MutableByteArray_read8 -> MutableByteArray_read8 - ANF.MutableByteArray_read16be -> MutableByteArray_read16be - ANF.MutableByteArray_read24be -> MutableByteArray_read24be - ANF.MutableByteArray_read32be -> MutableByteArray_read32be - ANF.MutableByteArray_read40be -> MutableByteArray_read40be - ANF.MutableByteArray_read64be -> MutableByteArray_read64be - ANF.MutableArray_write -> MutableArray_write - ANF.MutableByteArray_write8 -> MutableByteArray_write8 - ANF.MutableByteArray_write16be -> MutableByteArray_write16be - ANF.MutableByteArray_write32be -> MutableByteArray_write32be - ANF.MutableByteArray_write64be -> MutableByteArray_write64be - ANF.ImmutableArray_read -> ImmutableArray_read - ANF.ImmutableByteArray_read8 -> ImmutableByteArray_read8 - ANF.ImmutableByteArray_read16be -> ImmutableByteArray_read16be - ANF.ImmutableByteArray_read24be -> ImmutableByteArray_read24be - ANF.ImmutableByteArray_read32be -> ImmutableByteArray_read32be - ANF.ImmutableByteArray_read40be -> ImmutableByteArray_read40be - ANF.ImmutableByteArray_read64be -> ImmutableByteArray_read64be - ANF.MutableByteArray_freeze_force -> MutableByteArray_freeze_force - ANF.MutableArray_freeze_force -> MutableArray_freeze_force - ANF.MutableByteArray_freeze -> MutableByteArray_freeze - ANF.MutableArray_freeze -> MutableArray_freeze - ANF.MutableByteArray_length -> MutableByteArray_length - ANF.ImmutableByteArray_length -> ImmutableByteArray_length - ANF.IO_array -> IO_array - ANF.IO_arrayOf -> IO_arrayOf - ANF.IO_bytearray -> IO_bytearray - ANF.IO_bytearrayOf -> IO_bytearrayOf - ANF.Scope_array -> Scope_array - ANF.Scope_arrayOf -> Scope_arrayOf - ANF.Scope_bytearray -> Scope_bytearray - ANF.Scope_bytearrayOf -> Scope_bytearrayOf - ANF.Text_patterns_literal -> Text_patterns_literal - ANF.Text_patterns_digit -> Text_patterns_digit - ANF.Text_patterns_letter -> Text_patterns_letter - ANF.Text_patterns_space -> Text_patterns_space - ANF.Text_patterns_punctuation -> Text_patterns_punctuation - ANF.Text_patterns_anyChar -> Text_patterns_anyChar - ANF.Text_patterns_eof -> Text_patterns_eof - ANF.Text_patterns_charRange -> Text_patterns_charRange - ANF.Text_patterns_notCharRange -> Text_patterns_notCharRange - ANF.Text_patterns_charIn -> Text_patterns_charIn - ANF.Text_patterns_notCharIn -> Text_patterns_notCharIn - ANF.Pattern_many -> Pattern_many - ANF.Pattern_many_corrected -> Pattern_many_corrected - ANF.Pattern_capture -> Pattern_capture - ANF.Pattern_captureAs -> Pattern_captureAs - ANF.Pattern_join -> Pattern_join - ANF.Pattern_or -> Pattern_or - ANF.Pattern_replicate -> Pattern_replicate - ANF.Pattern_run -> Pattern_run - ANF.Pattern_isMatch -> Pattern_isMatch - ANF.Char_Class_any -> Char_Class_any - ANF.Char_Class_not -> Char_Class_not - ANF.Char_Class_and -> Char_Class_and - ANF.Char_Class_or -> Char_Class_or - ANF.Char_Class_range -> Char_Class_range - ANF.Char_Class_anyOf -> Char_Class_anyOf - ANF.Char_Class_alphanumeric -> Char_Class_alphanumeric - ANF.Char_Class_upper -> Char_Class_upper - ANF.Char_Class_lower -> Char_Class_lower - ANF.Char_Class_whitespace -> Char_Class_whitespace - ANF.Char_Class_control -> Char_Class_control - ANF.Char_Class_printable -> Char_Class_printable - ANF.Char_Class_mark -> Char_Class_mark - ANF.Char_Class_number -> Char_Class_number - ANF.Char_Class_punctuation -> Char_Class_punctuation - ANF.Char_Class_symbol -> Char_Class_symbol - ANF.Char_Class_separator -> Char_Class_separator - ANF.Char_Class_letter -> Char_Class_letter - ANF.Char_Class_is -> Char_Class_is - ANF.Text_patterns_char -> Text_patterns_char +emitFOp :: ForeignFunc -> Args -> Instr +emitFOp fop = ForeignCall True fop -- Helper functions for packing the variable argument representation -- into the indexes stored in prim op instructions @@ -2301,3 +1805,38 @@ prettyIns i = shows i prettyArgs :: Args -> ShowS prettyArgs ZArgs = showString "ZArgs" prettyArgs v = showParen True $ shows v + +sanitizeCombs :: Bool -> (Set ForeignFunc) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) +sanitizeCombs sanitize sandboxedForeigns m + | sanitize = (fmap . fmap) (sanitizeComb sandboxedForeigns) m + | otherwise = m + +sanitizeComb :: Set ForeignFunc -> GComb Void CombIx -> GComb Void CombIx +sanitizeComb sandboxedForeigns = \case + Lam a b s -> Lam a b (sanitizeSection sandboxedForeigns s) + +-- | Crawl the source code and statically replace all sandboxed foreign funcs with an error. +sanitizeSection :: Set ForeignFunc -> GSection CombIx -> GSection CombIx +sanitizeSection sandboxedForeigns section = case section of + Ins (ForeignCall _ f as) nx + | Set.member f sandboxedForeigns -> Ins (SandboxingFailure (foreignFuncBuiltinName f)) (sanitizeSection sandboxedForeigns nx) + | otherwise -> Ins (ForeignCall True f as) (sanitizeSection sandboxedForeigns nx) + Ins i nx -> Ins i (sanitizeSection sandboxedForeigns nx) + App {} -> section + Call {} -> section + Jump {} -> section + Match i bs -> Match i (sanitizeBranches sandboxedForeigns bs) + Yield {} -> section + Let s i f b -> Let (sanitizeSection sandboxedForeigns s) i f (sanitizeSection sandboxedForeigns b) + Die {} -> section + Exit -> section + DMatch i j bs -> DMatch i j (sanitizeBranches sandboxedForeigns bs) + NMatch i j bs -> NMatch i j (sanitizeBranches sandboxedForeigns bs) + RMatch i s bs -> RMatch i (sanitizeSection sandboxedForeigns s) (fmap (sanitizeBranches sandboxedForeigns) bs) + +sanitizeBranches :: Set ForeignFunc -> GBranch CombIx -> GBranch CombIx +sanitizeBranches sandboxedForeigns = \case + Test1 i s d -> Test1 i (sanitizeSection sandboxedForeigns s) (sanitizeSection sandboxedForeigns d) + Test2 i s j t d -> Test2 i (sanitizeSection sandboxedForeigns s) j (sanitizeSection sandboxedForeigns t) (sanitizeSection sandboxedForeigns d) + TestW d m -> TestW (sanitizeSection sandboxedForeigns d) (fmap (sanitizeSection sandboxedForeigns) m) + TestT d m -> TestT (sanitizeSection sandboxedForeigns d) (fmap (sanitizeSection sandboxedForeigns) m) diff --git a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs index 2b0fd4aa81..e6946403d9 100644 --- a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs @@ -19,6 +19,7 @@ import Data.Word (Word64) import GHC.Exts (IsList (..)) import Unison.Runtime.ANF (PackedTag (..)) import Unison.Runtime.Array (PrimArray) +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) import Unison.Runtime.MCode hiding (MatchT) import Unison.Runtime.Serialize import Unison.Util.Text qualified as Util.Text @@ -54,11 +55,11 @@ getComb = Lam <$> gInt <*> gInt <*> getSection CachedClosureT -> error "getComb: Unexpected serialized Cached Closure" -getMForeignFunc :: (MonadGet m) => m MForeignFunc +getMForeignFunc :: (MonadGet m) => m ForeignFunc getMForeignFunc = do toEnum <$> gInt -putMForeignFunc :: (MonadPut m) => MForeignFunc -> m () +putMForeignFunc :: (MonadPut m) => ForeignFunc -> m () putMForeignFunc = pInt . fromEnum data SectionT diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 94a075b6b5..95b951514f 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -177,6 +177,7 @@ baseCCache sandboxed = do combs :: EnumMap Word64 MCombs combs = srcCombs + & sanitizeCombs sandboxed sandboxedForeignFuncs & absurdCombs & resolveCombs Nothing @@ -493,8 +494,8 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 SDBL i) stk <- bump stk pokeS stk . encodeSandboxListResult =<< sandboxList env tl pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (BPrim1 op i) = do - stk <- bprim1 stk op i +exec !env !denv !_activeThreads !stk !k _ (BPrim1 op i) = do + stk <- bprim1 env stk op i pure (denv, stk, k) exec !env !denv !_activeThreads !stk !k _ (BPrim2 SDBX i j) = do s <- peekOffS stk i @@ -565,17 +566,19 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim2 TRCE i j) exec !_ !denv !_trackThreads !stk !k _ (BPrim2 op i j) = do stk <- bprim2 stk op i j pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (RefCAS refI ticketI valI) = do - (ref :: IORef Val) <- peekOffBi stk refI - -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it - -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal - -- forcing of the values and tickets. - !(ticket :: Atomic.Ticket Val) <- peekOffBi stk ticketI - v <- peekOff stk valI - (r, _) <- Atomic.casIORef ref ticket v - stk <- bump stk - pokeBool stk r - pure (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 + (ref :: IORef Val) <- peekOffBi stk refI + -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it + -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal + -- forcing of the values and tickets. + !(ticket :: Atomic.Ticket Val) <- peekOffBi stk ticketI + v <- peekOff stk valI + (r, _) <- Atomic.casIORef ref ticket v + stk <- bump stk + pokeBool stk r + pure (denv, stk, k) exec !_ !denv !_activeThreads !stk !k _ (Pack r t args) = do clo <- buildData stk r t args stk <- bump stk @@ -1533,36 +1536,37 @@ uprim2 !stk IORB !i !j = do {-# INLINE uprim2 #-} bprim1 :: + CCache -> Stack -> BPrim1 -> Int -> IO Stack -bprim1 !stk SIZT i = do +bprim1 !_env !stk SIZT i = do t <- peekOffBi stk i stk <- bump stk unsafePokeIasN stk $ Util.Text.size t pure stk -bprim1 !stk SIZS i = do +bprim1 !_env !stk SIZS i = do s <- peekOffS stk i stk <- bump stk unsafePokeIasN stk $ Sq.length s pure stk -bprim1 !stk ITOT i = do +bprim1 !_env !stk ITOT i = do n <- upeekOff stk i stk <- bump stk pokeBi stk . Util.Text.pack $ show n pure stk -bprim1 !stk NTOT i = do +bprim1 !_env !stk NTOT i = do n <- peekOffN stk i stk <- bump stk pokeBi stk . Util.Text.pack $ show n pure stk -bprim1 !stk FTOT i = do +bprim1 !_env !stk FTOT i = do f <- peekOffD stk i stk <- bump stk pokeBi stk . Util.Text.pack $ show f pure stk -bprim1 !stk USNC i = +bprim1 !_env !stk USNC i = peekOffBi stk i >>= \t -> case Util.Text.unsnoc t of Nothing -> do stk <- bump stk @@ -1574,7 +1578,7 @@ bprim1 !stk USNC i = pokeOffBi stk 1 t -- remaining text pokeTag stk 1 -- 'Just' tag pure stk -bprim1 !stk UCNS i = +bprim1 !_env !stk UCNS i = peekOffBi stk i >>= \t -> case Util.Text.uncons t of Nothing -> do stk <- bump stk @@ -1586,7 +1590,7 @@ bprim1 !stk UCNS i = pokeOffC stk 1 $ c -- char value pokeTag stk 1 -- 'Just' tag pure stk -bprim1 !stk TTOI i = +bprim1 !_env !stk TTOI i = peekOffBi stk i >>= \t -> case readm $ Util.Text.unpack t of Just n | fromIntegral (minBound :: Int) <= n, @@ -1602,7 +1606,7 @@ bprim1 !stk TTOI i = where readm ('+' : s) = readMaybe s readm s = readMaybe s -bprim1 !stk TTON i = +bprim1 !_env !stk TTON i = peekOffBi stk i >>= \t -> case readMaybe $ Util.Text.unpack t of Just n | 0 <= n, @@ -1615,7 +1619,7 @@ bprim1 !stk TTON i = stk <- bump stk pokeTag stk 0 pure stk -bprim1 !stk TTOF i = +bprim1 !_env !stk TTOF i = peekOffBi stk i >>= \t -> case readMaybe $ Util.Text.unpack t of Nothing -> do stk <- bump stk @@ -1626,7 +1630,7 @@ bprim1 !stk TTOF i = pokeTag stk 1 pokeOffD stk 1 f pure stk -bprim1 !stk VWLS i = +bprim1 !_env !stk VWLS i = peekOffS stk i >>= \case Sq.Empty -> do stk <- bump stk @@ -1638,7 +1642,7 @@ bprim1 !stk VWLS i = pokeOff stk 1 x -- head pokeTag stk 1 -- ':<|' tag pure stk -bprim1 !stk VWRS i = +bprim1 !_env !stk VWRS i = peekOffS stk i >>= \case Sq.Empty -> do stk <- bump stk @@ -1650,7 +1654,7 @@ bprim1 !stk VWRS i = pokeOffS stk 1 xs -- remaining seq pokeTag stk 1 -- ':|>' tag pure stk -bprim1 !stk PAKT i = do +bprim1 !_env !stk PAKT i = do s <- peekOffS stk i stk <- bump stk pokeBi stk . Util.Text.pack . toList $ val2char <$> s @@ -1659,7 +1663,7 @@ bprim1 !stk PAKT i = do val2char :: Val -> Char val2char (CharVal c) = c val2char c = error $ "pack text: non-character closure: " ++ show c -bprim1 !stk UPKT i = do +bprim1 !_env !stk UPKT i = do t <- peekOffBi stk i stk <- bump stk pokeS stk @@ -1668,7 +1672,7 @@ bprim1 !stk UPKT i = do . Util.Text.unpack $ t pure stk -bprim1 !stk PAKB i = do +bprim1 !_env !stk PAKB i = do s <- peekOffS stk i stk <- bump stk pokeBi stk . By.fromWord8s . fmap val2w8 $ toList s @@ -1678,18 +1682,18 @@ bprim1 !stk PAKB i = do val2w8 :: Val -> Word8 val2w8 (NatVal n) = toEnum . fromEnum $ n val2w8 c = error $ "pack bytes: non-natural closure: " ++ show c -bprim1 !stk UPKB i = do +bprim1 !_env !stk UPKB i = do b <- peekOffBi stk i stk <- bump stk pokeS stk . Sq.fromList . fmap (NatVal . toEnum @Word64 . fromEnum @Word8) $ By.toWord8s b pure stk -bprim1 !stk SIZB i = do +bprim1 !_env !stk SIZB i = do b <- peekOffBi stk i stk <- bump stk unsafePokeIasN stk $ By.size b pure stk -bprim1 !stk FLTB i = do +bprim1 !_env !stk FLTB i = do b <- peekOffBi stk i stk <- bump stk pokeBi stk $ By.flatten b @@ -1702,13 +1706,13 @@ bprim1 !stk FLTB i = do -- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2 -- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286 -- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298 -bprim1 !stk REFR i = do +bprim1 !_env !stk REFR i = do (ref :: IORef Val) <- peekOffBi stk i v <- IORef.readIORef ref stk <- bump stk poke stk v pure stk -bprim1 !stk REFN i = do +bprim1 !_env !stk REFN i = do -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal -- forcing of the values and tickets. @@ -1717,13 +1721,15 @@ bprim1 !stk REFN i = do stk <- bump stk pokeBi stk ref pure stk -bprim1 !stk RRFC i = do - (ref :: IORef Val) <- peekOffBi stk i - ticket <- Atomic.readForCAS ref - stk <- bump stk - pokeBi stk ticket - pure stk -bprim1 !stk TIKR i = do +bprim1 !env !stk RRFC i + | sandboxed env = die "attempted to use sandboxed operation: Ref.readForCAS" + | otherwise = do + (ref :: IORef Val) <- peekOffBi stk i + ticket <- Atomic.readForCAS ref + stk <- bump stk + pokeBi stk ticket + pure stk +bprim1 !_env !stk TIKR i = do (t :: Atomic.Ticket Val) <- peekOffBi stk i stk <- bump stk let v = Atomic.peekTicket t @@ -1731,15 +1737,15 @@ bprim1 !stk TIKR i = do pure stk -- impossible -bprim1 !stk MISS _ = pure stk -bprim1 !stk CACH _ = pure stk -bprim1 !stk LKUP _ = pure stk -bprim1 !stk CVLD _ = pure stk -bprim1 !stk TLTT _ = pure stk -bprim1 !stk LOAD _ = pure stk -bprim1 !stk VALU _ = pure stk -bprim1 !stk DBTX _ = pure stk -bprim1 !stk SDBL _ = pure stk +bprim1 !_env !stk MISS _ = pure stk +bprim1 !_env !stk CACH _ = pure stk +bprim1 !_env !stk LKUP _ = pure stk +bprim1 !_env !stk CVLD _ = pure stk +bprim1 !_env !stk TLTT _ = pure stk +bprim1 !_env !stk LOAD _ = pure stk +bprim1 !_env !stk VALU _ = pure stk +bprim1 !_env !stk DBTX _ = pure stk +bprim1 !_env !stk SDBL _ = pure stk {-# INLINE bprim1 #-} bprim2 :: @@ -2261,7 +2267,8 @@ cacheAdd0 ntys0 termSuperGroups sands cc = do newCombRefs <- updateMap combRefUpdates (combRefs cc) (unresolvedNewCombs, unresolvedCacheableCombs, unresolvedNonCacheableCombs, updatedCombs) <- stateTVar (combs cc) \oldCombs -> let unresolvedNewCombs :: EnumMap Word64 (GCombs any CombIx) - unresolvedNewCombs = absurdCombs . mapFromList $ zipWith combinate [ntm ..] rgs + unresolvedNewCombs = + absurdCombs . sanitizeCombs (sandboxed cc) sandboxedForeignFuncs . mapFromList $ zipWith combinate [ntm ..] rgs (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = EC.mapToList unresolvedNewCombs & foldMap \(w, gcombs) -> if EC.member w newCacheableCombs diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index 7b1eb787b3..10fac3e1a2 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -44,6 +44,7 @@ library Unison.Runtime.Exception Unison.Runtime.Foreign Unison.Runtime.Foreign.Function + Unison.Runtime.Foreign.Function.Type Unison.Runtime.Foreign.Impl Unison.Runtime.Interface Unison.Runtime.IOSource From 7baa4689a7c8a12c13844f671518c29eef75c8d1 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Mon, 9 Dec 2024 12:07:42 -0500 Subject: [PATCH 10/36] add failing transcript --- unison-src/transcripts/idempotent/fix-5489.md | 42 +++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 unison-src/transcripts/idempotent/fix-5489.md diff --git a/unison-src/transcripts/idempotent/fix-5489.md b/unison-src/transcripts/idempotent/fix-5489.md new file mode 100644 index 0000000000..d4decb0f7e --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5489.md @@ -0,0 +1,42 @@ +``` unison +namespace foo +type Foo = Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type foo.Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type foo.Foo +``` + +``` unison +namespace foo +type Foo = Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type foo.Foo +``` From dfac40452a6f97796c2d095c674a3eaec9d81743 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 9 Dec 2024 13:22:40 -0800 Subject: [PATCH 11/36] Get Stack unboxing more reliably --- .../src/Unison/Runtime/Foreign/Function.hs | 100 ++- .../src/Unison/Runtime/Foreign/Impl.hs | 636 +++++++++++++++++- unison-runtime/src/Unison/Runtime/Machine.hs | 5 +- unison-runtime/src/Unison/Runtime/Stack.hs | 14 +- 4 files changed, 737 insertions(+), 18 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 335d9ff61d..e322c5920c 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -7,10 +7,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -module Unison.Runtime.Foreign.Function - ( ForeignConvention (..), - ) -where +module Unison.Runtime.Foreign.Function () where import Control.Concurrent (ThreadId) import Control.Concurrent.MVar (MVar) @@ -58,81 +55,111 @@ class ForeignConvention a where instance ForeignConvention Int where readForeign (i : args) stk = (args,) <$> peekOffI stk i readForeign [] _ = foreignCCError "Int" + {-# INLINE readForeign #-} writeForeign stk i = do stk <- bump stk stk <$ pokeI stk i + {-# INLINE writeForeign #-} instance ForeignConvention Word64 where readForeign (i : args) stk = (args,) <$> peekOffN stk i readForeign [] _ = foreignCCError "Word64" + {-# INLINE readForeign #-} writeForeign stk n = do stk <- bump stk stk <$ pokeN stk n + {-# INLINE writeForeign #-} -- 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) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64) + {-# INLINE writeForeign #-} instance ForeignConvention Word16 where readForeign = readForeignAs (fromIntegral :: Word64 -> Word16) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (fromIntegral :: Word16 -> Word64) + {-# INLINE writeForeign #-} instance ForeignConvention Word32 where readForeign = readForeignAs (fromIntegral :: Word64 -> Word32) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64) + {-# INLINE writeForeign #-} instance ForeignConvention Char where readForeign (i : args) stk = (args,) <$> peekOffC stk i readForeign [] _ = foreignCCError "Char" + {-# INLINE readForeign #-} writeForeign stk ch = do stk <- bump stk stk <$ pokeC stk ch + {-# INLINE writeForeign #-} instance ForeignConvention Val where readForeign (i : args) stk = (args,) <$> peekOff stk i readForeign [] _ = foreignCCError "Val" + {-# INLINE readForeign #-} writeForeign stk v = do stk <- bump stk stk <$ (poke stk =<< evaluate v) + {-# INLINE writeForeign #-} -- 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" + {-# INLINE readForeign #-} writeForeign stk c = do stk <- bump stk stk <$ (bpoke stk =<< evaluate c) + {-# INLINE writeForeign #-} instance ForeignConvention Text where readForeign = readForeignBuiltin + {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} instance ForeignConvention Bytes where readForeign = readForeignBuiltin + {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} instance ForeignConvention Socket where readForeign = readForeignBuiltin + {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} instance ForeignConvention UDPSocket where readForeign = readForeignBuiltin + {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} instance ForeignConvention ThreadId where readForeign = readForeignBuiltin + {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} instance ForeignConvention Handle where readForeign = readForeignBuiltin + {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} instance ForeignConvention POSIXTime where readForeign = readForeignAs (fromIntegral :: Int -> POSIXTime) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (round :: POSIXTime -> Int) + {-# INLINE writeForeign #-} instance (ForeignConvention a) => ForeignConvention (Maybe a) where readForeign (i : args) stk = @@ -141,6 +168,7 @@ instance (ForeignConvention a) => ForeignConvention (Maybe a) where 1 -> fmap Just <$> readForeign args stk _ -> foreignCCError "Maybe" readForeign [] _ = foreignCCError "Maybe" + {-# INLINE readForeign #-} writeForeign stk Nothing = do stk <- bump stk @@ -149,6 +177,7 @@ instance (ForeignConvention a) => ForeignConvention (Maybe a) where stk <- writeForeign stk x stk <- bump stk stk <$ pokeTag stk 1 + {-# INLINE writeForeign #-} instance (ForeignConvention a, ForeignConvention b) => @@ -160,6 +189,7 @@ instance 1 -> readForeignAs Right args stk _ -> foreignCCError "Either" readForeign _ _ = foreignCCError "Either" + {-# INLINE readForeign #-} writeForeign stk (Left a) = do stk <- writeForeign stk a @@ -169,6 +199,7 @@ instance stk <- writeForeign stk b stk <- bump stk stk <$ pokeTag stk 1 + {-# INLINE writeForeign #-} ioeDecode :: Int -> IOErrorType ioeDecode 0 = AlreadyExists @@ -196,8 +227,10 @@ instance ForeignConvention IOException where readForeign = readForeignAs (bld . ioeDecode) where bld t = IOError Nothing t "" "" Nothing Nothing + {-# INLINE readForeign #-} writeForeign = writeForeignAs (ioeEncode . ioe_type) + {-# INLINE writeForeign #-} readForeignAs :: (ForeignConvention a) => @@ -258,36 +291,48 @@ readTypelink = readForeignAs (unwrapForeign . marshalToForeign) instance ForeignConvention Double where readForeign (i : args) stk = (args,) <$> peekOffD stk i readForeign _ _ = foreignCCError "Double" + {-# INLINE readForeign #-} writeForeign stk d = bump stk >>= \stk -> do pokeD stk d pure stk + {-# INLINE writeForeign #-} instance ForeignConvention Bool where readForeign (i : args) stk = do b <- peekOffBool stk i pure (args, b) readForeign _ _ = foreignCCError "Bool" + {-# INLINE readForeign #-} writeForeign stk b = do stk <- bump stk pokeBool stk b pure stk + {-# INLINE writeForeign #-} instance ForeignConvention String where readForeign = readForeignAs unpack + {-# INLINE readForeign #-} writeForeign = writeForeignAs pack + {-# INLINE writeForeign #-} instance ForeignConvention SeekMode where readForeign = readForeignEnum + {-# INLINE readForeign #-} writeForeign = writeForeignEnum + {-# INLINE writeForeign #-} instance ForeignConvention IOMode where readForeign = readForeignEnum + {-# INLINE readForeign #-} writeForeign = writeForeignEnum + {-# INLINE writeForeign #-} instance ForeignConvention () where readForeign args _ = pure (args, ()) + {-# INLINE readForeign #-} writeForeign stk _ = pure stk + {-# INLINE writeForeign #-} instance (ForeignConvention a, ForeignConvention b) => @@ -297,10 +342,12 @@ instance (args, a) <- readForeign args stk (args, b) <- readForeign args stk pure (args, (a, b)) + {-# INLINE readForeign #-} writeForeign stk (x, y) = do stk <- writeForeign stk y writeForeign stk x + {-# INLINE writeForeign #-} instance (ForeignConvention a) => ForeignConvention (Failure a) where readForeign args stk = do @@ -308,11 +355,13 @@ instance (ForeignConvention a) => ForeignConvention (Failure a) where (args, message) <- readForeign args stk (args, any) <- readForeign args stk pure (args, Failure typeref message any) + {-# INLINE readForeign #-} writeForeign stk (Failure typeref message any) = do stk <- writeForeign stk any stk <- writeForeign stk message writeTypeLink stk typeref + {-# INLINE writeForeign #-} instance ( ForeignConvention a, @@ -326,11 +375,13 @@ instance (args, b) <- readForeign args stk (args, c) <- readForeign args stk pure (args, (a, b, c)) + {-# INLINE readForeign #-} writeForeign stk (a, b, c) = do stk <- writeForeign stk c stk <- writeForeign stk b writeForeign stk a + {-# INLINE writeForeign #-} instance ( ForeignConvention a, @@ -346,12 +397,14 @@ instance (args, c) <- readForeign args stk (args, d) <- readForeign args stk pure (args, (a, b, c, d)) + {-# INLINE readForeign #-} writeForeign stk (a, b, c, d) = do stk <- writeForeign stk d stk <- writeForeign stk c stk <- writeForeign stk b writeForeign stk a + {-# INLINE writeForeign #-} instance ( ForeignConvention a, @@ -369,6 +422,7 @@ instance (args, d) <- readForeign args stk (args, e) <- readForeign args stk pure (args, (a, b, c, d, e)) + {-# INLINE readForeign #-} writeForeign stk (a, b, c, d, e) = do stk <- writeForeign stk e @@ -376,6 +430,7 @@ instance stk <- writeForeign stk c stk <- writeForeign stk b writeForeign stk a + {-# INLINE writeForeign #-} no'buf, line'buf, block'buf, sblock'buf :: Word64 no'buf = fromIntegral Ty.bufferModeNoBufferingId @@ -397,6 +452,7 @@ instance ForeignConvention BufferMode where foreignCCError $ "BufferMode (unknown tag: " <> show t <> ")" readForeign _ _ = foreignCCError $ "BufferMode (empty stack)" + {-# INLINE readForeign #-} writeForeign stk bm = bump stk >>= \stk -> @@ -408,6 +464,7 @@ instance ForeignConvention BufferMode where pokeI stk n stk <- bump stk stk <$ pokeN stk sblock'buf + {-# INLINE writeForeign #-} -- 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. @@ -415,9 +472,11 @@ instance {-# OVERLAPPING #-} ForeignConvention [Val] where readForeign (i : args) stk = (args,) . toList <$> peekOffS stk i readForeign _ _ = foreignCCError "[Val]" + {-# INLINE readForeign #-} writeForeign stk l = do stk <- bump stk stk <$ pokeS stk (Sq.fromList l) + {-# INLINE writeForeign #-} -- 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. @@ -425,65 +484,95 @@ instance {-# OVERLAPPING #-} ForeignConvention [Closure] where readForeign (i : args) stk = (args,) . fmap getBoxedVal . toList <$> peekOffS stk i readForeign _ _ = foreignCCError "[Closure]" + {-# INLINE readForeign #-} writeForeign stk l = do stk <- bump stk stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l) + {-# INLINE writeForeign #-} instance ForeignConvention [Foreign] where readForeign = readForeignAs (fmap marshalToForeign) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (fmap Foreign) + {-# INLINE writeForeign #-} instance ForeignConvention (MVar Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap mvarRef) + {-# INLINE writeForeign #-} instance ForeignConvention (TVar Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap tvarRef) + {-# INLINE writeForeign #-} instance ForeignConvention (IORef Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap refRef) + {-# INLINE writeForeign #-} instance ForeignConvention (Ticket Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap ticketRef) + {-# INLINE writeForeign #-} instance ForeignConvention (Promise Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap promiseRef) + {-# INLINE writeForeign #-} instance ForeignConvention Code where readForeign = readForeignBuiltin + {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} instance ForeignConvention Value where readForeign = readForeignBuiltin + {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} instance ForeignConvention Foreign where readForeign = readForeignAs marshalToForeign + {-# INLINE readForeign #-} writeForeign = writeForeignAs Foreign + {-# INLINE writeForeign #-} instance ForeignConvention (PA.MutableArray s Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap marrayRef) + {-# INLINE writeForeign #-} instance ForeignConvention (PA.MutableByteArray s) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef) + {-# INLINE writeForeign #-} instance ForeignConvention (PA.Array Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap iarrayRef) + {-# INLINE writeForeign #-} instance ForeignConvention PA.ByteArray where readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap ibytearrayRef) + {-# INLINE writeForeign #-} instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where readForeign = readForeignBuiltin + {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} fromUnisonPair :: (BuiltinForeign a, BuiltinForeign b) => Closure -> (a, b) fromUnisonPair (DataC _ _ [BoxedVal x, BoxedVal (DataC _ _ [BoxedVal y, BoxedVal _unit])]) = @@ -511,6 +600,7 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignCon . toList <$> peekOffS stk i readForeign _ _ = foreignCCError "[(a,b)]" + {-# INLINE readForeign #-} writeForeign stk l = do stk <- bump stk @@ -523,9 +613,11 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where . toList <$> peekOffS stk i readForeign _ _ = foreignCCError "[b]" + {-# INLINE readForeign #-} writeForeign stk l = do stk <- bump stk stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l) + {-# INLINE writeForeign #-} foreignCCError :: String -> IO a foreignCCError nm = diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs index e924243759..961498bd82 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + module Unison.Runtime.Foreign.Impl (foreignCall) where import Control.Concurrent (ThreadId) @@ -6,6 +9,7 @@ import Control.Concurrent as SYS threadDelay, ) import Control.Concurrent.MVar as SYS +import Control.Concurrent.STM (TVar) import Control.Concurrent.STM qualified as STM import Control.DeepSeq (NFData) import Control.Exception @@ -18,16 +22,20 @@ import Crypto.MAC.HMAC qualified as HMAC import Crypto.PubKey.Ed25519 qualified as Ed25519 import Crypto.PubKey.RSA.PKCS15 qualified as RSA import Crypto.Random (getRandomBytes) +import Data.Atomics (Ticket) import Data.Bits (shiftL, shiftR, (.|.)) import Data.ByteArray qualified as BA import Data.ByteString (hGet, hGetSome, hPut) import Data.ByteString.Lazy qualified as L import Data.Default (def) import Data.Digest.Murmur64 (asWord64, hash64) +import Data.IORef (IORef) import Data.IP (IP) import Data.PEM (PEM, pemContent, pemParseLBS) +import Data.Sequence qualified as Sq import Data.Text qualified import Data.Text.IO qualified as Text.IO +import Data.Time.Clock.POSIX (POSIXTime) import Data.Time.Clock.POSIX as SYS ( getPOSIXTime, posixSecondsToUTCTime, @@ -39,6 +47,7 @@ import Data.X509.CertificateStore qualified as X import Data.X509.Memory qualified as X import GHC.Conc qualified as STM import GHC.IO (IO (IO)) +import GHC.IO.Exception (IOErrorType (..), IOException (..)) import Network.Simple.TCP as SYS ( HostPreference (..), bindSock, @@ -48,6 +57,7 @@ import Network.Simple.TCP as SYS recv, send, ) +import Network.Socket (Socket) import Network.Socket as SYS ( PortNumber, Socket, @@ -56,10 +66,10 @@ import Network.Socket as SYS ) import Network.TLS as TLS import Network.TLS.Extra.Cipher as Cipher +import Network.UDP (UDPSocket) import Network.UDP as UDP ( ClientSockAddr, ListenSocket, - UDPSocket (..), clientSocket, close, recv, @@ -91,7 +101,7 @@ import System.Environment as SYS ) import System.Exit as SYS (ExitCode (..)) import System.FilePath (isPathSeparator) -import System.IO (Handle) +import System.IO (BufferMode (..), Handle, IOMode, SeekMode) import System.IO as SYS ( IOMode (..), hClose, @@ -125,21 +135,34 @@ import Unison.Builtin.Decls qualified as Ty import Unison.Prelude hiding (Text, some) import Unison.Reference import Unison.Referent (Referent, pattern Ref) +import Unison.Runtime.ANF (Code, PackedTag (..), Value, internalBug) import Unison.Runtime.ANF qualified as ANF import Unison.Runtime.ANF.Rehash (checkGroupHashes) import Unison.Runtime.ANF.Serialize qualified as ANF import Unison.Runtime.Array qualified as PA import Unison.Runtime.Builtin import Unison.Runtime.Crypto.Rsa qualified as Rsa -import Unison.Runtime.Exception (die) +import Unison.Runtime.Exception import Unison.Runtime.Foreign hiding (Failure) import Unison.Runtime.Foreign qualified as F -import Unison.Runtime.Foreign.Function (ForeignConvention (..)) import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) import Unison.Runtime.MCode import Unison.Runtime.Stack import Unison.Symbol +import Unison.Type + ( iarrayRef, + ibytearrayRef, + marrayRef, + mbytearrayRef, + mvarRef, + promiseRef, + refRef, + ticketRef, + tvarRef, + typeLinkRef, + ) import Unison.Type qualified as Ty +import Unison.Util.Bytes (Bytes) import Unison.Util.Bytes qualified as Bytes import Unison.Util.RefPromise ( Promise, @@ -148,13 +171,18 @@ import Unison.Util.RefPromise tryReadPromise, writePromise, ) -import Unison.Util.Text (Text) +import Unison.Util.Text (Text, pack, unpack) import Unison.Util.Text qualified as Util.Text import Unison.Util.Text.Pattern qualified as TPat import UnliftIO qualified -foreignCall :: ForeignFunc -> Args -> Stack -> IO Stack -foreignCall = \case +foreignCall :: ForeignFunc -> Args -> XStack -> IOXStack +foreignCall !ff !args !xstk = + stackIOToIOX $ foreignCallHelper ff args (packXStack xstk) +{-# INLINE foreignCall #-} + +foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO Stack +foreignCallHelper = \case IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> let hostStr = Util.Text.toString host portStr = Util.Text.toString port @@ -861,16 +889,16 @@ foreignCall = \case pure $ case e of Left se -> Left (Util.Text.pack (show se)) Right a -> Right a -{-# INLINE foreignCall #-} +{-# INLINE foreignCallHelper #-} mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack -mkForeign f args stk = do +mkForeign !f !args !stk = do args <- decodeArgs args stk res <- f args writeForeign stk res where decodeArgs :: (ForeignConvention x) => Args -> Stack -> IO x - decodeArgs args stk = + decodeArgs !args !stk = readForeign (argsToLists args) stk >>= \case ([], a) -> pure a _ -> @@ -910,6 +938,7 @@ mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) flatten (Right (Right a)) = Right a +{-# INLINE mkForeignTls #-} mkForeignTlsE :: forall a r. @@ -929,9 +958,11 @@ mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) flatten (Right (Right (Left e))) = Left e flatten (Right (Right (Right a))) = Right a +{-# INLINE mkForeignTlsE #-} unsafeSTMToIO :: STM.STM a -> IO a unsafeSTMToIO (STM.STM m) = IO m +{-# INLINE unsafeSTMToIO #-} signEd25519Wrapper :: (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes @@ -1275,3 +1306,588 @@ checkedIndex64 name (arr, i) = (PA.indexByteArray arr (j + 5)) (PA.indexByteArray arr (j + 6)) (PA.indexByteArray arr (j + 7)) + +class ForeignConvention a where + readForeign :: + [Int] -> Stack -> IO ([Int], a) + writeForeign :: + Stack -> a -> IO Stack + +instance ForeignConvention Int where + readForeign !(i : args) !stk = (args,) <$> peekOffI stk i + readForeign ![] !_ = foreignCCError "Int" + {-# INLINE readForeign #-} + writeForeign !stk !i = do + stk <- bump stk + stk <$ pokeI stk i + {-# INLINE writeForeign #-} + +instance ForeignConvention Word64 where + readForeign !(i : args) !stk = (args,) <$> peekOffN stk i + readForeign ![] !_ = foreignCCError "Word64" + {-# INLINE readForeign #-} + writeForeign !stk !n = do + stk <- bump stk + stk <$ pokeN stk n + {-# INLINE writeForeign #-} + +-- 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) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64) + {-# INLINE writeForeign #-} + +instance ForeignConvention Word16 where + readForeign = readForeignAs (fromIntegral :: Word64 -> Word16) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (fromIntegral :: Word16 -> Word64) + {-# INLINE writeForeign #-} + +instance ForeignConvention Word32 where + readForeign = readForeignAs (fromIntegral :: Word64 -> Word32) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64) + {-# INLINE writeForeign #-} + +instance ForeignConvention Char where + readForeign !(i : args) !stk = (args,) <$> peekOffC stk i + readForeign ![] !_ = foreignCCError "Char" + {-# INLINE readForeign #-} + writeForeign !stk !ch = do + stk <- bump stk + stk <$ pokeC stk ch + {-# INLINE writeForeign #-} + +instance ForeignConvention Val where + readForeign !(i : args) !stk = (args,) <$> peekOff stk i + readForeign ![] !_ = foreignCCError "Val" + {-# INLINE readForeign #-} + writeForeign !stk !v = do + stk <- bump stk + stk <$ (poke stk =<< evaluate v) + {-# INLINE writeForeign #-} + +-- 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" + {-# INLINE readForeign #-} + writeForeign !stk !c = do + stk <- bump stk + stk <$ (bpoke stk =<< evaluate c) + {-# INLINE writeForeign #-} + +instance ForeignConvention Text where + readForeign = readForeignBuiltin + {-# INLINE readForeign #-} + writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} + +instance ForeignConvention Unison.Util.Bytes.Bytes where + readForeign = readForeignBuiltin + {-# INLINE readForeign #-} + writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} + +instance ForeignConvention Socket where + readForeign = readForeignBuiltin + {-# INLINE readForeign #-} + writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} + +instance ForeignConvention UDPSocket where + readForeign = readForeignBuiltin + {-# INLINE readForeign #-} + writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} + +instance ForeignConvention ThreadId where + readForeign = readForeignBuiltin + {-# INLINE readForeign #-} + writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} + +instance ForeignConvention Handle where + readForeign = readForeignBuiltin + {-# INLINE readForeign #-} + writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} + +instance ForeignConvention POSIXTime where + readForeign = readForeignAs (fromIntegral :: Int -> POSIXTime) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (round :: POSIXTime -> Int) + {-# INLINE writeForeign #-} + +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" + {-# INLINE readForeign #-} + + 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 + {-# INLINE writeForeign #-} + +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" + {-# INLINE readForeign #-} + + 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 + {-# INLINE writeForeign #-} + +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 + {-# INLINE readForeign #-} + + writeForeign = writeForeignAs (ioeEncode . ioe_type) + {-# INLINE writeForeign #-} + +readForeignAs :: + (ForeignConvention a) => + (a -> b) -> + [Int] -> + Stack -> + IO ([Int], b) +readForeignAs !f !args !stk = fmap f <$> readForeign args stk +{-# INLINE readForeignAs #-} + +writeForeignAs :: + (ForeignConvention b) => + (a -> b) -> + Stack -> + a -> + IO Stack +writeForeignAs !f !stk !x = writeForeign stk (f x) +{-# INLINE writeForeignAs #-} + +readForeignEnum :: + (Enum a) => + [Int] -> + Stack -> + IO ([Int], a) +readForeignEnum = readForeignAs toEnum +{-# INLINE readForeignEnum #-} + +writeForeignEnum :: + (Enum a) => + Stack -> + a -> + IO Stack +writeForeignEnum = writeForeignAs fromEnum +{-# INLINE writeForeignEnum #-} + +readForeignBuiltin :: + (BuiltinForeign b) => + [Int] -> + Stack -> + IO ([Int], b) +readForeignBuiltin = readForeignAs (unwrapBuiltin . marshalToForeign) +{-# INLINE readForeignBuiltin #-} + +writeForeignBuiltin :: + (BuiltinForeign b) => + Stack -> + b -> + IO Stack +writeForeignBuiltin = writeForeignAs (Foreign . wrapBuiltin) +{-# INLINE writeForeignBuiltin #-} + +writeTypeLink :: + Stack -> + Reference -> + IO Stack +writeTypeLink = writeForeignAs (Foreign . Wrap typeLinkRef) +{-# INLINE writeTypeLink #-} + +readTypelink :: + [Int] -> + Stack -> + IO ([Int], Reference) +readTypelink = readForeignAs (unwrapForeign . marshalToForeign) +{-# INLINE readTypelink #-} + +instance ForeignConvention Double where + readForeign !(i : args) !stk = (args,) <$> peekOffD stk i + readForeign !_ !_ = foreignCCError "Double" + {-# INLINE readForeign #-} + writeForeign !stk !d = + bump stk >>= \(!stk) -> do + pokeD stk d + pure stk + {-# INLINE writeForeign #-} + +instance ForeignConvention Bool where + readForeign !(i : args) !stk = do + b <- peekOffBool stk i + pure (args, b) + readForeign !_ !_ = foreignCCError "Bool" + {-# INLINE readForeign #-} + writeForeign !stk !b = do + stk <- bump stk + pokeBool stk b + pure stk + {-# INLINE writeForeign #-} + +instance ForeignConvention String where + readForeign = readForeignAs unpack + {-# INLINE readForeign #-} + writeForeign = writeForeignAs pack + {-# INLINE writeForeign #-} + +instance ForeignConvention SeekMode where + readForeign = readForeignEnum + {-# INLINE readForeign #-} + writeForeign = writeForeignEnum + {-# INLINE writeForeign #-} + +instance ForeignConvention IOMode where + readForeign = readForeignEnum + {-# INLINE readForeign #-} + writeForeign = writeForeignEnum + {-# INLINE writeForeign #-} + +instance ForeignConvention () where + readForeign args !_ = pure (args, ()) + {-# INLINE readForeign #-} + writeForeign !stk !_ = pure stk + {-# INLINE writeForeign #-} + +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)) + {-# INLINE readForeign #-} + + writeForeign !stk !(x, y) = do + stk <- writeForeign stk y + writeForeign stk x + {-# INLINE writeForeign #-} + +instance (ForeignConvention a) => ForeignConvention (F.Failure a) where + readForeign !args !stk = do + (args, typeref) <- readTypelink args stk + (args, message) <- readForeign args stk + (args, any) <- readForeign args stk + pure (args, F.Failure typeref message any) + {-# INLINE readForeign #-} + + writeForeign !stk !(F.Failure typeref message any) = do + stk <- writeForeign stk any + stk <- writeForeign stk message + writeTypeLink stk typeref + {-# INLINE writeForeign #-} + +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)) + {-# INLINE readForeign #-} + + writeForeign !stk !(a, b, c) = do + stk <- writeForeign stk c + stk <- writeForeign stk b + writeForeign stk a + {-# INLINE writeForeign #-} + +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)) + {-# INLINE readForeign #-} + + writeForeign !stk !(a, b, c, d) = do + stk <- writeForeign stk d + stk <- writeForeign stk c + stk <- writeForeign stk b + writeForeign stk a + {-# INLINE writeForeign #-} + +instance + ( ForeignConvention a, + ForeignConvention b, + ForeignConvention c, + ForeignConvention d, + ForeignConvention e + ) => + 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)) + {-# INLINE readForeign #-} + + 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 + {-# INLINE writeForeign #-} + +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 + +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)" + {-# INLINE readForeign #-} + + 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 + {-# INLINE writeForeign #-} + +-- 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]" + {-# INLINE readForeign #-} + writeForeign !stk !l = do + stk <- bump stk + stk <$ pokeS stk (Sq.fromList l) + {-# INLINE writeForeign #-} + +-- 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]" + {-# INLINE readForeign #-} + writeForeign !stk !l = do + stk <- bump stk + stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l) + {-# INLINE writeForeign #-} + +instance ForeignConvention [Foreign] where + readForeign = readForeignAs (fmap marshalToForeign) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (fmap Foreign) + {-# INLINE writeForeign #-} + +instance ForeignConvention (MVar Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (Foreign . Wrap mvarRef) + {-# INLINE writeForeign #-} + +instance ForeignConvention (TVar Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (Foreign . Wrap tvarRef) + {-# INLINE writeForeign #-} + +instance ForeignConvention (IORef Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (Foreign . Wrap refRef) + {-# INLINE writeForeign #-} + +instance ForeignConvention (Ticket Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (Foreign . Wrap ticketRef) + {-# INLINE writeForeign #-} + +instance ForeignConvention (Promise Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (Foreign . Wrap promiseRef) + {-# INLINE writeForeign #-} + +instance ForeignConvention Code where + readForeign = readForeignBuiltin + {-# INLINE readForeign #-} + writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} + +instance ForeignConvention Value where + readForeign = readForeignBuiltin + {-# INLINE readForeign #-} + writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} + +instance ForeignConvention Foreign where + readForeign = readForeignAs marshalToForeign + {-# INLINE readForeign #-} + writeForeign = writeForeignAs Foreign + {-# INLINE writeForeign #-} + +instance ForeignConvention (PA.MutableArray s Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (Foreign . Wrap marrayRef) + {-# INLINE writeForeign #-} + +instance ForeignConvention (PA.MutableByteArray s) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef) + {-# INLINE writeForeign #-} + +instance ForeignConvention (PA.Array Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (Foreign . Wrap iarrayRef) + {-# INLINE writeForeign #-} + +instance ForeignConvention PA.ByteArray where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + {-# INLINE readForeign #-} + writeForeign = writeForeignAs (Foreign . Wrap ibytearrayRef) + {-# INLINE writeForeign #-} + +instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where + readForeign = readForeignBuiltin + {-# INLINE readForeign #-} + writeForeign = writeForeignBuiltin + {-# INLINE writeForeign #-} + +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)]" + {-# INLINE readForeign #-} + + 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]" + {-# INLINE readForeign #-} + writeForeign !stk !l = do + stk <- bump stk + stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l) + {-# INLINE writeForeign #-} + +foreignCCError :: String -> IO a +foreignCCError nm = + die $ "mismatched foreign calling convention for `" ++ nm ++ "`" diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 9356bd4dc0..e05cc558c2 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -591,8 +591,9 @@ exec !_ !denv !_activeThreads !stk !k _ (Seq as) = do stk <- bump stk pokeS stk $ Sq.fromList l pure (denv, stk, k) -exec !_env !denv !_activeThreads !stk !k _ (ForeignCall _ func args) = - (denv,,k) <$> foreignCall func args stk +exec !_env !denv !_activeThreads !stk !k _ (ForeignCall _ func args) = do + stk <- xStackIOToIO $ foreignCall func args (unpackXStack stk) + pure (denv, stk, k) exec !env !denv !activeThreads !stk !k _ (Fork i) | sandboxed env = die "attempted to use sandboxed operation: fork" | otherwise = do diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index 3747114de6..33e5e8bd0e 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -34,7 +34,9 @@ module Unison.Runtime.Stack pattern XStack, packXStack, unpackXStack, - IOStack, + xStackIOToIO, + stackIOToIOX, + IOXStack, apX, fpX, spX, @@ -639,7 +641,7 @@ data Stack = Stack -- Unboxed representation of the Stack, used to force GHC optimizations in a few spots. type XStack = (# Int#, Int#, Int#, MutableByteArray# (PrimState IO), MutableArray# (PrimState IO) Closure #) -type IOStack = State# RealWorld -> (# State# RealWorld, XStack #) +type IOXStack = State# RealWorld -> (# State# RealWorld, 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) @@ -656,6 +658,14 @@ unpackXStack :: Stack -> XStack unpackXStack (Stack (I# ap) (I# fp) (I# sp) (MutableByteArray ustk) (MutableArray bstk)) = (# ap, fp, sp, ustk, bstk #) {-# INLINE unpackXStack #-} +xStackIOToIO :: IOXStack -> IO Stack +xStackIOToIO f = IO $ \s -> case f s of (# s', x #) -> (# s', packXStack x #) +{-# INLINE xStackIOToIO #-} + +stackIOToIOX :: IO Stack -> IOXStack +stackIOToIOX (IO f) = \s -> case f s of (# s', x #) -> (# s', unpackXStack x #) +{-# INLINE stackIOToIOX #-} + instance Show Stack where show (Stack ap fp sp _ _) = "Stack " ++ show ap ++ " " ++ show fp ++ " " ++ show sp From 5e2b968e3ade67af91f7f91ab58eb6631a4ca29a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 9 Dec 2024 16:29:53 -0800 Subject: [PATCH 12/36] Inline argsToLists --- unison-runtime/src/Unison/Runtime/Foreign/Impl.hs | 2 +- unison-runtime/src/Unison/Runtime/MCode.hs | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs index 961498bd82..c698ef15f2 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -179,7 +179,7 @@ import UnliftIO qualified foreignCall :: ForeignFunc -> Args -> XStack -> IOXStack foreignCall !ff !args !xstk = stackIOToIOX $ foreignCallHelper ff args (packXStack xstk) -{-# INLINE foreignCall #-} +{-# NOINLINE foreignCall #-} foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO Stack foreignCallHelper = \case diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index ee3a682858..032bfa354d 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -285,6 +285,7 @@ argsToLists = \case VArgR i l -> take l [i ..] VArgN us -> primArrayToList us VArgV _ -> internalBug "argsToLists: DArgV" +{-# INLINEABLE argsToLists #-} countArgs :: Args -> Int countArgs ZArgs = 0 @@ -293,6 +294,7 @@ countArgs (VArg2 {}) = 2 countArgs (VArgR _ l) = l countArgs (VArgN us) = sizeofPrimArray us countArgs (VArgV {}) = internalBug "countArgs: DArgV" +{-# INLINEABLE countArgs #-} data UPrim1 = -- integral From 30609ee223ec9eba6bbbf8a6c794d4db514c5fb5 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Tue, 10 Dec 2024 11:48:58 -0500 Subject: [PATCH 13/36] small term printer refactor --- .../src/Unison/Syntax/TermPrinter.hs | 57 ++++++++++--------- 1 file changed, 31 insertions(+), 26 deletions(-) diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index e516fb404a..283bd6991f 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -209,8 +209,7 @@ pretty0 blockContext = bc, infixContext = ic, imports = im, - docContext = doc, - elideUnit = elideUnit + docContext = doc } term = specialCases term \case @@ -360,7 +359,7 @@ pretty0 ] LetBlock bs e -> let (im', uses) = calcImports im term - in printLet elideUnit bc bs e im' uses + in printLet a {imports = im'} bc bs e uses -- Some matches are rendered as a destructuring bind, like -- match foo with (a,b) -> blah -- becomes @@ -641,29 +640,6 @@ pretty0 sepList' f sep xs = fold . intersperse sep <$> traverse f xs varList = runIdentity . sepList' (Identity . PP.text . Var.name) PP.softbreak - printLet :: - Bool -> -- elideUnit - BlockContext -> - [(v, Term3 v PrintAnnotation)] -> - Term3 v PrintAnnotation -> - Imports -> - [Pretty SyntaxText] -> - m (Pretty SyntaxText) - printLet elideUnit sc bs e im uses = do - bs <- traverse printBinding bs - body <- body e - pure . paren (sc /= Block && p >= Top) . letIntro $ PP.lines (uses <> bs <> body) - where - body (Constructor' (ConstructorReference DD.UnitRef 0)) | elideUnit = pure [] - body e = (: []) <$> pretty0 (ac Annotation Normal im doc) e - printBinding (v, binding) = - if Var.isAction v - then pretty0 (ac Bottom Normal im doc) binding - else renderPrettyBinding <$> prettyBinding0' (ac Bottom Normal im doc) (HQ.unsafeFromVar v) binding - letIntro = case sc of - Block -> id - Normal -> \x -> fmt S.ControlKeyword "let" `PP.hang` x - nonForcePred :: Term3 v PrintAnnotation -> Bool nonForcePred = \case Constructor' (ConstructorReference DD.DocRef _) -> False @@ -672,6 +648,35 @@ pretty0 nonUnitArgPred :: (Var v) => v -> Bool nonUnitArgPred v = Var.name v /= "()" +printLet :: + (MonadPretty v m) => + AmbientContext -> + BlockContext -> + [(v, Term3 v PrintAnnotation)] -> + Term3 v PrintAnnotation -> + [Pretty SyntaxText] -> + m (Pretty SyntaxText) +printLet context sc bs e uses = do + bs <- traverse (printLetBinding bindingContext) bs + body <- body e + pure . paren (sc /= Block && context.precedence >= Top) . letIntro $ PP.lines (uses <> bs <> body) + where + bindingContext :: AmbientContext + bindingContext = + ac Bottom Normal context.imports context.docContext + body = \case + Constructor' (ConstructorReference DD.UnitRef 0) | context.elideUnit -> pure [] + e -> List.singleton <$> pretty0 (ac Annotation Normal context.imports context.docContext) e + letIntro = case sc of + Block -> id + Normal -> (fmt S.ControlKeyword "let" `PP.hang`) + +printLetBinding :: (MonadPretty v m) => AmbientContext -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText) +printLetBinding context (v, binding) = + if Var.isAction v + then pretty0 context binding + else renderPrettyBinding <$> prettyBinding0' context (HQ.unsafeFromVar v) binding + prettyPattern :: forall v loc. (Var v) => From ef2df9464219608888f5576524924ba1eb406b0a Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Tue, 10 Dec 2024 12:23:15 -0500 Subject: [PATCH 14/36] add another failing transcript --- unison-src/transcripts/idempotent/fix-5427.md | 61 ++++++++++++++++++- 1 file changed, 59 insertions(+), 2 deletions(-) diff --git a/unison-src/transcripts/idempotent/fix-5427.md b/unison-src/transcripts/idempotent/fix-5427.md index 6455f38eed..8812085e66 100644 --- a/unison-src/transcripts/idempotent/fix-5427.md +++ b/unison-src/transcripts/idempotent/fix-5427.md @@ -1,3 +1,60 @@ +# Issue 1 + +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +foo : Nat +foo = 17 + +bar : Nat +bar = + foo _ = + _ = foo + .foo + foo() +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat + +scratch/main> view bar + + bar : Nat + bar = + foo1 _ = + _ = foo + foo + foo() +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +# Issue 2 + ``` ucm scratch/main> builtins.merge lib.builtin @@ -25,7 +82,7 @@ baz = foo + foo change: ⍟ These new definitions are ok to `add`: - + bar : Nat baz : Nat foo : Nat @@ -60,7 +117,7 @@ bar = ⍟ These names already exist. You can `update` them to your new definition: - + bar : Nat foo : Nat ``` From d272484805021c75f6feb6ab4c992f0f22863c70 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Tue, 10 Dec 2024 12:35:07 -0500 Subject: [PATCH 15/36] reset vars in a couple more places --- parser-typechecker/src/Unison/Syntax/TermPrinter.hs | 6 +++--- unison-src/transcripts/idempotent/fix-5427.md | 10 +++++----- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index 283bd6991f..d864435c57 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -675,7 +675,7 @@ printLetBinding :: (MonadPretty v m) => AmbientContext -> (v, Term3 v PrintAnnot printLetBinding context (v, binding) = if Var.isAction v then pretty0 context binding - else renderPrettyBinding <$> prettyBinding0' context (HQ.unsafeFromVar v) binding + else renderPrettyBinding <$> prettyBinding0' context (HQ.unsafeFromVar (Var.reset v)) binding prettyPattern :: forall v loc. @@ -1317,7 +1317,7 @@ printAnnotate n tm = Set.fromList [n | v <- ABT.allVars tm, n <- varToName v] usedTypeNames = Set.fromList [n | Ann' _ ty <- ABT.subterms tm, v <- ABT.allVars ty, n <- varToName v] - varToName v = toList (Name.parseText (Var.name v)) + varToName = toList . Name.parseText . Var.name . Var.reset go :: (Ord v) => Term2 v at ap v b -> Term2 v () () v b go = extraMap' id (const ()) (const ()) @@ -2213,7 +2213,7 @@ avoidShadowing tm (PrettyPrintEnv terms types) = in (HQ'.NameOnly fullName, HQ'.NameOnly resuffixifiedName) tweak _ p = p varToName :: (Var v) => v -> [Name] - varToName = toList . Name.parseText . Var.name + varToName = toList . Name.parseText . Var.name . Var.reset isLeaf :: Term2 vt at ap v a -> Bool isLeaf (Var' {}) = True diff --git a/unison-src/transcripts/idempotent/fix-5427.md b/unison-src/transcripts/idempotent/fix-5427.md index 8812085e66..cf8b25ef81 100644 --- a/unison-src/transcripts/idempotent/fix-5427.md +++ b/unison-src/transcripts/idempotent/fix-5427.md @@ -26,7 +26,7 @@ bar = change: ⍟ These new definitions are ok to `add`: - + bar : Nat foo : Nat ``` @@ -43,9 +43,9 @@ scratch/main> view bar bar : Nat bar = - foo1 _ = + foo _ = _ = foo - foo + .foo foo() ``` @@ -82,7 +82,7 @@ baz = foo + foo change: ⍟ These new definitions are ok to `add`: - + bar : Nat baz : Nat foo : Nat @@ -117,7 +117,7 @@ bar = ⍟ These names already exist. You can `update` them to your new definition: - + bar : Nat foo : Nat ``` From adc5f2039a9172d2580217df316182bb7257e53b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 10 Dec 2024 09:41:36 -0800 Subject: [PATCH 16/36] Fix MCode Serialization tests --- .../tests/Unison/Test/Runtime/MCode/Serialization.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs b/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs index 1b95a96b40..a9b82a272a 100644 --- a/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs +++ b/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs @@ -13,6 +13,7 @@ import Hedgehog hiding (Rec, Test, test) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Unison.Prelude +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) import Unison.Runtime.Interface import Unison.Runtime.MCode (Args (..), BPrim1, BPrim2, Branch, Comb, CombIx (..), GBranch (..), GComb (..), GCombInfo (..), GInstr (..), GRef (..), GSection (..), Instr, MLit (..), Ref, Section, UPrim1, UPrim2) import Unison.Runtime.Machine (Combs) @@ -33,6 +34,9 @@ test = ] EasyTest.expect success +genForeignCall :: Gen ForeignFunc +genForeignCall = Gen.enumBounded + genEnumMap :: (EC.EnumKey k) => Gen k -> Gen v -> Gen (EnumMap k v) genEnumMap genK genV = EC.mapFromList <$> Gen.list (Range.linear 0 10) ((,) <$> genK <*> genV) @@ -116,7 +120,7 @@ genInstr = UPrim2 <$> genUPrim2 <*> genSmallInt <*> genSmallInt, BPrim1 <$> genBPrim1 <*> genSmallInt, BPrim2 <$> genBPrim2 <*> genSmallInt <*> genSmallInt, - ForeignCall <$> Gen.bool <*> genSmallWord64 <*> genArgs, + ForeignCall <$> Gen.bool <*> genForeignCall <*> genArgs, SetDyn <$> genSmallWord64 <*> genSmallInt, Capture <$> genSmallWord64, Name <$> genGRef <*> genArgs, From 2dddbdfe939016e20897cf0f49c7fdd6433380b4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 10 Dec 2024 10:06:45 -0800 Subject: [PATCH 17/36] Replace unused Foreign Function module with Impl --- .../src/Unison/Runtime/Foreign/Function.hs | 1423 ++++++++++++- .../src/Unison/Runtime/Foreign/Impl.hs | 1893 ----------------- unison-runtime/src/Unison/Runtime/Machine.hs | 2 +- unison-runtime/unison-runtime.cabal | 1 - 4 files changed, 1347 insertions(+), 1972 deletions(-) delete mode 100644 unison-runtime/src/Unison/Runtime/Foreign/Impl.hs diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index e322c5920c..f8ef85c88c 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -1,35 +1,154 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -module Unison.Runtime.Foreign.Function () where +module Unison.Runtime.Foreign.Function (foreignCall) where import Control.Concurrent (ThreadId) -import Control.Concurrent.MVar (MVar) +import Control.Concurrent as SYS + ( killThread, + threadDelay, + ) +import Control.Concurrent.MVar as SYS import Control.Concurrent.STM (TVar) -import Control.Exception (evaluate) +import Control.Concurrent.STM qualified as STM +import Control.DeepSeq (NFData) +import Control.Exception +import Control.Exception.Safe qualified as Exception +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Primitive qualified as PA +import Crypto.Error (CryptoError (..), CryptoFailable (..)) +import Crypto.Hash qualified as Hash +import Crypto.MAC.HMAC qualified as HMAC +import Crypto.PubKey.Ed25519 qualified as Ed25519 +import Crypto.PubKey.RSA.PKCS15 qualified as RSA +import Crypto.Random (getRandomBytes) import Data.Atomics (Ticket) -import Data.Foldable (toList) +import Data.Bits (shiftL, shiftR, (.|.)) +import Data.ByteArray qualified as BA +import Data.ByteString (hGet, hGetSome, hPut) +import Data.ByteString.Lazy qualified as L +import Data.Default (def) +import Data.Digest.Murmur64 (asWord64, hash64) import Data.IORef (IORef) +import Data.IP (IP) +import Data.PEM (PEM, pemContent, pemParseLBS) import Data.Sequence qualified as Sq +import Data.Text qualified +import Data.Text.IO qualified as Text.IO import Data.Time.Clock.POSIX (POSIXTime) -import Data.Word (Word16, Word32, Word64, Word8) +import Data.Time.Clock.POSIX as SYS + ( getPOSIXTime, + posixSecondsToUTCTime, + utcTimeToPOSIXSeconds, + ) +import Data.Time.LocalTime (TimeZone (..), getTimeZone) +import Data.X509 qualified as X +import Data.X509.CertificateStore qualified as X +import Data.X509.Memory qualified as X +import GHC.Conc qualified as STM +import GHC.IO (IO (IO)) import GHC.IO.Exception (IOErrorType (..), IOException (..)) +import Network.Simple.TCP as SYS + ( HostPreference (..), + bindSock, + closeSock, + connectSock, + listenSock, + recv, + send, + ) import Network.Socket (Socket) +import Network.Socket as SYS + ( PortNumber, + Socket, + accept, + socketPort, + ) +import Network.TLS as TLS +import Network.TLS.Extra.Cipher as Cipher import Network.UDP (UDPSocket) +import Network.UDP as UDP + ( ClientSockAddr, + ListenSocket, + clientSocket, + close, + recv, + recvFrom, + send, + sendTo, + serverSocket, + stop, + ) +import System.Clock (Clock (..), getTime, nsec, sec) +import System.Directory as SYS + ( createDirectoryIfMissing, + doesDirectoryExist, + doesPathExist, + getCurrentDirectory, + getDirectoryContents, + getFileSize, + getModificationTime, + getTemporaryDirectory, + removeDirectoryRecursive, + removeFile, + renameDirectory, + renameFile, + setCurrentDirectory, + ) +import System.Environment as SYS + ( getArgs, + getEnv, + ) +import System.Exit as SYS (ExitCode (..)) +import System.FilePath (isPathSeparator) import System.IO (BufferMode (..), Handle, IOMode, SeekMode) +import System.IO as SYS + ( IOMode (..), + hClose, + hGetBuffering, + hGetChar, + hGetEcho, + hIsEOF, + hIsOpen, + hIsSeekable, + hReady, + hSeek, + hSetBuffering, + hSetEcho, + hTell, + openFile, + stderr, + stdin, + stdout, + ) +import System.IO.Temp (createTempDirectory) +import System.Process as SYS + ( getProcessExitCode, + proc, + runInteractiveProcess, + terminateProcess, + waitForProcess, + withCreateProcess, + ) +import System.X509 qualified as X import Unison.Builtin.Decls qualified as Ty -import Unison.Reference (Reference) +import Unison.Prelude hiding (Text, some) +import Unison.Reference +import Unison.Referent (Referent, pattern Ref) import Unison.Runtime.ANF (Code, PackedTag (..), Value, internalBug) +import Unison.Runtime.ANF qualified as ANF +import Unison.Runtime.ANF.Rehash (checkGroupHashes) +import Unison.Runtime.ANF.Serialize qualified as ANF import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Builtin +import Unison.Runtime.Crypto.Rsa qualified as Rsa import Unison.Runtime.Exception -import Unison.Runtime.Foreign +import Unison.Runtime.Foreign hiding (Failure) +import Unison.Runtime.Foreign qualified as F +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) +import Unison.Runtime.MCode import Unison.Runtime.Stack +import Unison.Symbol import Unison.Type ( iarrayRef, ibytearrayRef, @@ -42,9 +161,1151 @@ import Unison.Type tvarRef, typeLinkRef, ) +import Unison.Type qualified as Ty import Unison.Util.Bytes (Bytes) -import Unison.Util.RefPromise (Promise) +import Unison.Util.Bytes qualified as Bytes +import Unison.Util.RefPromise + ( Promise, + newPromise, + readPromise, + tryReadPromise, + writePromise, + ) import Unison.Util.Text (Text, pack, unpack) +import Unison.Util.Text qualified as Util.Text +import Unison.Util.Text.Pattern qualified as TPat +import UnliftIO qualified + +foreignCall :: ForeignFunc -> Args -> XStack -> IOXStack +foreignCall !ff !args !xstk = + stackIOToIOX $ foreignCallHelper ff args (packXStack xstk) +{-# NOINLINE foreignCall #-} + +foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO Stack +foreignCallHelper = \case + IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> + let hostStr = Util.Text.toString host + portStr = Util.Text.toString port + in UDP.clientSocket hostStr portStr True + IO_UDP_UDPSocket_recv_impl_v1 -> mkForeignIOF $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock + IO_UDP_UDPSocket_send_impl_v1 -> mkForeignIOF $ + \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> + UDP.send sock (Bytes.toArray bytes) + IO_UDP_UDPSocket_close_impl_v1 -> mkForeignIOF $ + \(sock :: UDPSocket) -> UDP.close sock + IO_UDP_ListenSocket_close_impl_v1 -> mkForeignIOF $ + \(sock :: ListenSocket) -> UDP.stop sock + IO_UDP_UDPSocket_toText_impl_v1 -> mkForeign $ + \(sock :: UDPSocket) -> pure $ show sock + IO_UDP_serverSocket_impl_v1 -> mkForeignIOF $ + \(ip :: Util.Text.Text, port :: Util.Text.Text) -> + let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP + maybePort = readMaybe $ Util.Text.toString port :: Maybe PortNumber + in case (maybeIp, maybePort) of + (Nothing, _) -> fail "Invalid IP Address" + (_, Nothing) -> fail "Invalid Port Number" + (Just ip, Just pt) -> UDP.serverSocket (ip, pt) + IO_UDP_ListenSocket_toText_impl_v1 -> mkForeign $ + \(sock :: ListenSocket) -> pure $ show sock + IO_UDP_ListenSocket_recvFrom_impl_v1 -> + mkForeignIOF $ + fmap (first Bytes.fromArray) <$> UDP.recvFrom + IO_UDP_ClientSockAddr_toText_v1 -> mkForeign $ + \(sock :: ClientSockAddr) -> pure $ show sock + 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) -> + 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 + IO_isFileOpen_impl_v3 -> mkForeignIOF hIsOpen + IO_getEcho_impl_v1 -> mkForeignIOF hGetEcho + IO_ready_impl_v1 -> mkForeignIOF hReady + IO_getChar_impl_v1 -> mkForeignIOF hGetChar + IO_isSeekable_impl_v3 -> mkForeignIOF hIsSeekable + IO_seekHandle_impl_v3 -> mkForeignIOF $ + \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) + IO_handlePosition_impl_v3 -> + -- TODO: truncating integer + mkForeignIOF $ + \h -> fromInteger @Word64 <$> hTell h + IO_getBuffering_impl_v3 -> mkForeignIOF hGetBuffering + IO_setBuffering_impl_v3 -> + mkForeignIOF $ + uncurry hSetBuffering + IO_setEcho_impl_v1 -> mkForeignIOF $ uncurry hSetEcho + IO_getLine_impl_v1 -> + mkForeignIOF $ + fmap Util.Text.fromText . Text.IO.hGetLine + IO_getBytes_impl_v3 -> mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGet h n + IO_getSomeBytes_impl_v1 -> mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGetSome h n + IO_putBytes_impl_v3 -> mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) + IO_systemTime_impl_v3 -> mkForeignIOF $ + \() -> getPOSIXTime + IO_systemTimeMicroseconds_v1 -> mkForeign $ + \() -> fmap (1e6 *) getPOSIXTime + Clock_internals_monotonic_v1 -> mkForeignIOF $ + \() -> getTime Monotonic + Clock_internals_realtime_v1 -> mkForeignIOF $ + \() -> getTime Realtime + Clock_internals_processCPUTime_v1 -> mkForeignIOF $ + \() -> getTime ProcessCPUTime + Clock_internals_threadCPUTime_v1 -> mkForeignIOF $ + \() -> getTime ThreadCPUTime + Clock_internals_sec_v1 -> mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) + Clock_internals_nsec_v1 -> mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) + Clock_internals_systemTimeZone_v1 -> + mkForeign + ( \secs -> do + TimeZone offset summer name <- getTimeZone (posixSecondsToUTCTime (fromIntegral (secs :: Int))) + pure (offset :: Int, summer, name) + ) + IO_getTempDirectory_impl_v3 -> + mkForeignIOF $ + \() -> chop <$> getTemporaryDirectory + IO_createTempDirectory_impl_v3 -> mkForeignIOF $ \prefix -> do + temp <- getTemporaryDirectory + chop <$> createTempDirectory temp prefix + IO_getCurrentDirectory_impl_v3 -> mkForeignIOF $ + \() -> getCurrentDirectory + IO_setCurrentDirectory_impl_v3 -> mkForeignIOF setCurrentDirectory + IO_fileExists_impl_v3 -> mkForeignIOF doesPathExist + IO_getEnv_impl_v1 -> mkForeignIOF getEnv + IO_getArgs_impl_v1 -> mkForeignIOF $ + \() -> fmap Util.Text.pack <$> SYS.getArgs + IO_isDirectory_impl_v3 -> mkForeignIOF doesDirectoryExist + IO_createDirectory_impl_v3 -> + mkForeignIOF $ + createDirectoryIfMissing True + IO_removeDirectory_impl_v3 -> mkForeignIOF removeDirectoryRecursive + IO_renameDirectory_impl_v3 -> + mkForeignIOF $ + uncurry renameDirectory + IO_directoryContents_impl_v3 -> + mkForeignIOF $ + (fmap Util.Text.pack <$>) . getDirectoryContents + IO_removeFile_impl_v3 -> mkForeignIOF removeFile + IO_renameFile_impl_v3 -> + mkForeignIOF $ + uncurry renameFile + IO_getFileTimestamp_impl_v3 -> + mkForeignIOF $ + fmap utcTimeToPOSIXSeconds . getModificationTime + IO_getFileSize_impl_v3 -> + -- TODO: truncating integer + mkForeignIOF $ + \fp -> fromInteger @Word64 <$> getFileSize fp + IO_serverSocket_impl_v3 -> + mkForeignIOF $ + \( mhst :: Maybe Util.Text.Text, + port + ) -> + fst <$> SYS.bindSock (hostPreference mhst) port + Socket_toText -> mkForeign $ + \(sock :: Socket) -> pure $ show sock + Handle_toText -> mkForeign $ + \(hand :: Handle) -> pure $ show hand + ThreadId_toText -> mkForeign $ + \(threadId :: ThreadId) -> pure $ show threadId + IO_socketPort_impl_v3 -> mkForeignIOF $ + \(handle :: Socket) -> do + n <- SYS.socketPort handle + return (fromIntegral n :: Word64) + IO_listen_impl_v3 -> mkForeignIOF $ + \sk -> SYS.listenSock sk 2048 + IO_clientSocket_impl_v3 -> + mkForeignIOF $ + fmap fst . uncurry SYS.connectSock + IO_closeSocket_impl_v3 -> mkForeignIOF SYS.closeSock + IO_socketAccept_impl_v3 -> + mkForeignIOF $ + fmap fst . SYS.accept + IO_socketSend_impl_v3 -> mkForeignIOF $ + \(sk, bs) -> SYS.send sk (Bytes.toArray bs) + IO_socketReceive_impl_v3 -> mkForeignIOF $ + \(hs, n) -> + maybe mempty Bytes.fromArray <$> SYS.recv hs n + 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." + IO_process_call -> mkForeign $ + \(exe, map Util.Text.unpack -> args) -> + withCreateProcess (proc exe args) $ \_ _ _ p -> + exitDecode <$> waitForProcess p + IO_process_start -> mkForeign $ \(exe, map Util.Text.unpack -> args) -> + runInteractiveProcess exe args Nothing Nothing + IO_process_kill -> mkForeign $ terminateProcess + IO_process_wait -> mkForeign $ + \ph -> exitDecode <$> waitForProcess ph + IO_process_exitCode -> + mkForeign $ + fmap (fmap exitDecode) . getProcessExitCode + MVar_new -> mkForeign $ + \(c :: Val) -> newMVar c + MVar_newEmpty_v2 -> mkForeign $ + \() -> newEmptyMVar @Val + MVar_take_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> takeMVar mv + MVar_tryTake -> mkForeign $ + \(mv :: MVar Val) -> tryTakeMVar mv + MVar_put_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> putMVar mv x + MVar_tryPut_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> tryPutMVar mv x + MVar_swap_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> swapMVar mv x + MVar_isEmpty -> mkForeign $ + \(mv :: MVar Val) -> isEmptyMVar mv + MVar_read_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> readMVar mv + MVar_tryRead_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> tryReadMVar mv + Char_toText -> mkForeign $ + \(ch :: Char) -> pure (Util.Text.singleton ch) + Text_repeat -> mkForeign $ + \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) + Text_reverse -> + mkForeign $ + pure . Util.Text.reverse + Text_toUppercase -> + mkForeign $ + pure . Util.Text.toUppercase + Text_toLowercase -> + mkForeign $ + pure . Util.Text.toLowercase + Text_toUtf8 -> + mkForeign $ + pure . Util.Text.toUtf8 + Text_fromUtf8_impl_v3 -> + mkForeign $ + pure . mapLeft (\t -> F.Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 + Tls_ClientConfig_default -> mkForeign $ + \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> + fmap + ( \store -> + (defaultParamsClient (Util.Text.unpack hostName) (Bytes.toArray serverId)) + { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, + TLS.clientShared = def {TLS.sharedCAStore = store} + } + ) + X.getSystemCertificateStore + Tls_ServerConfig_default -> + mkForeign $ + \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> + pure $ + (def :: TLS.ServerParams) + { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, + TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]} + } + Tls_ClientConfig_certificates_set -> + let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams + updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} + in mkForeign $ + \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params + Tls_ServerConfig_certificates_set -> + let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams + updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} + in mkForeign $ + \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params + TVar_new -> mkForeign $ + \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c + TVar_read -> mkForeign $ + \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v + TVar_write -> mkForeign $ + \(v :: STM.TVar Val, c :: Val) -> + unsafeSTMToIO $ STM.writeTVar v c + TVar_newIO -> mkForeign $ + \(c :: Val) -> STM.newTVarIO c + TVar_readIO -> mkForeign $ + \(v :: STM.TVar Val) -> STM.readTVarIO v + TVar_swap -> mkForeign $ + \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c + STM_retry -> mkForeign $ + \() -> unsafeSTMToIO STM.retry :: IO Val + Promise_new -> mkForeign $ + \() -> newPromise @Val + Promise_read -> mkForeign $ + \(p :: Promise Val) -> readPromise p + Promise_tryRead -> mkForeign $ + \(p :: Promise Val) -> tryReadPromise p + Promise_write -> mkForeign $ + \(p :: Promise Val, a :: Val) -> writePromise p a + Tls_newClient_impl_v3 -> + mkForeignTls $ + \( config :: TLS.ClientParams, + socket :: SYS.Socket + ) -> TLS.contextNew socket config + Tls_newServer_impl_v3 -> + mkForeignTls $ + \( config :: TLS.ServerParams, + socket :: SYS.Socket + ) -> TLS.contextNew socket config + Tls_handshake_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> TLS.handshake tls + Tls_send_impl_v3 -> + mkForeignTls $ + \( tls :: TLS.Context, + bytes :: Bytes.Bytes + ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) + Tls_decodeCert_impl_v3 -> + let wrapFailure t = F.Failure Ty.tlsFailureRef (Util.Text.pack t) unitValue + decoded :: Bytes.Bytes -> Either String PEM + decoded bytes = case pemParseLBS $ Bytes.toLazyByteString bytes of + Right (pem : _) -> Right pem + Right [] -> Left "no PEM found" + Left l -> Left l + asCert :: PEM -> Either String X.SignedCertificate + asCert pem = X.decodeSignedCertificate $ pemContent pem + in mkForeignTlsE $ + \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes + Tls_encodeCert -> mkForeign $ + \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert + Tls_decodePrivateKey -> mkForeign $ + \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes + Tls_encodePrivateKey -> mkForeign $ + \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey + Tls_receive_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> do + bs <- TLS.recvData tls + pure $ Bytes.fromArray bs + Tls_terminate_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> TLS.bye tls + Code_validateLinks -> mkForeign $ + \(lsgs0 :: [(Referent, ANF.Code)]) -> do + let f (msg, rs) = + F.Failure Ty.miscFailureRef (Util.Text.fromText msg) rs + pure . first f $ checkGroupHashes lsgs0 + Code_dependencies -> mkForeign $ + \(ANF.CodeRep sg _) -> + pure $ Wrap Ty.termLinkRef . Ref <$> ANF.groupTermLinks sg + Code_serialize -> mkForeign $ + \(co :: ANF.Code) -> + pure . Bytes.fromArray $ ANF.serializeCode builtinForeignNames co + Code_deserialize -> + mkForeign $ + pure . ANF.deserializeCode . Bytes.toArray + Code_display -> mkForeign $ + \(nm, (ANF.CodeRep sg _)) -> + pure $ ANF.prettyGroup @Symbol (Util.Text.unpack nm) sg "" + Value_dependencies -> + mkForeign $ + pure . fmap (Wrap Ty.termLinkRef . Ref) . ANF.valueTermLinks + Value_serialize -> + mkForeign $ + pure . Bytes.fromArray . ANF.serializeValue + Value_deserialize -> + mkForeign $ + pure . ANF.deserializeValue . Bytes.toArray + Crypto_HashAlgorithm_Sha3_512 -> mkHashAlgorithm "Sha3_512" Hash.SHA3_512 + Crypto_HashAlgorithm_Sha3_256 -> mkHashAlgorithm "Sha3_256" Hash.SHA3_256 + Crypto_HashAlgorithm_Sha2_512 -> mkHashAlgorithm "Sha2_512" Hash.SHA512 + Crypto_HashAlgorithm_Sha2_256 -> mkHashAlgorithm "Sha2_256" Hash.SHA256 + Crypto_HashAlgorithm_Sha1 -> mkHashAlgorithm "Sha1" Hash.SHA1 + Crypto_HashAlgorithm_Blake2b_512 -> mkHashAlgorithm "Blake2b_512" Hash.Blake2b_512 + Crypto_HashAlgorithm_Blake2b_256 -> mkHashAlgorithm "Blake2b_256" Hash.Blake2b_256 + Crypto_HashAlgorithm_Blake2s_256 -> mkHashAlgorithm "Blake2s_256" Hash.Blake2s_256 + Crypto_HashAlgorithm_Md5 -> mkHashAlgorithm "Md5" Hash.MD5 + Crypto_hashBytes -> mkForeign $ + \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> + let ctx = Hash.hashInitWith alg + in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) + Crypto_hmacBytes -> mkForeign $ + \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> + let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) + u :: a -> HMAC.HMAC a -> HMAC.HMAC a + u _ h = h -- to help typechecker along + in pure $ Bytes.fromArray out + Crypto_hash -> mkForeign $ + \(HashAlgorithm _ alg, x) -> + let hashlazy :: + (Hash.HashAlgorithm a) => + a -> + L.ByteString -> + Hash.Digest a + hashlazy _ l = Hash.hashlazy l + in pure . Bytes.fromArray . hashlazy alg $ ANF.serializeValueForHash x + Crypto_hmac -> mkForeign $ + \(HashAlgorithm _ alg, key, x) -> + let hmac :: + (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a + hmac _ s = + HMAC.finalize + . HMAC.updates + (HMAC.initialize $ Bytes.toArray @BA.Bytes key) + $ L.toChunks s + in pure . Bytes.fromArray . hmac alg $ ANF.serializeValueForHash x + Crypto_Ed25519_sign_impl -> + mkForeign $ + pure . signEd25519Wrapper + Crypto_Ed25519_verify_impl -> + mkForeign $ + pure . verifyEd25519Wrapper + Crypto_Rsa_sign_impl -> + mkForeign $ + pure . signRsaWrapper + Crypto_Rsa_verify_impl -> + mkForeign $ + pure . verifyRsaWrapper + Universal_murmurHash -> + mkForeign $ + pure . asWord64 . hash64 . ANF.serializeValueForHash + IO_randomBytes -> mkForeign $ + \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n + Bytes_zlib_compress -> mkForeign $ pure . Bytes.zlibCompress + Bytes_gzip_compress -> mkForeign $ pure . Bytes.gzipCompress + Bytes_zlib_decompress -> mkForeign $ \bs -> + catchAll (pure (Bytes.zlibDecompress bs)) + Bytes_gzip_decompress -> mkForeign $ \bs -> + catchAll (pure (Bytes.gzipDecompress bs)) + Bytes_toBase16 -> mkForeign $ pure . Bytes.toBase16 + Bytes_toBase32 -> mkForeign $ pure . Bytes.toBase32 + Bytes_toBase64 -> mkForeign $ pure . Bytes.toBase64 + Bytes_toBase64UrlUnpadded -> mkForeign $ pure . Bytes.toBase64UrlUnpadded + Bytes_fromBase16 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase16 + Bytes_fromBase32 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase32 + Bytes_fromBase64 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase64 + Bytes_fromBase64UrlUnpadded -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded + Bytes_decodeNat64be -> mkForeign $ pure . Bytes.decodeNat64be + Bytes_decodeNat64le -> mkForeign $ pure . Bytes.decodeNat64le + Bytes_decodeNat32be -> mkForeign $ pure . Bytes.decodeNat32be + Bytes_decodeNat32le -> mkForeign $ pure . Bytes.decodeNat32le + Bytes_decodeNat16be -> mkForeign $ pure . Bytes.decodeNat16be + Bytes_decodeNat16le -> mkForeign $ pure . Bytes.decodeNat16le + Bytes_encodeNat64be -> mkForeign $ pure . Bytes.encodeNat64be + Bytes_encodeNat64le -> mkForeign $ pure . Bytes.encodeNat64le + Bytes_encodeNat32be -> mkForeign $ pure . Bytes.encodeNat32be + Bytes_encodeNat32le -> mkForeign $ pure . Bytes.encodeNat32le + Bytes_encodeNat16be -> mkForeign $ pure . Bytes.encodeNat16be + Bytes_encodeNat16le -> mkForeign $ pure . Bytes.encodeNat16le + MutableArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "MutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ + Right + <$> PA.copyMutableArray @IO @Val + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + MutableByteArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "MutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ + Right + <$> PA.copyMutableByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + ImmutableArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "ImmutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofArray src) (soff + l - 1) $ + Right + <$> PA.copyArray @IO @Val + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + ImmutableArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofArray @Val + MutableArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Val + ImmutableByteArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofByteArray + MutableByteArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld + ImmutableByteArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "ImmutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ + Right + <$> PA.copyByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + MutableArray_read -> + mkForeign $ + checkedRead "MutableArray.read" + MutableByteArray_read8 -> + mkForeign $ + checkedRead8 "MutableByteArray.read8" + MutableByteArray_read16be -> + mkForeign $ + checkedRead16 "MutableByteArray.read16be" + MutableByteArray_read24be -> + mkForeign $ + checkedRead24 "MutableByteArray.read24be" + MutableByteArray_read32be -> + mkForeign $ + checkedRead32 "MutableByteArray.read32be" + MutableByteArray_read40be -> + mkForeign $ + checkedRead40 "MutableByteArray.read40be" + MutableByteArray_read64be -> + mkForeign $ + checkedRead64 "MutableByteArray.read64be" + MutableArray_write -> + mkForeign $ + checkedWrite "MutableArray.write" + MutableByteArray_write8 -> + mkForeign $ + checkedWrite8 "MutableByteArray.write8" + MutableByteArray_write16be -> + mkForeign $ + checkedWrite16 "MutableByteArray.write16be" + MutableByteArray_write32be -> + mkForeign $ + checkedWrite32 "MutableByteArray.write32be" + MutableByteArray_write64be -> + mkForeign $ + checkedWrite64 "MutableByteArray.write64be" + ImmutableArray_read -> + mkForeign $ + checkedIndex "ImmutableArray.read" + ImmutableByteArray_read8 -> + mkForeign $ + checkedIndex8 "ImmutableByteArray.read8" + ImmutableByteArray_read16be -> + mkForeign $ + checkedIndex16 "ImmutableByteArray.read16be" + ImmutableByteArray_read24be -> + mkForeign $ + checkedIndex24 "ImmutableByteArray.read24be" + ImmutableByteArray_read32be -> + mkForeign $ + checkedIndex32 "ImmutableByteArray.read32be" + ImmutableByteArray_read40be -> + mkForeign $ + checkedIndex40 "ImmutableByteArray.read40be" + ImmutableByteArray_read64be -> + mkForeign $ + checkedIndex64 "ImmutableByteArray.read64be" + MutableByteArray_freeze_force -> + mkForeign $ + PA.unsafeFreezeByteArray + MutableArray_freeze_force -> + mkForeign $ + PA.unsafeFreezeArray @IO @Val + MutableByteArray_freeze -> mkForeign $ + \(src, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 + else + checkBoundsPrim + "MutableByteArray.freeze" + (PA.sizeofMutableByteArray src) + (off + len) + 0 + $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) + MutableArray_freeze -> mkForeign $ + \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal + else + checkBounds + "MutableArray.freeze" + (PA.sizeofMutableArray src) + (off + len - 1) + $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) + MutableByteArray_length -> + mkForeign $ + pure . PA.sizeofMutableByteArray @PA.RealWorld + ImmutableByteArray_length -> + mkForeign $ + pure . PA.sizeofByteArray + IO_array -> mkForeign $ + \n -> PA.newArray n emptyVal + IO_arrayOf -> mkForeign $ + \(v :: Val, n) -> PA.newArray n v + IO_bytearray -> mkForeign $ PA.newByteArray + IO_bytearrayOf -> mkForeign $ + \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + Scope_array -> mkForeign $ + \n -> PA.newArray n emptyVal + Scope_arrayOf -> mkForeign $ + \(v :: Val, n) -> PA.newArray n v + Scope_bytearray -> mkForeign $ PA.newByteArray + Scope_bytearrayOf -> mkForeign $ + \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + Text_patterns_literal -> mkForeign $ + \txt -> evaluate . TPat.cpattern $ TPat.Literal txt + Text_patterns_digit -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v + Text_patterns_letter -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Letter)) in \() -> pure v + Text_patterns_space -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Whitespace)) in \() -> pure v + Text_patterns_punctuation -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Punctuation)) in \() -> pure v + Text_patterns_anyChar -> + mkForeign $ + let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v + Text_patterns_eof -> + mkForeign $ + let v = TPat.cpattern TPat.Eof in \() -> pure v + Text_patterns_charRange -> mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end + Text_patterns_notCharRange -> mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end + Text_patterns_charIn -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.charIn: non-character closure" + evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs + Text_patterns_notCharIn -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.notCharIn: non-character closure" + evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs + Pattern_many -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p + Pattern_many_corrected -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p + Pattern_capture -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p + Pattern_captureAs -> mkForeign $ + \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p + Pattern_join -> mkForeign $ \ps -> + evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps + Pattern_or -> mkForeign $ + \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r + Pattern_replicate -> mkForeign $ + \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> + let m = fromIntegral m0; n = fromIntegral n0 + in evaluate . TPat.cpattern $ TPat.Replicate m n p + Pattern_run -> mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input + Pattern_isMatch -> mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input + Char_Class_any -> mkForeign $ \() -> pure TPat.Any + Char_Class_not -> mkForeign $ pure . TPat.Not + Char_Class_and -> mkForeign $ \(a, b) -> pure $ TPat.Intersect a b + Char_Class_or -> mkForeign $ \(a, b) -> pure $ TPat.Union a b + Char_Class_range -> mkForeign $ \(a, b) -> pure $ TPat.CharRange a b + Char_Class_anyOf -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.charIn: non-character closure" + evaluate $ TPat.CharSet cs + Char_Class_alphanumeric -> mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) + Char_Class_upper -> mkForeign $ \() -> pure (TPat.CharClass TPat.Upper) + Char_Class_lower -> mkForeign $ \() -> pure (TPat.CharClass TPat.Lower) + Char_Class_whitespace -> mkForeign $ \() -> pure (TPat.CharClass TPat.Whitespace) + Char_Class_control -> mkForeign $ \() -> pure (TPat.CharClass TPat.Control) + Char_Class_printable -> mkForeign $ \() -> pure (TPat.CharClass TPat.Printable) + Char_Class_mark -> mkForeign $ \() -> pure (TPat.CharClass TPat.MarkChar) + Char_Class_number -> mkForeign $ \() -> pure (TPat.CharClass TPat.Number) + Char_Class_punctuation -> mkForeign $ \() -> pure (TPat.CharClass TPat.Punctuation) + Char_Class_symbol -> mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) + Char_Class_separator -> mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) + Char_Class_letter -> mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) + Char_Class_is -> mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c + Text_patterns_char -> mkForeign $ \c -> + let v = TPat.cpattern (TPat.Char c) in pure v + where + chop = reverse . dropWhile isPathSeparator . reverse + + hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference + hostPreference Nothing = SYS.HostAny + hostPreference (Just host) = SYS.Host $ Util.Text.unpack host + + mx :: Word64 + mx = fromIntegral (maxBound :: Int) + + customDelay :: Word64 -> IO () + customDelay n + | n < mx = threadDelay (fromIntegral n) + | otherwise = threadDelay maxBound >> customDelay (n - mx) + + exitDecode ExitSuccess = 0 + exitDecode (ExitFailure n) = n + + mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO Stack + mkHashAlgorithm txt alg = + let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) + in mkForeign $ \() -> pure (HashAlgorithm algoRef alg) + + catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) + catchAll e = do + e <- Exception.tryAnyDeep e + pure $ case e of + Left se -> Left (Util.Text.pack (show se)) + Right a -> Right a +{-# INLINE foreignCallHelper #-} + +mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack +mkForeign !f !args !stk = do + args <- decodeArgs args stk + res <- f args + writeForeign stk res + where + decodeArgs :: (ForeignConvention x) => Args -> Stack -> IO x + decodeArgs !args !stk = + readForeign (argsToLists args) stk >>= \case + ([], a) -> pure a + _ -> + error + "mkForeign: too many arguments for foreign function" +{-# INLINE mkForeign #-} + +mkForeignIOF :: + (ForeignConvention a, ForeignConvention r) => + (a -> IO r) -> + Args -> + Stack -> + IO Stack +mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) + where + tryIOE :: IO a -> IO (Either (F.Failure Val) a) + tryIOE = fmap handleIOE . UnliftIO.try + handleIOE :: Either IOException a -> Either (F.Failure Val) a + handleIOE (Left e) = Left $ F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue + handleIOE (Right a) = Right a +{-# INLINE mkForeignIOF #-} + +mkForeignTls :: + forall a r. + (ForeignConvention a, ForeignConvention r) => + (a -> IO r) -> + Args -> + Stack -> + IO Stack +mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO r -> IO (Either TLS.TLSException r) + tryIO1 = UnliftIO.try + tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) + tryIO2 = UnliftIO.try + flatten :: Either IOException (Either TLS.TLSException r) -> Either ((F.Failure Val)) r + flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Right a)) = Right a +{-# INLINE mkForeignTls #-} + +mkForeignTlsE :: + forall a r. + (ForeignConvention a, ForeignConvention r) => + (a -> IO (Either Failure r)) -> + Args -> + Stack -> + IO Stack +mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) + tryIO1 = UnliftIO.try + tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r))) + tryIO2 = UnliftIO.try + flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r + flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Right (Left e))) = Left e + flatten (Right (Right (Right a))) = Right a +{-# INLINE mkForeignTlsE #-} + +unsafeSTMToIO :: STM.STM a -> IO a +unsafeSTMToIO (STM.STM m) = IO m +{-# INLINE unsafeSTMToIO #-} + +signEd25519Wrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes +signEd25519Wrapper (secret0, public0, msg0) = case validated of + CryptoFailed err -> + Left (F.Failure Ty.cryptoFailureRef (errMsg err) unitValue) + CryptoPassed (secret, public) -> + Right . Bytes.fromArray $ Ed25519.sign secret public msg + where + msg = Bytes.toArray msg0 :: ByteString + validated = + (,) + <$> Ed25519.secretKey (Bytes.toArray secret0 :: ByteString) + <*> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) + + errMsg CryptoError_PublicKeySizeInvalid = + "ed25519: Public key size invalid" + errMsg CryptoError_SecretKeySizeInvalid = + "ed25519: Secret key size invalid" + errMsg CryptoError_SecretKeyStructureInvalid = + "ed25519: Secret key structure invalid" + errMsg _ = "ed25519: unexpected error" + +verifyEd25519Wrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool +verifyEd25519Wrapper (public0, msg0, sig0) = case validated of + CryptoFailed err -> + Left $ F.Failure Ty.cryptoFailureRef (errMsg err) unitValue + CryptoPassed (public, sig) -> + Right $ Ed25519.verify public msg sig + where + msg = Bytes.toArray msg0 :: ByteString + validated = + (,) + <$> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) + <*> Ed25519.signature (Bytes.toArray sig0 :: ByteString) + + errMsg CryptoError_PublicKeySizeInvalid = + "ed25519: Public key size invalid" + errMsg CryptoError_SecretKeySizeInvalid = + "ed25519: Secret key size invalid" + errMsg CryptoError_SecretKeyStructureInvalid = + "ed25519: Secret key structure invalid" + errMsg _ = "ed25519: unexpected error" + +signRsaWrapper :: + (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes +signRsaWrapper (secret0, msg0) = case validated of + Left err -> + Left (F.Failure Ty.cryptoFailureRef err unitValue) + Right secret -> + case RSA.sign Nothing (Just Hash.SHA256) secret msg of + Left err -> Left (F.Failure Ty.cryptoFailureRef (Rsa.rsaErrorToText err) unitValue) + Right signature -> Right $ Bytes.fromByteString signature + where + msg = Bytes.toArray msg0 :: ByteString + validated = Rsa.parseRsaPrivateKey (Bytes.toArray secret0 :: ByteString) + +verifyRsaWrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool +verifyRsaWrapper (public0, msg0, sig0) = case validated of + Left err -> + Left $ F.Failure Ty.cryptoFailureRef err unitValue + Right public -> + Right $ RSA.verify (Just Hash.SHA256) public msg sig + where + msg = Bytes.toArray msg0 :: ByteString + sig = Bytes.toArray sig0 :: ByteString + validated = Rsa.parseRsaPublicKey (Bytes.toArray public0 :: ByteString) + +type Failure = F.Failure Val + +checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBounds name l w act + | w < fromIntegral l = act + | otherwise = pure $ Left err + where + msg = name <> ": array index out of bounds" + err = F.Failure Ty.arrayFailureRef msg (natValue w) + +-- Performs a bounds check on a byte array. Strategy is as follows: +-- +-- isz = signed array size-in-bytes +-- off = unsigned byte offset into the array +-- esz = unsigned number of bytes to be read +-- +-- 1. Turn the signed size-in-bytes of the array unsigned +-- 2. Add the offset to the to-be-read number to get the maximum size needed +-- 3. Check that the actual array size is at least as big as the needed size +-- 4. Check that the offset is less than the size +-- +-- Step 4 ensures that step 3 has not overflowed. Since an actual array size can +-- only be 63 bits (since it is signed), the only way for 3 to overflow is if +-- the offset is larger than a possible array size, since it would need to be +-- 2^64-k, where k is the small (<=8) number of bytes to be read. +checkBoundsPrim :: + Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBoundsPrim name isz off esz act + | w > bsz || off > bsz = pure $ Left err + | otherwise = act + where + msg = name <> ": array index out of bounds" + err = F.Failure Ty.arrayFailureRef msg (natValue off) + + bsz = fromIntegral isz + w = off + esz + +type RW = PA.PrimState IO + +checkedRead :: + Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val) +checkedRead name (arr, w) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.readArray arr (fromIntegral w)) + +checkedWrite :: + Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ()) +checkedWrite name (arr, w, v) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.writeArray arr (fromIntegral w) v) + +checkedIndex :: + Text -> (PA.Array Val, Word64) -> IO (Either Failure Val) +checkedIndex name (arr, w) = + checkBounds + name + (PA.sizeofArray arr) + w + (Right <$> PA.indexArrayM arr (fromIntegral w)) + +checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead8 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ + (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j + where + j = fromIntegral i + +checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead16 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ + mk16 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + where + j = fromIntegral i + +checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead24 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ + mk24 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + where + j = fromIntegral i + +checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead32 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ + mk32 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + where + j = fromIntegral i + +checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead40 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ + mk40 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + where + j = fromIntegral i + +checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead64 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ + mk64 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + <*> PA.readByteArray @Word8 arr (j + 5) + <*> PA.readByteArray @Word8 arr (j + 6) + <*> PA.readByteArray @Word8 arr (j + 7) + where + j = fromIntegral i + +mk16 :: Word8 -> Word8 -> Either Failure Word64 +mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) + +mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk24 b0 b1 b2 = + Right $ + (fromIntegral b0 `shiftL` 16) + .|. (fromIntegral b1 `shiftL` 8) + .|. (fromIntegral b2) + +mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk32 b0 b1 b2 b3 = + Right $ + (fromIntegral b0 `shiftL` 24) + .|. (fromIntegral b1 `shiftL` 16) + .|. (fromIntegral b2 `shiftL` 8) + .|. (fromIntegral b3) + +mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk40 b0 b1 b2 b3 b4 = + Right $ + (fromIntegral b0 `shiftL` 32) + .|. (fromIntegral b1 `shiftL` 24) + .|. (fromIntegral b2 `shiftL` 16) + .|. (fromIntegral b3 `shiftL` 8) + .|. (fromIntegral b4) + +mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk64 b0 b1 b2 b3 b4 b5 b6 b7 = + Right $ + (fromIntegral b0 `shiftL` 56) + .|. (fromIntegral b1 `shiftL` 48) + .|. (fromIntegral b2 `shiftL` 40) + .|. (fromIntegral b3 `shiftL` 32) + .|. (fromIntegral b4 `shiftL` 24) + .|. (fromIntegral b5 `shiftL` 16) + .|. (fromIntegral b6 `shiftL` 8) + .|. (fromIntegral b7) + +checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite8 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do + PA.writeByteArray arr j (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite16 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite32 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite64 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) + PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +-- index single byte +checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex8 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ + let j = fromIntegral i + in Right . fromIntegral $ PA.indexByteArray @Word8 arr j + +-- index 16 big-endian +checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex16 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ + let j = fromIntegral i + in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) + +-- index 32 big-endian +checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex24 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ + let j = fromIntegral i + in mk24 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + +-- index 32 big-endian +checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex32 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ + let j = fromIntegral i + in mk32 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + +-- index 40 big-endian +checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex40 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ + let j = fromIntegral i + in mk40 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + +-- index 64 big-endian +checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex64 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ + let j = fromIntegral i + in mk64 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + (PA.indexByteArray arr (j + 5)) + (PA.indexByteArray arr (j + 6)) + (PA.indexByteArray arr (j + 7)) class ForeignConvention a where readForeign :: @@ -53,19 +1314,19 @@ class ForeignConvention a where Stack -> a -> IO Stack instance ForeignConvention Int where - readForeign (i : args) stk = (args,) <$> peekOffI stk i - readForeign [] _ = foreignCCError "Int" + readForeign !(i : args) !stk = (args,) <$> peekOffI stk i + readForeign ![] !_ = foreignCCError "Int" {-# INLINE readForeign #-} - writeForeign stk i = do + writeForeign !stk !i = do stk <- bump stk stk <$ pokeI stk i {-# INLINE writeForeign #-} instance ForeignConvention Word64 where - readForeign (i : args) stk = (args,) <$> peekOffN stk i - readForeign [] _ = foreignCCError "Word64" + readForeign !(i : args) !stk = (args,) <$> peekOffN stk i + readForeign ![] !_ = foreignCCError "Word64" {-# INLINE readForeign #-} - writeForeign stk n = do + writeForeign !stk !n = do stk <- bump stk stk <$ pokeN stk n {-# INLINE writeForeign #-} @@ -91,19 +1352,19 @@ instance ForeignConvention Word32 where {-# INLINE writeForeign #-} instance ForeignConvention Char where - readForeign (i : args) stk = (args,) <$> peekOffC stk i - readForeign [] _ = foreignCCError "Char" + readForeign !(i : args) !stk = (args,) <$> peekOffC stk i + readForeign ![] !_ = foreignCCError "Char" {-# INLINE readForeign #-} - writeForeign stk ch = do + writeForeign !stk !ch = do stk <- bump stk stk <$ pokeC stk ch {-# INLINE writeForeign #-} instance ForeignConvention Val where - readForeign (i : args) stk = (args,) <$> peekOff stk i - readForeign [] _ = foreignCCError "Val" + readForeign !(i : args) !stk = (args,) <$> peekOff stk i + readForeign ![] !_ = foreignCCError "Val" {-# INLINE readForeign #-} - writeForeign stk v = do + writeForeign !stk !v = do stk <- bump stk stk <$ (poke stk =<< evaluate v) {-# INLINE writeForeign #-} @@ -111,10 +1372,10 @@ instance ForeignConvention Val where -- 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" + readForeign !(i : args) !stk = (args,) <$> bpeekOff stk i + readForeign ![] !_ = foreignCCError "Closure" {-# INLINE readForeign #-} - writeForeign stk c = do + writeForeign !stk !c = do stk <- bump stk stk <$ (bpoke stk =<< evaluate c) {-# INLINE writeForeign #-} @@ -125,7 +1386,7 @@ instance ForeignConvention Text where writeForeign = writeForeignBuiltin {-# INLINE writeForeign #-} -instance ForeignConvention Bytes where +instance ForeignConvention Unison.Util.Bytes.Bytes where readForeign = readForeignBuiltin {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin @@ -162,18 +1423,18 @@ instance ForeignConvention POSIXTime where {-# INLINE writeForeign #-} instance (ForeignConvention a) => ForeignConvention (Maybe a) where - readForeign (i : args) stk = + readForeign !(i : args) !stk = upeekOff stk i >>= \case 0 -> pure (args, Nothing) 1 -> fmap Just <$> readForeign args stk _ -> foreignCCError "Maybe" - readForeign [] _ = foreignCCError "Maybe" + readForeign ![] !_ = foreignCCError "Maybe" {-# INLINE readForeign #-} - writeForeign stk Nothing = do + writeForeign !stk !Nothing = do stk <- bump stk stk <$ pokeTag stk 0 - writeForeign stk (Just x) = do + writeForeign !stk !(Just x) = do stk <- writeForeign stk x stk <- bump stk stk <$ pokeTag stk 1 @@ -183,19 +1444,19 @@ instance (ForeignConvention a, ForeignConvention b) => ForeignConvention (Either a b) where - readForeign (i : args) stk = + readForeign !(i : args) !stk = peekTagOff stk i >>= \case 0 -> readForeignAs Left args stk 1 -> readForeignAs Right args stk _ -> foreignCCError "Either" - readForeign _ _ = foreignCCError "Either" + readForeign !_ !_ = foreignCCError "Either" {-# INLINE readForeign #-} - writeForeign stk (Left a) = do + writeForeign !stk !(Left a) = do stk <- writeForeign stk a stk <- bump stk stk <$ pokeTag stk 0 - writeForeign stk (Right b) = do + writeForeign !stk !(Right b) = do stk <- writeForeign stk b stk <- bump stk stk <$ pokeTag stk 1 @@ -238,7 +1499,8 @@ readForeignAs :: [Int] -> Stack -> IO ([Int], b) -readForeignAs f args stk = fmap f <$> readForeign args stk +readForeignAs !f !args !stk = fmap f <$> readForeign args stk +{-# INLINE readForeignAs #-} writeForeignAs :: (ForeignConvention b) => @@ -246,7 +1508,8 @@ writeForeignAs :: Stack -> a -> IO Stack -writeForeignAs f stk x = writeForeign stk (f x) +writeForeignAs !f !stk !x = writeForeign stk (f x) +{-# INLINE writeForeignAs #-} readForeignEnum :: (Enum a) => @@ -254,6 +1517,7 @@ readForeignEnum :: Stack -> IO ([Int], a) readForeignEnum = readForeignAs toEnum +{-# INLINE readForeignEnum #-} writeForeignEnum :: (Enum a) => @@ -261,6 +1525,7 @@ writeForeignEnum :: a -> IO Stack writeForeignEnum = writeForeignAs fromEnum +{-# INLINE writeForeignEnum #-} readForeignBuiltin :: (BuiltinForeign b) => @@ -268,6 +1533,7 @@ readForeignBuiltin :: Stack -> IO ([Int], b) readForeignBuiltin = readForeignAs (unwrapBuiltin . marshalToForeign) +{-# INLINE readForeignBuiltin #-} writeForeignBuiltin :: (BuiltinForeign b) => @@ -275,36 +1541,39 @@ writeForeignBuiltin :: b -> IO Stack writeForeignBuiltin = writeForeignAs (Foreign . wrapBuiltin) +{-# INLINE writeForeignBuiltin #-} writeTypeLink :: Stack -> Reference -> IO Stack writeTypeLink = writeForeignAs (Foreign . Wrap typeLinkRef) +{-# INLINE writeTypeLink #-} readTypelink :: [Int] -> Stack -> IO ([Int], Reference) readTypelink = readForeignAs (unwrapForeign . marshalToForeign) +{-# INLINE readTypelink #-} instance ForeignConvention Double where - readForeign (i : args) stk = (args,) <$> peekOffD stk i - readForeign _ _ = foreignCCError "Double" + readForeign !(i : args) !stk = (args,) <$> peekOffD stk i + readForeign !_ !_ = foreignCCError "Double" {-# INLINE readForeign #-} - writeForeign stk d = - bump stk >>= \stk -> do + writeForeign !stk !d = + bump stk >>= \(!stk) -> do pokeD stk d pure stk {-# INLINE writeForeign #-} instance ForeignConvention Bool where - readForeign (i : args) stk = do + readForeign !(i : args) !stk = do b <- peekOffBool stk i pure (args, b) - readForeign _ _ = foreignCCError "Bool" + readForeign !_ !_ = foreignCCError "Bool" {-# INLINE readForeign #-} - writeForeign stk b = do + writeForeign !stk !b = do stk <- bump stk pokeBool stk b pure stk @@ -329,35 +1598,35 @@ instance ForeignConvention IOMode where {-# INLINE writeForeign #-} instance ForeignConvention () where - readForeign args _ = pure (args, ()) + readForeign args !_ = pure (args, ()) {-# INLINE readForeign #-} - writeForeign stk _ = pure stk + writeForeign !stk !_ = pure stk {-# INLINE writeForeign #-} instance (ForeignConvention a, ForeignConvention b) => ForeignConvention (a, b) where - readForeign args stk = do + readForeign !args !stk = do (args, a) <- readForeign args stk (args, b) <- readForeign args stk pure (args, (a, b)) {-# INLINE readForeign #-} - writeForeign stk (x, y) = do + writeForeign !stk !(x, y) = do stk <- writeForeign stk y writeForeign stk x {-# INLINE writeForeign #-} -instance (ForeignConvention a) => ForeignConvention (Failure a) where - readForeign args stk = do +instance (ForeignConvention a) => ForeignConvention (F.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) + pure (args, F.Failure typeref message any) {-# INLINE readForeign #-} - writeForeign stk (Failure typeref message any) = do + writeForeign !stk !(F.Failure typeref message any) = do stk <- writeForeign stk any stk <- writeForeign stk message writeTypeLink stk typeref @@ -370,14 +1639,14 @@ instance ) => ForeignConvention (a, b, c) where - readForeign args stk = do + readForeign args !stk = do (args, a) <- readForeign args stk (args, b) <- readForeign args stk (args, c) <- readForeign args stk pure (args, (a, b, c)) {-# INLINE readForeign #-} - writeForeign stk (a, b, c) = do + writeForeign !stk !(a, b, c) = do stk <- writeForeign stk c stk <- writeForeign stk b writeForeign stk a @@ -391,7 +1660,7 @@ instance ) => ForeignConvention (a, b, c, d) where - readForeign args stk = do + readForeign !args !stk = do (args, a) <- readForeign args stk (args, b) <- readForeign args stk (args, c) <- readForeign args stk @@ -399,7 +1668,7 @@ instance pure (args, (a, b, c, d)) {-# INLINE readForeign #-} - writeForeign stk (a, b, c, d) = do + writeForeign !stk !(a, b, c, d) = do stk <- writeForeign stk d stk <- writeForeign stk c stk <- writeForeign stk b @@ -415,7 +1684,7 @@ instance ) => ForeignConvention (a, b, c, d, e) where - readForeign args stk = do + readForeign !args !stk = do (args, a) <- readForeign args stk (args, b) <- readForeign args stk (args, c) <- readForeign args stk @@ -424,7 +1693,7 @@ instance pure (args, (a, b, c, d, e)) {-# INLINE readForeign #-} - writeForeign stk (a, b, c, d, e) = do + writeForeign !stk !(a, b, c, d, e) = do stk <- writeForeign stk e stk <- writeForeign stk d stk <- writeForeign stk c @@ -439,7 +1708,7 @@ block'buf = fromIntegral Ty.bufferModeBlockBufferingId sblock'buf = fromIntegral Ty.bufferModeSizedBlockBufferingId instance ForeignConvention BufferMode where - readForeign (i : args) stk = + readForeign !(i : args) !stk = peekOffN stk i >>= \case t | t == no'buf -> pure (args, NoBuffering) @@ -451,11 +1720,11 @@ instance ForeignConvention BufferMode where | otherwise -> foreignCCError $ "BufferMode (unknown tag: " <> show t <> ")" - readForeign _ _ = foreignCCError $ "BufferMode (empty stack)" + readForeign !_ !_ = foreignCCError $ "BufferMode (empty stack)" {-# INLINE readForeign #-} - writeForeign stk bm = - bump stk >>= \stk -> + writeForeign !stk !bm = + bump stk >>= \(!stk) -> case bm of NoBuffering -> stk <$ pokeN stk no'buf LineBuffering -> stk <$ pokeN stk line'buf @@ -469,11 +1738,11 @@ instance ForeignConvention BufferMode where -- 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 = + readForeign !(i : args) !stk = (args,) . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[Val]" + readForeign !_ !_ = foreignCCError "[Val]" {-# INLINE readForeign #-} - writeForeign stk l = do + writeForeign !stk !l = do stk <- bump stk stk <$ pokeS stk (Sq.fromList l) {-# INLINE writeForeign #-} @@ -481,11 +1750,11 @@ instance {-# OVERLAPPING #-} ForeignConvention [Val] where -- 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 = + readForeign !(i : args) !stk = (args,) . fmap getBoxedVal . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[Closure]" + readForeign !_ !_ = foreignCCError "[Closure]" {-# INLINE readForeign #-} - writeForeign stk l = do + writeForeign !stk !l = do stk <- bump stk stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l) {-# INLINE writeForeign #-} @@ -594,27 +1863,27 @@ unwrapForeignClosure :: Closure -> a unwrapForeignClosure = unwrapForeign . marshalToForeign instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where - readForeign (i : args) stk = + readForeign !(i : args) !stk = (args,) . fmap (fromUnisonPair . getBoxedVal) . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[(a,b)]" + readForeign !_ !_ = foreignCCError "[(a,b)]" {-# INLINE readForeign #-} - writeForeign stk l = do + 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 = + readForeign !(i : args) !stk = (args,) . fmap (unwrapForeignClosure . getBoxedVal) . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[b]" + readForeign !_ !_ = foreignCCError "[b]" {-# INLINE readForeign #-} - writeForeign stk l = do + writeForeign !stk !l = do stk <- bump stk stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l) {-# INLINE writeForeign #-} diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs deleted file mode 100644 index c698ef15f2..0000000000 --- a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs +++ /dev/null @@ -1,1893 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} - -module Unison.Runtime.Foreign.Impl (foreignCall) where - -import Control.Concurrent (ThreadId) -import Control.Concurrent as SYS - ( killThread, - threadDelay, - ) -import Control.Concurrent.MVar as SYS -import Control.Concurrent.STM (TVar) -import Control.Concurrent.STM qualified as STM -import Control.DeepSeq (NFData) -import Control.Exception -import Control.Exception.Safe qualified as Exception -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Primitive qualified as PA -import Crypto.Error (CryptoError (..), CryptoFailable (..)) -import Crypto.Hash qualified as Hash -import Crypto.MAC.HMAC qualified as HMAC -import Crypto.PubKey.Ed25519 qualified as Ed25519 -import Crypto.PubKey.RSA.PKCS15 qualified as RSA -import Crypto.Random (getRandomBytes) -import Data.Atomics (Ticket) -import Data.Bits (shiftL, shiftR, (.|.)) -import Data.ByteArray qualified as BA -import Data.ByteString (hGet, hGetSome, hPut) -import Data.ByteString.Lazy qualified as L -import Data.Default (def) -import Data.Digest.Murmur64 (asWord64, hash64) -import Data.IORef (IORef) -import Data.IP (IP) -import Data.PEM (PEM, pemContent, pemParseLBS) -import Data.Sequence qualified as Sq -import Data.Text qualified -import Data.Text.IO qualified as Text.IO -import Data.Time.Clock.POSIX (POSIXTime) -import Data.Time.Clock.POSIX as SYS - ( getPOSIXTime, - posixSecondsToUTCTime, - utcTimeToPOSIXSeconds, - ) -import Data.Time.LocalTime (TimeZone (..), getTimeZone) -import Data.X509 qualified as X -import Data.X509.CertificateStore qualified as X -import Data.X509.Memory qualified as X -import GHC.Conc qualified as STM -import GHC.IO (IO (IO)) -import GHC.IO.Exception (IOErrorType (..), IOException (..)) -import Network.Simple.TCP as SYS - ( HostPreference (..), - bindSock, - closeSock, - connectSock, - listenSock, - recv, - send, - ) -import Network.Socket (Socket) -import Network.Socket as SYS - ( PortNumber, - Socket, - accept, - socketPort, - ) -import Network.TLS as TLS -import Network.TLS.Extra.Cipher as Cipher -import Network.UDP (UDPSocket) -import Network.UDP as UDP - ( ClientSockAddr, - ListenSocket, - clientSocket, - close, - recv, - recvFrom, - send, - sendTo, - serverSocket, - stop, - ) -import System.Clock (Clock (..), getTime, nsec, sec) -import System.Directory as SYS - ( createDirectoryIfMissing, - doesDirectoryExist, - doesPathExist, - getCurrentDirectory, - getDirectoryContents, - getFileSize, - getModificationTime, - getTemporaryDirectory, - removeDirectoryRecursive, - removeFile, - renameDirectory, - renameFile, - setCurrentDirectory, - ) -import System.Environment as SYS - ( getArgs, - getEnv, - ) -import System.Exit as SYS (ExitCode (..)) -import System.FilePath (isPathSeparator) -import System.IO (BufferMode (..), Handle, IOMode, SeekMode) -import System.IO as SYS - ( IOMode (..), - hClose, - hGetBuffering, - hGetChar, - hGetEcho, - hIsEOF, - hIsOpen, - hIsSeekable, - hReady, - hSeek, - hSetBuffering, - hSetEcho, - hTell, - openFile, - stderr, - stdin, - stdout, - ) -import System.IO.Temp (createTempDirectory) -import System.Process as SYS - ( getProcessExitCode, - proc, - runInteractiveProcess, - terminateProcess, - waitForProcess, - withCreateProcess, - ) -import System.X509 qualified as X -import Unison.Builtin.Decls qualified as Ty -import Unison.Prelude hiding (Text, some) -import Unison.Reference -import Unison.Referent (Referent, pattern Ref) -import Unison.Runtime.ANF (Code, PackedTag (..), Value, internalBug) -import Unison.Runtime.ANF qualified as ANF -import Unison.Runtime.ANF.Rehash (checkGroupHashes) -import Unison.Runtime.ANF.Serialize qualified as ANF -import Unison.Runtime.Array qualified as PA -import Unison.Runtime.Builtin -import Unison.Runtime.Crypto.Rsa qualified as Rsa -import Unison.Runtime.Exception -import Unison.Runtime.Foreign hiding (Failure) -import Unison.Runtime.Foreign qualified as F -import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) -import Unison.Runtime.MCode -import Unison.Runtime.Stack -import Unison.Symbol -import Unison.Type - ( iarrayRef, - ibytearrayRef, - marrayRef, - mbytearrayRef, - mvarRef, - promiseRef, - refRef, - ticketRef, - tvarRef, - typeLinkRef, - ) -import Unison.Type qualified as Ty -import Unison.Util.Bytes (Bytes) -import Unison.Util.Bytes qualified as Bytes -import Unison.Util.RefPromise - ( Promise, - newPromise, - readPromise, - tryReadPromise, - writePromise, - ) -import Unison.Util.Text (Text, pack, unpack) -import Unison.Util.Text qualified as Util.Text -import Unison.Util.Text.Pattern qualified as TPat -import UnliftIO qualified - -foreignCall :: ForeignFunc -> Args -> XStack -> IOXStack -foreignCall !ff !args !xstk = - stackIOToIOX $ foreignCallHelper ff args (packXStack xstk) -{-# NOINLINE foreignCall #-} - -foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO Stack -foreignCallHelper = \case - IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> - let hostStr = Util.Text.toString host - portStr = Util.Text.toString port - in UDP.clientSocket hostStr portStr True - IO_UDP_UDPSocket_recv_impl_v1 -> mkForeignIOF $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock - IO_UDP_UDPSocket_send_impl_v1 -> mkForeignIOF $ - \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> - UDP.send sock (Bytes.toArray bytes) - IO_UDP_UDPSocket_close_impl_v1 -> mkForeignIOF $ - \(sock :: UDPSocket) -> UDP.close sock - IO_UDP_ListenSocket_close_impl_v1 -> mkForeignIOF $ - \(sock :: ListenSocket) -> UDP.stop sock - IO_UDP_UDPSocket_toText_impl_v1 -> mkForeign $ - \(sock :: UDPSocket) -> pure $ show sock - IO_UDP_serverSocket_impl_v1 -> mkForeignIOF $ - \(ip :: Util.Text.Text, port :: Util.Text.Text) -> - let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP - maybePort = readMaybe $ Util.Text.toString port :: Maybe PortNumber - in case (maybeIp, maybePort) of - (Nothing, _) -> fail "Invalid IP Address" - (_, Nothing) -> fail "Invalid Port Number" - (Just ip, Just pt) -> UDP.serverSocket (ip, pt) - IO_UDP_ListenSocket_toText_impl_v1 -> mkForeign $ - \(sock :: ListenSocket) -> pure $ show sock - IO_UDP_ListenSocket_recvFrom_impl_v1 -> - mkForeignIOF $ - fmap (first Bytes.fromArray) <$> UDP.recvFrom - IO_UDP_ClientSockAddr_toText_v1 -> mkForeign $ - \(sock :: ClientSockAddr) -> pure $ show sock - 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) -> - 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 - IO_isFileOpen_impl_v3 -> mkForeignIOF hIsOpen - IO_getEcho_impl_v1 -> mkForeignIOF hGetEcho - IO_ready_impl_v1 -> mkForeignIOF hReady - IO_getChar_impl_v1 -> mkForeignIOF hGetChar - IO_isSeekable_impl_v3 -> mkForeignIOF hIsSeekable - IO_seekHandle_impl_v3 -> mkForeignIOF $ - \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) - IO_handlePosition_impl_v3 -> - -- TODO: truncating integer - mkForeignIOF $ - \h -> fromInteger @Word64 <$> hTell h - IO_getBuffering_impl_v3 -> mkForeignIOF hGetBuffering - IO_setBuffering_impl_v3 -> - mkForeignIOF $ - uncurry hSetBuffering - IO_setEcho_impl_v1 -> mkForeignIOF $ uncurry hSetEcho - IO_getLine_impl_v1 -> - mkForeignIOF $ - fmap Util.Text.fromText . Text.IO.hGetLine - IO_getBytes_impl_v3 -> mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGet h n - IO_getSomeBytes_impl_v1 -> mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGetSome h n - IO_putBytes_impl_v3 -> mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) - IO_systemTime_impl_v3 -> mkForeignIOF $ - \() -> getPOSIXTime - IO_systemTimeMicroseconds_v1 -> mkForeign $ - \() -> fmap (1e6 *) getPOSIXTime - Clock_internals_monotonic_v1 -> mkForeignIOF $ - \() -> getTime Monotonic - Clock_internals_realtime_v1 -> mkForeignIOF $ - \() -> getTime Realtime - Clock_internals_processCPUTime_v1 -> mkForeignIOF $ - \() -> getTime ProcessCPUTime - Clock_internals_threadCPUTime_v1 -> mkForeignIOF $ - \() -> getTime ThreadCPUTime - Clock_internals_sec_v1 -> mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) - Clock_internals_nsec_v1 -> mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) - Clock_internals_systemTimeZone_v1 -> - mkForeign - ( \secs -> do - TimeZone offset summer name <- getTimeZone (posixSecondsToUTCTime (fromIntegral (secs :: Int))) - pure (offset :: Int, summer, name) - ) - IO_getTempDirectory_impl_v3 -> - mkForeignIOF $ - \() -> chop <$> getTemporaryDirectory - IO_createTempDirectory_impl_v3 -> mkForeignIOF $ \prefix -> do - temp <- getTemporaryDirectory - chop <$> createTempDirectory temp prefix - IO_getCurrentDirectory_impl_v3 -> mkForeignIOF $ - \() -> getCurrentDirectory - IO_setCurrentDirectory_impl_v3 -> mkForeignIOF setCurrentDirectory - IO_fileExists_impl_v3 -> mkForeignIOF doesPathExist - IO_getEnv_impl_v1 -> mkForeignIOF getEnv - IO_getArgs_impl_v1 -> mkForeignIOF $ - \() -> fmap Util.Text.pack <$> SYS.getArgs - IO_isDirectory_impl_v3 -> mkForeignIOF doesDirectoryExist - IO_createDirectory_impl_v3 -> - mkForeignIOF $ - createDirectoryIfMissing True - IO_removeDirectory_impl_v3 -> mkForeignIOF removeDirectoryRecursive - IO_renameDirectory_impl_v3 -> - mkForeignIOF $ - uncurry renameDirectory - IO_directoryContents_impl_v3 -> - mkForeignIOF $ - (fmap Util.Text.pack <$>) . getDirectoryContents - IO_removeFile_impl_v3 -> mkForeignIOF removeFile - IO_renameFile_impl_v3 -> - mkForeignIOF $ - uncurry renameFile - IO_getFileTimestamp_impl_v3 -> - mkForeignIOF $ - fmap utcTimeToPOSIXSeconds . getModificationTime - IO_getFileSize_impl_v3 -> - -- TODO: truncating integer - mkForeignIOF $ - \fp -> fromInteger @Word64 <$> getFileSize fp - IO_serverSocket_impl_v3 -> - mkForeignIOF $ - \( mhst :: Maybe Util.Text.Text, - port - ) -> - fst <$> SYS.bindSock (hostPreference mhst) port - Socket_toText -> mkForeign $ - \(sock :: Socket) -> pure $ show sock - Handle_toText -> mkForeign $ - \(hand :: Handle) -> pure $ show hand - ThreadId_toText -> mkForeign $ - \(threadId :: ThreadId) -> pure $ show threadId - IO_socketPort_impl_v3 -> mkForeignIOF $ - \(handle :: Socket) -> do - n <- SYS.socketPort handle - return (fromIntegral n :: Word64) - IO_listen_impl_v3 -> mkForeignIOF $ - \sk -> SYS.listenSock sk 2048 - IO_clientSocket_impl_v3 -> - mkForeignIOF $ - fmap fst . uncurry SYS.connectSock - IO_closeSocket_impl_v3 -> mkForeignIOF SYS.closeSock - IO_socketAccept_impl_v3 -> - mkForeignIOF $ - fmap fst . SYS.accept - IO_socketSend_impl_v3 -> mkForeignIOF $ - \(sk, bs) -> SYS.send sk (Bytes.toArray bs) - IO_socketReceive_impl_v3 -> mkForeignIOF $ - \(hs, n) -> - maybe mempty Bytes.fromArray <$> SYS.recv hs n - 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." - IO_process_call -> mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - withCreateProcess (proc exe args) $ \_ _ _ p -> - exitDecode <$> waitForProcess p - IO_process_start -> mkForeign $ \(exe, map Util.Text.unpack -> args) -> - runInteractiveProcess exe args Nothing Nothing - IO_process_kill -> mkForeign $ terminateProcess - IO_process_wait -> mkForeign $ - \ph -> exitDecode <$> waitForProcess ph - IO_process_exitCode -> - mkForeign $ - fmap (fmap exitDecode) . getProcessExitCode - MVar_new -> mkForeign $ - \(c :: Val) -> newMVar c - MVar_newEmpty_v2 -> mkForeign $ - \() -> newEmptyMVar @Val - MVar_take_impl_v3 -> mkForeignIOF $ - \(mv :: MVar Val) -> takeMVar mv - MVar_tryTake -> mkForeign $ - \(mv :: MVar Val) -> tryTakeMVar mv - MVar_put_impl_v3 -> mkForeignIOF $ - \(mv :: MVar Val, x) -> putMVar mv x - MVar_tryPut_impl_v3 -> mkForeignIOF $ - \(mv :: MVar Val, x) -> tryPutMVar mv x - MVar_swap_impl_v3 -> mkForeignIOF $ - \(mv :: MVar Val, x) -> swapMVar mv x - MVar_isEmpty -> mkForeign $ - \(mv :: MVar Val) -> isEmptyMVar mv - MVar_read_impl_v3 -> mkForeignIOF $ - \(mv :: MVar Val) -> readMVar mv - MVar_tryRead_impl_v3 -> mkForeignIOF $ - \(mv :: MVar Val) -> tryReadMVar mv - Char_toText -> mkForeign $ - \(ch :: Char) -> pure (Util.Text.singleton ch) - Text_repeat -> mkForeign $ - \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) - Text_reverse -> - mkForeign $ - pure . Util.Text.reverse - Text_toUppercase -> - mkForeign $ - pure . Util.Text.toUppercase - Text_toLowercase -> - mkForeign $ - pure . Util.Text.toLowercase - Text_toUtf8 -> - mkForeign $ - pure . Util.Text.toUtf8 - Text_fromUtf8_impl_v3 -> - mkForeign $ - pure . mapLeft (\t -> F.Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 - Tls_ClientConfig_default -> mkForeign $ - \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> - fmap - ( \store -> - (defaultParamsClient (Util.Text.unpack hostName) (Bytes.toArray serverId)) - { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, - TLS.clientShared = def {TLS.sharedCAStore = store} - } - ) - X.getSystemCertificateStore - Tls_ServerConfig_default -> - mkForeign $ - \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> - pure $ - (def :: TLS.ServerParams) - { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, - TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]} - } - Tls_ClientConfig_certificates_set -> - let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams - updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} - in mkForeign $ - \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params - Tls_ServerConfig_certificates_set -> - let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams - updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} - in mkForeign $ - \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params - TVar_new -> mkForeign $ - \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c - TVar_read -> mkForeign $ - \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v - TVar_write -> mkForeign $ - \(v :: STM.TVar Val, c :: Val) -> - unsafeSTMToIO $ STM.writeTVar v c - TVar_newIO -> mkForeign $ - \(c :: Val) -> STM.newTVarIO c - TVar_readIO -> mkForeign $ - \(v :: STM.TVar Val) -> STM.readTVarIO v - TVar_swap -> mkForeign $ - \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c - STM_retry -> mkForeign $ - \() -> unsafeSTMToIO STM.retry :: IO Val - Promise_new -> mkForeign $ - \() -> newPromise @Val - Promise_read -> mkForeign $ - \(p :: Promise Val) -> readPromise p - Promise_tryRead -> mkForeign $ - \(p :: Promise Val) -> tryReadPromise p - Promise_write -> mkForeign $ - \(p :: Promise Val, a :: Val) -> writePromise p a - Tls_newClient_impl_v3 -> - mkForeignTls $ - \( config :: TLS.ClientParams, - socket :: SYS.Socket - ) -> TLS.contextNew socket config - Tls_newServer_impl_v3 -> - mkForeignTls $ - \( config :: TLS.ServerParams, - socket :: SYS.Socket - ) -> TLS.contextNew socket config - Tls_handshake_impl_v3 -> mkForeignTls $ - \(tls :: TLS.Context) -> TLS.handshake tls - Tls_send_impl_v3 -> - mkForeignTls $ - \( tls :: TLS.Context, - bytes :: Bytes.Bytes - ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) - Tls_decodeCert_impl_v3 -> - let wrapFailure t = F.Failure Ty.tlsFailureRef (Util.Text.pack t) unitValue - decoded :: Bytes.Bytes -> Either String PEM - decoded bytes = case pemParseLBS $ Bytes.toLazyByteString bytes of - Right (pem : _) -> Right pem - Right [] -> Left "no PEM found" - Left l -> Left l - asCert :: PEM -> Either String X.SignedCertificate - asCert pem = X.decodeSignedCertificate $ pemContent pem - in mkForeignTlsE $ - \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes - Tls_encodeCert -> mkForeign $ - \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert - Tls_decodePrivateKey -> mkForeign $ - \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes - Tls_encodePrivateKey -> mkForeign $ - \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey - Tls_receive_impl_v3 -> mkForeignTls $ - \(tls :: TLS.Context) -> do - bs <- TLS.recvData tls - pure $ Bytes.fromArray bs - Tls_terminate_impl_v3 -> mkForeignTls $ - \(tls :: TLS.Context) -> TLS.bye tls - Code_validateLinks -> mkForeign $ - \(lsgs0 :: [(Referent, ANF.Code)]) -> do - let f (msg, rs) = - F.Failure Ty.miscFailureRef (Util.Text.fromText msg) rs - pure . first f $ checkGroupHashes lsgs0 - Code_dependencies -> mkForeign $ - \(ANF.CodeRep sg _) -> - pure $ Wrap Ty.termLinkRef . Ref <$> ANF.groupTermLinks sg - Code_serialize -> mkForeign $ - \(co :: ANF.Code) -> - pure . Bytes.fromArray $ ANF.serializeCode builtinForeignNames co - Code_deserialize -> - mkForeign $ - pure . ANF.deserializeCode . Bytes.toArray - Code_display -> mkForeign $ - \(nm, (ANF.CodeRep sg _)) -> - pure $ ANF.prettyGroup @Symbol (Util.Text.unpack nm) sg "" - Value_dependencies -> - mkForeign $ - pure . fmap (Wrap Ty.termLinkRef . Ref) . ANF.valueTermLinks - Value_serialize -> - mkForeign $ - pure . Bytes.fromArray . ANF.serializeValue - Value_deserialize -> - mkForeign $ - pure . ANF.deserializeValue . Bytes.toArray - Crypto_HashAlgorithm_Sha3_512 -> mkHashAlgorithm "Sha3_512" Hash.SHA3_512 - Crypto_HashAlgorithm_Sha3_256 -> mkHashAlgorithm "Sha3_256" Hash.SHA3_256 - Crypto_HashAlgorithm_Sha2_512 -> mkHashAlgorithm "Sha2_512" Hash.SHA512 - Crypto_HashAlgorithm_Sha2_256 -> mkHashAlgorithm "Sha2_256" Hash.SHA256 - Crypto_HashAlgorithm_Sha1 -> mkHashAlgorithm "Sha1" Hash.SHA1 - Crypto_HashAlgorithm_Blake2b_512 -> mkHashAlgorithm "Blake2b_512" Hash.Blake2b_512 - Crypto_HashAlgorithm_Blake2b_256 -> mkHashAlgorithm "Blake2b_256" Hash.Blake2b_256 - Crypto_HashAlgorithm_Blake2s_256 -> mkHashAlgorithm "Blake2s_256" Hash.Blake2s_256 - Crypto_HashAlgorithm_Md5 -> mkHashAlgorithm "Md5" Hash.MD5 - Crypto_hashBytes -> mkForeign $ - \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> - let ctx = Hash.hashInitWith alg - in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) - Crypto_hmacBytes -> mkForeign $ - \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> - let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) - u :: a -> HMAC.HMAC a -> HMAC.HMAC a - u _ h = h -- to help typechecker along - in pure $ Bytes.fromArray out - Crypto_hash -> mkForeign $ - \(HashAlgorithm _ alg, x) -> - let hashlazy :: - (Hash.HashAlgorithm a) => - a -> - L.ByteString -> - Hash.Digest a - hashlazy _ l = Hash.hashlazy l - in pure . Bytes.fromArray . hashlazy alg $ ANF.serializeValueForHash x - Crypto_hmac -> mkForeign $ - \(HashAlgorithm _ alg, key, x) -> - let hmac :: - (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a - hmac _ s = - HMAC.finalize - . HMAC.updates - (HMAC.initialize $ Bytes.toArray @BA.Bytes key) - $ L.toChunks s - in pure . Bytes.fromArray . hmac alg $ ANF.serializeValueForHash x - Crypto_Ed25519_sign_impl -> - mkForeign $ - pure . signEd25519Wrapper - Crypto_Ed25519_verify_impl -> - mkForeign $ - pure . verifyEd25519Wrapper - Crypto_Rsa_sign_impl -> - mkForeign $ - pure . signRsaWrapper - Crypto_Rsa_verify_impl -> - mkForeign $ - pure . verifyRsaWrapper - Universal_murmurHash -> - mkForeign $ - pure . asWord64 . hash64 . ANF.serializeValueForHash - IO_randomBytes -> mkForeign $ - \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n - Bytes_zlib_compress -> mkForeign $ pure . Bytes.zlibCompress - Bytes_gzip_compress -> mkForeign $ pure . Bytes.gzipCompress - Bytes_zlib_decompress -> mkForeign $ \bs -> - catchAll (pure (Bytes.zlibDecompress bs)) - Bytes_gzip_decompress -> mkForeign $ \bs -> - catchAll (pure (Bytes.gzipDecompress bs)) - Bytes_toBase16 -> mkForeign $ pure . Bytes.toBase16 - Bytes_toBase32 -> mkForeign $ pure . Bytes.toBase32 - Bytes_toBase64 -> mkForeign $ pure . Bytes.toBase64 - Bytes_toBase64UrlUnpadded -> mkForeign $ pure . Bytes.toBase64UrlUnpadded - Bytes_fromBase16 -> - mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase16 - Bytes_fromBase32 -> - mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase32 - Bytes_fromBase64 -> - mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase64 - Bytes_fromBase64UrlUnpadded -> - mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded - Bytes_decodeNat64be -> mkForeign $ pure . Bytes.decodeNat64be - Bytes_decodeNat64le -> mkForeign $ pure . Bytes.decodeNat64le - Bytes_decodeNat32be -> mkForeign $ pure . Bytes.decodeNat32be - Bytes_decodeNat32le -> mkForeign $ pure . Bytes.decodeNat32le - Bytes_decodeNat16be -> mkForeign $ pure . Bytes.decodeNat16be - Bytes_decodeNat16le -> mkForeign $ pure . Bytes.decodeNat16le - Bytes_encodeNat64be -> mkForeign $ pure . Bytes.encodeNat64be - Bytes_encodeNat64le -> mkForeign $ pure . Bytes.encodeNat64le - Bytes_encodeNat32be -> mkForeign $ pure . Bytes.encodeNat32be - Bytes_encodeNat32le -> mkForeign $ pure . Bytes.encodeNat32le - Bytes_encodeNat16be -> mkForeign $ pure . Bytes.encodeNat16be - Bytes_encodeNat16le -> mkForeign $ pure . Bytes.encodeNat16le - MutableArray_copyTo_force -> mkForeign $ - \(dst, doff, src, soff, l) -> - let name = "MutableArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ - checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ - Right - <$> PA.copyMutableArray @IO @Val - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - MutableByteArray_copyTo_force -> mkForeign $ - \(dst, doff, src, soff, l) -> - let name = "MutableByteArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ - checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ - Right - <$> PA.copyMutableByteArray @IO - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - ImmutableArray_copyTo_force -> mkForeign $ - \(dst, doff, src, soff, l) -> - let name = "ImmutableArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ - checkBounds name (PA.sizeofArray src) (soff + l - 1) $ - Right - <$> PA.copyArray @IO @Val - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - ImmutableArray_size -> - mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofArray @Val - MutableArray_size -> - mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Val - ImmutableByteArray_size -> - mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofByteArray - MutableByteArray_size -> - mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld - ImmutableByteArray_copyTo_force -> mkForeign $ - \(dst, doff, src, soff, l) -> - let name = "ImmutableByteArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ - checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ - Right - <$> PA.copyByteArray @IO - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - MutableArray_read -> - mkForeign $ - checkedRead "MutableArray.read" - MutableByteArray_read8 -> - mkForeign $ - checkedRead8 "MutableByteArray.read8" - MutableByteArray_read16be -> - mkForeign $ - checkedRead16 "MutableByteArray.read16be" - MutableByteArray_read24be -> - mkForeign $ - checkedRead24 "MutableByteArray.read24be" - MutableByteArray_read32be -> - mkForeign $ - checkedRead32 "MutableByteArray.read32be" - MutableByteArray_read40be -> - mkForeign $ - checkedRead40 "MutableByteArray.read40be" - MutableByteArray_read64be -> - mkForeign $ - checkedRead64 "MutableByteArray.read64be" - MutableArray_write -> - mkForeign $ - checkedWrite "MutableArray.write" - MutableByteArray_write8 -> - mkForeign $ - checkedWrite8 "MutableByteArray.write8" - MutableByteArray_write16be -> - mkForeign $ - checkedWrite16 "MutableByteArray.write16be" - MutableByteArray_write32be -> - mkForeign $ - checkedWrite32 "MutableByteArray.write32be" - MutableByteArray_write64be -> - mkForeign $ - checkedWrite64 "MutableByteArray.write64be" - ImmutableArray_read -> - mkForeign $ - checkedIndex "ImmutableArray.read" - ImmutableByteArray_read8 -> - mkForeign $ - checkedIndex8 "ImmutableByteArray.read8" - ImmutableByteArray_read16be -> - mkForeign $ - checkedIndex16 "ImmutableByteArray.read16be" - ImmutableByteArray_read24be -> - mkForeign $ - checkedIndex24 "ImmutableByteArray.read24be" - ImmutableByteArray_read32be -> - mkForeign $ - checkedIndex32 "ImmutableByteArray.read32be" - ImmutableByteArray_read40be -> - mkForeign $ - checkedIndex40 "ImmutableByteArray.read40be" - ImmutableByteArray_read64be -> - mkForeign $ - checkedIndex64 "ImmutableByteArray.read64be" - MutableByteArray_freeze_force -> - mkForeign $ - PA.unsafeFreezeByteArray - MutableArray_freeze_force -> - mkForeign $ - PA.unsafeFreezeArray @IO @Val - MutableByteArray_freeze -> mkForeign $ - \(src, off, len) -> - if len == 0 - then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 - else - checkBoundsPrim - "MutableByteArray.freeze" - (PA.sizeofMutableByteArray src) - (off + len) - 0 - $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) - MutableArray_freeze -> mkForeign $ - \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> - if len == 0 - then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal - else - checkBounds - "MutableArray.freeze" - (PA.sizeofMutableArray src) - (off + len - 1) - $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) - MutableByteArray_length -> - mkForeign $ - pure . PA.sizeofMutableByteArray @PA.RealWorld - ImmutableByteArray_length -> - mkForeign $ - pure . PA.sizeofByteArray - IO_array -> mkForeign $ - \n -> PA.newArray n emptyVal - IO_arrayOf -> mkForeign $ - \(v :: Val, n) -> PA.newArray n v - IO_bytearray -> mkForeign $ PA.newByteArray - IO_bytearrayOf -> mkForeign $ - \(init, sz) -> do - arr <- PA.newByteArray sz - PA.fillByteArray arr 0 sz init - pure arr - Scope_array -> mkForeign $ - \n -> PA.newArray n emptyVal - Scope_arrayOf -> mkForeign $ - \(v :: Val, n) -> PA.newArray n v - Scope_bytearray -> mkForeign $ PA.newByteArray - Scope_bytearrayOf -> mkForeign $ - \(init, sz) -> do - arr <- PA.newByteArray sz - PA.fillByteArray arr 0 sz init - pure arr - Text_patterns_literal -> mkForeign $ - \txt -> evaluate . TPat.cpattern $ TPat.Literal txt - Text_patterns_digit -> - mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v - Text_patterns_letter -> - mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Letter)) in \() -> pure v - Text_patterns_space -> - mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Whitespace)) in \() -> pure v - Text_patterns_punctuation -> - mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Punctuation)) in \() -> pure v - Text_patterns_anyChar -> - mkForeign $ - let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v - Text_patterns_eof -> - mkForeign $ - let v = TPat.cpattern TPat.Eof in \() -> pure v - Text_patterns_charRange -> mkForeign $ - \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end - Text_patterns_notCharRange -> mkForeign $ - \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end - Text_patterns_charIn -> mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.charIn: non-character closure" - evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs - Text_patterns_notCharIn -> mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.notCharIn: non-character closure" - evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs - Pattern_many -> mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p - Pattern_many_corrected -> mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p - Pattern_capture -> mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p - Pattern_captureAs -> mkForeign $ - \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p - Pattern_join -> mkForeign $ \ps -> - evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps - Pattern_or -> mkForeign $ - \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r - Pattern_replicate -> mkForeign $ - \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> - let m = fromIntegral m0; n = fromIntegral n0 - in evaluate . TPat.cpattern $ TPat.Replicate m n p - Pattern_run -> mkForeign $ - \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input - Pattern_isMatch -> mkForeign $ - \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input - Char_Class_any -> mkForeign $ \() -> pure TPat.Any - Char_Class_not -> mkForeign $ pure . TPat.Not - Char_Class_and -> mkForeign $ \(a, b) -> pure $ TPat.Intersect a b - Char_Class_or -> mkForeign $ \(a, b) -> pure $ TPat.Union a b - Char_Class_range -> mkForeign $ \(a, b) -> pure $ TPat.CharRange a b - Char_Class_anyOf -> mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.charIn: non-character closure" - evaluate $ TPat.CharSet cs - Char_Class_alphanumeric -> mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) - Char_Class_upper -> mkForeign $ \() -> pure (TPat.CharClass TPat.Upper) - Char_Class_lower -> mkForeign $ \() -> pure (TPat.CharClass TPat.Lower) - Char_Class_whitespace -> mkForeign $ \() -> pure (TPat.CharClass TPat.Whitespace) - Char_Class_control -> mkForeign $ \() -> pure (TPat.CharClass TPat.Control) - Char_Class_printable -> mkForeign $ \() -> pure (TPat.CharClass TPat.Printable) - Char_Class_mark -> mkForeign $ \() -> pure (TPat.CharClass TPat.MarkChar) - Char_Class_number -> mkForeign $ \() -> pure (TPat.CharClass TPat.Number) - Char_Class_punctuation -> mkForeign $ \() -> pure (TPat.CharClass TPat.Punctuation) - Char_Class_symbol -> mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) - Char_Class_separator -> mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) - Char_Class_letter -> mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) - Char_Class_is -> mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c - Text_patterns_char -> mkForeign $ \c -> - let v = TPat.cpattern (TPat.Char c) in pure v - where - chop = reverse . dropWhile isPathSeparator . reverse - - hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference - hostPreference Nothing = SYS.HostAny - hostPreference (Just host) = SYS.Host $ Util.Text.unpack host - - mx :: Word64 - mx = fromIntegral (maxBound :: Int) - - customDelay :: Word64 -> IO () - customDelay n - | n < mx = threadDelay (fromIntegral n) - | otherwise = threadDelay maxBound >> customDelay (n - mx) - - exitDecode ExitSuccess = 0 - exitDecode (ExitFailure n) = n - - mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO Stack - mkHashAlgorithm txt alg = - let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) - in mkForeign $ \() -> pure (HashAlgorithm algoRef alg) - - catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) - catchAll e = do - e <- Exception.tryAnyDeep e - pure $ case e of - Left se -> Left (Util.Text.pack (show se)) - Right a -> Right a -{-# INLINE foreignCallHelper #-} - -mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack -mkForeign !f !args !stk = do - args <- decodeArgs args stk - res <- f args - writeForeign stk res - where - decodeArgs :: (ForeignConvention x) => Args -> Stack -> IO x - decodeArgs !args !stk = - readForeign (argsToLists args) stk >>= \case - ([], a) -> pure a - _ -> - error - "mkForeign: too many arguments for foreign function" -{-# INLINE mkForeign #-} - -mkForeignIOF :: - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - Args -> - Stack -> - IO Stack -mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) - where - tryIOE :: IO a -> IO (Either (F.Failure Val) a) - tryIOE = fmap handleIOE . UnliftIO.try - handleIOE :: Either IOException a -> Either (F.Failure Val) a - handleIOE (Left e) = Left $ F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue - handleIOE (Right a) = Right a -{-# INLINE mkForeignIOF #-} - -mkForeignTls :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - Args -> - Stack -> - IO Stack -mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) - where - tryIO1 :: IO r -> IO (Either TLS.TLSException r) - tryIO1 = UnliftIO.try - tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) - tryIO2 = UnliftIO.try - flatten :: Either IOException (Either TLS.TLSException r) -> Either ((F.Failure Val)) r - flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Right a)) = Right a -{-# INLINE mkForeignTls #-} - -mkForeignTlsE :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO (Either Failure r)) -> - Args -> - Stack -> - IO Stack -mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) - where - tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) - tryIO1 = UnliftIO.try - tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r))) - tryIO2 = UnliftIO.try - flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r - flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Right (Left e))) = Left e - flatten (Right (Right (Right a))) = Right a -{-# INLINE mkForeignTlsE #-} - -unsafeSTMToIO :: STM.STM a -> IO a -unsafeSTMToIO (STM.STM m) = IO m -{-# INLINE unsafeSTMToIO #-} - -signEd25519Wrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes -signEd25519Wrapper (secret0, public0, msg0) = case validated of - CryptoFailed err -> - Left (F.Failure Ty.cryptoFailureRef (errMsg err) unitValue) - CryptoPassed (secret, public) -> - Right . Bytes.fromArray $ Ed25519.sign secret public msg - where - msg = Bytes.toArray msg0 :: ByteString - validated = - (,) - <$> Ed25519.secretKey (Bytes.toArray secret0 :: ByteString) - <*> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) - - errMsg CryptoError_PublicKeySizeInvalid = - "ed25519: Public key size invalid" - errMsg CryptoError_SecretKeySizeInvalid = - "ed25519: Secret key size invalid" - errMsg CryptoError_SecretKeyStructureInvalid = - "ed25519: Secret key structure invalid" - errMsg _ = "ed25519: unexpected error" - -verifyEd25519Wrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool -verifyEd25519Wrapper (public0, msg0, sig0) = case validated of - CryptoFailed err -> - Left $ F.Failure Ty.cryptoFailureRef (errMsg err) unitValue - CryptoPassed (public, sig) -> - Right $ Ed25519.verify public msg sig - where - msg = Bytes.toArray msg0 :: ByteString - validated = - (,) - <$> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) - <*> Ed25519.signature (Bytes.toArray sig0 :: ByteString) - - errMsg CryptoError_PublicKeySizeInvalid = - "ed25519: Public key size invalid" - errMsg CryptoError_SecretKeySizeInvalid = - "ed25519: Secret key size invalid" - errMsg CryptoError_SecretKeyStructureInvalid = - "ed25519: Secret key structure invalid" - errMsg _ = "ed25519: unexpected error" - -signRsaWrapper :: - (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes -signRsaWrapper (secret0, msg0) = case validated of - Left err -> - Left (F.Failure Ty.cryptoFailureRef err unitValue) - Right secret -> - case RSA.sign Nothing (Just Hash.SHA256) secret msg of - Left err -> Left (F.Failure Ty.cryptoFailureRef (Rsa.rsaErrorToText err) unitValue) - Right signature -> Right $ Bytes.fromByteString signature - where - msg = Bytes.toArray msg0 :: ByteString - validated = Rsa.parseRsaPrivateKey (Bytes.toArray secret0 :: ByteString) - -verifyRsaWrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool -verifyRsaWrapper (public0, msg0, sig0) = case validated of - Left err -> - Left $ F.Failure Ty.cryptoFailureRef err unitValue - Right public -> - Right $ RSA.verify (Just Hash.SHA256) public msg sig - where - msg = Bytes.toArray msg0 :: ByteString - sig = Bytes.toArray sig0 :: ByteString - validated = Rsa.parseRsaPublicKey (Bytes.toArray public0 :: ByteString) - -type Failure = F.Failure Val - -checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) -checkBounds name l w act - | w < fromIntegral l = act - | otherwise = pure $ Left err - where - msg = name <> ": array index out of bounds" - err = F.Failure Ty.arrayFailureRef msg (natValue w) - --- Performs a bounds check on a byte array. Strategy is as follows: --- --- isz = signed array size-in-bytes --- off = unsigned byte offset into the array --- esz = unsigned number of bytes to be read --- --- 1. Turn the signed size-in-bytes of the array unsigned --- 2. Add the offset to the to-be-read number to get the maximum size needed --- 3. Check that the actual array size is at least as big as the needed size --- 4. Check that the offset is less than the size --- --- Step 4 ensures that step 3 has not overflowed. Since an actual array size can --- only be 63 bits (since it is signed), the only way for 3 to overflow is if --- the offset is larger than a possible array size, since it would need to be --- 2^64-k, where k is the small (<=8) number of bytes to be read. -checkBoundsPrim :: - Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) -checkBoundsPrim name isz off esz act - | w > bsz || off > bsz = pure $ Left err - | otherwise = act - where - msg = name <> ": array index out of bounds" - err = F.Failure Ty.arrayFailureRef msg (natValue off) - - bsz = fromIntegral isz - w = off + esz - -type RW = PA.PrimState IO - -checkedRead :: - Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val) -checkedRead name (arr, w) = - checkBounds - name - (PA.sizeofMutableArray arr) - w - (Right <$> PA.readArray arr (fromIntegral w)) - -checkedWrite :: - Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ()) -checkedWrite name (arr, w, v) = - checkBounds - name - (PA.sizeofMutableArray arr) - w - (Right <$> PA.writeArray arr (fromIntegral w) v) - -checkedIndex :: - Text -> (PA.Array Val, Word64) -> IO (Either Failure Val) -checkedIndex name (arr, w) = - checkBounds - name - (PA.sizeofArray arr) - w - (Right <$> PA.indexArrayM arr (fromIntegral w)) - -checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead8 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ - (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j - where - j = fromIntegral i - -checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead16 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ - mk16 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - where - j = fromIntegral i - -checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead24 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ - mk24 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - where - j = fromIntegral i - -checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead32 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ - mk32 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - where - j = fromIntegral i - -checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead40 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ - mk40 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - <*> PA.readByteArray @Word8 arr (j + 4) - where - j = fromIntegral i - -checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead64 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ - mk64 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - <*> PA.readByteArray @Word8 arr (j + 4) - <*> PA.readByteArray @Word8 arr (j + 5) - <*> PA.readByteArray @Word8 arr (j + 6) - <*> PA.readByteArray @Word8 arr (j + 7) - where - j = fromIntegral i - -mk16 :: Word8 -> Word8 -> Either Failure Word64 -mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) - -mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk24 b0 b1 b2 = - Right $ - (fromIntegral b0 `shiftL` 16) - .|. (fromIntegral b1 `shiftL` 8) - .|. (fromIntegral b2) - -mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk32 b0 b1 b2 b3 = - Right $ - (fromIntegral b0 `shiftL` 24) - .|. (fromIntegral b1 `shiftL` 16) - .|. (fromIntegral b2 `shiftL` 8) - .|. (fromIntegral b3) - -mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk40 b0 b1 b2 b3 b4 = - Right $ - (fromIntegral b0 `shiftL` 32) - .|. (fromIntegral b1 `shiftL` 24) - .|. (fromIntegral b2 `shiftL` 16) - .|. (fromIntegral b3 `shiftL` 8) - .|. (fromIntegral b4) - -mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk64 b0 b1 b2 b3 b4 b5 b6 b7 = - Right $ - (fromIntegral b0 `shiftL` 56) - .|. (fromIntegral b1 `shiftL` 48) - .|. (fromIntegral b2 `shiftL` 40) - .|. (fromIntegral b3 `shiftL` 32) - .|. (fromIntegral b4 `shiftL` 24) - .|. (fromIntegral b5 `shiftL` 16) - .|. (fromIntegral b6 `shiftL` 8) - .|. (fromIntegral b7) - -checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite8 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do - PA.writeByteArray arr j (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite16 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite32 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) - PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite64 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) - PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) - PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) - PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) - PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) - PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - --- index single byte -checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex8 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ - let j = fromIntegral i - in Right . fromIntegral $ PA.indexByteArray @Word8 arr j - --- index 16 big-endian -checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex16 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ - let j = fromIntegral i - in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) - --- index 32 big-endian -checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex24 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ - let j = fromIntegral i - in mk24 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - --- index 32 big-endian -checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex32 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ - let j = fromIntegral i - in mk32 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - --- index 40 big-endian -checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex40 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ - let j = fromIntegral i - in mk40 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - (PA.indexByteArray arr (j + 4)) - --- index 64 big-endian -checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex64 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ - let j = fromIntegral i - in mk64 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - (PA.indexByteArray arr (j + 4)) - (PA.indexByteArray arr (j + 5)) - (PA.indexByteArray arr (j + 6)) - (PA.indexByteArray arr (j + 7)) - -class ForeignConvention a where - readForeign :: - [Int] -> Stack -> IO ([Int], a) - writeForeign :: - Stack -> a -> IO Stack - -instance ForeignConvention Int where - readForeign !(i : args) !stk = (args,) <$> peekOffI stk i - readForeign ![] !_ = foreignCCError "Int" - {-# INLINE readForeign #-} - writeForeign !stk !i = do - stk <- bump stk - stk <$ pokeI stk i - {-# INLINE writeForeign #-} - -instance ForeignConvention Word64 where - readForeign !(i : args) !stk = (args,) <$> peekOffN stk i - readForeign ![] !_ = foreignCCError "Word64" - {-# INLINE readForeign #-} - writeForeign !stk !n = do - stk <- bump stk - stk <$ pokeN stk n - {-# INLINE writeForeign #-} - --- 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) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64) - {-# INLINE writeForeign #-} - -instance ForeignConvention Word16 where - readForeign = readForeignAs (fromIntegral :: Word64 -> Word16) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (fromIntegral :: Word16 -> Word64) - {-# INLINE writeForeign #-} - -instance ForeignConvention Word32 where - readForeign = readForeignAs (fromIntegral :: Word64 -> Word32) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64) - {-# INLINE writeForeign #-} - -instance ForeignConvention Char where - readForeign !(i : args) !stk = (args,) <$> peekOffC stk i - readForeign ![] !_ = foreignCCError "Char" - {-# INLINE readForeign #-} - writeForeign !stk !ch = do - stk <- bump stk - stk <$ pokeC stk ch - {-# INLINE writeForeign #-} - -instance ForeignConvention Val where - readForeign !(i : args) !stk = (args,) <$> peekOff stk i - readForeign ![] !_ = foreignCCError "Val" - {-# INLINE readForeign #-} - writeForeign !stk !v = do - stk <- bump stk - stk <$ (poke stk =<< evaluate v) - {-# INLINE writeForeign #-} - --- 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" - {-# INLINE readForeign #-} - writeForeign !stk !c = do - stk <- bump stk - stk <$ (bpoke stk =<< evaluate c) - {-# INLINE writeForeign #-} - -instance ForeignConvention Text where - readForeign = readForeignBuiltin - {-# INLINE readForeign #-} - writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} - -instance ForeignConvention Unison.Util.Bytes.Bytes where - readForeign = readForeignBuiltin - {-# INLINE readForeign #-} - writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} - -instance ForeignConvention Socket where - readForeign = readForeignBuiltin - {-# INLINE readForeign #-} - writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} - -instance ForeignConvention UDPSocket where - readForeign = readForeignBuiltin - {-# INLINE readForeign #-} - writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} - -instance ForeignConvention ThreadId where - readForeign = readForeignBuiltin - {-# INLINE readForeign #-} - writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} - -instance ForeignConvention Handle where - readForeign = readForeignBuiltin - {-# INLINE readForeign #-} - writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} - -instance ForeignConvention POSIXTime where - readForeign = readForeignAs (fromIntegral :: Int -> POSIXTime) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (round :: POSIXTime -> Int) - {-# INLINE writeForeign #-} - -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" - {-# INLINE readForeign #-} - - 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 - {-# INLINE writeForeign #-} - -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" - {-# INLINE readForeign #-} - - 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 - {-# INLINE writeForeign #-} - -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 - {-# INLINE readForeign #-} - - writeForeign = writeForeignAs (ioeEncode . ioe_type) - {-# INLINE writeForeign #-} - -readForeignAs :: - (ForeignConvention a) => - (a -> b) -> - [Int] -> - Stack -> - IO ([Int], b) -readForeignAs !f !args !stk = fmap f <$> readForeign args stk -{-# INLINE readForeignAs #-} - -writeForeignAs :: - (ForeignConvention b) => - (a -> b) -> - Stack -> - a -> - IO Stack -writeForeignAs !f !stk !x = writeForeign stk (f x) -{-# INLINE writeForeignAs #-} - -readForeignEnum :: - (Enum a) => - [Int] -> - Stack -> - IO ([Int], a) -readForeignEnum = readForeignAs toEnum -{-# INLINE readForeignEnum #-} - -writeForeignEnum :: - (Enum a) => - Stack -> - a -> - IO Stack -writeForeignEnum = writeForeignAs fromEnum -{-# INLINE writeForeignEnum #-} - -readForeignBuiltin :: - (BuiltinForeign b) => - [Int] -> - Stack -> - IO ([Int], b) -readForeignBuiltin = readForeignAs (unwrapBuiltin . marshalToForeign) -{-# INLINE readForeignBuiltin #-} - -writeForeignBuiltin :: - (BuiltinForeign b) => - Stack -> - b -> - IO Stack -writeForeignBuiltin = writeForeignAs (Foreign . wrapBuiltin) -{-# INLINE writeForeignBuiltin #-} - -writeTypeLink :: - Stack -> - Reference -> - IO Stack -writeTypeLink = writeForeignAs (Foreign . Wrap typeLinkRef) -{-# INLINE writeTypeLink #-} - -readTypelink :: - [Int] -> - Stack -> - IO ([Int], Reference) -readTypelink = readForeignAs (unwrapForeign . marshalToForeign) -{-# INLINE readTypelink #-} - -instance ForeignConvention Double where - readForeign !(i : args) !stk = (args,) <$> peekOffD stk i - readForeign !_ !_ = foreignCCError "Double" - {-# INLINE readForeign #-} - writeForeign !stk !d = - bump stk >>= \(!stk) -> do - pokeD stk d - pure stk - {-# INLINE writeForeign #-} - -instance ForeignConvention Bool where - readForeign !(i : args) !stk = do - b <- peekOffBool stk i - pure (args, b) - readForeign !_ !_ = foreignCCError "Bool" - {-# INLINE readForeign #-} - writeForeign !stk !b = do - stk <- bump stk - pokeBool stk b - pure stk - {-# INLINE writeForeign #-} - -instance ForeignConvention String where - readForeign = readForeignAs unpack - {-# INLINE readForeign #-} - writeForeign = writeForeignAs pack - {-# INLINE writeForeign #-} - -instance ForeignConvention SeekMode where - readForeign = readForeignEnum - {-# INLINE readForeign #-} - writeForeign = writeForeignEnum - {-# INLINE writeForeign #-} - -instance ForeignConvention IOMode where - readForeign = readForeignEnum - {-# INLINE readForeign #-} - writeForeign = writeForeignEnum - {-# INLINE writeForeign #-} - -instance ForeignConvention () where - readForeign args !_ = pure (args, ()) - {-# INLINE readForeign #-} - writeForeign !stk !_ = pure stk - {-# INLINE writeForeign #-} - -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)) - {-# INLINE readForeign #-} - - writeForeign !stk !(x, y) = do - stk <- writeForeign stk y - writeForeign stk x - {-# INLINE writeForeign #-} - -instance (ForeignConvention a) => ForeignConvention (F.Failure a) where - readForeign !args !stk = do - (args, typeref) <- readTypelink args stk - (args, message) <- readForeign args stk - (args, any) <- readForeign args stk - pure (args, F.Failure typeref message any) - {-# INLINE readForeign #-} - - writeForeign !stk !(F.Failure typeref message any) = do - stk <- writeForeign stk any - stk <- writeForeign stk message - writeTypeLink stk typeref - {-# INLINE writeForeign #-} - -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)) - {-# INLINE readForeign #-} - - writeForeign !stk !(a, b, c) = do - stk <- writeForeign stk c - stk <- writeForeign stk b - writeForeign stk a - {-# INLINE writeForeign #-} - -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)) - {-# INLINE readForeign #-} - - writeForeign !stk !(a, b, c, d) = do - stk <- writeForeign stk d - stk <- writeForeign stk c - stk <- writeForeign stk b - writeForeign stk a - {-# INLINE writeForeign #-} - -instance - ( ForeignConvention a, - ForeignConvention b, - ForeignConvention c, - ForeignConvention d, - ForeignConvention e - ) => - 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)) - {-# INLINE readForeign #-} - - 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 - {-# INLINE writeForeign #-} - -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 - -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)" - {-# INLINE readForeign #-} - - 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 - {-# INLINE writeForeign #-} - --- 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]" - {-# INLINE readForeign #-} - writeForeign !stk !l = do - stk <- bump stk - stk <$ pokeS stk (Sq.fromList l) - {-# INLINE writeForeign #-} - --- 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]" - {-# INLINE readForeign #-} - writeForeign !stk !l = do - stk <- bump stk - stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l) - {-# INLINE writeForeign #-} - -instance ForeignConvention [Foreign] where - readForeign = readForeignAs (fmap marshalToForeign) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (fmap Foreign) - {-# INLINE writeForeign #-} - -instance ForeignConvention (MVar Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (Foreign . Wrap mvarRef) - {-# INLINE writeForeign #-} - -instance ForeignConvention (TVar Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (Foreign . Wrap tvarRef) - {-# INLINE writeForeign #-} - -instance ForeignConvention (IORef Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (Foreign . Wrap refRef) - {-# INLINE writeForeign #-} - -instance ForeignConvention (Ticket Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (Foreign . Wrap ticketRef) - {-# INLINE writeForeign #-} - -instance ForeignConvention (Promise Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (Foreign . Wrap promiseRef) - {-# INLINE writeForeign #-} - -instance ForeignConvention Code where - readForeign = readForeignBuiltin - {-# INLINE readForeign #-} - writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} - -instance ForeignConvention Value where - readForeign = readForeignBuiltin - {-# INLINE readForeign #-} - writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} - -instance ForeignConvention Foreign where - readForeign = readForeignAs marshalToForeign - {-# INLINE readForeign #-} - writeForeign = writeForeignAs Foreign - {-# INLINE writeForeign #-} - -instance ForeignConvention (PA.MutableArray s Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (Foreign . Wrap marrayRef) - {-# INLINE writeForeign #-} - -instance ForeignConvention (PA.MutableByteArray s) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef) - {-# INLINE writeForeign #-} - -instance ForeignConvention (PA.Array Val) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (Foreign . Wrap iarrayRef) - {-# INLINE writeForeign #-} - -instance ForeignConvention PA.ByteArray where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} - writeForeign = writeForeignAs (Foreign . Wrap ibytearrayRef) - {-# INLINE writeForeign #-} - -instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where - readForeign = readForeignBuiltin - {-# INLINE readForeign #-} - writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} - -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)]" - {-# INLINE readForeign #-} - - 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]" - {-# INLINE readForeign #-} - writeForeign !stk !l = do - stk <- bump stk - stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l) - {-# INLINE writeForeign #-} - -foreignCCError :: String -> IO a -foreignCCError nm = - die $ "mismatched foreign calling convention for `" ++ nm ++ "`" diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index e05cc558c2..cd61c00fa6 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -75,7 +75,7 @@ import Unison.Runtime.Array as PA import Unison.Runtime.Builtin hiding (unitValue) import Unison.Runtime.Exception hiding (die) import Unison.Runtime.Foreign -import Unison.Runtime.Foreign.Impl (foreignCall) +import Unison.Runtime.Foreign.Function (foreignCall) import Unison.Runtime.MCode import Unison.Runtime.Stack import Unison.Runtime.TypeTags qualified as TT diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index ba2bc42b9c..ffb43b0179 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -49,7 +49,6 @@ library Unison.Runtime.Foreign Unison.Runtime.Foreign.Function Unison.Runtime.Foreign.Function.Type - Unison.Runtime.Foreign.Impl Unison.Runtime.Interface Unison.Runtime.IOSource Unison.Runtime.Machine From 316e45234cbce3a30408b27a6b50a32a389a18cc Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 10 Dec 2024 10:32:25 -0800 Subject: [PATCH 18/36] Cleanup and docs --- .../src/Unison/Runtime/Foreign/Function.hs | 35 +++++++++++-------- 1 file changed, 21 insertions(+), 14 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index f8ef85c88c..09da50d99d 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -176,11 +176,18 @@ import Unison.Util.Text qualified as Util.Text import Unison.Util.Text.Pattern qualified as TPat import UnliftIO qualified +-- foreignCall is explicitly NOINLINE'd because it's a _huge_ chunk of code and negatively affects code caching. +-- Because we're not inlining it, we need a wrapper using an explicitly unboxed Stack so we don't block the +-- worker-wrapper optimizations in the main eval loop. +-- It looks dump to accept an unboxed stack and then immediately box it up, but GHC is sufficiently smart to +-- 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 !ff !args !xstk = stackIOToIOX $ foreignCallHelper ff args (packXStack xstk) -{-# NOINLINE foreignCall #-} +{-# INLINE foreignCallHelper #-} foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO Stack foreignCallHelper = \case IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> @@ -878,19 +885,20 @@ foreignCallHelper = \case exitDecode ExitSuccess = 0 exitDecode (ExitFailure n) = n - mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO Stack - mkHashAlgorithm txt alg = - let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) - in mkForeign $ \() -> pure (HashAlgorithm algoRef alg) - catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) catchAll e = do e <- Exception.tryAnyDeep e pure $ case e of Left se -> Left (Util.Text.pack (show se)) Right a -> Right a -{-# INLINE foreignCallHelper #-} +{-# INLINE mkHashAlgorithm #-} +mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO 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 !f !args !stk = do args <- decodeArgs args stk @@ -904,8 +912,8 @@ mkForeign !f !args !stk = do _ -> error "mkForeign: too many arguments for foreign function" -{-# INLINE mkForeign #-} +{-# INLINE mkForeignIOF #-} mkForeignIOF :: (ForeignConvention a, ForeignConvention r) => (a -> IO r) -> @@ -919,8 +927,8 @@ mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) handleIOE :: Either IOException a -> Either (F.Failure Val) a handleIOE (Left e) = Left $ F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue handleIOE (Right a) = Right a -{-# INLINE mkForeignIOF #-} +{-# INLINE mkForeignTls #-} mkForeignTls :: forall a r. (ForeignConvention a, ForeignConvention r) => @@ -938,8 +946,8 @@ mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) flatten (Right (Right a)) = Right a -{-# INLINE mkForeignTls #-} +{-# INLINE mkForeignTlsE #-} mkForeignTlsE :: forall a r. (ForeignConvention a, ForeignConvention r) => @@ -958,11 +966,10 @@ mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) flatten (Right (Right (Left e))) = Left e flatten (Right (Right (Right a))) = Right a -{-# INLINE mkForeignTlsE #-} +{-# INLINE unsafeSTMToIO #-} unsafeSTMToIO :: STM.STM a -> IO a unsafeSTMToIO (STM.STM m) = IO m -{-# INLINE unsafeSTMToIO #-} signEd25519Wrapper :: (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes @@ -1598,7 +1605,7 @@ instance ForeignConvention IOMode where {-# INLINE writeForeign #-} instance ForeignConvention () where - readForeign args !_ = pure (args, ()) + readForeign !args !_ = pure (args, ()) {-# INLINE readForeign #-} writeForeign !stk !_ = pure stk {-# INLINE writeForeign #-} @@ -1639,7 +1646,7 @@ instance ) => ForeignConvention (a, b, c) where - readForeign args !stk = do + readForeign !args !stk = do (args, a) <- readForeign args stk (args, b) <- readForeign args stk (args, c) <- readForeign args stk From af717a7bcb2966c7626606d112d0c8a3c3f219aa Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 10 Dec 2024 10:32:25 -0800 Subject: [PATCH 19/36] Rename sanitization --- unison-runtime/src/Unison/Runtime/Foreign/Function.hs | 2 ++ unison-runtime/src/Unison/Runtime/Interface.hs | 6 +++--- unison-runtime/src/Unison/Runtime/MCode.hs | 7 ++++--- unison-runtime/src/Unison/Runtime/Machine.hs | 4 ++-- 4 files changed, 11 insertions(+), 8 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 09da50d99d..f19872dcb0 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index 3f2ba86f83..d108b2b159 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -120,7 +120,7 @@ import Unison.Runtime.MCode emitComb, emptyRNs, resolveCombs, - sanitizeCombs, + sanitizeCombsOfForeignFuncs, ) import Unison.Runtime.MCode.Serialize import Unison.Runtime.Machine @@ -1337,7 +1337,7 @@ restoreCache sandboxed (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs <*> newTVarIO (sbs <> baseSandboxInfo) let (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = srcCombs - & sanitizeCombs sandboxed sandboxedForeignFuncs + & sanitizeCombsOfForeignFuncs sandboxed sandboxedForeignFuncs & absurdCombs & EC.mapToList & foldMap @@ -1371,7 +1371,7 @@ restoreCache sandboxed (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs combs :: EnumMap Word64 (RCombs Val) combs = srcCombs - & sanitizeCombs sandboxed sandboxedForeignFuncs + & sanitizeCombsOfForeignFuncs sandboxed sandboxedForeignFuncs & absurdCombs & resolveCombs Nothing diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 032bfa354d..a2ac8112d3 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -38,7 +38,7 @@ module Unison.Runtime.MCode emitCombs, emitComb, resolveCombs, - sanitizeCombs, + sanitizeCombsOfForeignFuncs, absurdCombs, emptyRNs, argsToLists, @@ -1808,8 +1808,9 @@ prettyArgs :: Args -> ShowS prettyArgs ZArgs = showString "ZArgs" prettyArgs v = showParen True $ shows v -sanitizeCombs :: Bool -> (Set ForeignFunc) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) -sanitizeCombs sanitize sandboxedForeigns m +-- | If running in a sandboxed environment, replace all restricted foreign functions with an error. +sanitizeCombsOfForeignFuncs :: Bool -> (Set ForeignFunc) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) +sanitizeCombsOfForeignFuncs sanitize sandboxedForeigns m | sanitize = (fmap . fmap) (sanitizeComb sandboxedForeigns) m | otherwise = m diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index cd61c00fa6..6f0516b1ce 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -196,7 +196,7 @@ baseCCache sandboxed = do combs :: EnumMap Word64 MCombs combs = srcCombs - & sanitizeCombs sandboxed sandboxedForeignFuncs + & sanitizeCombsOfForeignFuncs sandboxed sandboxedForeignFuncs & absurdCombs & resolveCombs Nothing @@ -2232,7 +2232,7 @@ cacheAdd0 ntys0 termSuperGroups sands cc = do (unresolvedNewCombs, unresolvedCacheableCombs, unresolvedNonCacheableCombs, updatedCombs) <- stateTVar (combs cc) \oldCombs -> let unresolvedNewCombs :: EnumMap Word64 (GCombs any CombIx) unresolvedNewCombs = - absurdCombs . sanitizeCombs (sandboxed cc) sandboxedForeignFuncs . mapFromList $ zipWith combinate [ntm ..] rgs + absurdCombs . sanitizeCombsOfForeignFuncs (sandboxed cc) sandboxedForeignFuncs . mapFromList $ zipWith combinate [ntm ..] rgs (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = EC.mapToList unresolvedNewCombs & foldMap \(w, gcombs) -> if EC.member w newCacheableCombs From 455649784967e500ba2549b97d00c7d690d02074 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Wed, 11 Dec 2024 19:59:27 -0500 Subject: [PATCH 20/36] distinguish between recursive and nonrecursive lets in term printer --- .../src/Unison/Syntax/TermPrinter.hs | 155 +++++++++++++++--- 1 file changed, 131 insertions(+), 24 deletions(-) diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index d864435c57..09a3fc77a5 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -18,9 +18,11 @@ import Control.Lens (unsnoc) import Control.Monad.State (evalState) import Control.Monad.State qualified as State import Data.Char (isPrint) +import Data.Foldable qualified as Foldable import Data.List import Data.List qualified as List import Data.Map qualified as Map +import Data.Sequence qualified as Seq import Data.Set qualified as Set import Data.Text (unpack) import Data.Text qualified as Text @@ -408,8 +410,7 @@ pretty0 where goNormal prec tm = pretty0 (ac prec Normal im doc) tm specialCases term go = do - doc <- prettyDoc2 a term - case doc of + prettyDoc2 a term >>= \case Just d -> pure d Nothing -> notDoc go where @@ -652,14 +653,14 @@ printLet :: (MonadPretty v m) => AmbientContext -> BlockContext -> - [(v, Term3 v PrintAnnotation)] -> + [LetBindings v (Term3 v PrintAnnotation)] -> Term3 v PrintAnnotation -> [Pretty SyntaxText] -> m (Pretty SyntaxText) printLet context sc bs e uses = do - bs <- traverse (printLetBinding bindingContext) bs + bs <- traverse (printLetBindings bindingContext) bs body <- body e - pure . paren (sc /= Block && context.precedence >= Top) . letIntro $ PP.lines (uses <> bs <> body) + pure . paren (sc /= Block && context.precedence >= Top) . letIntro $ PP.lines (uses <> concat bs <> body) where bindingContext :: AmbientContext bindingContext = @@ -671,12 +672,25 @@ printLet context sc bs e uses = do Block -> id Normal -> (fmt S.ControlKeyword "let" `PP.hang`) +printLetBindings :: + (MonadPretty v m) => + AmbientContext -> + LetBindings v (Term3 v PrintAnnotation) -> + m [Pretty SyntaxText] +printLetBindings context = \case + LetBindings bindings -> traverse (printLetBinding context) bindings + LetrecBindings bindings -> traverse (printLetrecBinding context) bindings + printLetBinding :: (MonadPretty v m) => AmbientContext -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText) printLetBinding context (v, binding) = if Var.isAction v then pretty0 context binding else renderPrettyBinding <$> prettyBinding0' context (HQ.unsafeFromVar (Var.reset v)) binding +printLetrecBinding :: (MonadPretty v m) => AmbientContext -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText) +printLetrecBinding context (v, binding) = + renderPrettyBinding <$> prettyBinding0' context (HQ.unsafeFromVar (Var.reset v)) binding + prettyPattern :: forall v loc. (Var v) => @@ -1568,14 +1582,18 @@ allInSubBlock tm p s i = -- statement, need to be emitted also by this function, otherwise the `use` -- statement may come out at an enclosing scope instead. immediateChildBlockTerms :: - (Var vt, Var v) => Term2 vt at ap v a -> [Term2 vt at ap v a] + forall a ap at v vt. (Var vt, Var v) => Term2 vt at ap v a -> [Term2 vt at ap v a] immediateChildBlockTerms = \case LetBlock bs e -> concatMap doLet bs ++ handleDelay e _ -> [] where handleDelay (Delay' b) | isLet b = [b] handleDelay _ = [] - doLet (v, Ann' tm _) = doLet (v, tm) + doLet :: LetBindings v (Term2 vt at ap v a) -> [Term2 vt at ap v a] + doLet = \case + LetBindings bindings -> concatMap doLet2 bindings + LetrecBindings bindings -> concatMap doLet2 bindings + doLet2 (v, Ann' tm _) = doLet2 (v, tm) -- we don't consider 'body' to be a place we can insert a `use` -- clause unless it's already a let block. This avoids silliness like: -- x = 1 + 1 @@ -1583,8 +1601,8 @@ immediateChildBlockTerms = \case -- x = -- use Nat + -- 1 + 1 - doLet (v, LamsNamedOpt' _ body) = [body | not (Var.isAction v), isLet body] - doLet t = error (show t) [] + doLet2 (v, LamsNamedOpt' _ body) = [body | not (Var.isAction v), isLet body] + doLet2 t = error (show t) [] isSoftHangable :: (Var v) => Term2 vt at ap v a -> Bool -- isSoftHangable (Delay' d) = isLet d || isSoftHangable d || case d of @@ -1643,42 +1661,131 @@ isBlock tm = Delay' _ -> True _ -> False +-- A `LetBindings` is either: +-- + +-- * A list of nonrecusrive lets (e.g. let x = ... in let y = ... in let z = ... in ...), where each binding is in + +-- scope for all subsequent bindings. +-- +-- In made-up syntax: +-- +-- let +-- x = ... +-- in +-- let +-- y = ... +-- in +-- let +-- z = ... +-- in +-- body +-- + +-- * A single letrec's bindings, where each binding is in scope for all subsequent bindings. + +-- +-- In made-up syntax: +-- +-- letrec +-- x = ... +-- y = ... +-- z = ... +-- in +-- body +data LetBindings v term + = LetBindings [(v, term)] + | LetrecBindings [(v, term)] + +-- | A group of let bindings (with all bound variables cached at the top level for efficiency). +-- +-- The sequence has an invariant: no two `LetBindings` in a row (that would be a single `LetBindings`). +-- +-- For example, the bindings +-- +-- a = ... +-- b = ... +-- c = ... +-- d = ... +-- e = ... +-- f = ... +-- body +-- +-- might be two lets `a` and `b`, followed by a letrec `c` and `d`, followed by a different letrec `e`, `f`: +-- +-- let +-- a = ... +-- in +-- let +-- b = ... +-- in +-- letrec +-- c = ... +-- d = ... +-- in +-- letrec +-- e = ... +-- f = ... +-- in +-- body +data LetBindingsGroups v term + = LetBindingsGroups (Set v) (Seq (LetBindings v term)) + +instance (Ord v) => Semigroup (LetBindingsGroups v term) where + LetBindingsGroups vs1 bs1 <> LetBindingsGroups vs2 bs2 = + LetBindingsGroups (Set.union vs1 vs2) (bs1 <> bs2) + +letBindingsToLetBindingsGroups :: (Ord v) => [(v, term)] -> LetBindingsGroups v term +letBindingsToLetBindingsGroups bindings = + LetBindingsGroups (Set.fromList (map fst bindings)) (Seq.singleton (LetBindings bindings)) + +letrecBindingsToLetBindingsGroups :: (Ord v) => [(v, term)] -> LetBindingsGroups v term +letrecBindingsToLetBindingsGroups bindings = + LetBindingsGroups (Set.fromList (map fst bindings)) (Seq.singleton (LetrecBindings bindings)) + pattern LetBlock :: (Ord v) => - [(v, Term2 vt at ap v a)] -> + [LetBindings v (Term2 vt at ap v a)] -> Term2 vt at ap v a -> Term2 vt at ap v a -pattern LetBlock bindings body <- (unLetBlock -> Just (bindings, body)) +pattern LetBlock bindings body <- + (unLetBlock -> Just (LetBindingsGroups _ (Foldable.toList @Seq -> bindings), body)) -- Collects nested let/let rec blocks into one minimally nested block. -- Handy because `let` and `let rec` blocks get rendered the same way. -- We preserve nesting when the inner block shadows definitions in the -- outer block. unLetBlock :: + forall a ap at v vt. (Ord v) => Term2 vt at ap v a -> - Maybe ([(v, Term2 vt at ap v a)], Term2 vt at ap v a) -unLetBlock t = rec t + Maybe (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a) +unLetBlock = rec where - dontIntersect v1s v2s = - all (`Set.notMember` v2set) (fst <$> v1s) - where - v2set = Set.fromList (fst <$> v2s) + dontIntersect :: LetBindingsGroups v term -> LetBindingsGroups v term -> Bool + dontIntersect (LetBindingsGroups xs _) (LetBindingsGroups ys _) = + Set.disjoint xs ys + + rec :: Term2 vt at ap v a -> Maybe (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a) rec t = case unLetRecNamed t of Nothing -> nonrec t - Just (_isTop, bindings, body) -> case rec body of - Just (innerBindings, innerBody) - | dontIntersect bindings innerBindings -> - Just (bindings ++ innerBindings, innerBody) - _ -> Just (bindings, body) + Just (_isTop, bindings0, body) -> + let bindings = letrecBindingsToLetBindingsGroups bindings0 + in case rec body of + Just (innerBindings, innerBody) + | dontIntersect bindings innerBindings -> + Just (bindings <> innerBindings, innerBody) + _ -> Just (bindings, body) + + nonrec :: Term2 vt at ap v a -> Maybe (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a) nonrec t = case unLet t of Nothing -> Nothing Just (bindings0, body) -> - let bindings = [(v, b) | (_, v, b) <- bindings0] + let bindings = letBindingsToLetBindingsGroups [(v, b) | (_, v, b) <- bindings0] in case rec body of Just (innerBindings, innerBody) | dontIntersect bindings innerBindings -> - Just (bindings ++ innerBindings, innerBody) + Just (bindings <> innerBindings, innerBody) _ -> Just (bindings, body) pattern LamsNamedMatch' :: From 6779235ac8792a4ee3e9b3a1c8cc31e13b184d1b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 13 Dec 2024 11:46:01 -0800 Subject: [PATCH 21/36] Remove obviously redundant bang patterns --- .../src/Unison/Runtime/Foreign/Function.hs | 56 +++++++++---------- 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index f19872dcb0..c16039f134 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -1323,8 +1323,8 @@ class ForeignConvention a where Stack -> a -> IO Stack instance ForeignConvention Int where - readForeign !(i : args) !stk = (args,) <$> peekOffI stk i - readForeign ![] !_ = foreignCCError "Int" + readForeign (i : args) !stk = (args,) <$> peekOffI stk i + readForeign [] !_ = foreignCCError "Int" {-# INLINE readForeign #-} writeForeign !stk !i = do stk <- bump stk @@ -1332,8 +1332,8 @@ instance ForeignConvention Int where {-# INLINE writeForeign #-} instance ForeignConvention Word64 where - readForeign !(i : args) !stk = (args,) <$> peekOffN stk i - readForeign ![] !_ = foreignCCError "Word64" + readForeign (i : args) !stk = (args,) <$> peekOffN stk i + readForeign [] !_ = foreignCCError "Word64" {-# INLINE readForeign #-} writeForeign !stk !n = do stk <- bump stk @@ -1361,8 +1361,8 @@ instance ForeignConvention Word32 where {-# INLINE writeForeign #-} instance ForeignConvention Char where - readForeign !(i : args) !stk = (args,) <$> peekOffC stk i - readForeign ![] !_ = foreignCCError "Char" + readForeign (i : args) !stk = (args,) <$> peekOffC stk i + readForeign [] !_ = foreignCCError "Char" {-# INLINE readForeign #-} writeForeign !stk !ch = do stk <- bump stk @@ -1370,8 +1370,8 @@ instance ForeignConvention Char where {-# INLINE writeForeign #-} instance ForeignConvention Val where - readForeign !(i : args) !stk = (args,) <$> peekOff stk i - readForeign ![] !_ = foreignCCError "Val" + readForeign (i : args) !stk = (args,) <$> peekOff stk i + readForeign [] !_ = foreignCCError "Val" {-# INLINE readForeign #-} writeForeign !stk !v = do stk <- bump stk @@ -1381,8 +1381,8 @@ instance ForeignConvention Val where -- 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" + readForeign (i : args) !stk = (args,) <$> bpeekOff stk i + readForeign [] !_ = foreignCCError "Closure" {-# INLINE readForeign #-} writeForeign !stk !c = do stk <- bump stk @@ -1432,18 +1432,18 @@ instance ForeignConvention POSIXTime where {-# INLINE writeForeign #-} instance (ForeignConvention a) => ForeignConvention (Maybe a) where - readForeign !(i : args) !stk = + readForeign (i : args) !stk = upeekOff stk i >>= \case 0 -> pure (args, Nothing) 1 -> fmap Just <$> readForeign args stk _ -> foreignCCError "Maybe" - readForeign ![] !_ = foreignCCError "Maybe" + readForeign [] !_ = foreignCCError "Maybe" {-# INLINE readForeign #-} - writeForeign !stk !Nothing = do + writeForeign !stk Nothing = do stk <- bump stk stk <$ pokeTag stk 0 - writeForeign !stk !(Just x) = do + writeForeign !stk (Just x) = do stk <- writeForeign stk x stk <- bump stk stk <$ pokeTag stk 1 @@ -1453,7 +1453,7 @@ instance (ForeignConvention a, ForeignConvention b) => ForeignConvention (Either a b) where - readForeign !(i : args) !stk = + readForeign (i : args) !stk = peekTagOff stk i >>= \case 0 -> readForeignAs Left args stk 1 -> readForeignAs Right args stk @@ -1567,7 +1567,7 @@ readTypelink = readForeignAs (unwrapForeign . marshalToForeign) {-# INLINE readTypelink #-} instance ForeignConvention Double where - readForeign !(i : args) !stk = (args,) <$> peekOffD stk i + readForeign (i : args) !stk = (args,) <$> peekOffD stk i readForeign !_ !_ = foreignCCError "Double" {-# INLINE readForeign #-} writeForeign !stk !d = @@ -1577,7 +1577,7 @@ instance ForeignConvention Double where {-# INLINE writeForeign #-} instance ForeignConvention Bool where - readForeign !(i : args) !stk = do + readForeign (i : args) !stk = do b <- peekOffBool stk i pure (args, b) readForeign !_ !_ = foreignCCError "Bool" @@ -1622,7 +1622,7 @@ instance pure (args, (a, b)) {-# INLINE readForeign #-} - writeForeign !stk !(x, y) = do + writeForeign !stk (x, y) = do stk <- writeForeign stk y writeForeign stk x {-# INLINE writeForeign #-} @@ -1635,7 +1635,7 @@ instance (ForeignConvention a) => ForeignConvention (F.Failure a) where pure (args, F.Failure typeref message any) {-# INLINE readForeign #-} - writeForeign !stk !(F.Failure typeref message any) = do + writeForeign !stk (F.Failure typeref message any) = do stk <- writeForeign stk any stk <- writeForeign stk message writeTypeLink stk typeref @@ -1655,7 +1655,7 @@ instance pure (args, (a, b, c)) {-# INLINE readForeign #-} - writeForeign !stk !(a, b, c) = do + writeForeign !stk (a, b, c) = do stk <- writeForeign stk c stk <- writeForeign stk b writeForeign stk a @@ -1677,7 +1677,7 @@ instance pure (args, (a, b, c, d)) {-# INLINE readForeign #-} - writeForeign !stk !(a, b, c, d) = do + writeForeign !stk (a, b, c, d) = do stk <- writeForeign stk d stk <- writeForeign stk c stk <- writeForeign stk b @@ -1702,7 +1702,7 @@ instance pure (args, (a, b, c, d, e)) {-# INLINE readForeign #-} - writeForeign !stk !(a, b, c, d, e) = do + writeForeign !stk (a, b, c, d, e) = do stk <- writeForeign stk e stk <- writeForeign stk d stk <- writeForeign stk c @@ -1717,7 +1717,7 @@ block'buf = fromIntegral Ty.bufferModeBlockBufferingId sblock'buf = fromIntegral Ty.bufferModeSizedBlockBufferingId instance ForeignConvention BufferMode where - readForeign !(i : args) !stk = + readForeign (i : args) !stk = peekOffN stk i >>= \case t | t == no'buf -> pure (args, NoBuffering) @@ -1733,7 +1733,7 @@ instance ForeignConvention BufferMode where {-# INLINE readForeign #-} writeForeign !stk !bm = - bump stk >>= \(!stk) -> + bump stk >>= \(stk) -> case bm of NoBuffering -> stk <$ pokeN stk no'buf LineBuffering -> stk <$ pokeN stk line'buf @@ -1747,7 +1747,7 @@ instance ForeignConvention BufferMode where -- 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 = + readForeign (i : args) !stk = (args,) . toList <$> peekOffS stk i readForeign !_ !_ = foreignCCError "[Val]" {-# INLINE readForeign #-} @@ -1759,7 +1759,7 @@ instance {-# OVERLAPPING #-} ForeignConvention [Val] where -- 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 = + readForeign (i : args) !stk = (args,) . fmap getBoxedVal . toList <$> peekOffS stk i readForeign !_ !_ = foreignCCError "[Closure]" {-# INLINE readForeign #-} @@ -1872,7 +1872,7 @@ unwrapForeignClosure :: Closure -> a unwrapForeignClosure = unwrapForeign . marshalToForeign instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where - readForeign !(i : args) !stk = + readForeign (i : args) !stk = (args,) . fmap (fromUnisonPair . getBoxedVal) . toList @@ -1885,7 +1885,7 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignCon stk <$ pokeS stk (boxedVal . toUnisonPair <$> Sq.fromList l) instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where - readForeign !(i : args) !stk = + readForeign (i : args) !stk = (args,) . fmap (unwrapForeignClosure . getBoxedVal) . toList From 33db037cdeefd2935cfb5f4614b4314ff8a51330 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 13 Dec 2024 11:59:26 -0800 Subject: [PATCH 22/36] Remove all INLINEs on ForeignConvention --- .../src/Unison/Runtime/Foreign/Function.hs | 101 ------------------ 1 file changed, 101 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index c16039f134..f4404ccfb7 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -1325,111 +1325,81 @@ class ForeignConvention a where instance ForeignConvention Int where readForeign (i : args) !stk = (args,) <$> peekOffI stk i readForeign [] !_ = foreignCCError "Int" - {-# INLINE readForeign #-} writeForeign !stk !i = do stk <- bump stk stk <$ pokeI stk i - {-# INLINE writeForeign #-} instance ForeignConvention Word64 where readForeign (i : args) !stk = (args,) <$> peekOffN stk i readForeign [] !_ = foreignCCError "Word64" - {-# INLINE readForeign #-} writeForeign !stk !n = do stk <- bump stk stk <$ pokeN stk n - {-# INLINE writeForeign #-} -- 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) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64) - {-# INLINE writeForeign #-} instance ForeignConvention Word16 where readForeign = readForeignAs (fromIntegral :: Word64 -> Word16) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (fromIntegral :: Word16 -> Word64) - {-# INLINE writeForeign #-} instance ForeignConvention Word32 where readForeign = readForeignAs (fromIntegral :: Word64 -> Word32) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64) - {-# INLINE writeForeign #-} instance ForeignConvention Char where readForeign (i : args) !stk = (args,) <$> peekOffC stk i readForeign [] !_ = foreignCCError "Char" - {-# INLINE readForeign #-} writeForeign !stk !ch = do stk <- bump stk stk <$ pokeC stk ch - {-# INLINE writeForeign #-} instance ForeignConvention Val where readForeign (i : args) !stk = (args,) <$> peekOff stk i readForeign [] !_ = foreignCCError "Val" - {-# INLINE readForeign #-} writeForeign !stk !v = do stk <- bump stk stk <$ (poke stk =<< evaluate v) - {-# INLINE writeForeign #-} -- 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" - {-# INLINE readForeign #-} writeForeign !stk !c = do stk <- bump stk stk <$ (bpoke stk =<< evaluate c) - {-# INLINE writeForeign #-} instance ForeignConvention Text where readForeign = readForeignBuiltin - {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} instance ForeignConvention Unison.Util.Bytes.Bytes where readForeign = readForeignBuiltin - {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} instance ForeignConvention Socket where readForeign = readForeignBuiltin - {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} instance ForeignConvention UDPSocket where readForeign = readForeignBuiltin - {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} instance ForeignConvention ThreadId where readForeign = readForeignBuiltin - {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} instance ForeignConvention Handle where readForeign = readForeignBuiltin - {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} instance ForeignConvention POSIXTime where readForeign = readForeignAs (fromIntegral :: Int -> POSIXTime) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (round :: POSIXTime -> Int) - {-# INLINE writeForeign #-} instance (ForeignConvention a) => ForeignConvention (Maybe a) where readForeign (i : args) !stk = @@ -1438,7 +1408,6 @@ instance (ForeignConvention a) => ForeignConvention (Maybe a) where 1 -> fmap Just <$> readForeign args stk _ -> foreignCCError "Maybe" readForeign [] !_ = foreignCCError "Maybe" - {-# INLINE readForeign #-} writeForeign !stk Nothing = do stk <- bump stk @@ -1447,7 +1416,6 @@ instance (ForeignConvention a) => ForeignConvention (Maybe a) where stk <- writeForeign stk x stk <- bump stk stk <$ pokeTag stk 1 - {-# INLINE writeForeign #-} instance (ForeignConvention a, ForeignConvention b) => @@ -1459,7 +1427,6 @@ instance 1 -> readForeignAs Right args stk _ -> foreignCCError "Either" readForeign !_ !_ = foreignCCError "Either" - {-# INLINE readForeign #-} writeForeign !stk !(Left a) = do stk <- writeForeign stk a @@ -1469,7 +1436,6 @@ instance stk <- writeForeign stk b stk <- bump stk stk <$ pokeTag stk 1 - {-# INLINE writeForeign #-} ioeDecode :: Int -> IOErrorType ioeDecode 0 = AlreadyExists @@ -1497,10 +1463,8 @@ instance ForeignConvention IOException where readForeign = readForeignAs (bld . ioeDecode) where bld t = IOError Nothing t "" "" Nothing Nothing - {-# INLINE readForeign #-} writeForeign = writeForeignAs (ioeEncode . ioe_type) - {-# INLINE writeForeign #-} readForeignAs :: (ForeignConvention a) => @@ -1509,7 +1473,6 @@ readForeignAs :: Stack -> IO ([Int], b) readForeignAs !f !args !stk = fmap f <$> readForeign args stk -{-# INLINE readForeignAs #-} writeForeignAs :: (ForeignConvention b) => @@ -1518,7 +1481,6 @@ writeForeignAs :: a -> IO Stack writeForeignAs !f !stk !x = writeForeign stk (f x) -{-# INLINE writeForeignAs #-} readForeignEnum :: (Enum a) => @@ -1526,7 +1488,6 @@ readForeignEnum :: Stack -> IO ([Int], a) readForeignEnum = readForeignAs toEnum -{-# INLINE readForeignEnum #-} writeForeignEnum :: (Enum a) => @@ -1534,7 +1495,6 @@ writeForeignEnum :: a -> IO Stack writeForeignEnum = writeForeignAs fromEnum -{-# INLINE writeForeignEnum #-} readForeignBuiltin :: (BuiltinForeign b) => @@ -1542,7 +1502,6 @@ readForeignBuiltin :: Stack -> IO ([Int], b) readForeignBuiltin = readForeignAs (unwrapBuiltin . marshalToForeign) -{-# INLINE readForeignBuiltin #-} writeForeignBuiltin :: (BuiltinForeign b) => @@ -1550,7 +1509,6 @@ writeForeignBuiltin :: b -> IO Stack writeForeignBuiltin = writeForeignAs (Foreign . wrapBuiltin) -{-# INLINE writeForeignBuiltin #-} writeTypeLink :: Stack -> @@ -1569,48 +1527,36 @@ readTypelink = readForeignAs (unwrapForeign . marshalToForeign) instance ForeignConvention Double where readForeign (i : args) !stk = (args,) <$> peekOffD stk i readForeign !_ !_ = foreignCCError "Double" - {-# INLINE readForeign #-} writeForeign !stk !d = bump stk >>= \(!stk) -> do pokeD stk d pure stk - {-# INLINE writeForeign #-} instance ForeignConvention Bool where readForeign (i : args) !stk = do b <- peekOffBool stk i pure (args, b) readForeign !_ !_ = foreignCCError "Bool" - {-# INLINE readForeign #-} writeForeign !stk !b = do stk <- bump stk pokeBool stk b pure stk - {-# INLINE writeForeign #-} instance ForeignConvention String where readForeign = readForeignAs unpack - {-# INLINE readForeign #-} writeForeign = writeForeignAs pack - {-# INLINE writeForeign #-} instance ForeignConvention SeekMode where readForeign = readForeignEnum - {-# INLINE readForeign #-} writeForeign = writeForeignEnum - {-# INLINE writeForeign #-} instance ForeignConvention IOMode where readForeign = readForeignEnum - {-# INLINE readForeign #-} writeForeign = writeForeignEnum - {-# INLINE writeForeign #-} instance ForeignConvention () where readForeign !args !_ = pure (args, ()) - {-# INLINE readForeign #-} writeForeign !stk !_ = pure stk - {-# INLINE writeForeign #-} instance (ForeignConvention a, ForeignConvention b) => @@ -1620,12 +1566,10 @@ instance (args, a) <- readForeign args stk (args, b) <- readForeign args stk pure (args, (a, b)) - {-# INLINE readForeign #-} writeForeign !stk (x, y) = do stk <- writeForeign stk y writeForeign stk x - {-# INLINE writeForeign #-} instance (ForeignConvention a) => ForeignConvention (F.Failure a) where readForeign !args !stk = do @@ -1633,13 +1577,11 @@ instance (ForeignConvention a) => ForeignConvention (F.Failure a) where (args, message) <- readForeign args stk (args, any) <- readForeign args stk pure (args, F.Failure typeref message any) - {-# INLINE readForeign #-} writeForeign !stk (F.Failure typeref message any) = do stk <- writeForeign stk any stk <- writeForeign stk message writeTypeLink stk typeref - {-# INLINE writeForeign #-} instance ( ForeignConvention a, @@ -1653,13 +1595,11 @@ instance (args, b) <- readForeign args stk (args, c) <- readForeign args stk pure (args, (a, b, c)) - {-# INLINE readForeign #-} writeForeign !stk (a, b, c) = do stk <- writeForeign stk c stk <- writeForeign stk b writeForeign stk a - {-# INLINE writeForeign #-} instance ( ForeignConvention a, @@ -1675,14 +1615,12 @@ instance (args, c) <- readForeign args stk (args, d) <- readForeign args stk pure (args, (a, b, c, d)) - {-# INLINE readForeign #-} writeForeign !stk (a, b, c, d) = do stk <- writeForeign stk d stk <- writeForeign stk c stk <- writeForeign stk b writeForeign stk a - {-# INLINE writeForeign #-} instance ( ForeignConvention a, @@ -1700,7 +1638,6 @@ instance (args, d) <- readForeign args stk (args, e) <- readForeign args stk pure (args, (a, b, c, d, e)) - {-# INLINE readForeign #-} writeForeign !stk (a, b, c, d, e) = do stk <- writeForeign stk e @@ -1708,7 +1645,6 @@ instance stk <- writeForeign stk c stk <- writeForeign stk b writeForeign stk a - {-# INLINE writeForeign #-} no'buf, line'buf, block'buf, sblock'buf :: Word64 no'buf = fromIntegral Ty.bufferModeNoBufferingId @@ -1730,7 +1666,6 @@ instance ForeignConvention BufferMode where foreignCCError $ "BufferMode (unknown tag: " <> show t <> ")" readForeign !_ !_ = foreignCCError $ "BufferMode (empty stack)" - {-# INLINE readForeign #-} writeForeign !stk !bm = bump stk >>= \(stk) -> @@ -1742,7 +1677,6 @@ instance ForeignConvention BufferMode where pokeI stk n stk <- bump stk stk <$ pokeN stk sblock'buf - {-# INLINE writeForeign #-} -- 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. @@ -1750,11 +1684,9 @@ instance {-# OVERLAPPING #-} ForeignConvention [Val] where readForeign (i : args) !stk = (args,) . toList <$> peekOffS stk i readForeign !_ !_ = foreignCCError "[Val]" - {-# INLINE readForeign #-} writeForeign !stk !l = do stk <- bump stk stk <$ pokeS stk (Sq.fromList l) - {-# INLINE writeForeign #-} -- 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. @@ -1762,95 +1694,65 @@ instance {-# OVERLAPPING #-} ForeignConvention [Closure] where readForeign (i : args) !stk = (args,) . fmap getBoxedVal . toList <$> peekOffS stk i readForeign !_ !_ = foreignCCError "[Closure]" - {-# INLINE readForeign #-} writeForeign !stk !l = do stk <- bump stk stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l) - {-# INLINE writeForeign #-} instance ForeignConvention [Foreign] where readForeign = readForeignAs (fmap marshalToForeign) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (fmap Foreign) - {-# INLINE writeForeign #-} instance ForeignConvention (MVar Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap mvarRef) - {-# INLINE writeForeign #-} instance ForeignConvention (TVar Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap tvarRef) - {-# INLINE writeForeign #-} instance ForeignConvention (IORef Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap refRef) - {-# INLINE writeForeign #-} instance ForeignConvention (Ticket Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap ticketRef) - {-# INLINE writeForeign #-} instance ForeignConvention (Promise Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap promiseRef) - {-# INLINE writeForeign #-} instance ForeignConvention Code where readForeign = readForeignBuiltin - {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} instance ForeignConvention Value where readForeign = readForeignBuiltin - {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} instance ForeignConvention Foreign where readForeign = readForeignAs marshalToForeign - {-# INLINE readForeign #-} writeForeign = writeForeignAs Foreign - {-# INLINE writeForeign #-} instance ForeignConvention (PA.MutableArray s Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap marrayRef) - {-# INLINE writeForeign #-} instance ForeignConvention (PA.MutableByteArray s) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef) - {-# INLINE writeForeign #-} instance ForeignConvention (PA.Array Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap iarrayRef) - {-# INLINE writeForeign #-} instance ForeignConvention PA.ByteArray where readForeign = readForeignAs (unwrapForeign . marshalToForeign) - {-# INLINE readForeign #-} writeForeign = writeForeignAs (Foreign . Wrap ibytearrayRef) - {-# INLINE writeForeign #-} instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where readForeign = readForeignBuiltin - {-# INLINE readForeign #-} writeForeign = writeForeignBuiltin - {-# INLINE writeForeign #-} fromUnisonPair :: (BuiltinForeign a, BuiltinForeign b) => Closure -> (a, b) fromUnisonPair (DataC _ _ [BoxedVal x, BoxedVal (DataC _ _ [BoxedVal y, BoxedVal _unit])]) = @@ -1878,7 +1780,6 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignCon . toList <$> peekOffS stk i readForeign !_ !_ = foreignCCError "[(a,b)]" - {-# INLINE readForeign #-} writeForeign !stk !l = do stk <- bump stk @@ -1891,11 +1792,9 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where . toList <$> peekOffS stk i readForeign !_ !_ = foreignCCError "[b]" - {-# INLINE readForeign #-} writeForeign !stk !l = do stk <- bump stk stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l) - {-# INLINE writeForeign #-} foreignCCError :: String -> IO a foreignCCError nm = From ad1fb708d617e8323e0b4caeb415253b0c53c2a4 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 13 Dec 2024 17:00:09 -0500 Subject: [PATCH 23/36] Do reference-based pruning for ucm compile, turn back on inlining The pruning was causing problems with compiled programs when inlining was on, because it would prune based on the inlined code. The inlined code may have certain intermediate combinators omitted, but those are still necessary to have a full picture of the source code. Since `compile` was using the MCode numbering and backing out which References are necessary from that, it would throw away the source code for these intermediate definitions. This then caused problems when e.g. cloud (running from a compiled build) would try to send code to other environments. It wouldn't have the intermediate terms necessary for the remote environment to do its own intermediate->interpreter step. This new approach does all the 'necessary terms' tracing at the intermediate level, and then instead determines which MCode level defintions are necessary from that. This means that the pruning is no longer sensitive to the inlining. So, it should be safe to turn inlining back on. --- .../src/Unison/Runtime/Interface.hs | 74 +++++++++++-------- unison-runtime/src/Unison/Runtime/Machine.hs | 3 +- 2 files changed, 46 insertions(+), 31 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index 33619b22b0..07b7bd2c0d 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -109,13 +109,11 @@ import Unison.Runtime.Exception import Unison.Runtime.MCode ( Args (..), CombIx (..), - GCombs, GInstr (..), GSection (..), RCombs, RefNums (..), absurdCombs, - combDeps, combTypes, emitComb, emptyRNs, @@ -1373,21 +1371,22 @@ restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do & resolveCombs Nothing traceNeeded :: - Word64 -> - EnumMap Word64 (GCombs clos comb) -> - IO (EnumMap Word64 (GCombs clos comb)) -traceNeeded init src = fmap (`withoutKeys` ks) $ go mempty init + Reference -> + Map Reference (SuperGroup Symbol) -> + IO (Map Reference (SuperGroup Symbol)) +traceNeeded init src = go mempty init where - ks = keysSet numberedTermLookup - go acc w - | hasKey w acc = pure acc - | Just co <- EC.lookup w src = - foldlM go (mapInsert w co acc) (foldMap combDeps co) - | otherwise = die $ "traceNeeded: unknown combinator: " ++ show w + go acc nx + | RF.isBuiltin nx = pure acc + | Map.member nx acc = pure acc + | Just co <- Map.lookup nx src = + foldlM go (Map.insert nx co acc) (groupTermLinks co) + | otherwise = + die $ "traceNeeded: unknown combinator: " ++ show nx buildSCache :: - EnumMap Word64 Combs -> EnumMap Word64 Reference -> + EnumMap Word64 Combs -> EnumSet Word64 -> EnumMap Word64 Reference -> Word64 -> @@ -1397,7 +1396,7 @@ buildSCache :: Map Reference Word64 -> Map Reference (Set Reference) -> StoredCache -buildSCache cs crsrc cacheableCombs trsrc ftm fty intsrc rtmsrc rtysrc sndbx = +buildSCache crsrc cssrc cacheableCombs trsrc ftm fty int rtmsrc rtysrc sndbx = SCache cs crs @@ -1405,19 +1404,31 @@ buildSCache cs crsrc cacheableCombs trsrc ftm fty intsrc rtmsrc rtysrc sndbx = trs ftm fty - (restrictTmR intsrc) - (restrictTmR rtmsrc) + int + rtm (restrictTyR rtysrc) (restrictTmR sndbx) where - combKeys = keysSet cs + termRefs = Map.keysSet int + + -- Retain just the Reference->Word mappings for needed code + rtm :: Map Reference Word64 + rtm = restrictTmR rtmsrc + + -- Retain numbers that correspond to the above termRefs + combKeys :: EnumSet Word64 + combKeys = foldMap setSingleton rtm + crs = restrictTmW crsrc - termRefs = foldMap Set.singleton crs + + cs :: EnumMap Word64 Combs + cs = restrictTmW cssrc typeKeys = setFromList $ (foldMap . foldMap) combTypes cs trs = restrictTyW trsrc typeRefs = foldMap Set.singleton trs + restrictTmW :: EnumMap Word64 a -> EnumMap Word64 a restrictTmW m = restrictKeys m combKeys restrictTmR :: Map Reference a -> Map Reference a restrictTmR m = Map.restrictKeys m termRefs @@ -1426,15 +1437,18 @@ buildSCache cs crsrc cacheableCombs trsrc ftm fty intsrc rtmsrc rtysrc sndbx = restrictTyR m = Map.restrictKeys m typeRefs standalone :: CCache -> Word64 -> IO StoredCache -standalone cc init = - buildSCache - <$> (readTVarIO (srcCombs cc) >>= traceNeeded init) - <*> readTVarIO (combRefs cc) - <*> readTVarIO (cacheableCombs cc) - <*> readTVarIO (tagRefs cc) - <*> readTVarIO (freshTm cc) - <*> readTVarIO (freshTy cc) - <*> readTVarIO (intermed cc) - <*> readTVarIO (refTm cc) - <*> readTVarIO (refTy cc) - <*> readTVarIO (sandbox cc) +standalone cc init = readTVarIO (combRefs cc) >>= \crs -> + case EC.lookup init crs of + Just rinit -> + buildSCache crs + <$> readTVarIO (srcCombs cc) + <*> readTVarIO (cacheableCombs cc) + <*> readTVarIO (tagRefs cc) + <*> readTVarIO (freshTm cc) + <*> readTVarIO (freshTy cc) + <*> (readTVarIO (intermed cc) >>= traceNeeded rinit) + <*> readTVarIO (refTm cc) + <*> readTVarIO (refTy cc) + <*> readTVarIO (sandbox cc) + Nothing -> + die $ "standalone: unknown combinator: " ++ show init diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 6ed9bf82de..f8993e7132 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -2207,10 +2207,11 @@ cacheAdd0 ntys0 termSuperGroups sands cc = do rtm <- updateMap (M.fromList $ zip rs [ntm ..]) (refTm cc) -- check for missing references let arities = fmap (head . ANF.arities) int <> builtinArities + inlinfo = ANF.buildInlineMap int <> builtinInlineInfo rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) (flip M.lookup arities) combinate :: Word64 -> (Reference, SuperGroup Symbol) -> (Word64, EnumMap Word64 Comb) combinate n (r, g) = - (n, emitCombs rns r n g) + (n, emitCombs rns r n $ ANF.inline inlinfo g) let combRefUpdates = (mapFromList $ zip [ntm ..] rs) let combIdFromRefMap = (M.fromList $ zip rs [ntm ..]) let newCacheableCombs = From 1fc33089bf1f9d0e2abd68393ce5549d14d720d9 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Mon, 16 Dec 2024 10:42:03 -0500 Subject: [PATCH 24/36] delay assigning a unique type guid until after namespace directive is applied --- .../src/Unison/Syntax/DeclParser.hs | 313 ++++++++---------- .../src/Unison/Syntax/FileParser.hs | 186 ++++++++--- unison-src/transcripts/idempotent/fix-5489.md | 12 +- unison-syntax/src/Unison/Syntax/Parser.hs | 15 +- 4 files changed, 278 insertions(+), 248 deletions(-) diff --git a/parser-typechecker/src/Unison/Syntax/DeclParser.hs b/parser-typechecker/src/Unison/Syntax/DeclParser.hs index 734bb51b46..3d8c9d12b1 100644 --- a/parser-typechecker/src/Unison/Syntax/DeclParser.hs +++ b/parser-typechecker/src/Unison/Syntax/DeclParser.hs @@ -1,17 +1,18 @@ module Unison.Syntax.DeclParser - ( declarations, + ( synDeclsP, + SynDecl (..), + synDeclConstructors, + synDeclName, + SynDataDecl (..), + SynEffectDecl (..), + UnresolvedModifier (..), ) where import Control.Lens -import Control.Monad.Reader (MonadReader (..)) import Data.List.NonEmpty (pattern (:|)) import Data.List.NonEmpty qualified as NonEmpty -import Data.Map qualified as Map -import Text.Megaparsec qualified as P import Unison.ABT qualified as ABT -import Unison.DataDeclaration (DataDeclaration, EffectDeclaration) -import Unison.DataDeclaration qualified as DD import Unison.Name qualified as Name import Unison.Parser.Ann (Ann) import Unison.Prelude @@ -27,45 +28,47 @@ import Unison.Var (Var) import Unison.Var qualified as Var (name, named) import Prelude hiding (readFile) --- The parsed form of record accessors, as in: --- --- type Additive a = { zero : a, (+) : a -> a -> a } --- --- The `Token v` is the variable name and location (here `zero` and `(+)`) of --- each field, and the type is the type of that field -type Accessors v = [(L.Token v, [(L.Token v, Type v Ann)])] +data SynDecl v + = SynDecl'Data !(SynDataDecl v) + | SynDecl'Effect !(SynEffectDecl v) -declarations :: - (Monad m, Var v) => - P - v - m - ( Map v (DataDeclaration v Ann), - Map v (EffectDeclaration v Ann), - Accessors v - ) -declarations = do - declarations <- many $ declaration <* optional semi - let (dataDecls0, effectDecls) = partitionEithers declarations - dataDecls = [(a, b) | (a, b, _) <- dataDecls0] - multimap :: (Ord k) => [(k, v)] -> Map k [v] - multimap = foldl' mi Map.empty - mi m (k, v) = Map.insertWith (++) k [v] m - mds = multimap dataDecls - mes = multimap effectDecls - mdsBad = Map.filter (\xs -> length xs /= 1) mds - mesBad = Map.filter (\xs -> length xs /= 1) mes - if Map.null mdsBad && Map.null mesBad - then - pure - ( Map.fromList dataDecls, - Map.fromList effectDecls, - join . map (view _3) $ dataDecls0 - ) - else - P.customFailure . DuplicateTypeNames $ - [(v, DD.annotation <$> ds) | (v, ds) <- Map.toList mdsBad] - <> [(v, DD.annotation . DD.toDataDecl <$> es) | (v, es) <- Map.toList mesBad] +instance Annotated (SynDecl v) where + ann = \case + SynDecl'Data decl -> decl.annotation + SynDecl'Effect decl -> decl.annotation + +synDeclConstructors :: SynDecl v -> [(Ann, v, Type v Ann)] +synDeclConstructors = \case + SynDecl'Data decl -> decl.constructors + SynDecl'Effect decl -> decl.constructors + +synDeclName :: SynDecl v -> L.Token v +synDeclName = \case + SynDecl'Data decl -> decl.name + SynDecl'Effect decl -> decl.name + +data SynDataDecl v = SynDataDecl + { annotation :: !Ann, + constructors :: ![(Ann, v, Type v Ann)], + fields :: !(Maybe [(L.Token v, Type v Ann)]), + modifier :: !(Maybe (L.Token UnresolvedModifier)), + name :: !(L.Token v), + tyvars :: ![v] + } + deriving stock (Generic) + +data SynEffectDecl v = SynEffectDecl + { annotation :: !Ann, + constructors :: ![(Ann, v, Type v Ann)], + modifier :: !(Maybe (L.Token UnresolvedModifier)), + name :: !(L.Token v), + tyvars :: ![v] + } + deriving stock (Generic) + +synDeclsP :: (Monad m, Var v) => P v m [SynDecl v] +synDeclsP = + many (synDeclP <* optional semi) -- | When we first walk over the modifier, it may be a `unique`, in which case we want to use a function in the parsing -- environment to map the type's name (which we haven't parsed yet) to a GUID to reuse (if any). @@ -77,27 +80,9 @@ data UnresolvedModifier | UnresolvedModifier'UniqueWithGuid !Text | UnresolvedModifier'UniqueWithoutGuid -resolveUnresolvedModifier :: (Monad m, Var v) => L.Token UnresolvedModifier -> v -> P v m (L.Token DD.Modifier) -resolveUnresolvedModifier unresolvedModifier var = - case L.payload unresolvedModifier of - UnresolvedModifier'Structural -> pure (DD.Structural <$ unresolvedModifier) - UnresolvedModifier'UniqueWithGuid guid -> pure (DD.Unique guid <$ unresolvedModifier) - UnresolvedModifier'UniqueWithoutGuid -> do - unique <- resolveUniqueModifier var - pure $ unique <$ unresolvedModifier - -resolveUniqueModifier :: (Monad m, Var v) => v -> P v m DD.Modifier -resolveUniqueModifier var = do - env <- ask - guid <- - lift (lift (env.uniqueTypeGuid (Name.unsafeParseVar var))) >>= \case - Nothing -> uniqueName 32 - Just guid -> pure guid - pure (DD.Unique guid) - -- unique[someguid] type Blah = ... -modifier :: (Monad m, Var v) => P v m (Maybe (L.Token UnresolvedModifier)) -modifier = do +modifierP :: (Monad m, Var v) => P v m (Maybe (L.Token UnresolvedModifier)) +modifierP = do optional (unique <|> structural) where unique = do @@ -109,31 +94,16 @@ modifier = do tok <- openBlockWith "structural" pure (UnresolvedModifier'Structural <$ tok) -declaration :: - (Monad m, Var v) => - P - v - m - ( Either - (v, DataDeclaration v Ann, Accessors v) - (v, EffectDeclaration v Ann) - ) -declaration = do - mod <- modifier - fmap Right (effectDeclaration mod) <|> fmap Left (dataDeclaration mod) +synDeclP :: (Monad m, Var v) => P v m (SynDecl v) +synDeclP = do + modifier <- modifierP + SynDecl'Effect <$> synEffectDeclP modifier <|> SynDecl'Data <$> synDataDeclP modifier -dataDeclaration :: - forall m v. - (Monad m, Var v) => - Maybe (L.Token UnresolvedModifier) -> - P v m (v, DataDeclaration v Ann, Accessors v) -dataDeclaration maybeUnresolvedModifier = do +synDataDeclP :: forall m v. (Monad m, Var v) => Maybe (L.Token UnresolvedModifier) -> P v m (SynDataDecl v) +synDataDeclP modifier = do typeToken <- fmap void (reserved "type") <|> openBlockWith "type" - (name, typeArgs) <- - (,) - <$> TermParser.verifyRelativeVarName prefixDefinitionName - <*> many (TermParser.verifyRelativeVarName prefixDefinitionName) - let typeArgVs = L.payload <$> typeArgs + (name, typeArgs) <- (,) <$> prefixVar <*> many prefixVar + let tyvars = L.payload <$> typeArgs eq <- reserved "=" let -- go gives the type of the constructor, given the types of -- the constructor arguments, e.g. Cons becomes forall a . a -> List a -> List a @@ -146,127 +116,104 @@ dataDeclaration maybeUnresolvedModifier = do -- ctorType e.g. `a -> Optional a` -- or just `Optional a` in the case of `None` ctorType = foldr arrow ctorReturnType ctorArgs - ctorAnn = ann ctorName <> maybe (ann ctorName) ann (lastMay ctorArgs) + ctorAnn = ann ctorName <> maybe mempty ann (lastMay ctorArgs) in ( ctorAnn, ( ann ctorName, Var.namespaced (L.payload name :| [L.payload ctorName]), - Type.foralls ctorAnn typeArgVs ctorType + Type.foralls ctorAnn tyvars ctorType ) ) - prefixVar = TermParser.verifyRelativeVarName prefixDefinitionName - dataConstructor :: P v m (Ann, (Ann, v, Type v Ann)) - dataConstructor = go <$> prefixVar <*> many TypeParser.valueTypeLeaf - record :: P v m ([(Ann, (Ann, v, Type v Ann))], [(L.Token v, [(L.Token v, Type v Ann)])], Ann) + record :: P v m ((Ann, v, Type v Ann), Maybe [(L.Token v, Type v Ann)], Ann) record = do _ <- openBlockWith "{" let field :: P v m [(L.Token v, Type v Ann)] field = do f <- liftA2 (,) (prefixVar <* reserved ":") TypeParser.valueType - optional (reserved ",") - >>= ( \case - Nothing -> pure [f] - Just _ -> maybe [f] (f :) <$> (optional semi *> optional field) - ) + optional (reserved ",") >>= \case + Nothing -> pure [f] + Just _ -> maybe [f] (f :) <$> (optional semi *> optional field) fields <- field closingToken <- closeBlock let lastSegment = name <&> (\v -> Var.named (Name.toText $ Name.unqualified (Name.unsafeParseVar v))) - pure ([go lastSegment (snd <$> fields)], [(name, fields)], ann closingToken) - (constructors, accessors, closingAnn) <- - msum [Left <$> record, Right <$> sepBy (reserved "|") dataConstructor] <&> \case - Left (constructors, accessors, closingAnn) -> (constructors, accessors, closingAnn) - Right constructors -> do - let closingAnn :: Ann - closingAnn = NonEmpty.last (ann eq NonEmpty.:| ((\(constrSpanAnn, _) -> constrSpanAnn) <$> constructors)) - in (constructors, [], closingAnn) - _ <- closeBlock - case maybeUnresolvedModifier of + pure (snd (go lastSegment (snd <$> fields)), Just fields, ann closingToken) + optional record >>= \case Nothing -> do - modifier <- resolveUniqueModifier (L.payload name) - -- ann spanning the whole Decl. - let declSpanAnn = ann typeToken <> closingAnn + constructors <- sepBy (reserved "|") (go <$> prefixVar <*> many TypeParser.valueTypeLeaf) + _ <- closeBlock + let closingAnn :: Ann + closingAnn = NonEmpty.last (ann eq NonEmpty.:| ((\(constrSpanAnn, _) -> constrSpanAnn) <$> constructors)) pure - ( L.payload name, - DD.mkDataDecl' modifier declSpanAnn typeArgVs (snd <$> constructors), - accessors - ) - Just unresolvedModifier -> do - modifier <- resolveUnresolvedModifier unresolvedModifier (L.payload name) - -- ann spanning the whole Decl. - -- Technically the typeToken is redundant here, but this is more future proof. - let declSpanAnn = ann typeToken <> ann modifier <> closingAnn + SynDataDecl + { annotation = maybe (ann typeToken) ann modifier <> closingAnn, + constructors = snd <$> constructors, + fields = Nothing, + modifier, + name, + tyvars + } + Just (constructor, fields, closingAnn) -> do + _ <- closeBlock pure - ( L.payload name, - DD.mkDataDecl' (L.payload modifier) declSpanAnn typeArgVs (snd <$> constructors), - accessors - ) + SynDataDecl + { annotation = maybe (ann typeToken) ann modifier <> closingAnn, + constructors = [constructor], + fields, + modifier, + name, + tyvars + } + where + prefixVar :: P v m (L.Token v) + prefixVar = + TermParser.verifyRelativeVarName prefixDefinitionName -effectDeclaration :: - forall m v. - (Monad m, Var v) => - Maybe (L.Token UnresolvedModifier) -> - P v m (v, EffectDeclaration v Ann) -effectDeclaration maybeUnresolvedModifier = do +synEffectDeclP :: forall m v. (Monad m, Var v) => Maybe (L.Token UnresolvedModifier) -> P v m (SynEffectDecl v) +synEffectDeclP modifier = do abilityToken <- fmap void (reserved "ability") <|> openBlockWith "ability" name <- TermParser.verifyRelativeVarName prefixDefinitionName typeArgs <- many (TermParser.verifyRelativeVarName prefixDefinitionName) - let typeArgVs = L.payload <$> typeArgs blockStart <- openBlockWith "where" - constructors <- sepBy semi (constructor typeArgs name) + constructors <- sepBy semi (effectConstructorP typeArgs name) -- `ability` opens a block, as does `where` _ <- closeBlock <* closeBlock let closingAnn = last $ ann blockStart : ((\(_, _, t) -> ann t) <$> constructors) + pure + SynEffectDecl + { annotation = maybe (ann abilityToken) ann modifier <> closingAnn, + constructors, + modifier, + name, + tyvars = L.payload <$> typeArgs + } - case maybeUnresolvedModifier of - Nothing -> do - modifier <- resolveUniqueModifier (L.payload name) - -- ann spanning the whole ability declaration. - let abilitySpanAnn = ann abilityToken <> closingAnn - pure - ( L.payload name, - DD.mkEffectDecl' modifier abilitySpanAnn typeArgVs constructors - ) - Just unresolvedModifier -> do - modifier <- resolveUnresolvedModifier unresolvedModifier (L.payload name) - -- ann spanning the whole ability declaration. - -- Technically the abilityToken is redundant here, but this is more future proof. - let abilitySpanAnn = ann abilityToken <> ann modifier <> closingAnn - pure - ( L.payload name, - DD.mkEffectDecl' - (L.payload modifier) - abilitySpanAnn - typeArgVs - constructors +effectConstructorP :: (Monad m, Var v) => [L.Token v] -> L.Token v -> P v m (Ann, v, Type v Ann) +effectConstructorP typeArgs name = + explodeToken + <$> TermParser.verifyRelativeVarName prefixDefinitionName + <* reserved ":" + <*> ( Type.generalizeLowercase mempty + . ensureEffect + <$> TypeParser.computationType ) where - constructor :: [L.Token v] -> L.Token v -> P v m (Ann, v, Type v Ann) - constructor typeArgs name = - explodeToken - <$> TermParser.verifyRelativeVarName prefixDefinitionName - <* reserved ":" - <*> ( Type.generalizeLowercase mempty - . ensureEffect - <$> TypeParser.computationType - ) - where - explodeToken v t = (ann v, Var.namespaced (L.payload name :| [L.payload v]), t) - -- If the effect is not syntactically present in the constructor types, - -- add them after parsing. - ensureEffect t = case t of - Type.Effect' _ _ -> modEffect t - x -> Type.editFunctionResult modEffect x - modEffect t = case t of - Type.Effect' es t -> go es t - t -> go [] t - toTypeVar t = Type.av' (ann t) (Var.name $ L.payload t) - headIs t v = case t of - Type.Apps' (Type.Var' x) _ -> x == v - Type.Var' x -> x == v - _ -> False - go es t = - let es' = - if any (`headIs` L.payload name) es - then es - else Type.apps' (toTypeVar name) (toTypeVar <$> typeArgs) : es - in Type.cleanupAbilityLists $ Type.effect (ABT.annotation t) es' t + explodeToken v t = (ann v, Var.namespaced (L.payload name :| [L.payload v]), t) + -- If the effect is not syntactically present in the constructor types, + -- add them after parsing. + ensureEffect t = case t of + Type.Effect' _ _ -> modEffect t + x -> Type.editFunctionResult modEffect x + modEffect t = case t of + Type.Effect' es t -> go es t + t -> go [] t + toTypeVar t = Type.av' (ann t) (Var.name $ L.payload t) + headIs t v = case t of + Type.Apps' (Type.Var' x) _ -> x == v + Type.Var' x -> x == v + _ -> False + go es t = + let es' = + if any (`headIs` L.payload name) es + then es + else Type.apps' (toTypeVar name) (toTypeVar <$> typeArgs) : es + in Type.cleanupAbilityLists $ Type.effect (ABT.annotation t) es' t diff --git a/parser-typechecker/src/Unison/Syntax/FileParser.hs b/parser-typechecker/src/Unison/Syntax/FileParser.hs index 1c41678d1f..96e07287ad 100644 --- a/parser-typechecker/src/Unison/Syntax/FileParser.hs +++ b/parser-typechecker/src/Unison/Syntax/FileParser.hs @@ -5,14 +5,14 @@ where import Control.Lens import Control.Monad.Reader (asks, local) +import Data.Foldable (foldlM) import Data.List qualified as List import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text import Text.Megaparsec qualified as P import Unison.ABT qualified as ABT -import Unison.DataDeclaration (DataDeclaration, EffectDeclaration) -import Unison.DataDeclaration qualified as DD +import Unison.DataDeclaration (DataDeclaration (..), EffectDeclaration) import Unison.DataDeclaration qualified as DataDeclaration import Unison.DataDeclaration.Records (generateRecordAccessors) import Unison.Name qualified as Name @@ -23,7 +23,7 @@ import Unison.Parser.Ann (Ann) import Unison.Parser.Ann qualified as Ann import Unison.Prelude import Unison.Reference (TypeReferenceId) -import Unison.Syntax.DeclParser (declarations) +import Unison.Syntax.DeclParser (SynDataDecl (..), SynDecl (..), SynEffectDecl (..), UnresolvedModifier (..), synDeclName, synDeclsP, synDeclConstructors) import Unison.Syntax.Lexer qualified as L import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar) import Unison.Syntax.Parser @@ -57,62 +57,74 @@ file = do Just _ -> do namespace <- importWordyId <|> importSymbolyId void (optional semi) - pure (Just (L.payload namespace)) + pure (Just namespace.payload) let maybeNamespaceVar = Name.toVar <$> maybeNamespace -- The file may optionally contain top-level imports, -- which are parsed and applied to the type decls and term stanzas (namesStart, imports) <- TermParser.imports <* optional semi - (dataDecls, effectDecls, parsedAccessors) <- declarations - env <- - let applyNamespaceToDecls :: forall decl. Iso' decl (DataDeclaration v Ann) -> Map v decl -> Map v decl - applyNamespaceToDecls dataDeclL = - case maybeNamespaceVar of - Nothing -> id - Just namespace -> Map.fromList . map f . Map.toList - where - f :: (v, decl) -> (v, decl) - f (declName, decl) = - ( Var.namespaced2 namespace declName, - review dataDeclL (applyNamespaceToDataDecl namespace unNamespacedTypeNames (view dataDeclL decl)) - ) + -- Parse all syn decls + unNamespacedSynDecls <- synDeclsP + + -- Sanity check: bail if there's a duplicate name among them + unNamespacedSynDecls + & List.map (\decl -> (L.payload (synDeclName decl), decl)) + & List.multimap + & Map.toList + & mapMaybe \case + (name, decls@(_ : _ : _)) -> Just (name, map ann decls) + _ -> Nothing + & \case + [] -> pure () + dupes -> P.customFailure (DuplicateTypeNames dupes) + + -- Apply the namespace directive (if there is one) to the decls + let synDecls = maybe id applyNamespaceToSynDecls maybeNamespaceVar unNamespacedSynDecls - unNamespacedTypeNames :: Set v - unNamespacedTypeNames = - Set.union (Map.keysSet dataDecls) (Map.keysSet effectDecls) + -- Compute an environment from the decls that we use to parse terms + env <- do + -- Make real data/effect decls from the "syntactic" ones + (dataDecls, effectDecls) <- synDeclsToDecls synDecls + result <- UFN.environmentFor namesStart dataDecls effectDecls & onLeft \errs -> resolutionFailures (toList errs) + result & onLeft \errs -> P.customFailure (TypeDeclarationErrors errs) - dataDecls1 = applyNamespaceToDecls id dataDecls - effectDecls1 = applyNamespaceToDecls DataDeclaration.asDataDecl_ effectDecls - in case UFN.environmentFor namesStart dataDecls1 effectDecls1 of - Right (Right env) -> pure env - Right (Left es) -> P.customFailure $ TypeDeclarationErrors es - Left es -> resolutionFailures (toList es) + -- Generate the record accessors with *un-namespaced* names (passing `typ` rather than `typ1`) below, because we need + -- to know these names in order to perform rewriting. As an example, + -- + -- namespace foo + -- type Bar = { baz : Nat } + -- term = ... Bar.baz ... + -- + -- we want to rename `Bar.baz` to `foo.Bar.baz`, and it seems easier to first generate un-namespaced accessors like + -- `Bar.baz`, rather than rip off the namespace from accessors like `foo.Bar.baz` (though not by much). let unNamespacedAccessors :: [(v, Ann, Term v Ann)] - unNamespacedAccessors = do - (typ, fields) <- parsedAccessors - -- The parsed accessor has an un-namespaced type, so apply the namespace directive (if necessary) before - -- looking up in the environment computed by `environmentFor`. - let typ1 = maybe id Var.namespaced2 maybeNamespaceVar (L.payload typ) - Just (r, _) <- [Map.lookup typ1 (UF.datas env)] - -- Generate the record accessors with *un-namespaced* names (passing `typ` rather than `typ1`) below, because we - -- need to know these names in order to perform rewriting. As an example, - -- - -- namespace foo - -- type Bar = { baz : Nat } - -- term = ... Bar.baz ... - -- - -- we want to rename `Bar.baz` to `foo.Bar.baz`, and it seems easier to first generate un-namespaced accessors - -- like `Bar.baz`, rather than rip off the namespace from accessors like `foo.Bar.baz` (though not by much). - generateRecordAccessors Var.namespaced Ann.GeneratedFrom (toPair <$> fields) (L.payload typ) r + unNamespacedAccessors = + foldMap + ( \case + -- N.B. the fields themselves were not namespaced by `applyNamespaceToSynDecls` + SynDecl'Data decl + | Just fields <- decl.fields, + Just (ref, _) <- Map.lookup decl.name.payload (UF.datas env) -> + generateRecordAccessors + Var.namespaced + Ann.GeneratedFrom + (toPair <$> fields) + decl.name.payload + ref + _ -> [] + ) + synDecls where - toPair (tok, typ) = (L.payload tok, ann tok <> ann typ) + toPair (tok, typ) = (tok.payload, ann tok <> ann typ) + let accessors :: [(v, Ann, Term v Ann)] accessors = unNamespacedAccessors & case maybeNamespaceVar of Nothing -> id Just namespace -> over (mapped . _1) (Var.namespaced2 namespace) + -- At this stage of the file parser, we've parsed all the type and ability -- declarations. let updateEnvForTermParsing e = @@ -137,8 +149,7 @@ file = do [ -- The vars parsed from the stanzas themselves (before applying namespace directive) Set.fromList (unNamespacedStanzas >>= getVars), -- The un-namespaced constructor names (from the *originally-parsed* data and effect decls) - foldMap (Set.fromList . DataDeclaration.constructorVars) dataDecls, - foldMap (Set.fromList . DataDeclaration.constructorVars . DataDeclaration.toDataDecl) effectDecls, + foldMap (Set.fromList . map (view _2) . synDeclConstructors) unNamespacedSynDecls, -- The un-namespaced accessors Set.fromList (map (view _1) unNamespacedAccessors) ] @@ -175,18 +186,85 @@ file = do (terms <> accessors) (List.multimap watches) -applyNamespaceToDataDecl :: forall a v. (Var v) => v -> Set v -> DataDeclaration v a -> DataDeclaration v a -applyNamespaceToDataDecl namespace locallyBoundTypes = - over (DataDeclaration.constructors_ . mapped) \(ann, conName, conTy) -> - (ann, Var.namespaced2 namespace conName, ABT.substsInheritAnnotation replacements conTy) +-- | Suppose a data declaration `Foo` has a constructor `A` with fields `B` and `C`, where `B` is locally-bound and `C` +-- is not: +-- +-- @ +-- type B +-- +-- type Foo +-- constructor Foo.A : B -> C -> Foo +-- @ +-- +-- Then, this function applies a namespace "namespace" to the data declaration `Foo` by prefixing each of its +-- constructors and references to locally-bound types with "namespace": +-- +-- @ +-- type Foo +-- constructor namespace.Foo.A : namespace.B -> C -> foo.Foo +-- ^^^^^^^^^^ ^^^^^^^^^^ ^^^^ +-- @ +-- +-- (note that the name for the data declaration itself is not prefixed within this function, because a data declaration +-- does not contain its own name). +applyNamespaceToSynDecls :: forall v. (Var v) => v -> [SynDecl v] -> [SynDecl v] +applyNamespaceToSynDecls namespace decls = + map + ( \case + SynDecl'Data decl -> + SynDecl'Data + ( decl + & over (#constructors . mapped) applyToConstructor + & over (#name . mapped) (Var.namespaced2 namespace) + ) + SynDecl'Effect decl -> + SynDecl'Effect + ( decl + & over (#constructors . mapped) applyToConstructor + & over (#name . mapped) (Var.namespaced2 namespace) + ) + ) + decls where + applyToConstructor :: (Ann, v, Type v Ann) -> (Ann, v, Type v Ann) + applyToConstructor (ann, name, typ) = + ( ann, + Var.namespaced2 namespace name, + ABT.substsInheritAnnotation typeReplacements typ + ) + -- Replace var "Foo" with var "namespace.Foo" - replacements :: [(v, Type v ())] - replacements = - locallyBoundTypes + typeReplacements :: [(v, Type v ())] + typeReplacements = + decls + & List.foldl' (\acc decl -> Set.insert (L.payload (synDeclName decl)) acc) Set.empty & Set.toList & map (\v -> (v, Type.var () (Var.namespaced2 namespace v))) +synDeclsToDecls :: (Monad m, Var v) => [SynDecl v] -> P v m (Map v (DataDeclaration v Ann), Map v (EffectDeclaration v Ann)) +synDeclsToDecls = do + foldlM + ( \(datas, effects) -> \case + SynDecl'Data decl -> do + modifier <- resolveModifier decl.name decl.modifier + let decl1 = DataDeclaration modifier decl.annotation decl.tyvars decl.constructors + let !datas1 = Map.insert decl.name.payload decl1 datas + pure (datas1, effects) + SynDecl'Effect decl -> do + modifier <- resolveModifier decl.name decl.modifier + let decl1 = DataDeclaration.mkEffectDecl' modifier decl.annotation decl.tyvars decl.constructors + let !effects1 = Map.insert decl.name.payload decl1 effects + pure (datas, effects1) + ) + (Map.empty, Map.empty) + where + resolveModifier name modifier = + case L.payload <$> modifier of + Just UnresolvedModifier'Structural -> pure DataDeclaration.Structural + Just (UnresolvedModifier'UniqueWithGuid guid) -> pure (DataDeclaration.Unique guid) + Just UnresolvedModifier'UniqueWithoutGuid -> resolveUniqueTypeGuid name.payload + Nothing -> resolveUniqueTypeGuid name.payload + applyNamespaceToStanza :: forall a v. (Var v) => @@ -253,13 +331,13 @@ checkForDuplicateTermsAndConstructors datas effects terms watches = do } where effectDecls :: [DataDeclaration v Ann] - effectDecls = Map.elems . fmap (DD.toDataDecl . snd) $ effects + effectDecls = Map.elems . fmap (DataDeclaration.toDataDecl . snd) $ effects dataDecls :: [DataDeclaration v Ann] dataDecls = fmap snd $ Map.elems datas allConstructors :: [(v, Ann)] allConstructors = (dataDecls <> effectDecls) - & foldMap DD.constructors' + & foldMap DataDeclaration.constructors' & fmap (\(ann, v, _typ) -> (v, ann)) allTerms :: [(v, Ann)] allTerms = diff --git a/unison-src/transcripts/idempotent/fix-5489.md b/unison-src/transcripts/idempotent/fix-5489.md index d4decb0f7e..d02355ebb7 100644 --- a/unison-src/transcripts/idempotent/fix-5489.md +++ b/unison-src/transcripts/idempotent/fix-5489.md @@ -11,7 +11,7 @@ type Foo = Foo change: ⍟ These new definitions are ok to `add`: - + type foo.Foo ``` @@ -31,12 +31,6 @@ type Foo = Foo ``` ucm :added-by-ucm Loading changes detected in scratch.u. - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type foo.Foo + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. ``` diff --git a/unison-syntax/src/Unison/Syntax/Parser.hs b/unison-syntax/src/Unison/Syntax/Parser.hs index 30126c7d8b..ae37936cd5 100644 --- a/unison-syntax/src/Unison/Syntax/Parser.hs +++ b/unison-syntax/src/Unison/Syntax/Parser.hs @@ -38,6 +38,7 @@ module Unison.Syntax.Parser prefixTermName, queryToken, reserved, + resolveUniqueTypeGuid, root, rootFile, run', @@ -59,7 +60,7 @@ module Unison.Syntax.Parser ) where -import Control.Monad.Reader (ReaderT (..)) +import Control.Monad.Reader (ReaderT (..), ask) import Control.Monad.Reader.Class (asks) import Crypto.Random qualified as Random import Data.Bool (bool) @@ -76,6 +77,7 @@ import Text.Megaparsec qualified as P import U.Codebase.Reference (ReferenceType (..)) import U.Util.Base32Hex qualified as Base32Hex import Unison.ABT qualified as ABT +import Unison.DataDeclaration (Modifier (Unique)) import Unison.Hash qualified as Hash import Unison.HashQualified qualified as HQ import Unison.HashQualifiedPrime qualified as HQ' @@ -92,7 +94,7 @@ import Unison.Prelude import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.Syntax.Lexer.Unison qualified as L -import Unison.Syntax.Name qualified as Name (toVar) +import Unison.Syntax.Name qualified as Name (toVar, unsafeParseVar) import Unison.Syntax.Parser.Doc qualified as Doc import Unison.Syntax.Parser.Doc.Data qualified as Doc import Unison.Term (MatchCase (..)) @@ -180,6 +182,15 @@ uniqueName lenInBase32Hex = do let none = Base32Hex.toText . Base32Hex.fromByteString . encodeUtf8 . Text.pack $ show pos pure . fromMaybe none $ mkName pos lenInBase32Hex +resolveUniqueTypeGuid :: (Monad m, Var v) => v -> P v m Modifier +resolveUniqueTypeGuid name = do + ParsingEnv {uniqueTypeGuid} <- ask + guid <- + lift (lift (uniqueTypeGuid (Name.unsafeParseVar name))) >>= \case + Nothing -> uniqueName 32 + Just guid -> pure guid + pure (Unique guid) + data Error v = SignatureNeedsAccompanyingBody (L.Token v) | DisallowedAbsoluteName (L.Token Name) From 3de24bfad21b57b9ff0dde4b375f1c9750ad601f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Tue, 17 Dec 2024 12:02:41 -0500 Subject: [PATCH 25/36] Add Repobeats. Git repository stats For more details on Repobeats, check out https://repobeats.axiom.co --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index ee703bcc22..202fffff16 100644 --- a/README.md +++ b/README.md @@ -10,6 +10,8 @@ The Unison language * [Codebase Server](#codebase-server) * [Configuration](./docs/configuration.md) +![Alt](https://repobeats.axiom.co/api/embed/92b662a65fd842d49cb8d7d813043f5f5b4b550d.svg "Repobeats analytics image") + Overview -------- From 55e11eef11560b422cf59cf906ab5bab110797fa Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Tue, 17 Dec 2024 13:24:34 -0500 Subject: [PATCH 26/36] involve the current namespace directive when generating a unique type guid --- .../src/Unison/Syntax/DeclParser.hs | 27 +++++++++++++------ .../src/Unison/Syntax/FileParser.hs | 19 ++++--------- unison-syntax/src/Unison/Syntax/Parser.hs | 11 +++++--- 3 files changed, 32 insertions(+), 25 deletions(-) diff --git a/parser-typechecker/src/Unison/Syntax/DeclParser.hs b/parser-typechecker/src/Unison/Syntax/DeclParser.hs index 3d8c9d12b1..1f2e4f564e 100644 --- a/parser-typechecker/src/Unison/Syntax/DeclParser.hs +++ b/parser-typechecker/src/Unison/Syntax/DeclParser.hs @@ -5,7 +5,6 @@ module Unison.Syntax.DeclParser synDeclName, SynDataDecl (..), SynEffectDecl (..), - UnresolvedModifier (..), ) where @@ -13,6 +12,7 @@ import Control.Lens import Data.List.NonEmpty (pattern (:|)) import Data.List.NonEmpty qualified as NonEmpty import Unison.ABT qualified as ABT +import Unison.DataDeclaration qualified as DataDeclaration import Unison.Name qualified as Name import Unison.Parser.Ann (Ann) import Unison.Prelude @@ -51,7 +51,7 @@ data SynDataDecl v = SynDataDecl { annotation :: !Ann, constructors :: ![(Ann, v, Type v Ann)], fields :: !(Maybe [(L.Token v, Type v Ann)]), - modifier :: !(Maybe (L.Token UnresolvedModifier)), + modifier :: !DataDeclaration.Modifier, name :: !(L.Token v), tyvars :: ![v] } @@ -60,7 +60,7 @@ data SynDataDecl v = SynDataDecl data SynEffectDecl v = SynEffectDecl { annotation :: !Ann, constructors :: ![(Ann, v, Type v Ann)], - modifier :: !(Maybe (L.Token UnresolvedModifier)), + modifier :: !DataDeclaration.Modifier, name :: !(L.Token v), tyvars :: ![v] } @@ -100,7 +100,7 @@ synDeclP = do SynDecl'Effect <$> synEffectDeclP modifier <|> SynDecl'Data <$> synDataDeclP modifier synDataDeclP :: forall m v. (Monad m, Var v) => Maybe (L.Token UnresolvedModifier) -> P v m (SynDataDecl v) -synDataDeclP modifier = do +synDataDeclP modifier0 = do typeToken <- fmap void (reserved "type") <|> openBlockWith "type" (name, typeArgs) <- (,) <$> prefixVar <*> many prefixVar let tyvars = L.payload <$> typeArgs @@ -142,9 +142,10 @@ synDataDeclP modifier = do _ <- closeBlock let closingAnn :: Ann closingAnn = NonEmpty.last (ann eq NonEmpty.:| ((\(constrSpanAnn, _) -> constrSpanAnn) <$> constructors)) + modifier <- resolveModifier name modifier0 pure SynDataDecl - { annotation = maybe (ann typeToken) ann modifier <> closingAnn, + { annotation = maybe (ann typeToken) ann modifier0 <> closingAnn, constructors = snd <$> constructors, fields = Nothing, modifier, @@ -153,9 +154,10 @@ synDataDeclP modifier = do } Just (constructor, fields, closingAnn) -> do _ <- closeBlock + modifier <- resolveModifier name modifier0 pure SynDataDecl - { annotation = maybe (ann typeToken) ann modifier <> closingAnn, + { annotation = maybe (ann typeToken) ann modifier0 <> closingAnn, constructors = [constructor], fields, modifier, @@ -168,7 +170,7 @@ synDataDeclP modifier = do TermParser.verifyRelativeVarName prefixDefinitionName synEffectDeclP :: forall m v. (Monad m, Var v) => Maybe (L.Token UnresolvedModifier) -> P v m (SynEffectDecl v) -synEffectDeclP modifier = do +synEffectDeclP modifier0 = do abilityToken <- fmap void (reserved "ability") <|> openBlockWith "ability" name <- TermParser.verifyRelativeVarName prefixDefinitionName typeArgs <- many (TermParser.verifyRelativeVarName prefixDefinitionName) @@ -178,9 +180,10 @@ synEffectDeclP modifier = do _ <- closeBlock <* closeBlock let closingAnn = last $ ann blockStart : ((\(_, _, t) -> ann t) <$> constructors) + modifier <- resolveModifier name modifier0 pure SynEffectDecl - { annotation = maybe (ann abilityToken) ann modifier <> closingAnn, + { annotation = maybe (ann abilityToken) ann modifier0 <> closingAnn, constructors, modifier, name, @@ -217,3 +220,11 @@ effectConstructorP typeArgs name = then es else Type.apps' (toTypeVar name) (toTypeVar <$> typeArgs) : es in Type.cleanupAbilityLists $ Type.effect (ABT.annotation t) es' t + +resolveModifier :: (Monad m, Var v) => L.Token v -> Maybe (L.Token UnresolvedModifier) -> P v m DataDeclaration.Modifier +resolveModifier name modifier = + case L.payload <$> modifier of + Just UnresolvedModifier'Structural -> pure DataDeclaration.Structural + Just (UnresolvedModifier'UniqueWithGuid guid) -> pure (DataDeclaration.Unique guid) + Just UnresolvedModifier'UniqueWithoutGuid -> resolveUniqueTypeGuid name.payload + Nothing -> resolveUniqueTypeGuid name.payload diff --git a/parser-typechecker/src/Unison/Syntax/FileParser.hs b/parser-typechecker/src/Unison/Syntax/FileParser.hs index 96e07287ad..f5f3ef3f2b 100644 --- a/parser-typechecker/src/Unison/Syntax/FileParser.hs +++ b/parser-typechecker/src/Unison/Syntax/FileParser.hs @@ -23,7 +23,7 @@ import Unison.Parser.Ann (Ann) import Unison.Parser.Ann qualified as Ann import Unison.Prelude import Unison.Reference (TypeReferenceId) -import Unison.Syntax.DeclParser (SynDataDecl (..), SynDecl (..), SynEffectDecl (..), UnresolvedModifier (..), synDeclName, synDeclsP, synDeclConstructors) +import Unison.Syntax.DeclParser (SynDataDecl (..), SynDecl (..), SynEffectDecl (..), synDeclConstructors, synDeclName, synDeclsP) import Unison.Syntax.Lexer qualified as L import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar) import Unison.Syntax.Parser @@ -64,8 +64,8 @@ file = do -- which are parsed and applied to the type decls and term stanzas (namesStart, imports) <- TermParser.imports <* optional semi - -- Parse all syn decls - unNamespacedSynDecls <- synDeclsP + -- Parse all syn decls. The namespace in the parsing environment is required here in order to avoid unique type churn. + unNamespacedSynDecls <- local (\e -> e {maybeNamespace}) synDeclsP -- Sanity check: bail if there's a duplicate name among them unNamespacedSynDecls @@ -246,24 +246,15 @@ synDeclsToDecls = do foldlM ( \(datas, effects) -> \case SynDecl'Data decl -> do - modifier <- resolveModifier decl.name decl.modifier - let decl1 = DataDeclaration modifier decl.annotation decl.tyvars decl.constructors + let decl1 = DataDeclaration decl.modifier decl.annotation decl.tyvars decl.constructors let !datas1 = Map.insert decl.name.payload decl1 datas pure (datas1, effects) SynDecl'Effect decl -> do - modifier <- resolveModifier decl.name decl.modifier - let decl1 = DataDeclaration.mkEffectDecl' modifier decl.annotation decl.tyvars decl.constructors + let decl1 = DataDeclaration.mkEffectDecl' decl.modifier decl.annotation decl.tyvars decl.constructors let !effects1 = Map.insert decl.name.payload decl1 effects pure (datas, effects1) ) (Map.empty, Map.empty) - where - resolveModifier name modifier = - case L.payload <$> modifier of - Just UnresolvedModifier'Structural -> pure DataDeclaration.Structural - Just (UnresolvedModifier'UniqueWithGuid guid) -> pure (DataDeclaration.Unique guid) - Just UnresolvedModifier'UniqueWithoutGuid -> resolveUniqueTypeGuid name.payload - Nothing -> resolveUniqueTypeGuid name.payload applyNamespaceToStanza :: forall a v. diff --git a/unison-syntax/src/Unison/Syntax/Parser.hs b/unison-syntax/src/Unison/Syntax/Parser.hs index ae37936cd5..b013075145 100644 --- a/unison-syntax/src/Unison/Syntax/Parser.hs +++ b/unison-syntax/src/Unison/Syntax/Parser.hs @@ -97,6 +97,7 @@ import Unison.Syntax.Lexer.Unison qualified as L import Unison.Syntax.Name qualified as Name (toVar, unsafeParseVar) import Unison.Syntax.Parser.Doc qualified as Doc import Unison.Syntax.Parser.Doc.Data qualified as Doc +import Unison.Syntax.Var qualified as Var import Unison.Term (MatchCase (..)) import Unison.UnisonFile.Error qualified as UF import Unison.Util.Bytes (Bytes) @@ -144,6 +145,9 @@ data ParsingEnv (m :: Type -> Type) = ParsingEnv -- And for term links we are certainly out of luck: we can't look up a resolved file-bound term by hash *during -- parsing*. That's an issue with term links in general, unrelated to namespaces, but perhaps complicated by -- namespaces nonetheless. + -- + -- New development: this namespace is now also used during decl parsing, because in order to accurately reuse a + -- unique type guid we need to look up by namespaced name. maybeNamespace :: Maybe Name, localNamespacePrefixedTypesAndConstructors :: Names } @@ -183,10 +187,11 @@ uniqueName lenInBase32Hex = do pure . fromMaybe none $ mkName pos lenInBase32Hex resolveUniqueTypeGuid :: (Monad m, Var v) => v -> P v m Modifier -resolveUniqueTypeGuid name = do - ParsingEnv {uniqueTypeGuid} <- ask +resolveUniqueTypeGuid name0 = do + ParsingEnv {maybeNamespace, uniqueTypeGuid} <- ask + let name = Name.unsafeParseVar (maybe id (Var.namespaced2 . Name.toVar) maybeNamespace name0) guid <- - lift (lift (uniqueTypeGuid (Name.unsafeParseVar name))) >>= \case + lift (lift (uniqueTypeGuid name)) >>= \case Nothing -> uniqueName 32 Just guid -> pure guid pure (Unique guid) From 8ecaf099351c971525827a335f9fb8ceeac6f235 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Tue, 17 Dec 2024 16:35:40 -0500 Subject: [PATCH 27/36] fix record accessors issue --- parser-typechecker/src/Unison/Syntax/FileParser.hs | 10 +++++----- unison-src/transcripts/idempotent/duplicate-names.md | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/parser-typechecker/src/Unison/Syntax/FileParser.hs b/parser-typechecker/src/Unison/Syntax/FileParser.hs index f5f3ef3f2b..65c217a2cb 100644 --- a/parser-typechecker/src/Unison/Syntax/FileParser.hs +++ b/parser-typechecker/src/Unison/Syntax/FileParser.hs @@ -89,8 +89,8 @@ file = do result <- UFN.environmentFor namesStart dataDecls effectDecls & onLeft \errs -> resolutionFailures (toList errs) result & onLeft \errs -> P.customFailure (TypeDeclarationErrors errs) - -- Generate the record accessors with *un-namespaced* names (passing `typ` rather than `typ1`) below, because we need - -- to know these names in order to perform rewriting. As an example, + -- Generate the record accessors with *un-namespaced* names below, because we need to know these names in order to + -- perform rewriting. As an example, -- -- namespace foo -- type Bar = { baz : Nat } @@ -102,10 +102,10 @@ file = do unNamespacedAccessors = foldMap ( \case - -- N.B. the fields themselves were not namespaced by `applyNamespaceToSynDecls` SynDecl'Data decl | Just fields <- decl.fields, - Just (ref, _) <- Map.lookup decl.name.payload (UF.datas env) -> + Just (ref, _) <- + Map.lookup (maybe id Var.namespaced2 maybeNamespaceVar decl.name.payload) (UF.datas env) -> generateRecordAccessors Var.namespaced Ann.GeneratedFrom @@ -114,7 +114,7 @@ file = do ref _ -> [] ) - synDecls + unNamespacedSynDecls where toPair (tok, typ) = (tok.payload, ann tok <> ann typ) diff --git a/unison-src/transcripts/idempotent/duplicate-names.md b/unison-src/transcripts/idempotent/duplicate-names.md index 7f67014c75..9ce9da638a 100644 --- a/unison-src/transcripts/idempotent/duplicate-names.md +++ b/unison-src/transcripts/idempotent/duplicate-names.md @@ -58,7 +58,7 @@ structural ability X where ``` ucm :added-by-ucm Loading changes detected in scratch.u. - I found two types called X: + I found multiple types with the name X: 1 | structural type X = x 2 | structural ability X where From eca815c6d5a1bbb32513e3e7f4218437e9163ea6 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Wed, 18 Dec 2024 12:04:14 -0500 Subject: [PATCH 28/36] add bound terms to term printer environment --- parser-typechecker/package.yaml | 1 + .../src/Unison/PrettyPrintEnv/MonadPretty.hs | 62 ++++---- .../src/Unison/Syntax/TermPrinter.hs | 132 ++++++++++-------- .../src/Unison/Syntax/TypePrinter.hs | 9 +- .../unison-parser-typechecker.cabal | 4 +- 5 files changed, 116 insertions(+), 92 deletions(-) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index d9760e15c9..a6757ae515 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -103,6 +103,7 @@ default-extensions: - ApplicativeDo - BangPatterns - BlockArguments + - ConstraintKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs index cace699ec8..2c7b9ae56e 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs @@ -1,38 +1,31 @@ -{-# LANGUAGE ConstraintKinds #-} - -module Unison.PrettyPrintEnv.MonadPretty where - -import Control.Lens (views, _1, _2) +module Unison.PrettyPrintEnv.MonadPretty + ( MonadPretty, + Env (..), + runPretty, + addTypeVars, + willCaptureType, + ) +where + +import Control.Lens (views) import Control.Monad.Reader (MonadReader, Reader, local, runReader) import Data.Set qualified as Set import Unison.Prelude import Unison.PrettyPrintEnv (PrettyPrintEnv) +import Unison.Util.Set qualified as Set import Unison.Var (Var) -type MonadPretty v m = (Var v, MonadReader (PrettyPrintEnv, Set v) m) - -getPPE :: (MonadPretty v m) => m PrettyPrintEnv -getPPE = view _1 - --- | Run a computation with a modified PrettyPrintEnv, restoring the original -withPPE :: (MonadPretty v m) => PrettyPrintEnv -> m a -> m a -withPPE p = local (set _1 p) +type MonadPretty v m = (Var v, MonadReader (Env v) m) -applyPPE :: (MonadPretty v m) => (PrettyPrintEnv -> a) -> m a -applyPPE = views _1 - -applyPPE2 :: (MonadPretty v m) => (PrettyPrintEnv -> a -> b) -> a -> m b -applyPPE2 f a = views _1 (`f` a) - -applyPPE3 :: (MonadPretty v m) => (PrettyPrintEnv -> a -> b -> c) -> a -> b -> m c -applyPPE3 f a b = views _1 (\ppe -> f ppe a b) - --- | Run a computation with a modified PrettyPrintEnv, restoring the original -modifyPPE :: (MonadPretty v m) => (PrettyPrintEnv -> PrettyPrintEnv) -> m a -> m a -modifyPPE = local . over _1 +data Env v = Env + { boundTerms :: !(Set v), + boundTypes :: !(Set v), + ppe :: !PrettyPrintEnv + } + deriving stock (Generic) modifyTypeVars :: (MonadPretty v m) => (Set v -> Set v) -> m a -> m a -modifyTypeVars = local . over _2 +modifyTypeVars = local . over #boundTypes -- | Add type variables to the set of variables that need to be avoided addTypeVars :: (MonadPretty v m) => [v] -> m a -> m a @@ -40,8 +33,15 @@ addTypeVars = modifyTypeVars . Set.union . Set.fromList -- | Check if a list of type variables contains any variables that need to be -- avoided -willCapture :: (MonadPretty v m) => [v] -> m Bool -willCapture vs = views _2 (not . Set.null . Set.intersection (Set.fromList vs)) - -runPretty :: (Var v) => PrettyPrintEnv -> Reader (PrettyPrintEnv, Set v) a -> a -runPretty ppe m = runReader m (ppe, mempty) +willCaptureType :: (MonadPretty v m) => [v] -> m Bool +willCaptureType vs = views #boundTypes (Set.intersects (Set.fromList vs)) + +runPretty :: (Var v) => PrettyPrintEnv -> Reader (Env v) a -> a +runPretty ppe m = + runReader + m + Env + { boundTerms = Set.empty, + boundTypes = Set.empty, + ppe + } diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index 09a3fc77a5..d4c9a4684b 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -68,6 +68,7 @@ import Unison.Util.Pretty qualified as PP import Unison.Util.SyntaxText qualified as S import Unison.Var (Var) import Unison.Var qualified as Var +import Control.Monad.Reader (ask) type SyntaxText = S.SyntaxText' Reference @@ -99,7 +100,8 @@ data AmbientContext = AmbientContext infixContext :: !InfixContext, imports :: !Imports, docContext :: !DocLiteralContext, - elideUnit :: !Bool -- `True` if a `()` at the end of a block should be elided + -- `True` if a `()` at the end of a block should be elided + elideUnit :: !Bool } -- Description of the position of this ABT node, when viewed in the @@ -215,23 +217,24 @@ pretty0 } term = specialCases term \case - Var' v -> pure . parenIfInfix name ic $ styleHashQualified'' (fmt S.Var) name + Var' v -> do + pure . parenIfInfix name ic $ styleHashQualified'' (fmt S.Var) name where -- OK since all term vars are user specified, any freshening was just added during typechecking name = elideFQN im $ HQ.unsafeFromVar (Var.reset v) Ref' r -> do - n <- getPPE - let name = elideFQN im $ PrettyPrintEnv.termName n (Referent.Ref r) + env <- ask + let name = elideFQN im $ PrettyPrintEnv.termName env.ppe (Referent.Ref r) pure . parenIfInfix name ic $ styleHashQualified'' (fmt $ S.TermReference (Referent.Ref r)) name TermLink' r -> do - n <- getPPE - let name = elideFQN im $ PrettyPrintEnv.termName n r + env <- ask + let name = elideFQN im $ PrettyPrintEnv.termName env.ppe r pure . paren (p >= Application) $ fmt S.LinkKeyword "termLink " <> parenIfInfix name ic (styleHashQualified'' (fmt $ S.TermReference r) name) TypeLink' r -> do - n <- getPPE - let name = elideFQN im $ PrettyPrintEnv.typeName n r + env <- ask + let name = elideFQN im $ PrettyPrintEnv.typeName env.ppe r pure . paren (p >= Application) $ fmt S.LinkKeyword "typeLink " <> parenIfInfix name ic (styleHashQualified'' (fmt $ S.TypeReference r) name) @@ -277,13 +280,13 @@ pretty0 Nothing -> '?' : [c] Blank' id -> pure $ fmt S.Blank $ l "_" <> l (fromMaybe "" (Blank.nameb id)) Constructor' ref -> do - n <- getPPE - let name = elideFQN im $ PrettyPrintEnv.termName n conRef + env <- ask + let name = elideFQN im $ PrettyPrintEnv.termName env.ppe conRef conRef = Referent.Con ref CT.Data pure $ styleHashQualified'' (fmt $ S.TermReference conRef) name Request' ref -> do - n <- getPPE - let name = elideFQN im $ PrettyPrintEnv.termName n conRef + env <- ask + let name = elideFQN im $ PrettyPrintEnv.termName env.ppe conRef conRef = Referent.Con ref CT.Effect pure $ styleHashQualified'' (fmt $ S.TermReference conRef) name Handle' h body -> do @@ -370,12 +373,12 @@ pretty0 -- See `isDestructuringBind` definition. Match' scrutinee cs@[MatchCase pat guard (AbsN' vs body)] | p <= Control && isDestructuringBind scrutinee cs -> do - n <- getPPE + env <- ask let letIntro = case bc of Block -> id Normal -> \x -> fmt S.ControlKeyword "let" `PP.hang` x lhs <- do - let (lhs, _) = prettyPattern n (ac Annotation Block im doc) Application vs pat + let (lhs, _) = prettyPattern env.ppe (ac Annotation Block im doc) Application vs pat guard' <- printGuard guard pure $ PP.group lhs `PP.hang` guard' let eq = fmt S.BindingEquals "=" @@ -415,20 +418,20 @@ pretty0 Nothing -> notDoc go where notDoc go = do - n <- getPPE + env <- ask let -- This predicate controls which binary functions we render as infix -- operators. At the moment the policy is just to render symbolic -- operators as infix. binaryOpsPred :: Term3 v PrintAnnotation -> Bool binaryOpsPred = \case - Ref' r -> isSymbolic $ PrettyPrintEnv.termName n (Referent.Ref r) + Ref' r -> isSymbolic $ PrettyPrintEnv.termName env.ppe (Referent.Ref r) Var' v -> isSymbolic $ HQ.unsafeFromVar v _ -> False -- Gets the precedence of an infix operator, if it has one. termPrecedence :: Term3 v PrintAnnotation -> Maybe Precedence termPrecedence = \case Ref' r -> - HQ.toName (PrettyPrintEnv.termName n (Referent.Ref r)) + HQ.toName (PrettyPrintEnv.termName env.ppe (Referent.Ref r)) >>= operatorPrecedence . NameSegment.toEscapedText . Name.lastSegment @@ -523,11 +526,14 @@ pretty0 (DD.Doc, _) | doc == MaybeDoc -> if isDocLiteral term - then applyPPE3 prettyDoc im term + then do + env <- ask + pure (prettyDoc env.ppe im term) else pretty0 (a {docContext = NoDoc}) term (TupleTerm' [x], _) -> do let conRef = DD.pairCtorRef - name <- elideFQN im <$> applyPPE2 PrettyPrintEnv.termName conRef + env <- ask + let name = elideFQN im (PrettyPrintEnv.termName env.ppe conRef) let pair = parenIfInfix name ic $ styleHashQualified'' (fmt (S.TermReference conRef)) name x' <- pretty0 (ac Application Normal im doc) x pure . paren (p >= Application) $ @@ -685,7 +691,21 @@ printLetBinding :: (MonadPretty v m) => AmbientContext -> (v, Term3 v PrintAnnot printLetBinding context (v, binding) = if Var.isAction v then pretty0 context binding - else renderPrettyBinding <$> prettyBinding0' context (HQ.unsafeFromVar (Var.reset v)) binding + else + -- For a non-recursive let binding like "let x = y in z", variable "x" is not bound in "y". Yet, "x" may be free + -- in "y" anyway, referring to some previous binding. + -- + -- In Unison we don't have a syntax, for non-recusrive let, though, we just have this: + -- + -- x = y + -- z + -- + -- So, render free "x" in "y" with a leading dot. This is because we happen to know that the only way to have + -- a free "x" in "y" is if "x" is a top-level binding. + let + v1 = Var.reset v + in + renderPrettyBinding <$> prettyBinding0' context (HQ.unsafeFromVar v1) binding printLetrecBinding :: (MonadPretty v m) => AmbientContext -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText) printLetrecBinding context (v, binding) = @@ -877,8 +897,8 @@ printCase im doc ms0 = go (pats, vs, unzip -> (guards, bodies)) = do guards' <- traverse printGuard guards bodies' <- traverse printBody bodies - ppe <- getPPE - pure (patLhs ppe vs pats, guards', bodies') + env <- ask + pure (patLhs env.ppe vs pats, guards', bodies') where noGuards = all (== Nothing) guards printGuard Nothing | noGuards = pure mempty @@ -967,8 +987,8 @@ prettyBinding0 :: Term2 v at ap v a -> m PrettyBinding prettyBinding0 ac v tm = do - ppe <- getPPE - prettyBinding0' ac v (printAnnotate ppe tm) + env <- ask + prettyBinding0' ac v (printAnnotate env.ppe tm) prettyBinding0' :: (MonadPretty v m) => @@ -1889,7 +1909,7 @@ prettyDoc2 :: Term3 v PrintAnnotation -> m (Maybe (Pretty SyntaxText)) prettyDoc2 ac tm = do - ppe <- getPPE + env <- ask let brace p = if PP.isMultiLine p then fmt S.DocDelimiter "{{" <> PP.newline <> p <> PP.newline <> fmt S.DocDelimiter "}}" @@ -1909,11 +1929,11 @@ prettyDoc2 ac tm = do makeFence inner = PP.string $ replicate (max 3 $ longestRun '`' inner) '`' go :: Width -> Term3 v PrintAnnotation -> m (Pretty SyntaxText) go hdr = \case - (toDocTransclude ppe -> Just d) -> + (toDocTransclude env.ppe -> Just d) -> bail d - (toDocUntitledSection ppe -> Just ds) -> + (toDocUntitledSection env.ppe -> Just ds) -> sepBlankline ds - (toDocSection ppe -> Just (title, ds)) -> do + (toDocSection env.ppe -> Just (title, ds)) -> do prettyTitle <- rec title prettyDs <- intercalateMapM "\n\n" (go (hdr + 1)) ds pure $ @@ -1922,19 +1942,19 @@ prettyDoc2 ac tm = do "", PP.indentN (hdr + 1) prettyDs ] - (toDocParagraph ppe -> Just ds) -> + (toDocParagraph env.ppe -> Just ds) -> PP.wrap . mconcat <$> traverse rec ds - (toDocBulletedList ppe -> Just ds) -> do + (toDocBulletedList env.ppe -> Just ds) -> do PP.lines <$> traverse item ds where item d = ("* " <>) . PP.indentAfterNewline " " <$> rec d - (toDocNumberedList ppe -> Just (n, ds)) -> + (toDocNumberedList env.ppe -> Just (n, ds)) -> PP.column2 <$> traverse item (zip [n ..] ds) where item (n, d) = (PP.group (PP.shown n <> "."),) <$> rec d - (toDocWord ppe -> Just t) -> + (toDocWord env.ppe -> Just t) -> pure $ PP.text t - (toDocCode ppe -> Just d) -> do + (toDocCode env.ppe -> Just d) -> do inner <- rec d let quotes = -- Prefer ` if there aren't any in the inner text, @@ -1943,67 +1963,67 @@ prettyDoc2 ac tm = do then PP.string $ oneMore '\'' inner else PP.string "`" pure $ PP.group $ quotes <> inner <> quotes - (toDocJoin ppe -> Just ds) -> foldMapM rec ds - (toDocItalic ppe -> Just d) -> do + (toDocJoin env.ppe -> Just ds) -> foldMapM rec ds + (toDocItalic env.ppe -> Just d) -> do inner <- rec d let underscores = PP.string $ oneMore '_' inner pure $ PP.group $ underscores <> inner <> underscores - (toDocBold ppe -> Just d) -> do + (toDocBold env.ppe -> Just d) -> do inner <- rec d let stars = PP.string $ oneMore '*' inner pure $ PP.group $ stars <> inner <> stars - (toDocStrikethrough ppe -> Just d) -> do + (toDocStrikethrough env.ppe -> Just d) -> do inner <- rec d let quotes = PP.string $ oneMore '~' inner pure $ PP.group $ quotes <> inner <> quotes - (toDocGroup ppe -> Just d) -> + (toDocGroup env.ppe -> Just d) -> PP.group <$> rec d - (toDocColumn ppe -> Just ds) -> + (toDocColumn env.ppe -> Just ds) -> PP.lines <$> traverse rec ds - (toDocNamedLink ppe -> Just (name, target)) -> + (toDocNamedLink env.ppe -> Just (name, target)) -> do name' <- rec name target' <- rec target pure $ PP.group $ "[" <> name' <> "](" <> target' <> ")" - (toDocLink ppe -> Just e) -> pure . PP.group $ case e of + (toDocLink env.ppe -> Just e) -> pure . PP.group $ case e of Left r -> "{type " <> tyName r <> "}" Right r -> "{" <> tmName r <> "}" - (toDocEval ppe -> Just tm) -> + (toDocEval env.ppe -> Just tm) -> do inner <- pretty0 ac tm let fence = makeFence inner pure $ PP.lines [fence, inner, fence] - (toDocEvalInline ppe -> Just tm) -> + (toDocEvalInline env.ppe -> Just tm) -> do inner <- pretty0 ac tm pure $ "@eval{" <> inner <> "}" - (toDocExample ppe -> Just tm) -> + (toDocExample env.ppe -> Just tm) -> do inner <- pretty0 ac tm pure $ "``" <> inner <> "``" - (toDocExampleBlock ppe -> Just tm) -> + (toDocExampleBlock env.ppe -> Just tm) -> do inner <- pretty0 ac' tm let fence = makeFence inner pure $ PP.lines ["@typecheck " <> fence, inner, fence] where ac' = ac {elideUnit = True} - (toDocSource ppe -> Just es) -> + (toDocSource env.ppe -> Just es) -> pure . PP.group $ " @source{" <> intercalateMap ", " go es <> "}" where go (Left r, _anns) = "type " <> tyName r go (Right r, _anns) = tmName r - (toDocFoldedSource ppe -> Just es) -> + (toDocFoldedSource env.ppe -> Just es) -> pure . PP.group $ " @foldedSource{" <> intercalateMap ", " go es <> "}" where go (Left r, _anns) = "type " <> tyName r go (Right r, _anns) = tmName r - (toDocSignatureInline ppe -> Just tm) -> + (toDocSignatureInline env.ppe -> Just tm) -> pure . PP.group $ "@inlineSignature{" <> tmName tm <> "}" - (toDocSignature ppe -> Just tms) -> + (toDocSignature env.ppe -> Just tms) -> let name = if length tms == 1 then "@signature" else "@signatures" in pure . PP.group $ " " <> name <> "{" <> intercalateMap ", " tmName tms <> "}" - (toDocCodeBlock ppe -> Just (typ, txt)) -> + (toDocCodeBlock env.ppe -> Just (typ, txt)) -> pure $ let txt' = PP.text txt fence = makeFence txt' @@ -2013,7 +2033,7 @@ prettyDoc2 ac tm = do PP.group txt', fence ] - (toDocVerbatim ppe -> Just txt) -> + (toDocVerbatim env.ppe -> Just txt) -> pure $ PP.group $ PP.lines @@ -2025,15 +2045,15 @@ prettyDoc2 ac tm = do tm -> bail tm where im = imports ac - tyName r = styleHashQualified'' (fmt $ S.TypeReference r) . elideFQN im $ PrettyPrintEnv.typeName ppe r - tmName r = styleHashQualified'' (fmt $ S.TermReference r) . elideFQN im $ PrettyPrintEnv.termName ppe r + tyName r = styleHashQualified'' (fmt $ S.TypeReference r) . elideFQN im $ PrettyPrintEnv.typeName env.ppe r + tmName r = styleHashQualified'' (fmt $ S.TermReference r) . elideFQN im $ PrettyPrintEnv.termName env.ppe r rec = go hdr sepBlankline = intercalateMapM "\n\n" rec case tm of -- these patterns can introduce a {{ .. }} block - (toDocUntitledSection ppe -> Just _) -> Just . brace <$> go 1 tm - (toDocSection ppe -> Just _) -> Just . brace <$> go 1 tm - (toDocParagraph ppe -> Just _) -> Just . brace <$> go 1 tm + (toDocUntitledSection env.ppe -> Just _) -> Just . brace <$> go 1 tm + (toDocSection env.ppe -> Just _) -> Just . brace <$> go 1 tm + (toDocParagraph env.ppe -> Just _) -> Just . brace <$> go 1 tm _ -> pure Nothing toDocJoin :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation] diff --git a/parser-typechecker/src/Unison/Syntax/TypePrinter.hs b/parser-typechecker/src/Unison/Syntax/TypePrinter.hs index 271546e776..90cd52943e 100644 --- a/parser-typechecker/src/Unison/Syntax/TypePrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TypePrinter.hs @@ -17,6 +17,7 @@ module Unison.Syntax.TypePrinter ) where +import Control.Monad.Reader (ask) import Data.Map qualified as Map import Unison.Builtin.Decls qualified as DD import Unison.HashQualified (HashQualified) @@ -25,7 +26,7 @@ import Unison.Prelude import Unison.PrettyPrintEnv (PrettyPrintEnv) import Unison.PrettyPrintEnv qualified as PrettyPrintEnv import Unison.PrettyPrintEnv.FQN (Imports, elideFQN) -import Unison.PrettyPrintEnv.MonadPretty (MonadPretty, getPPE, runPretty, willCapture) +import Unison.PrettyPrintEnv.MonadPretty (Env (..), MonadPretty, runPretty, willCaptureType) import Unison.Reference (Reference, pattern Builtin) import Unison.Referent (Referent) import Unison.Settings qualified as Settings @@ -101,8 +102,8 @@ prettyRaw im p tp = go im p tp DD.TupleType' xs | length xs /= 1 -> PP.parenthesizeCommas <$> traverse (go im 0) xs -- Would be nice to use a different SyntaxHighlights color if the reference is an ability. Ref' r -> do - n <- getPPE - pure $ styleHashQualified'' (fmt $ S.TypeReference r) $ elideFQN im (PrettyPrintEnv.typeName n r) + env <- ask + pure $ styleHashQualified'' (fmt $ S.TypeReference r) $ elideFQN im (PrettyPrintEnv.typeName env.ppe r) Cycle' _ _ -> pure $ fromString "bug: TypeParser does not currently emit Cycle" Abs' _ -> pure $ fromString "bug: TypeParser does not currently emit Abs" Ann' _ _ -> pure $ fromString "bug: TypeParser does not currently emit Ann" @@ -125,7 +126,7 @@ prettyRaw im p tp = go im p tp -- are universally quantified, then we can omit the `forall` keyword -- only if the type variables are not bound in an outer scope if p < 0 && not Settings.debugRevealForalls && all Var.universallyQuantifyIfFree vs - then ifM (willCapture vs) (prettyForall p) (go im p body) + then ifM (willCaptureType vs) (prettyForall p) (go im p body) else paren (p >= 0) <$> prettyForall (-1) t@(Arrow' _ _) -> case t of EffectfulArrows' (Ref' DD.UnitRef) rest -> diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 820c2bec16..0e8691bbb2 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -165,6 +165,7 @@ library ApplicativeDo BangPatterns BlockArguments + ConstraintKinds DeriveAnyClass DeriveFunctor DeriveGeneric @@ -285,6 +286,7 @@ test-suite parser-typechecker-tests ApplicativeDo BangPatterns BlockArguments + ConstraintKinds DeriveAnyClass DeriveFunctor DeriveGeneric From 28884e3eabee3607a54c209d0160724ca0a4e038 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Wed, 18 Dec 2024 12:53:00 -0500 Subject: [PATCH 29/36] fix let-capture issue in term renderer --- .../src/Unison/Syntax/TermPrinter.hs | 29 +++++++++--------- unison-src/transcripts/idempotent/fix-5427.md | 30 ++++++------------- 2 files changed, 24 insertions(+), 35 deletions(-) diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index d4c9a4684b..717a7726d3 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -15,6 +15,7 @@ module Unison.Syntax.TermPrinter where import Control.Lens (unsnoc) +import Control.Monad.Reader (ask, local) import Control.Monad.State (evalState) import Control.Monad.State qualified as State import Data.Char (isPrint) @@ -53,7 +54,7 @@ import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Syntax.HashQualified qualified as HQ (unsafeFromVar) import Unison.Syntax.Lexer.Unison (showEscapeChar) -import Unison.Syntax.Name qualified as Name (isSymboly, parseText, parseTextEither, toText, unsafeParseText) +import Unison.Syntax.Name qualified as Name (isSymboly, parseText, parseTextEither, toText, unsafeParseText, unsafeParseVar) import Unison.Syntax.NamePrinter (styleHashQualified'') import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Syntax.Precedence (InfixPrecedence (..), Precedence (..), increment, isTopLevelPrecedence, operatorPrecedence) @@ -68,7 +69,6 @@ import Unison.Util.Pretty qualified as PP import Unison.Util.SyntaxText qualified as S import Unison.Var (Var) import Unison.Var qualified as Var -import Control.Monad.Reader (ask) type SyntaxText = S.SyntaxText' Reference @@ -217,11 +217,13 @@ pretty0 } term = specialCases term \case - Var' v -> do + Var' (Var.reset -> v) -> do + env <- ask + let name = + if Set.member v env.boundTerms + then HQ.fromName (Name.makeAbsolute (Name.unsafeParseVar v)) + else elideFQN im $ HQ.unsafeFromVar v pure . parenIfInfix name ic $ styleHashQualified'' (fmt S.Var) name - where - -- OK since all term vars are user specified, any freshening was just added during typechecking - name = elideFQN im $ HQ.unsafeFromVar (Var.reset v) Ref' r -> do env <- ask let name = elideFQN im $ PrettyPrintEnv.termName env.ppe (Referent.Ref r) @@ -688,10 +690,9 @@ printLetBindings context = \case LetrecBindings bindings -> traverse (printLetrecBinding context) bindings printLetBinding :: (MonadPretty v m) => AmbientContext -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText) -printLetBinding context (v, binding) = - if Var.isAction v - then pretty0 context binding - else +printLetBinding context (v, binding) + | Var.isAction v = pretty0 context binding + | otherwise = -- For a non-recursive let binding like "let x = y in z", variable "x" is not bound in "y". Yet, "x" may be free -- in "y" anyway, referring to some previous binding. -- @@ -702,10 +703,10 @@ printLetBinding context (v, binding) = -- -- So, render free "x" in "y" with a leading dot. This is because we happen to know that the only way to have -- a free "x" in "y" is if "x" is a top-level binding. - let - v1 = Var.reset v - in - renderPrettyBinding <$> prettyBinding0' context (HQ.unsafeFromVar v1) binding + renderPrettyBinding + <$> local (over #boundTerms (Set.insert v1)) (prettyBinding0' context (HQ.unsafeFromVar v1) binding) + where + v1 = Var.reset v printLetrecBinding :: (MonadPretty v m) => AmbientContext -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText) printLetrecBinding context (v, binding) = diff --git a/unison-src/transcripts/idempotent/fix-5427.md b/unison-src/transcripts/idempotent/fix-5427.md index cf8b25ef81..f403f10d04 100644 --- a/unison-src/transcripts/idempotent/fix-5427.md +++ b/unison-src/transcripts/idempotent/fix-5427.md @@ -122,9 +122,9 @@ bar = foo : Nat ``` -This should succeed, but `bar` gets printed incorrectly\! +Previously, `bar` would incorrectly print with a `foo = foo` line. Now, it works. -``` ucm :error +``` ucm scratch/main> update Okay, I'm searching the branch for code that needs to be @@ -132,26 +132,14 @@ scratch/main> update That's done. Now I'm making sure everything typechecks... - Typechecking failed. I've updated your scratch file with the - definitions that need fixing. Once the file is compiling, try - `update` again. -``` - -``` unison :added-by-ucm scratch.u -foo : Nat -foo = 18 - -bar : Nat -bar = - foo = foo - foo + Everything typechecks, so I'm saving the results... --- The definitions below no longer typecheck with the changes above. --- Please fix the errors and try `update` again. + Done. -baz : Nat -baz = - use Nat + - foo + foo +scratch/main> view bar + bar : Nat + bar = + foo = .foo + foo ``` From 0e41fc7ec5b725a2abf85e78bf1f061af19f9bf9 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 18 Dec 2024 15:07:51 -0500 Subject: [PATCH 30/36] add regression test for #5507 this specific test may become ineffective if the code serialization algorithm someday includes termlinks as dependencies. --- unison-src/tests/fix5507.md | 28 ++++++++++++++++++++++++++++ unison-src/tests/fix5507.sh | 12 ++++++++++++ 2 files changed, 40 insertions(+) create mode 100755 unison-src/tests/fix5507.md create mode 100755 unison-src/tests/fix5507.sh diff --git a/unison-src/tests/fix5507.md b/unison-src/tests/fix5507.md new file mode 100755 index 0000000000..bd5e3f4fa8 --- /dev/null +++ b/unison-src/tests/fix5507.md @@ -0,0 +1,28 @@ +```ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +```unison :hide +Nat.toBytesLittleEndian : Nat -> Bytes +Nat.toBytesLittleEndian = encodeNat64le +``` + +```ucm :hide +scratch/main> add +``` + +`Nat.toBytesLittleEndian` gets inlined, but it should still be found in the code cache when this is compiled and re-loaded. + +```unison :hide +main : '{IO} () +main = do + _ = Nat.toBytesLittleEndian 3 + match Code.lookup (termLink Nat.toBytesLittleEndian) with + Some _code -> () + None -> bug "code cache was empty" +``` + +```ucm :hide +scratch/main> add +scratch/main> compile main fix5507 +``` diff --git a/unison-src/tests/fix5507.sh b/unison-src/tests/fix5507.sh new file mode 100755 index 0000000000..26aac5c3ef --- /dev/null +++ b/unison-src/tests/fix5507.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env sh +set -ex + +# the first arg is the path to the unison executable +if [ -z "$1" ]; then + echo "Usage: $0 " + exit 1 +fi + +# call unison with all its args quoted +"$@" transcript unison-src/tests/fix5507.md \ + && "$@" run.compiled fix5507.uc From 159c2b39795744807728e314594f6c80a839214a Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 19 Dec 2024 11:52:21 -0500 Subject: [PATCH 31/36] add 5507 regression test in linux --- .github/workflows/ci.yaml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index d162852e92..554e175205 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -273,6 +273,10 @@ jobs: ${{env.transcripts}} # Fail if any transcripts cause git diffs. git diff --ignore-cr-at-eol --exit-code unison-src/transcripts + - name: shell-based regression tests + if: steps.cache-transcript-test-results.outputs.cache-hit != 'true' && runner.os == 'linux' + run: | + unison-src/tests/fix5507.sh ${{env.ucm}} - name: docs.to-html if: steps.cache-transcript-test-results.outputs.cache-hit != 'true' run: | From 866058e464d5e683f67734c5292dedfba60a91d3 Mon Sep 17 00:00:00 2001 From: Brandon Barker Date: Sat, 21 Dec 2024 08:54:18 -0500 Subject: [PATCH 32/36] add runOnly support for unison-syntax tests --- unison-syntax/test/Main.hs | 21 ++++++++++++++++++++- unison-syntax/test/Unison/Test/Doc.hs | 2 +- 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/unison-syntax/test/Main.hs b/unison-syntax/test/Main.hs index 3c84130548..fb4da5c3d0 100644 --- a/unison-syntax/test/Main.hs +++ b/unison-syntax/test/Main.hs @@ -1,9 +1,28 @@ module Main (main) where import EasyTest +import System.Environment (getArgs) +import System.IO import System.IO.CodePage (withCP65001) import Unison.Test.Doc qualified as Doc import Unison.Test.Unison qualified as Unison +-- main :: IO () +-- main = withCP65001 . run $ tests [Unison.test, Doc.test] + +test :: Test () +test = + tests + [ Doc.test, + Unison.test + ] + main :: IO () -main = withCP65001 . run $ tests [Unison.test, Doc.test] +main = withCP65001 do + args <- getArgs + mapM_ (`hSetEncoding` utf8) [stdout, stdin, stderr] + case args of + [] -> runOnly "" test + [prefix] -> runOnly prefix test + [seed, prefix] -> rerunOnly (read seed) prefix test + _ -> error "expected no args, a prefix, or a seed and a prefix" diff --git a/unison-syntax/test/Unison/Test/Doc.hs b/unison-syntax/test/Unison/Test/Doc.hs index cc4bedf4ce..9028404ada 100644 --- a/unison-syntax/test/Unison/Test/Doc.hs +++ b/unison-syntax/test/Unison/Test/Doc.hs @@ -15,7 +15,7 @@ import Unison.Util.Recursion test :: Test () test = - scope "Doc parser" . tests $ + scope "DocParser" . tests $ [ t "# Hello" [Doc.Section (Doc.Paragraph $ docWord "Hello" :| []) []], t ( unlines From c5d9f883dc4444113c3fbcdd0eb1df86446a9cec Mon Sep 17 00:00:00 2001 From: Brandon Barker Date: Sat, 21 Dec 2024 08:57:59 -0500 Subject: [PATCH 33/36] remove comment --- unison-syntax/test/Main.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/unison-syntax/test/Main.hs b/unison-syntax/test/Main.hs index fb4da5c3d0..825bf870d5 100644 --- a/unison-syntax/test/Main.hs +++ b/unison-syntax/test/Main.hs @@ -7,9 +7,6 @@ import System.IO.CodePage (withCP65001) import Unison.Test.Doc qualified as Doc import Unison.Test.Unison qualified as Unison --- main :: IO () --- main = withCP65001 . run $ tests [Unison.test, Doc.test] - test :: Test () test = tests From 0bc8cac1db7b1f0d92f434ceb8fa877eff96ade2 Mon Sep 17 00:00:00 2001 From: Brandon Barker Date: Sun, 22 Dec 2024 14:11:08 -0500 Subject: [PATCH 34/36] signing CONTRIBUTORS.markdown --- CONTRIBUTORS.markdown | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.markdown b/CONTRIBUTORS.markdown index 413ef3da70..57d863bfb8 100644 --- a/CONTRIBUTORS.markdown +++ b/CONTRIBUTORS.markdown @@ -89,3 +89,4 @@ The format for this list: name, GitHub handle * Eduard Nicodei (@neduard) * Brian McKenna (@puffnfresh) * Ruslan Simchuk (@SimaDovakin) +* Brandon Barker (@bbarker) From ab4e093467f40490e2c16495c49ed06988f9062e Mon Sep 17 00:00:00 2001 From: Manish Bhasin Date: Mon, 30 Dec 2024 21:21:31 -0500 Subject: [PATCH 35/36] fix(error messages): cli http request errors should show a summary with http status and message --- .../src/Unison/CommandLine/OutputMessages.hs | 41 ++++++++++--------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 2cb8ada215..f2d1ab61c0 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -138,6 +138,7 @@ import Unison.Term (Term) import Unison.Term qualified as Term import Unison.Type (Type) import Unison.UnisonFile qualified as UF +import Unison.Util.ColorText qualified import Unison.Util.Conflicted (Conflicted (..)) import Unison.Util.Defn (Defn (..)) import Unison.Util.Defns (Defns (..)) @@ -971,7 +972,6 @@ notifyUser dir = \case -- defs in the codebase. In some cases it's fine for bindings to -- shadow codebase names, but you don't want it to capture them in -- the decompiled output. - let prettyBindings = P.bracket . P.lines $ P.wrap "The watch expression(s) reference these definitions:" @@ -1771,16 +1771,16 @@ notifyUser dir = \case <> P.newline <> P.indentN 2 (P.pshown response) Servant.FailureResponse request response -> - P.wrap "Oops, I received an unexpected status code from the server." + unexpectedServerResponse response <> P.newline <> P.newline - <> P.wrap "Here is the request." + <> P.wrap "Here is the request:" <> P.newline <> P.newline <> P.indentN 2 (P.pshown request) <> P.newline <> P.newline - <> P.wrap "Here is the full response." + <> P.wrap "Here is the full response:" <> P.newline <> P.newline <> P.indentN 2 (P.pshown response) @@ -2362,21 +2362,24 @@ prettyTransportError = \case Share.RateLimitExceeded -> "Rate limit exceeded, please try again later." Share.Timeout -> "The code server timed-out when responding to your request. Please try again later or report an issue if the problem persists." Share.UnexpectedResponse resp -> - (P.lines . catMaybes) - [ Just - ( "The server sent a " - <> P.red (P.shown (Http.statusCode (Servant.responseStatusCode resp))) - <> " that we didn't expect." - ), - let body = Text.decodeUtf8 (LazyByteString.toStrict (Servant.responseBody resp)) - in if Text.null body then Nothing else Just (P.newline <> "Response body: " <> P.text body), - responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId) - ] - where - -- Dig the request id out of a response header. - responseRequestId :: Servant.Response -> Maybe Text - responseRequestId = - fmap Text.decodeUtf8 . List.lookup "X-RequestId" . Foldable.toList @Seq . Servant.responseHeaders + unexpectedServerResponse resp + +unexpectedServerResponse :: Servant.ResponseF LazyByteString.ByteString -> P.Pretty Unison.Util.ColorText.ColorText +unexpectedServerResponse resp = + (P.lines . catMaybes) + [ Just + ( "I received an unexpected status code from the server: " + <> P.red (P.shown (Http.statusCode (Servant.responseStatusCode resp))) + ), + let body = Text.decodeUtf8 (LazyByteString.toStrict (Servant.responseBody resp)) + in if Text.null body then Nothing else Just (P.newline <> "Response body: " <> P.text body), + responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId) + ] + +-- | Dig the request id out of a response header. +responseRequestId :: Servant.Response -> Maybe Text +responseRequestId = + fmap Text.decodeUtf8 . List.lookup "X-RequestId" . Foldable.toList @Seq . Servant.responseHeaders prettyEntityType :: Share.EntityType -> Pretty prettyEntityType = \case From daefc1da9a8565536328a9baf4fdcb457e0ed065 Mon Sep 17 00:00:00 2001 From: Manish Bhasin Date: Mon, 30 Dec 2024 21:27:54 -0500 Subject: [PATCH 36/36] docs(CONTRIBUTORS.markdown): add Manish Bhasin (@xmbhasin) --- CONTRIBUTORS.markdown | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.markdown b/CONTRIBUTORS.markdown index 57d863bfb8..302d01f095 100644 --- a/CONTRIBUTORS.markdown +++ b/CONTRIBUTORS.markdown @@ -90,3 +90,4 @@ The format for this list: name, GitHub handle * Brian McKenna (@puffnfresh) * Ruslan Simchuk (@SimaDovakin) * Brandon Barker (@bbarker) +* Manish Bhasin (@xmbhasin)