diff --git a/.gitignore b/.gitignore index 6ef1f50473..73249e2dab 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,4 @@ dist-newstyle # GHC *.hie *.prof +/libb2.dylib diff --git a/scheme-libs/chez/unison/concurrent.ss b/scheme-libs/chez/unison/concurrent.ss index e49a0c27d5..0e7ecf1b84 100644 --- a/scheme-libs/chez/unison/concurrent.ss +++ b/scheme-libs/chez/unison/concurrent.ss @@ -10,13 +10,13 @@ promise-try-read fork kill - sleep) + sleep + try-eval) (define err "This operation is not supported on the pure Chez Scheme backend, use the Racket over Chez Scheme backend") - ;; TODO feels like there is a macro waiting to happen here (define (ref-new a) (error err)) (define (ref-read ref) (error err)) (define (ref-write ref a) (error err)) @@ -25,5 +25,6 @@ backend, use the Racket over Chez Scheme backend") (define (promise-read promise) (error err)) (define (promise-try-read promise) (error err)) (define (fork thread-thunk) (error err)) - (define (kill thread-id) (error err))) + (define (kill thread-id) (error err)) + (define (try-eval thunk) (error err))) diff --git a/scheme-libs/common/unison/data.ss b/scheme-libs/common/unison/data.ss index d4848c111c..24c950473f 100644 --- a/scheme-libs/common/unison/data.ss +++ b/scheme-libs/common/unison/data.ss @@ -16,7 +16,10 @@ either-get unit false - true) + true + any + failure + exception) (import (rnrs)) @@ -60,4 +63,15 @@ (define (left? either) (eq? 0 (car either))) ; Either a b -> a | b - (define (either-get either) (car (cdr either)))) + (define (either-get either) (car (cdr either))) + + ; a -> Any + (define (any a) `(0 ,a)) + + ; Type -> Text -> Any -> Failure + (define (failure typeLink msg any) + `(0 ,typeLink ,msg ,any)) + + ; Type -> Text -> a ->{Exception} b + (define (exception typeLink msg a) + (failure typeLink msg (any a)))) diff --git a/scheme-libs/common/unison/primops.ss b/scheme-libs/common/unison/primops.ss index 98b32c886b..da84378340 100644 --- a/scheme-libs/common/unison/primops.ss +++ b/scheme-libs/common/unison/primops.ss @@ -73,6 +73,7 @@ unison-FOp-IO.delay.impl.v3 unison-POp-FORK unison-FOp-IO.kill.impl.v3 + unison-POp-TFRC unison-POp-ADDN unison-POp-ANDN @@ -327,6 +328,7 @@ (define (unison-FOp-Scope.array n) (make-vector n)) (define (unison-POp-FORK thunk) (fork thunk)) + (define (unison-POp-TFRC thunk) (try-eval thunk)) (define (unison-FOp-IO.delay.impl.v3 micros) (sleep micros)) (define (unison-FOp-IO.kill.impl.v3 threadId) (kill threadId)) (define (unison-FOp-Scope.ref a) (ref-new a)) diff --git a/scheme-libs/racket/unison/concurrent.ss b/scheme-libs/racket/unison/concurrent.ss index 3c79ae533a..5bd613fd80 100644 --- a/scheme-libs/racket/unison/concurrent.ss +++ b/scheme-libs/racket/unison/concurrent.ss @@ -12,7 +12,8 @@ promise-try-read fork kill - sleep) + sleep + try-eval) (import (rnrs) (rnrs records syntactic) @@ -32,14 +33,20 @@ parameterize-break sleep printf + with-handlers exn:break? - with-handlers) + exn:fail? + exn:fail:read? + exn:fail:filesystem? + exn:fail:network? + exn:fail:contract:divide-by-zero? + exn:fail:contract:non-fixnum-result?) (box ref-new) (unbox ref-read) (set-box! ref-write) (sleep sleep-secs)) - (only (racket unsafe ops) unsafe-struct*-cas!) - (unison data)) + (only (racket exn) exn->string) + (only (racket unsafe ops) unsafe-struct*-cas!)) (define-record-type promise (fields semaphore event (mutable value))) @@ -86,4 +93,23 @@ (define (kill threadId) (break-thread threadId) - (right unit))) + (right unit)) + + (define (exn:io? e) + (or (exn:fail:read? e) + (exn:fail:filesystem? e) + (exn:fail:network? e))) + + (define (exn:arith? e) + (or (exn:fail:contract:divide-by-zero? e) + (exn:fail:contract:non-fixnum-result? e))) + + ;; TODO Replace strings with proper type links once we have them + (define (try-eval thunk) + (with-handlers + ([exn:break? (lambda (e) (exception "ThreadKilledFailure" "thread killed" ()))] + [exn:io? (lambda (e) (exception "IOFailure" (exn->string e) ()))] + [exn:arith? (lambda (e) (exception "ArithmeticFailure" (exn->string e) ()))] + [exn:fail? (lambda (e) (exception "RuntimeFailure" (exn->string e) ()))] + [(lambda (x) #t) (lambda (e) (exception "MiscFailure" "unknown exception" e))]) + (right (thunk))))) diff --git a/unison-src/builtin-tests/base.output.md b/unison-src/builtin-tests/base.output.md index ea906338b1..e51894c11a 100644 --- a/unison-src/builtin-tests/base.output.md +++ b/unison-src/builtin-tests/base.output.md @@ -4,13 +4,13 @@ ✅ - ✅ Successfully pulled into newly created namespace base. + Successfully pulled into newly created namespace base. .> compile.native.fetch ✅ - ✅ Successfully updated .unison.internal from - dolio.public.internal.trunk. + Successfully updated .unison.internal from + unison.public.internal.trunk. ``` diff --git a/unison-src/builtin-tests/concurrency-tests.u b/unison-src/builtin-tests/concurrency-tests.u index b18ffb765d..50b197fc11 100644 --- a/unison-src/builtin-tests/concurrency-tests.u +++ b/unison-src/builtin-tests/concurrency-tests.u @@ -1,4 +1,4 @@ -concurrency.tests = Tests.main do +concurrency.tests = do !simpleRefTest !simpleRefTestScope !ticketTest @@ -6,7 +6,8 @@ concurrency.tests = Tests.main do !promiseSequentialTest !promiseConcurrentTest !forkKillTest - -- !tryEvalForkTest + !tryEvalForkTest + !tryEvalKillTest !fullTest simpleRefTest = do @@ -84,7 +85,27 @@ forkKillTest = do v = Ref.read ref checkEqual "Thread was killed" v "initial" -tryEvalForkTest = bug "Depends on the Exception ability being implemented" +tryEvalForkTest = do + ref = IO.ref "initial" + t = fork do + match catchAll do sleep_ (400 * millis) with + Left _ -> () + Right _ -> unsafeRun! do Ref.write ref "finished" + sleep_ (500 * millis) + v = Ref.read ref + checkEqual "tryEval is a no-op on success" v "finished" + +tryEvalKillTest = do + ref = IO.ref "initial" + t = fork do + match catchAll do sleep_ (400 * millis) with + Left (Failure typ msg a) -> unsafeRun! do Ref.write ref msg + Right _ -> unsafeRun! do Ref.write ref "finished" + sleep_ (200 * millis) + kill_ t + sleep_ (300 * millis) + v = Ref.read ref + checkEqual "Thread was killed, with finalisers" v "thread killed" atomicUpdate : Ref {IO} a -> (a -> a) ->{IO} () atomicUpdate ref f = diff --git a/unison-src/builtin-tests/interpreter-tests.md b/unison-src/builtin-tests/interpreter-tests.md index 7f94009be0..206efae6e8 100644 --- a/unison-src/builtin-tests/interpreter-tests.md +++ b/unison-src/builtin-tests/interpreter-tests.md @@ -11,20 +11,15 @@ then reference those tests (which should be of type `'{IO,Exception,Tests} ()`, to `Tests.check` and `Tests.checkEqual`). ```ucm:hide -.> load unison-src/builtin-tests/tests.u +.> load unison-src/builtin-tests/concurrency-tests.u .> add ``` -```ucm -.> run tests -``` - ```ucm:hide -.> load unison-src/builtin-tests/concurrency-tests.u +.> load unison-src/builtin-tests/tests.u .> add ``` ```ucm -.> run concurrency.tests +.> run tests ``` - diff --git a/unison-src/builtin-tests/interpreter-tests.output.md b/unison-src/builtin-tests/interpreter-tests.output.md index 311b77b6d5..947c5941a7 100644 --- a/unison-src/builtin-tests/interpreter-tests.output.md +++ b/unison-src/builtin-tests/interpreter-tests.output.md @@ -11,9 +11,3 @@ to `Tests.check` and `Tests.checkEqual`). () ``` -```ucm -.> run concurrency.tests - - () - -``` diff --git a/unison-src/builtin-tests/jit-tests.md b/unison-src/builtin-tests/jit-tests.md index b44da5dc01..3cb95d893b 100644 --- a/unison-src/builtin-tests/jit-tests.md +++ b/unison-src/builtin-tests/jit-tests.md @@ -13,19 +13,15 @@ then reference those tests (which should be of type `'{IO,Exception,Tests} ()`, to `Tests.check` and `Tests.checkEqual`). ```ucm:hide -.> load unison-src/builtin-tests/tests.u +.> load unison-src/builtin-tests/concurrency-tests.u .> add ``` -```ucm -.> run.native tests -``` - ```ucm:hide -.> load unison-src/builtin-tests/concurrency-tests.u +.> load unison-src/builtin-tests/tests.u .> add ``` ```ucm -.> run.native concurrency.tests +.> run.native tests ``` diff --git a/unison-src/builtin-tests/jit-tests.output.md b/unison-src/builtin-tests/jit-tests.output.md index 19ddeec195..016ea7e654 100644 --- a/unison-src/builtin-tests/jit-tests.output.md +++ b/unison-src/builtin-tests/jit-tests.output.md @@ -9,7 +9,3 @@ to `Tests.check` and `Tests.checkEqual`). .> run.native tests ``` -```ucm -.> run.native concurrency.tests - -``` diff --git a/unison-src/builtin-tests/tests.u b/unison-src/builtin-tests/tests.u index 5505853521..57ab19abec 100644 --- a/unison-src/builtin-tests/tests.u +++ b/unison-src/builtin-tests/tests.u @@ -1,26 +1,35 @@ tests : '{IO,Exception} () tests = Tests.main do - check "Nat.+" do 1 + 1 == 2 - check "Nat.*" do 10 * 100 == 1000 - check "Nat./" do 100 / 10 == 10 + !crypto.hash.tests + !hmac.tests + !concurrency.tests + check "bug is caught" do isLeft (catchAll do bug ()) - -- cryptographic hashing - check "Sha1 hashBytes" do hashBytes Sha1 (toUtf8 "") === 0xsda39a3ee5e6b4b0d3255bfef95601890afd80709 - check "Sha2_256 hashBytes" do hashBytes Sha2_256 (toUtf8 "") === 0xse3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855 - check "Sha2_512 hashBytes" do hashBytes Sha2_512 (toUtf8 "") === 0xscf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e - check "Sha3_256 hashBytes" do hashBytes Sha3_256 (toUtf8 "") === 0xsa7ffc6f8bf1ed76651c14756a061d662f580ff4de43b49fa82d80a4b80f8434a - check "Sha3_512 hashBytes" do hashBytes Sha3_512 (toUtf8 "") === 0xsa69f73cca23a9ac5c8b567dc185a756e97c982164fe25859e0d1dcc1475c80a615b2123af1f5f94c11e3e9402c3ac558f500199d95b6d3e301758586281dcd26 - check "Blake2s_256 hashBytes" do hashBytes Blake2s_256 (toUtf8 "") === 0xs69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9 - check "Blake2b_256 hashBytes" do hashBytes Blake2b_256 (toUtf8 "") === 0xs0e5751c026e543b2e8ab2eb06099daa1d1e5df47778f7787faab45cdf12fe3a8 - check "Blake2b_512 hashBytes" do hashBytes Blake2b_512 (toUtf8 "") === 0xs786a02f742015903c6c6fd852552d272912f4740e15847618a86e217f71f5419d25e1031afee585313896444934eb04b903a685b1448b755d56f701afe9be2ce +crypto.hash.tests = do + hash alg = hashBytes alg (toUtf8 "") + tag name = name ++ " hashBytes" + [ + ("Sha1", Sha1, 0xsda39a3ee5e6b4b0d3255bfef95601890afd80709), + ("Sha2_256", Sha2_256, 0xse3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855), + ("Sha2_512", Sha2_512, 0xscf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e), + ("Sha3_256", Sha3_256, 0xsa7ffc6f8bf1ed76651c14756a061d662f580ff4de43b49fa82d80a4b80f8434a), + ("Sha3_512", Sha3_512, 0xsa69f73cca23a9ac5c8b567dc185a756e97c982164fe25859e0d1dcc1475c80a615b2123af1f5f94c11e3e9402c3ac558f500199d95b6d3e301758586281dcd26), + ("Blake2s_256", Blake2s_256, 0xs69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9), + ("Blake2b_256", Blake2b_256, 0xs0e5751c026e543b2e8ab2eb06099daa1d1e5df47778f7787faab45cdf12fe3a8), + ("Blake2b_512", Blake2b_512, 0xs786a02f742015903c6c6fd852552d272912f4740e15847618a86e217f71f5419d25e1031afee585313896444934eb04b903a685b1448b755d56f701afe9be2ce) + ] |> List.foreach_ cases (name, alg, res) -> checkEqual (tag name) (hash alg) res - -- hmacs - check "Sha1 hmacBytes" do hmacBytes Sha1 (toUtf8 "key") (toUtf8 "") === 0xsf42bb0eeb018ebbd4597ae7213711ec60760843f - check "Sha2_256 hmacBytes" do hmacBytes Sha2_256 (toUtf8 "key") (toUtf8 "") === 0xs5d5d139563c95b5967b9bd9a8c9b233a9dedb45072794cd232dc1b74832607d0 - check "Sha2_512 hmacBytes" do hmacBytes Sha2_512 (toUtf8 "key") (toUtf8 "") === 0xs84fa5aa0279bbc473267d05a53ea03310a987cecc4c1535ff29b6d76b8f1444a728df3aadb89d4a9a6709e1998f373566e8f824a8ca93b1821f0b69bc2a2f65e - check "Sha3_256 hmacBytes" do hmacBytes Sha3_256 (toUtf8 "key") (toUtf8 "") === 0xs74f3c030ecc36a1835d04a333ebb7fce2688c0c78fb0bcf9592213331c884c75 - check "Sha3_512 hmacBytes" do hmacBytes Sha3_512 (toUtf8 "key") (toUtf8 "") === 0xs7539119b6367aa902bdc6f558d20c906d6acbd4aba3fd344eb08b0200144a1fa453ff6e7919962358be53f6db2a320d1852c52a3dea3e907070775f7a91f1282 - check "Blake2s_256 hmacBytes" do hmacBytes Blake2s_256 (toUtf8 "key") (toUtf8 "") === 0xs67148074efc0f6741b474ef81c4d98d266e880d372fe723d2569b1d414d234be - check "Blake2b_256 hmacBytes" do hmacBytes Blake2b_256 (toUtf8 "key") (toUtf8 "") === 0xs4224e1297e51239a642e21f756bde2785716f872298178180d7f3d1d36a5e4e4 - check "Blake2b_512 hmacBytes" do hmacBytes Blake2b_512 (toUtf8 "key") (toUtf8 "") === 0xs019fe04bf010b8d72772e6b46897ecf74b4878c394ff2c4d5cfa0b7cc9bbefcb28c36de23cef03089db9c3d900468c89804f135e9fdef7ec9b3c7abe50ed33d3 \ No newline at end of file +hmac.tests = do + hmac alg = hmacBytes alg (toUtf8 "key") (toUtf8 "") + tag name = name ++ " hmacBytes" + [ + ("Sha1", Sha1, 0xsf42bb0eeb018ebbd4597ae7213711ec60760843f), + ("Sha2_256", Sha2_256, 0xs5d5d139563c95b5967b9bd9a8c9b233a9dedb45072794cd232dc1b74832607d0), + ("Sha2_512", Sha2_512, 0xs84fa5aa0279bbc473267d05a53ea03310a987cecc4c1535ff29b6d76b8f1444a728df3aadb89d4a9a6709e1998f373566e8f824a8ca93b1821f0b69bc2a2f65e), + ("Sha3_256", Sha3_256, 0xs74f3c030ecc36a1835d04a333ebb7fce2688c0c78fb0bcf9592213331c884c75), + ("Sha3_512", Sha3_512, 0xs7539119b6367aa902bdc6f558d20c906d6acbd4aba3fd344eb08b0200144a1fa453ff6e7919962358be53f6db2a320d1852c52a3dea3e907070775f7a91f1282), + ("Blake2s_256", Blake2s_256, 0xs67148074efc0f6741b474ef81c4d98d266e880d372fe723d2569b1d414d234be), + ("Blake2b_256", Blake2b_256, 0xs4224e1297e51239a642e21f756bde2785716f872298178180d7f3d1d36a5e4e4), + ("Blake2b_512", Blake2b_512, 0xs019fe04bf010b8d72772e6b46897ecf74b4878c394ff2c4d5cfa0b7cc9bbefcb28c36de23cef03089db9c3d900468c89804f135e9fdef7ec9b3c7abe50ed33d3) + ] |> List.foreach_ cases (name, alg, res) -> checkEqual (tag name) (hmac alg) res