Merge pull request #3831 from unisonweb/try-eval-jit

Add tryEval to the JIT compiler

.gitignore

@@ -13,3 +13,4 @@ dist-newstyle
 # GHC
 *.hie
 *.prof
+/libb2.dylib

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)))
 

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))))

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))

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)))))

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.
 
 ```

unison-src/builtin-tests/concurrency-tests.u

@@ -1,12 +1,13 @@
-concurrency.tests = Tests.main do
+concurrency.tests = do
   !simpleRefTest
   !simpleRefTestScope
   !ticketTest
   !casTest
   !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 =

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
 ```
-

unison-src/builtin-tests/interpreter-tests.output.md

@@ -11,9 +11,3 @@ to `Tests.check` and `Tests.checkEqual`).
   ()
 
 ```
-```ucm
-.> run concurrency.tests
-
-  ()
-
-```

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
 ```

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
-
-```

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
+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