mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
Exception and debugging related work
Makes various internal values print more nicely, which makes debugging more tractable. Links now print as base32hex strings like they would in ucm. Functions inside unison structures print as their hash if possible. Also, short hashes are printed in most cases, rather than the full hash. Had to shuffle around some bytevector stuff to make the above work. Pulled `tryEval` completely into primops, and made it directly do an exception request, rather than implementing the TFRC pseudo instruction. This requires a share bump, as does a fix to the `Failure` data info. Some of the exception/failure related internal functions were wrapping the last argument in Any when they shouldn't have, causing errors for code expecting a single wrapper.
This commit is contained in:
parent
80fc452dd8
commit
3cb89e42b3
2
.github/workflows/ci.md
vendored
2
.github/workflows/ci.md
vendored
@ -9,7 +9,7 @@ At a high level, the CI process is:
|
||||
Some version numbers that are used during CI:
|
||||
- `ormolu_version: "0.5.0.1"`
|
||||
- `racket_version: "8.7"`
|
||||
- `jit_version: "@unison/internal/releases/0.0.11"`
|
||||
- `jit_version: "@unison/internal/releases/0.0.14"`
|
||||
|
||||
Some cached directories:
|
||||
- `ucm_local_bin` a temp path for caching a built `ucm`
|
||||
|
2
.github/workflows/ci.yaml
vendored
2
.github/workflows/ci.yaml
vendored
@ -21,7 +21,7 @@ env:
|
||||
ormolu_version: "0.5.2.0"
|
||||
racket_version: "8.7"
|
||||
ucm_local_bin: "ucm-local-bin"
|
||||
jit_version: "@unison/internal/releases/0.0.13"
|
||||
jit_version: "@unison/internal/releases/0.0.14"
|
||||
jit_src_scheme: "unison-jit-src/scheme-libs/racket"
|
||||
jit_dist: "unison-jit-dist"
|
||||
jit_generator_os: ubuntu-20.04
|
||||
|
@ -81,6 +81,7 @@
|
||||
exn:bug?
|
||||
exn:bug->exception
|
||||
exception->string
|
||||
raise-unison-exception
|
||||
|
||||
request
|
||||
request-case
|
||||
@ -565,7 +566,10 @@
|
||||
[0 (f)
|
||||
(control ref-exception:typelink k
|
||||
(let ([disp (describe-value f)])
|
||||
(raise (make-exn:bug "builtin.bug" disp))))]]))
|
||||
(raise
|
||||
(make-exn:bug
|
||||
(string->chunked-string "builtin.bug")
|
||||
disp))))]]))
|
||||
|
||||
(begin-encourage-inline
|
||||
(define mask64 #xffffffffffffffff)
|
||||
@ -594,3 +598,14 @@
|
||||
(if (and (fixnum? n) (exact-nonnegative-integer? n)) n
|
||||
(modulo n bit64))))
|
||||
|
||||
(define (raise-unison-exception ty msg val)
|
||||
(request
|
||||
ref-exception:typelink
|
||||
0
|
||||
(ref-failure-failure ty msg (unison-any-any val))))
|
||||
|
||||
(define (exn:bug->exception b)
|
||||
(raise-unison-exception
|
||||
ref-runtimefailure:typelink
|
||||
(exn:bug-msg b)
|
||||
(exn:bug-val b)))
|
||||
|
@ -5,129 +5,191 @@
|
||||
; implements all the functions we'd want. This library exports the
|
||||
; desired functionality on top of an unsafe in-place freeze
|
||||
; re-exported from the (unison core) module.
|
||||
#!r6rs
|
||||
(library (unison bytevector)
|
||||
(export
|
||||
freeze-bytevector!
|
||||
ibytevector-drop
|
||||
ibytevector-take
|
||||
ibytevector-append
|
||||
bytevector-u8-ref
|
||||
bytevector-u16-ref
|
||||
bytevector-u24-ref
|
||||
bytevector-u32-ref
|
||||
bytevector-u40-ref
|
||||
bytevector-u48-ref
|
||||
bytevector-u56-ref
|
||||
bytevector-u64-ref
|
||||
u8-list->ibytevector
|
||||
b32d
|
||||
b32hd
|
||||
base32-string->ibytevector)
|
||||
#lang racket/base
|
||||
|
||||
(import (rnrs)
|
||||
(unison core))
|
||||
(provide
|
||||
freeze-bytevector!
|
||||
ibytevector-drop
|
||||
ibytevector-take
|
||||
ibytevector-append
|
||||
bytevector-u8-ref
|
||||
bytevector-u16-ref
|
||||
bytevector-u24-ref
|
||||
bytevector-u32-ref
|
||||
bytevector-u40-ref
|
||||
bytevector-u48-ref
|
||||
bytevector-u56-ref
|
||||
bytevector-u64-ref
|
||||
u8-list->ibytevector
|
||||
bytevector->base32-string
|
||||
base32-string->ibytevector)
|
||||
|
||||
(define (ibytevector-drop n bs)
|
||||
(let* ([l (bytevector-length bs)]
|
||||
[k (max 0 (- l n))]
|
||||
[br (make-bytevector k)])
|
||||
(bytevector-copy! bs n br 0 k)
|
||||
(freeze-bytevector! br)))
|
||||
(require
|
||||
racket
|
||||
racket/fixnum
|
||||
(only-in racket/unsafe/ops
|
||||
unsafe-bytes->immutable-bytes!)
|
||||
(only-in rnrs
|
||||
div
|
||||
mod
|
||||
div-and-mod
|
||||
bytevector-u8-ref
|
||||
bytevector-u16-ref
|
||||
bytevector-u32-ref
|
||||
bytevector-u64-ref))
|
||||
|
||||
(define (ibytevector-take n bs)
|
||||
(let* ([sz (min n (bytevector-length bs))]
|
||||
[br (make-bytevector sz)])
|
||||
(bytevector-copy! bs 0 br 0 sz)
|
||||
(freeze-bytevector! br)))
|
||||
(define freeze-bytevector! unsafe-bytes->immutable-bytes!)
|
||||
|
||||
(define (ibytevector-append l r)
|
||||
(freeze-bytevector! (bytevector-append l r)))
|
||||
(define (ibytevector-drop n bs)
|
||||
(let* ([l (bytes-length bs)]
|
||||
[k (max 0 (- l n))]
|
||||
[br (make-bytes k)])
|
||||
(bytes-copy! br 0 bs n k)
|
||||
(unsafe-bytes->immutable-bytes! br)))
|
||||
|
||||
(define (u8-list->ibytevector l)
|
||||
(freeze-bytevector! (u8-list->bytevector l)))
|
||||
(define (ibytevector-take n bs)
|
||||
(let* ([sz (min n (bytes-length bs))]
|
||||
[br (make-bytes sz)])
|
||||
(bytes-copy br 0 bs 0 sz)
|
||||
(unsafe-bytes->immutable-bytes! br)))
|
||||
|
||||
(define (bytevector-u24-ref bs n end)
|
||||
(let ([v16 (bytevector-u16-ref bs n end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 2))])
|
||||
(case end
|
||||
[big (fxior v8 (fxarithmetic-shift-left v16 8))]
|
||||
[little (fxior v16 (fxarithmetic-shift-left v8 16))])))
|
||||
(define (ibytevector-append l r)
|
||||
(unsafe-bytes->immutable-bytes! (bytes-append l r)))
|
||||
|
||||
(define (bytevector-u40-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 4))])
|
||||
(case end
|
||||
[big (fxior v8 (fxarithmetic-shift-left v32 8))]
|
||||
[small (fxior v32 (fxarithmetic-shift-left v8 32))])))
|
||||
(define (u8-list->ibytevector l)
|
||||
(unsafe-bytes->immutable-bytes! (list->bytes l)))
|
||||
|
||||
(define (bytevector-u48-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v16 (bytevector-u16-ref bs (+ n 4) end)])
|
||||
(case end
|
||||
[big (fxior v16 (fxarithmetic-shift-left v32 8))]
|
||||
[small (fxior v32 (fxarithmetic-shift-left v16 32))])))
|
||||
(define (bytevector-u24-ref bs n end)
|
||||
(let ([v16 (bytevector-u16-ref bs n end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 2))])
|
||||
(case end
|
||||
[(big) (fxior v8 (fxlshift v16 8))]
|
||||
[(little) (fxior v16 (fxlshift v8 16))])))
|
||||
|
||||
(define (bytevector-u56-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v16 (bytevector-u16-ref bs (+ n 4) end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 6))])
|
||||
(case end
|
||||
[big (fxior v8
|
||||
(fxarithmetic-shift-left v16 8)
|
||||
(fxarithmetic-shift-left v32 24))]
|
||||
[small (fxior v32
|
||||
(fxarithmetic-shift-left v16 32)
|
||||
(fxarithmetic-shift-left v8 48))])))
|
||||
(define (bytevector-u40-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 4))])
|
||||
(case end
|
||||
[(big) (fxior v8 (fxlshift v32 8))]
|
||||
[(small) (fxior v32 (fxlshift v8 32))])))
|
||||
|
||||
(define (b32d c)
|
||||
(let ([n (char->integer c)])
|
||||
(define (bytevector-u48-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v16 (bytevector-u16-ref bs (+ n 4) end)])
|
||||
(case end
|
||||
[(big) (fxior v16 (fxlshift v32 8))]
|
||||
[(small) (fxior v32 (fxlshift v16 32))])))
|
||||
|
||||
(define (bytevector-u56-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v16 (bytevector-u16-ref bs (+ n 4) end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 6))])
|
||||
(case end
|
||||
[(big) (fxior v8
|
||||
(fxlshift v16 8)
|
||||
(fxlshift v32 24))]
|
||||
[(small) (fxior v32
|
||||
(fxlshift v16 32)
|
||||
(fxlshift v8 48))])))
|
||||
|
||||
(define (b32d c)
|
||||
(let ([n (char->integer c)])
|
||||
(cond
|
||||
[(and (<= 65 n) (<= n 90)) (- n 65)]
|
||||
[(and (<= 97 n) (<= n 122)) (- n 97)]
|
||||
[(and (<= 50 n) (<= n 55)) (- n 24)])))
|
||||
|
||||
(define (b32hd c)
|
||||
(let ([n (char->integer c)])
|
||||
(cond
|
||||
[(and (<= 48 n) (<= n 57)) (- n 48)]
|
||||
[(and (<= 65 n) (<= n 86)) (- n 65)]
|
||||
[(and (<= 97 n) (<= n 118)) (- n 97)])))
|
||||
|
||||
(define (base32-string->ibytevector str #:alphabet [alphabet 'standard])
|
||||
(define decode
|
||||
(match alphabet
|
||||
[hex b32hd]
|
||||
[standard b32d]))
|
||||
|
||||
(define (main ilen)
|
||||
(let* ([olen (div (* ilen 5) 8)]
|
||||
[out (make-bytes olen)])
|
||||
|
||||
(define (fill n k o)
|
||||
(when (>= k 0)
|
||||
(let ([m (fxand n 255)])
|
||||
(bytes-set! out (+ o k) m)
|
||||
(fill (fxrshift n 8) (- k 1) o))))
|
||||
|
||||
(define (fixup i)
|
||||
(if (= i 0) (values 0 -1)
|
||||
(let* ([chars (+ 1 (mod (- i 1) 8))])
|
||||
(div-and-mod (* 5 chars) 8))))
|
||||
|
||||
(let rec ([acc 0] [i 0] [o 0])
|
||||
(cond
|
||||
[(>= i ilen)
|
||||
(let-values ([(k n) (fixup i)])
|
||||
(fill (fxrshift acc n) (- k 1) o)
|
||||
(unsafe-bytes->immutable-bytes! out))]
|
||||
[(and (> i 0) (= 0 (mod i 8)))
|
||||
(fill acc 4 o)
|
||||
(rec (decode (string-ref str i)) (+ i 1) (+ o 5))]
|
||||
[else
|
||||
(let ([sacc (fxlshift acc 5)]
|
||||
[bits (decode (string-ref str i))])
|
||||
(rec (fxior sacc bits) (+ i 1) o))]))))
|
||||
|
||||
(let search ([i (- (string-length str) 1)])
|
||||
(if (and (>= i 0) (eq? (string-ref str i) #\=))
|
||||
(search (- i 1))
|
||||
(main (+ i 1)))))
|
||||
|
||||
; code should convert 5-bit numbers to the corresponding character
|
||||
(define (bytevector->base32-string bs #:alphabet [alphabet 'standard])
|
||||
(define code
|
||||
(match alphabet
|
||||
[hex b32h]
|
||||
[standard b32]))
|
||||
|
||||
(let* ([ilen (bytes-length bs)]
|
||||
[olen (* 8 (div (+ ilen 4) 5))]
|
||||
[out (make-string olen #\=)])
|
||||
|
||||
(define (fill n k o)
|
||||
(if (>= k 0)
|
||||
(let ([m (fxand n 31)])
|
||||
(string-set! out (+ o k) (code m))
|
||||
(fill (fxrshift n 5) (- k 1) o))
|
||||
#f))
|
||||
|
||||
(define (fixup i)
|
||||
(if (= i 0) (values 0 -1)
|
||||
(let ([bys (+ 1 (mod (- i 1) 5))])
|
||||
(let-values ([(d m) (div-and-mod (* 8 bys) 5)])
|
||||
(if (= m 0) (values m (- d 1))
|
||||
(values (- 5 m) d))))))
|
||||
|
||||
(let rec ([acc 0] [i 0] [o 0])
|
||||
(cond
|
||||
[(and (<= 65 n) (<= n 90)) (- n 65)]
|
||||
[(and (<= 97 n) (<= n 122)) (- n 97)]
|
||||
[(and (<= 50 n) (<= n 55)) (- n 24)])))
|
||||
[(>= i ilen)
|
||||
(let-values ([(n k) (fixup i)])
|
||||
(fill (fxlshift acc n) k o)
|
||||
out)]
|
||||
[(and (> i 0) (= 0 (mod i 5)))
|
||||
(fill acc 7 o)
|
||||
(rec (bytes-ref bs i) (+ i 1) (+ o 8))]
|
||||
[else
|
||||
(let ([sacc (fxlshift acc 8)]
|
||||
[by (bytes-ref bs i)])
|
||||
(rec (fxior sacc by) (+ i 1) o))]))))
|
||||
|
||||
(define (b32hd c)
|
||||
(let ([n (char->integer c)])
|
||||
(cond
|
||||
[(and (<= 48 n) (<= n 57)) (- n 48)]
|
||||
[(and (<= 65 n) (<= n 86)) (- n 65)]
|
||||
[(and (<= 97 n) (<= n 118)) (- n 97)])))
|
||||
; 65 = #\A
|
||||
; 24 = #\2 - 26
|
||||
(define (b32 n) (integer->char (+ n (if (< n 26) 65 24))))
|
||||
|
||||
(define (base32-string->ibytevector decode str)
|
||||
(define (main ilen)
|
||||
(let* ([olen (div (* ilen 5) 8)]
|
||||
[out (make-bytevector olen)])
|
||||
; 48 = #\0
|
||||
; 87 = #\a - 10
|
||||
(define (b32h n) (integer->char (+ n (if (< n 10) 48 87))))
|
||||
|
||||
(define (fill n k o)
|
||||
(if (>= k 0)
|
||||
(let ([m (fxand n 255)])
|
||||
(bytevector-u8-set! out (+ o k) m)
|
||||
(fill (fxarithmetic-shift-right n 8) (- k 1) o))))
|
||||
|
||||
(define (fixup i)
|
||||
(if (= i 0) (values 0 -1)
|
||||
(let ([chars (+ 1 (mod (- i 1) 8))])
|
||||
(div-and-mod (* 5 chars) 8))))
|
||||
|
||||
(let rec ([acc 0] [i 0] [o 0])
|
||||
(cond
|
||||
[(>= i ilen)
|
||||
(let-values ([(k n) (fixup i)])
|
||||
(fill (fxarithmetic-shift-right acc n) (- k 1) o)
|
||||
(freeze-bytevector! out))]
|
||||
[(and (> i 0) (= 0 (mod i 8)))
|
||||
(fill acc 4 o)
|
||||
(rec (decode (string-ref str i)) (+ i 1) (+ o 5))]
|
||||
[else
|
||||
(let ([sacc (fxarithmetic-shift-left acc 5)]
|
||||
[bits (decode (string-ref str i))])
|
||||
(rec (fxior sacc bits) (+ i 1) o))]))))
|
||||
|
||||
(let search ([i (- (string-length str) 1)])
|
||||
(if (and (>= i 0) (eq? (string-ref str i) #\=))
|
||||
(search (- i 1))
|
||||
(main (+ i 1)))))
|
||||
|
||||
|
||||
)
|
||||
|
@ -12,8 +12,7 @@
|
||||
promise-try-read
|
||||
fork
|
||||
kill
|
||||
sleep
|
||||
try-eval)
|
||||
sleep)
|
||||
|
||||
(import (rnrs)
|
||||
(rnrs records syntactic)
|
||||
@ -37,13 +36,7 @@
|
||||
sleep
|
||||
printf
|
||||
with-handlers
|
||||
exn:break?
|
||||
exn:fail?
|
||||
exn:fail:read?
|
||||
exn:fail:filesystem?
|
||||
exn:fail:network?
|
||||
exn:fail:contract:divide-by-zero?
|
||||
exn:fail:contract:non-fixnum-result?)
|
||||
exn:break?)
|
||||
(box ref-new)
|
||||
(unbox ref-read)
|
||||
(set-box! ref-write)
|
||||
@ -96,46 +89,4 @@
|
||||
(define (kill threadId)
|
||||
(break-thread threadId)
|
||||
(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)))
|
||||
|
||||
(define (try-eval thunk)
|
||||
(with-handlers
|
||||
([exn:break?
|
||||
(lambda (e)
|
||||
(exception
|
||||
ref-threadkilledfailure:typelink
|
||||
(string->chunked-string "thread killed")
|
||||
ref-unit-unit))]
|
||||
[exn:io?
|
||||
(lambda (e)
|
||||
(exception
|
||||
ref-iofailure:typelink
|
||||
(exception->string e) ref-unit-unit))]
|
||||
[exn:arith?
|
||||
(lambda (e)
|
||||
(exception
|
||||
ref-arithfailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))]
|
||||
[exn:bug? (lambda (e) (exn:bug->exception e))]
|
||||
[exn:fail?
|
||||
(lambda (e)
|
||||
(exception
|
||||
ref-runtimefailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))]
|
||||
[(lambda (x) #t)
|
||||
(lambda (e)
|
||||
(exception
|
||||
ref-miscfailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))])
|
||||
(right (thunk)))))
|
||||
)
|
||||
|
@ -20,10 +20,7 @@
|
||||
|
||||
exception->string
|
||||
|
||||
exn:bug
|
||||
make-exn:bug
|
||||
exn:bug?
|
||||
exn:bug->exception
|
||||
(struct-out exn:bug)
|
||||
|
||||
let-marks
|
||||
ref-mark
|
||||
@ -46,15 +43,10 @@
|
||||
decode-value
|
||||
describe-value
|
||||
|
||||
bytevector->base32-string
|
||||
b32
|
||||
b32h
|
||||
|
||||
bytevector->string/utf-8
|
||||
string->bytevector/utf-8)
|
||||
|
||||
(require
|
||||
racket/base
|
||||
(rename-in (only-in racket
|
||||
current-inexact-milliseconds
|
||||
directory-list
|
||||
@ -73,6 +65,7 @@
|
||||
path->string
|
||||
match
|
||||
match*
|
||||
string-append*
|
||||
for/fold)
|
||||
(string-copy! racket-string-copy!)
|
||||
(bytes-append bytevector-append)
|
||||
@ -83,6 +76,7 @@
|
||||
racket/exn
|
||||
(only-in racket/fixnum fl->fx fx- fxand fxlshift fxrshift fxior)
|
||||
racket/unsafe/ops
|
||||
unison/bytevector
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/chunked-seq)
|
||||
@ -108,48 +102,6 @@
|
||||
(string-set! out (+ o 1) (b16 c1))
|
||||
(rec (+ i 1) (+ o 2)))]))))
|
||||
|
||||
; code should convert 5-bit numbers to the corresponding character
|
||||
(define (bytevector->base32-string code bs)
|
||||
(let* ([ilen (bytes-length bs)]
|
||||
[olen (* 8 (div (+ ilen 4) 5))]
|
||||
[out (make-string olen #\=)])
|
||||
|
||||
(define (fill n k o)
|
||||
(if (>= k 0)
|
||||
(let ([m (fxand n 31)])
|
||||
(string-set! out (+ o k) (code m))
|
||||
(fill (fxrshift n 5) (- k 1) o))
|
||||
#f))
|
||||
|
||||
(define (fixup i)
|
||||
(if (= i 0) (values 0 -1)
|
||||
(let ([bys (+ 1 (mod (- i 1) 5))])
|
||||
(let-values ([(d m) (div-and-mod (* 8 bys) 5)])
|
||||
(if (= m 0) (values m (- d 1))
|
||||
(values (- 5 m) d))))))
|
||||
|
||||
(let rec ([acc 0] [i 0] [o 0])
|
||||
(cond
|
||||
[(>= i ilen)
|
||||
(let-values ([(n k) (fixup i)])
|
||||
(fill (fxlshift acc n) k o)
|
||||
out)]
|
||||
[(and (> i 0) (= 0 (mod i 5)))
|
||||
(fill acc 7 o)
|
||||
(rec (bytes-ref bs i) (+ i 1) (+ o 8))]
|
||||
[else
|
||||
(let ([sacc (fxlshift acc 8)]
|
||||
[by (bytes-ref bs i)])
|
||||
(rec (fxior sacc by) (+ i 1) o))]))))
|
||||
|
||||
; 65 = #\A
|
||||
; 24 = #\2 - 26
|
||||
(define (b32 n) (integer->char (+ n (if (< n 26) 65 24))))
|
||||
|
||||
; 48 = #\0
|
||||
; 87 = #\a - 10
|
||||
(define (b32h n) (integer->char (+ n (if (< n 10) 48 87))))
|
||||
|
||||
|
||||
(define (describe-list op cl l)
|
||||
(let rec ([pre (string op)] [post (string op cl)] [cur l])
|
||||
@ -164,7 +116,7 @@
|
||||
(define (describe-list-br l) (describe-list #\{ #\} l))
|
||||
|
||||
(define (describe-hash h)
|
||||
(substring (bytevector->base32-string b32h h) 0 8))
|
||||
(substring (bytevector->base32-string h #:alphabet 'hex) 0 8))
|
||||
|
||||
(define (describe-derived h i)
|
||||
(let ([th (describe-hash h)]
|
||||
@ -183,7 +135,7 @@
|
||||
[(unison-termlink-derived hash i) (describe-derived hash i)]))
|
||||
|
||||
(define (describe-bytes bs)
|
||||
(let* ([s (bytevector->base32-string b32h bs)]
|
||||
(let* ([s (bytevector->base32-string bs #:alphabet 'hex)]
|
||||
[l (string-length s)]
|
||||
[sfx (if (<= l 10) "" "...")])
|
||||
(string-append "32x" (substring s 0 10) sfx)))
|
||||
@ -216,6 +168,9 @@
|
||||
[else
|
||||
(format-non-tuple (cons tup acc))])))
|
||||
|
||||
(define (describe-applied f args)
|
||||
(string-append f " "))
|
||||
|
||||
(define (describe-value x)
|
||||
(match x
|
||||
[(unison-sum t fs)
|
||||
@ -229,22 +184,26 @@
|
||||
(let ([tt (number->string t)]
|
||||
[rt (describe-ref r)]
|
||||
[vs (describe-list-br fs)])
|
||||
(string-append "Data " rt " " tt " " vs))]
|
||||
(string-append "{Data " rt " " tt " " vs "}"))]
|
||||
[(unison-pure v)
|
||||
(string-append "Pure " (describe-list-br (list v)))]
|
||||
[(unison-termlink-con r t)
|
||||
(let ([rt (describe-ref r)]
|
||||
[tt (number->string t)])
|
||||
(string-append "{Con " r " " t "}"))]
|
||||
[(unison-termlink-builtin name) (string-append "##" name)]
|
||||
[(unison-termlink-derived hash i) (describe-derived hash i)]
|
||||
[(unison-typelink-builtin nm)
|
||||
(string-append "##" nm)]
|
||||
[(unison-typelink-derived hs i) (describe-derived hs i)]
|
||||
[(? unison-termlink?) (termlink->string x #t)]
|
||||
[(? unison-typelink?) (typelink->string x #t)]
|
||||
[(unison-quote v)
|
||||
(string-append "{Value " (describe-value v) "}")]
|
||||
[(unison-code v)
|
||||
(string-append "Code (" (describe-value v) ")")]
|
||||
(string-append "{Code " (describe-value v) "}")]
|
||||
[(unison-closure code env)
|
||||
(define dc
|
||||
(termlink->string (lookup-function-link code) #t))
|
||||
(define (f v)
|
||||
(string-append " " (describe-value v)))
|
||||
|
||||
(string-append* dc (map f env))]
|
||||
[(? procedure?)
|
||||
(string-append
|
||||
"ref"
|
||||
(termlink->string (lookup-function-link x) #t))]
|
||||
[(? chunked-list?)
|
||||
(describe-list-sq (vector->list (chunked-list->vector x)))]
|
||||
[(? chunked-string?)
|
||||
@ -496,8 +455,6 @@
|
||||
([c (in-chunked-string-chunks s)])
|
||||
(f acc (string->chunked-string (m c)))))
|
||||
|
||||
(define freeze-bytevector! unsafe-bytes->immutable-bytes!)
|
||||
|
||||
(define freeze-vector! unsafe-vector*->immutable-vector!)
|
||||
|
||||
(define (freeze-subvector src off len)
|
||||
@ -531,9 +488,3 @@
|
||||
#:methods gen:custom-write
|
||||
[(define write-proc write-exn:bug)])
|
||||
|
||||
|
||||
(define (exn:bug->exception b)
|
||||
(exception
|
||||
ref-runtimefailure:typelink
|
||||
(exn:bug-msg b)
|
||||
(exn:bug-val b)))
|
||||
|
@ -95,12 +95,16 @@
|
||||
builtin-tls.signedcert:typelink
|
||||
builtin-tls.version:typelink
|
||||
|
||||
unison-tuple->list)
|
||||
unison-tuple->list
|
||||
|
||||
typelink->string
|
||||
termlink->string)
|
||||
|
||||
(require
|
||||
racket
|
||||
racket/fixnum
|
||||
(only-in "vector-trie.rkt" ->fx/wraparound))
|
||||
(only-in "vector-trie.rkt" ->fx/wraparound)
|
||||
unison/bytevector)
|
||||
|
||||
(struct unison-data
|
||||
(ref tag fields)
|
||||
@ -152,6 +156,9 @@
|
||||
(struct unison-termlink ()
|
||||
#:transparent
|
||||
#:reflection-name 'termlink
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc tl port mode)
|
||||
(write-string (termlink->string tl #t) port))]
|
||||
#:property prop:equal+hash
|
||||
(let ()
|
||||
(define (equal-proc lnl lnr rec)
|
||||
@ -203,6 +210,9 @@
|
||||
(struct unison-typelink ()
|
||||
#:transparent
|
||||
#:reflection-name 'typelink
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc tl port mode)
|
||||
(write-string (typelink->string tl #t) port))]
|
||||
#:property prop:equal+hash
|
||||
(let ()
|
||||
(define (equal-proc lnl lnr rec)
|
||||
@ -243,9 +253,57 @@
|
||||
(struct unison-code (rep))
|
||||
(struct unison-quote (val))
|
||||
|
||||
(define (write-procedure f port mode)
|
||||
(cond
|
||||
[(hash-has-key? function-associations f)
|
||||
(define tl (lookup-function-link f))
|
||||
(write-string (termlink->string tl #t) port)]
|
||||
[else
|
||||
(case mode
|
||||
[(#f) (display f port)]
|
||||
[(#t) (write f port)]
|
||||
[else (print f port mode)])]))
|
||||
|
||||
(define (write-sequence s port mode)
|
||||
(define rec
|
||||
(case mode
|
||||
[(#f) display]
|
||||
[(#t) write]
|
||||
[else (lambda (e port) (print e port mode))]))
|
||||
|
||||
(write-string "'(" port)
|
||||
|
||||
(define first #t)
|
||||
|
||||
(for ([e s])
|
||||
(unless first
|
||||
(write-string " " port)
|
||||
(set! first #f))
|
||||
|
||||
(if (procedure? e)
|
||||
(write-procedure e port mode)
|
||||
(rec e port)))
|
||||
(write-string ")" port))
|
||||
|
||||
(struct unison-closure
|
||||
(code env)
|
||||
#:transparent
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc clo port mode)
|
||||
(define code-tl
|
||||
(lookup-function-link (unison-closure-code clo)))
|
||||
|
||||
(define rec
|
||||
(case mode
|
||||
[(#t) write]
|
||||
[(#f) display]
|
||||
[else (lambda (v port) (print v port mode))]))
|
||||
|
||||
(write-string "(unison-closure " port)
|
||||
(write-procedure (unison-closure-code clo) port mode)
|
||||
(write-string " " port)
|
||||
(write-sequence (unison-closure-env clo) port mode)
|
||||
(write-string ")" port))]
|
||||
#:property prop:procedure
|
||||
(case-lambda
|
||||
[(clo) clo]
|
||||
@ -395,9 +453,9 @@
|
||||
(define (failure typeLink msg any)
|
||||
(sum 0 typeLink msg any))
|
||||
|
||||
; Type -> Text -> a ->{Exception} b
|
||||
; Type -> Text -> a -> (type, text, a) + b
|
||||
(define (exception typeLink msg a)
|
||||
(failure typeLink msg (unison-any-any a)))
|
||||
(failure typeLink msg a))
|
||||
|
||||
; A counter for internally numbering declared data, so that the
|
||||
; entire reference doesn't need to be stored in every data record.
|
||||
@ -456,3 +514,35 @@
|
||||
(cons (car fs) (unison-tuple->list (cadr fs)))]
|
||||
[else
|
||||
(raise "unison-tuple->list: unexpected value")])))
|
||||
|
||||
(define (hash-string hs)
|
||||
(string-append
|
||||
"#"
|
||||
(bytevector->base32-string hs #:alphabet 'hex)))
|
||||
|
||||
(define (ix-string i)
|
||||
(if (= i 0)
|
||||
""
|
||||
(string-append "." (number->string i))))
|
||||
|
||||
(define (typelink->string ln [short #f])
|
||||
(define (clip s) (if short (substring s 0 8) s))
|
||||
|
||||
(match ln
|
||||
[(unison-typelink-builtin name)
|
||||
(string-append "##" name)]
|
||||
[(unison-typelink-derived hs i)
|
||||
(string-append (clip (hash-string hs)) (ix-string i))]))
|
||||
|
||||
(define (termlink->string ln [short #f])
|
||||
(define (clip s) (if short (substring s 0 8) s))
|
||||
|
||||
(match ln
|
||||
[(unison-termlink-builtin name)
|
||||
(string-append "##" name)]
|
||||
[(unison-termlink-derived hs i)
|
||||
(string-append (clip (hash-string hs)) (ix-string i))]
|
||||
[(unison-termlink-con rf t)
|
||||
(string-append
|
||||
(typelink->string rf short) "#" (number->string t))]))
|
||||
|
||||
|
@ -9,7 +9,7 @@
|
||||
racket/vector
|
||||
unison/boot
|
||||
unison/boot-generated
|
||||
(only-in unison/core bytevector->base32-string b32h)
|
||||
(only-in unison/bytevector bytevector->base32-string)
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/chunked-seq
|
||||
@ -220,7 +220,7 @@
|
||||
[(unison-termlink-builtin name)
|
||||
(string-append "builtin-" name)]
|
||||
[(unison-termlink-derived bs i)
|
||||
(let ([hs (bytevector->base32-string b32h bs)]
|
||||
(let ([hs (bytevector->base32-string bs #:alphabet 'hex)]
|
||||
[po (if (= i 0) "" (string-append "." (number->string i)))])
|
||||
(string->symbol
|
||||
(string-append "ref-" (substring hs 0 8) po)))]))
|
||||
|
@ -140,6 +140,8 @@
|
||||
builtin-Bytes.indexOf:termlink
|
||||
builtin-IO.randomBytes
|
||||
builtin-IO.randomBytes:termlink
|
||||
builtin-IO.tryEval
|
||||
builtin-IO.tryEval:termlink
|
||||
|
||||
builtin-Scope.bytearrayOf
|
||||
builtin-Scope.bytearrayOf:termlink
|
||||
@ -388,7 +390,6 @@
|
||||
unison-FOp-IO.delay.impl.v3
|
||||
unison-POp-FORK
|
||||
unison-FOp-IO.kill.impl.v3
|
||||
unison-POp-TFRC
|
||||
|
||||
unison-FOp-Handle.toText
|
||||
unison-FOp-Socket.toText
|
||||
@ -602,7 +603,14 @@
|
||||
vector-copy!
|
||||
bytes-copy!
|
||||
sub1
|
||||
add1)
|
||||
add1
|
||||
exn:break?
|
||||
exn:fail?
|
||||
exn:fail:read?
|
||||
exn:fail:filesystem?
|
||||
exn:fail:network?
|
||||
exn:fail:contract:divide-by-zero?
|
||||
exn:fail:contract:non-fixnum-result?)
|
||||
(car icar) (cdr icdr))
|
||||
(only (racket string)
|
||||
string-contains?
|
||||
@ -618,6 +626,8 @@
|
||||
clamp-integer
|
||||
clamp-natural
|
||||
wrap-natural
|
||||
exn:bug->exception
|
||||
raise-unison-exception
|
||||
bit64
|
||||
bit63
|
||||
nbit63)
|
||||
@ -698,6 +708,7 @@
|
||||
(define-builtin-link Text.!=)
|
||||
(define-builtin-link Bytes.indexOf)
|
||||
(define-builtin-link IO.randomBytes)
|
||||
(define-builtin-link IO.tryEval)
|
||||
(define-builtin-link List.splitLeft)
|
||||
(define-builtin-link List.splitRight)
|
||||
(define-builtin-link Value.toBuiltin)
|
||||
@ -827,34 +838,10 @@
|
||||
(define-unison (builtin-Scope.bytearrayOf i n)
|
||||
(make-bytevector n i))
|
||||
|
||||
(define (hash-string hs)
|
||||
(string-append "#" (bytevector->base32-string b32h hs)))
|
||||
|
||||
(define (ix-string i)
|
||||
(if (= i 0)
|
||||
""
|
||||
(string-append "." (number->string i))))
|
||||
|
||||
(define (typelink->string ln)
|
||||
(match ln
|
||||
[(unison-typelink-builtin name)
|
||||
(string-append "##" name)]
|
||||
[(unison-typelink-derived hs i)
|
||||
(string-append (hash-string hs) (ix-string i))]))
|
||||
|
||||
(define-builtin-link Link.Type.toText)
|
||||
(define-unison (builtin-Link.Type.toText ln)
|
||||
(string->chunked-string (typelink->string ln)))
|
||||
|
||||
(define (termlink->string ln)
|
||||
(match ln
|
||||
[(unison-termlink-builtin name)
|
||||
(string-append "##" name)]
|
||||
[(unison-termlink-derived hs i)
|
||||
(string-append (hash-string hs) (ix-string i))]
|
||||
[(unison-termlink-con rf t)
|
||||
(string-append (typelink->string rf) "#" (number->string t))]))
|
||||
|
||||
(define-builtin-link Link.Term.toText)
|
||||
(define-unison (builtin-Link.Term.toText ln)
|
||||
(string->chunked-string (termlink->string ln)))
|
||||
@ -1343,7 +1330,6 @@
|
||||
(define unison-FOp-ImmutableArray.size vector-length)
|
||||
|
||||
(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))
|
||||
@ -1358,6 +1344,50 @@
|
||||
(define (unison-FOp-Promise.tryRead promise) (promise-try-read promise))
|
||||
(define (unison-FOp-Promise.write promise a) (promise-write promise a)))
|
||||
|
||||
|
||||
(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)))
|
||||
|
||||
(define-unison (builtin-IO.tryEval thunk)
|
||||
(with-handlers
|
||||
([exn:break?
|
||||
(lambda (e)
|
||||
(raise-unison-exception
|
||||
ref-threadkilledfailure:typelink
|
||||
(string->chunked-string "thread killed")
|
||||
ref-unit-unit))]
|
||||
[exn:io?
|
||||
(lambda (e)
|
||||
(raise-unison-exception
|
||||
ref-iofailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))]
|
||||
[exn:arith?
|
||||
(lambda (e)
|
||||
(raise-unison-exception
|
||||
ref-arithfailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))]
|
||||
[exn:bug? (lambda (e) (exn:bug->exception e))]
|
||||
[exn:fail?
|
||||
(lambda (e)
|
||||
(raise-unison-exception
|
||||
ref-runtimefailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))]
|
||||
[(lambda (x) #t)
|
||||
(lambda (e)
|
||||
(raise-unison-exception
|
||||
ref-miscfailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))])
|
||||
(thunk ref-unit-unit)))
|
||||
|
||||
(declare-builtin-link builtin-Float.*)
|
||||
(declare-builtin-link builtin-Float.fromRepresentation)
|
||||
@ -1417,6 +1447,7 @@
|
||||
(declare-builtin-link builtin-Text.!=)
|
||||
(declare-builtin-link builtin-Bytes.indexOf)
|
||||
(declare-builtin-link builtin-IO.randomBytes)
|
||||
(declare-builtin-link builtin-IO.tryEval)
|
||||
(declare-builtin-link builtin-List.splitLeft)
|
||||
(declare-builtin-link builtin-List.splitRight)
|
||||
(declare-builtin-link builtin-Value.toBuiltin)
|
||||
|
@ -5,7 +5,7 @@ Next, we'll download the jit project and generate a few Racket files from it.
|
||||
|
||||
```ucm
|
||||
.> project.create-empty jit-setup
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.13 lib.jit
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.14 lib.jit
|
||||
```
|
||||
|
||||
```unison
|
||||
|
@ -20,7 +20,7 @@ Next, we'll download the jit project and generate a few Racket files from it.
|
||||
|
||||
🎉 🥳 Happy coding!
|
||||
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.13 lib.jit
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.14 lib.jit
|
||||
|
||||
Downloaded 15053 entities.
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user