simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

^long is a 64-bit long: fast-path-with-fallback ops + logical unsigned shift

Browse source 
Completes the JVM long-compatibility gap so clojure.test.check (and the
property-based suites built on it, e.g. data.codec) run on jolt.

A ^long is 64-bit but a Chez fixnum is only 61-bit, so the backend's fast fx
comparison / quot / min / max / inc / dec ops raised on a full-width long (one
from the PRNG or wrapping arithmetic). They now go through the jolt-l* macros
(host/chez/seq.ss): the fx fast path when the operands ARE fixnums, the generic
op otherwise — so e.g. ((fn [^long a ^long b] (< a b)) Long/MAX 1) is false, not
an error. Arithmetic +/-/* keep the raw fx ops (under *unchecked-math* they're
already the wrapping unchecked-*).

Also fixes unsigned-bit-shift-right: it was an arithmetic (sign-propagating)
shift, now a logical shift over the 64-bit two's-complement window, so
(unsigned-bit-shift-right -1 1) is 2^63-1 like the JVM.

Result: test.check 1.1.3 loads and runs (generators, quick-check, shrinking);
data.codec's base64 property suite passes (12/12 defspecs; the 2 deftests check
clojure.lang.IFn$OLLOL, a JVM primitive-fn interface, N/A). Both added to
docs/libraries.md + the site.

re-mint (backend/seed). make test green (+3 corpus rows, 0 new divergences,
numeric gate updated to the jolt-l* ops), shakesmoke byte-identical.
This commit is contained in:
Yogthos 2026-06-27 16:04:19 -04:00
parent a028cab04f
commit 3340635714
7 changed files with 62 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

4
docs/libraries.md
View file

@ -61,6 +61,10 @@ e.g. the [ring-app example](https://github.com/jolt-lang/examples/tree/main/ring
`clojure.data.zip.xml`; XML parsing via [jolt-lang/xml](https://github.com/jolt-lang/xml) `clojure.data.zip.xml`; XML parsing via [jolt-lang/xml](https://github.com/jolt-lang/xml)
(which now ships `clojure.xml/parse`). (which now ships `clojure.xml/parse`).
* [data.csv](https://github.com/clojure/data.csv) — reading and writing CSV. * [data.csv](https://github.com/clojure/data.csv) — reading and writing CSV.
* [data.codec](https://github.com/clojure/data.codec) — base64 encode/decode over
byte arrays.
* [test.check](https://github.com/clojure/test.check) — property-based testing
(generators, `quick-check`, shrinking).
* [tick](https://github.com/juxt/tick) — date/time over Jolt's `java.time`; * [tick](https://github.com/juxt/tick) — date/time over Jolt's `java.time`;
`#time/…` literals via `time-literals`. `#time/…` literals via `time-literals`.
* [transit-jolt](https://github.com/jolt-lang/transit-jolt) — Transit (JSON) read/write * [transit-jolt](https://github.com/jolt-lang/transit-jolt) — Transit (JSON) read/write

9
host/chez/natives-num.ss
View file

@ -17,11 +17,12 @@
(define (jolt-bit-clear x n) (bitwise-and (->int x) (bitwise-not (bit-mask n)))) (define (jolt-bit-clear x n) (bitwise-and (->int x) (bitwise-not (bit-mask n))))
(define (jolt-bit-flip x n) (bitwise-xor (->int x) (bit-mask n))) (define (jolt-bit-flip x n) (bitwise-xor (->int x) (bit-mask n)))
(define (jolt-bit-test x n) (not (zero? (bitwise-and (->int x) (bit-mask n))))) (define (jolt-bit-test x n) (not (zero? (bitwise-and (->int x) (bit-mask n)))))
;; unsigned-bit-shift-right: logical shift over 64-bit longs. For the common ;; unsigned-bit-shift-right: LOGICAL right shift over a 64-bit long (Java >>>),
;; non-negative operand it equals the arithmetic shift; the negative-operand ;; so a negative operand shifts in zeros from its 64-bit two's-complement window
;; 64-bit-window case is not modeled. ;; ((>>> -1 1) = 2^63-1), not the sign. The shift count is taken mod 64.
(define (jolt-unsigned-bit-shift-right x n) (define (jolt-unsigned-bit-shift-right x n)
(bitwise-arithmetic-shift-right (->int x) (->int n))) (bitwise-arithmetic-shift-right (bitwise-and (->int x) #xFFFFFFFFFFFFFFFF)
(bitwise-and (->int n) 63)))
;; ---- string->scalar parsers ------------------------------------------------- ;; ---- string->scalar parsers -------------------------------------------------
(define (ascii-digit? c) (and (char>=? c #\0) (char<=? c #\9))) (define (ascii-digit? c) (and (char>=? c #\0) (char<=? c #\9)))

4
host/chez/seed/image.ss
View file

@ -143,7 +143,7 @@
(guard (e (#t #f)) (guard (e (#t #f))
(def-var-with-meta! "jolt.backend-scheme" "dbl-ops" (let* ((_o$7452 "+") (_o$7453 "fl+") (_o$7454 "-") (_o$7455 "fl-") (_o$7456 "*") (_o$7457 "fl*") (_o$7458 "/") (_o$7459 "fl/") (_o$7460 "min") (_o$7461 "flmin") (_o$7462 "max") (_o$7463 "flmax") (_o$7464 "<") (_o$7465 "fl<?") (_o$7466 ">") (_o$7467 "fl>?") (_o$7468 "<=") (_o$7469 "fl<=?") (_o$7470 ">=") (_o$7471 "fl>=?") (_o$7472 "=") (_o$7473 "fl=?") (_o$7474 "==") (_o$7475 "fl=?")) (jolt-hash-map _o$7452 _o$7453 _o$7454 _o$7455 _o$7456 _o$7457 _o$7458 _o$7459 _o$7460 _o$7461 _o$7462 _o$7463 _o$7464 _o$7465 _o$7466 _o$7467 _o$7468 _o$7469 _o$7470 _o$7471 _o$7472 _o$7473 _o$7474 _o$7475)) (let* ((_o$7476 (keyword #f "private")) (_o$7477 #t)) (jolt-hash-map _o$7476 _o$7477)))) (def-var-with-meta! "jolt.backend-scheme" "dbl-ops" (let* ((_o$7452 "+") (_o$7453 "fl+") (_o$7454 "-") (_o$7455 "fl-") (_o$7456 "*") (_o$7457 "fl*") (_o$7458 "/") (_o$7459 "fl/") (_o$7460 "min") (_o$7461 "flmin") (_o$7462 "max") (_o$7463 "flmax") (_o$7464 "<") (_o$7465 "fl<?") (_o$7466 ">") (_o$7467 "fl>?") (_o$7468 "<=") (_o$7469 "fl<=?") (_o$7470 ">=") (_o$7471 "fl>=?") (_o$7472 "=") (_o$7473 "fl=?") (_o$7474 "==") (_o$7475 "fl=?")) (jolt-hash-map _o$7452 _o$7453 _o$7454 _o$7455 _o$7456 _o$7457 _o$7458 _o$7459 _o$7460 _o$7461 _o$7462 _o$7463 _o$7464 _o$7465 _o$7466 _o$7467 _o$7468 _o$7469 _o$7470 _o$7471 _o$7472 _o$7473 _o$7474 _o$7475)) (let* ((_o$7476 (keyword #f "private")) (_o$7477 #t)) (jolt-hash-map _o$7476 _o$7477))))
(guard (e (#t #f)) (guard (e (#t #f))
(def-var-with-meta! "jolt.backend-scheme" "lng-ops" (let* ((_o$7478 "+") (_o$7479 "fx+") (_o$7480 "-") (_o$7481 "fx-") (_o$7482 "*") (_o$7483 "fx*") (_o$7484 "min") (_o$7485 "fxmin") (_o$7486 "max") (_o$7487 "fxmax") (_o$7488 "unchecked-add") (_o$7489 "jolt-uncadd2") (_o$7490 "unchecked-subtract") (_o$7491 "jolt-uncsub2") (_o$7492 "unchecked-multiply") (_o$7493 "jolt-uncmul2") (_o$7494 "quot") (_o$7495 "fxquotient") (_o$7496 "rem") (_o$7497 "fxremainder") (_o$7498 "mod") (_o$7499 "fxmodulo") (_o$7500 "<") (_o$7501 "fx<?") (_o$7502 ">") (_o$7503 "fx>?") (_o$7504 "<=") (_o$7505 "fx<=?") (_o$7506 ">=") (_o$7507 "fx>=?") (_o$7508 "=") (_o$7509 "fx=?") (_o$7510 "==") (_o$7511 "fx=?")) (jolt-hash-map _o$7478 _o$7479 _o$7480 _o$7481 _o$7482 _o$7483 _o$7484 _o$7485 _o$7486 _o$7487 _o$7488 _o$7489 _o$7490 _o$7491 _o$7492 _o$7493 _o$7494 _o$7495 _o$7496 _o$7497 _o$7498 _o$7499 _o$7500 _o$7501 _o$7502 _o$7503 _o$7504 _o$7505 _o$7506 _o$7507 _o$7508 _o$7509 _o$7510 _o$7511)) (let* ((_o$7512 (keyword #f "private")) (_o$7513 #t)) (jolt-hash-map _o$7512 _o$7513)))) (def-var-with-meta! "jolt.backend-scheme" "lng-ops" (let* ((_o$7478 "+") (_o$7479 "fx+") (_o$7480 "-") (_o$7481 "fx-") (_o$7482 "*") (_o$7483 "fx*") (_o$7484 "min") (_o$7485 "jolt-l-min") (_o$7486 "max") (_o$7487 "jolt-l-max") (_o$7488 "unchecked-add") (_o$7489 "jolt-uncadd2") (_o$7490 "unchecked-subtract") (_o$7491 "jolt-uncsub2") (_o$7492 "unchecked-multiply") (_o$7493 "jolt-uncmul2") (_o$7494 "quot") (_o$7495 "jolt-l-quot") (_o$7496 "rem") (_o$7497 "jolt-l-rem") (_o$7498 "mod") (_o$7499 "jolt-l-mod") (_o$7500 "<") (_o$7501 "jolt-l<") (_o$7502 ">") (_o$7503 "jolt-l>") (_o$7504 "<=") (_o$7505 "jolt-l<=") (_o$7506 ">=") (_o$7507 "jolt-l>=") (_o$7508 "=") (_o$7509 "jolt-l=") (_o$7510 "==") (_o$7511 "jolt-l=")) (jolt-hash-map _o$7478 _o$7479 _o$7480 _o$7481 _o$7482 _o$7483 _o$7484 _o$7485 _o$7486 _o$7487 _o$7488 _o$7489 _o$7490 _o$7491 _o$7492 _o$7493 _o$7494 _o$7495 _o$7496 _o$7497 _o$7498 _o$7499 _o$7500 _o$7501 _o$7502 _o$7503 _o$7504 _o$7505 _o$7506 _o$7507 _o$7508 _o$7509 _o$7510 _o$7511)) (let* ((_o$7512 (keyword #f "private")) (_o$7513 #t)) (jolt-hash-map _o$7512 _o$7513))))
(guard (e (#t #f)) (guard (e (#t #f))
(def-var-with-meta! "jolt.backend-scheme" "bd-ops" (let* ((_o$7514 "+") (_o$7515 "jbd-add") (_o$7516 "-") (_o$7517 "jbd-sub") (_o$7518 "*") (_o$7519 "jbd-mul") (_o$7520 "/") (_o$7521 "jbd-div") (_o$7522 "min") (_o$7523 "jbd-min") (_o$7524 "max") (_o$7525 "jbd-max") (_o$7526 "quot") (_o$7527 "jbd-quot") (_o$7528 "rem") (_o$7529 "jbd-rem") (_o$7530 "<") (_o$7531 "jbd-lt?") (_o$7532 ">") (_o$7533 "jbd-gt?") (_o$7534 "<=") (_o$7535 "jbd-le?") (_o$7536 ">=") (_o$7537 "jbd-ge?") (_o$7538 "zero?") (_o$7539 "jbd-zero?") (_o$7540 "pos?") (_o$7541 "jbd-pos?") (_o$7542 "neg?") (_o$7543 "jbd-neg?")) (jolt-hash-map _o$7514 _o$7515 _o$7516 _o$7517 _o$7518 _o$7519 _o$7520 _o$7521 _o$7522 _o$7523 _o$7524 _o$7525 _o$7526 _o$7527 _o$7528 _o$7529 _o$7530 _o$7531 _o$7532 _o$7533 _o$7534 _o$7535 _o$7536 _o$7537 _o$7538 _o$7539 _o$7540 _o$7541 _o$7542 _o$7543)) (let* ((_o$7544 (keyword #f "private")) (_o$7545 #t)) (jolt-hash-map _o$7544 _o$7545)))) (def-var-with-meta! "jolt.backend-scheme" "bd-ops" (let* ((_o$7514 "+") (_o$7515 "jbd-add") (_o$7516 "-") (_o$7517 "jbd-sub") (_o$7518 "*") (_o$7519 "jbd-mul") (_o$7520 "/") (_o$7521 "jbd-div") (_o$7522 "min") (_o$7523 "jbd-min") (_o$7524 "max") (_o$7525 "jbd-max") (_o$7526 "quot") (_o$7527 "jbd-quot") (_o$7528 "rem") (_o$7529 "jbd-rem") (_o$7530 "<") (_o$7531 "jbd-lt?") (_o$7532 ">") (_o$7533 "jbd-gt?") (_o$7534 "<=") (_o$7535 "jbd-le?") (_o$7536 ">=") (_o$7537 "jbd-ge?") (_o$7538 "zero?") (_o$7539 "jbd-zero?") (_o$7540 "pos?") (_o$7541 "jbd-pos?") (_o$7542 "neg?") (_o$7543 "jbd-neg?")) (jolt-hash-map _o$7514 _o$7515 _o$7516 _o$7517 _o$7518 _o$7519 _o$7520 _o$7521 _o$7522 _o$7523 _o$7524 _o$7525 _o$7526 _o$7527 _o$7528 _o$7529 _o$7530 _o$7531 _o$7532 _o$7533 _o$7534 _o$7535 _o$7536 _o$7537 _o$7538 _o$7539 _o$7540 _o$7541 _o$7542 _o$7543)) (let* ((_o$7544 (keyword #f "private")) (_o$7545 #t)) (jolt-hash-map _o$7544 _o$7545))))
(guard (e (#t #f)) (guard (e (#t #f))
@ -241,7 +241,7 @@
(guard (e (#t #f)) (guard (e (#t #f))
(def-var-with-meta! "jolt.backend-scheme" "stdlib-var?" (letrec ((stdlib-var? (lambda (n) (let fnrec7835 ((n n)) (let* ((and__25__auto (jolt= (keyword #f "var") (jolt-get n (keyword #f "op"))))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "clojure.string" "starts-with?") (let* ((or__26__auto (jolt-get n (keyword #f "ns")))) (if (jolt-truthy? or__26__auto) or__26__auto "")) "clojure.") and__25__auto)))))) stdlib-var?) (let* ((_o$7836 (keyword #f "private")) (_o$7837 #t)) (jolt-hash-map _o$7836 _o$7837)))) (def-var-with-meta! "jolt.backend-scheme" "stdlib-var?" (letrec ((stdlib-var? (lambda (n) (let fnrec7835 ((n n)) (let* ((and__25__auto (jolt= (keyword #f "var") (jolt-get n (keyword #f "op"))))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "clojure.string" "starts-with?") (let* ((or__26__auto (jolt-get n (keyword #f "ns")))) (if (jolt-truthy? or__26__auto) or__26__auto "")) "clojure.") and__25__auto)))))) stdlib-var?) (let* ((_o$7836 (keyword #f "private")) (_o$7837 #t)) (jolt-hash-map _o$7836 _o$7837))))
(guard (e (#t #f)) (guard (e (#t #f))
(def-var-with-meta! "jolt.backend-scheme" "emit-numeric" (letrec ((emit-numeric (lambda (kind nm args order-args) (let fnrec7838 ((kind kind) (nm nm) (args args) (order-args order-args)) (if (let* ((and__25__auto (jolt= kind (keyword #f "double")))) (if (jolt-truthy? and__25__auto) (jolt= nm "inc") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(fl+ " (jolt-first args) " 1.0)") (if (let* ((and__25__auto (jolt= kind (keyword #f "double")))) (if (jolt-truthy? and__25__auto) (jolt= nm "dec") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(fl- " (jolt-first args) " 1.0)") (if (let* ((and__25__auto (jolt= kind (keyword #f "long")))) (if (jolt-truthy? and__25__auto) (jolt= nm "inc") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(fx1+ " (jolt-first args) ")") (if (let* ((and__25__auto (jolt= kind (keyword #f "long")))) (if (jolt-truthy? and__25__auto) (jolt= nm "dec") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(fx1- " (jolt-first args) ")") (if (let* ((and__25__auto (jolt= kind (keyword #f "long")))) (if (jolt-truthy? and__25__auto) (jolt= nm "unchecked-inc") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-uncinc " (jolt-first args) ")") (if (let* ((and__25__auto (jolt= kind (keyword #f "long")))) (if (jolt-truthy? and__25__auto) (jolt= nm "unchecked-dec") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-uncdec " (jolt-first args) ")") (if (jolt-truthy? (keyword #f "else")) (let* ((op (let* ((G__140 kind)) (if (jolt= G__140 (keyword #f "double")) (jolt-invoke (var-deref "jolt.backend-scheme" "dbl-ops") nm) (if (jolt= G__140 (keyword #f "long")) (jolt-invoke (var-deref "jolt.backend-scheme" "lng-ops") nm) (if (jolt= G__140 (keyword #f "bigdec")) (jolt-invoke (var-deref "jolt.backend-scheme" "bd-ops") nm) (jolt-throw (let* ((_a$7839 (jolt-invoke (var-deref "clojure.core" "str") "No matching clause: " G__140)) (_a$7840 (jolt-hash-map))) (jolt-ex-info _a$7839 _a$7840))))))))) (jolt-invoke order-args (lambda (as) (let fnrec7841 ((as as)) (jolt-invoke (var-deref "clojure.core" "str") "(" op " " (jolt-invoke (var-deref "clojure.string" "join") " " as) ")"))))) jolt-nil))))))))))) emit-numeric) (let* ((_o$7842 (keyword #f "private")) (_o$7843 #t)) (jolt-hash-map _o$7842 _o$7843)))) (def-var-with-meta! "jolt.backend-scheme" "emit-numeric" (letrec ((emit-numeric (lambda (kind nm args order-args) (let fnrec7838 ((kind kind) (nm nm) (args args) (order-args order-args)) (if (let* ((and__25__auto (jolt= kind (keyword #f "double")))) (if (jolt-truthy? and__25__auto) (jolt= nm "inc") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(fl+ " (jolt-first args) " 1.0)") (if (let* ((and__25__auto (jolt= kind (keyword #f "double")))) (if (jolt-truthy? and__25__auto) (jolt= nm "dec") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(fl- " (jolt-first args) " 1.0)") (if (let* ((and__25__auto (jolt= kind (keyword #f "long")))) (if (jolt-truthy? and__25__auto) (jolt= nm "inc") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-l-inc " (jolt-first args) ")") (if (let* ((and__25__auto (jolt= kind (keyword #f "long")))) (if (jolt-truthy? and__25__auto) (jolt= nm "dec") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-l-dec " (jolt-first args) ")") (if (let* ((and__25__auto (jolt= kind (keyword #f "long")))) (if (jolt-truthy? and__25__auto) (jolt= nm "unchecked-inc") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-uncinc " (jolt-first args) ")") (if (let* ((and__25__auto (jolt= kind (keyword #f "long")))) (if (jolt-truthy? and__25__auto) (jolt= nm "unchecked-dec") and__25__auto)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-uncdec " (jolt-first args) ")") (if (jolt-truthy? (keyword #f "else")) (let* ((op (let* ((G__140 kind)) (if (jolt= G__140 (keyword #f "double")) (jolt-invoke (var-deref "jolt.backend-scheme" "dbl-ops") nm) (if (jolt= G__140 (keyword #f "long")) (jolt-invoke (var-deref "jolt.backend-scheme" "lng-ops") nm) (if (jolt= G__140 (keyword #f "bigdec")) (jolt-invoke (var-deref "jolt.backend-scheme" "bd-ops") nm) (jolt-throw (let* ((_a$7839 (jolt-invoke (var-deref "clojure.core" "str") "No matching clause: " G__140)) (_a$7840 (jolt-hash-map))) (jolt-ex-info _a$7839 _a$7840))))))))) (jolt-invoke order-args (lambda (as) (let fnrec7841 ((as as)) (jolt-invoke (var-deref "clojure.core" "str") "(" op " " (jolt-invoke (var-deref "clojure.string" "join") " " as) ")"))))) jolt-nil))))))))))) emit-numeric) (let* ((_o$7842 (keyword #f "private")) (_o$7843 #t)) (jolt-hash-map _o$7842 _o$7843))))
(guard (e (#t #f)) (guard (e (#t #f))
(def-var-with-meta! "jolt.backend-scheme" "struct-field-index" (letrec ((struct-field-index (lambda (shape kw) (let fnrec7844 ((shape shape) (kw kw)) (if (jolt-truthy? shape) (let* ((i 0)) (let loop7845 ((i i)) (if (>= i (jolt-count shape)) jolt-nil (if (jolt= (jolt-nth shape i) kw) i (if (jolt-truthy? (keyword #f "else")) (loop7845 (jolt-inc i)) jolt-nil))))) jolt-nil))))) struct-field-index) (let* ((_o$7846 (keyword #f "private")) (_o$7847 #t)) (jolt-hash-map _o$7846 _o$7847)))) (def-var-with-meta! "jolt.backend-scheme" "struct-field-index" (letrec ((struct-field-index (lambda (shape kw) (let fnrec7844 ((shape shape) (kw kw)) (if (jolt-truthy? shape) (let* ((i 0)) (let loop7845 ((i i)) (if (>= i (jolt-count shape)) jolt-nil (if (jolt= (jolt-nth shape i) kw) i (if (jolt-truthy? (keyword #f "else")) (loop7845 (jolt-inc i)) jolt-nil))))) jolt-nil))))) struct-field-index) (let* ((_o$7846 (keyword #f "private")) (_o$7847 #t)) (jolt-hash-map _o$7846 _o$7847))))
(guard (e (#t #f)) (guard (e (#t #f))

26
host/chez/seq.ss
View file

@ -180,6 +180,32 @@
;; the clojure.core/unchecked-* vars are def-var!'d in natives-seq.ss (def-var! is ;; the clojure.core/unchecked-* vars are def-var!'d in natives-seq.ss (def-var! is
;; defined after this file loads). ;; defined after this file loads).
;; --- ^long ops that tolerate a full 64-bit value -----------------------------
;; A ^long is 64-bit but a Chez fixnum is only 61-bit, so the backend's fast fx
;; ops would raise on a value past 2^60 (e.g. a long from the PRNG / wrapping
;; arithmetic). These take the fx fast path when the operands ARE fixnums and fall
;; back to the generic op otherwise — so ^long comparisons / quot / min etc. on a
;; full-width long stay correct. Macros (define-syntax) so the fast path inlines.
(define-syntax define-l-binop
(syntax-rules ()
((_ name fxop genop)
(define-syntax name
(syntax-rules ()
((_ a b) (let ((x a) (y b))
(if (and (fixnum? x) (fixnum? y)) (fxop x y) (genop x y)))))))))
(define-l-binop jolt-l< fx<? <)
(define-l-binop jolt-l<= fx<=? <=)
(define-l-binop jolt-l> fx>? >)
(define-l-binop jolt-l>= fx>=? >=)
(define-l-binop jolt-l= fx=? =)
(define-l-binop jolt-l-min fxmin min)
(define-l-binop jolt-l-max fxmax max)
(define-l-binop jolt-l-quot fxquotient quotient)
(define-l-binop jolt-l-rem fxremainder remainder)
(define-l-binop jolt-l-mod fxmodulo modulo)
(define-syntax jolt-l-inc (syntax-rules () ((_ a) (let ((x a)) (if (fixnum? x) (fx1+ x) (+ x 1))))))
(define-syntax jolt-l-dec (syntax-rules () ((_ a) (let ((x a)) (if (fixnum? x) (fx1- x) (- x 1))))))
;; ============================================================================ ;; ============================================================================
;; IFn dispatch — the dynamic "value as fn" fallback. A callee that the emitter ;; IFn dispatch — the dynamic "value as fn" fallback. A callee that the emitter
;; can't statically resolve to a procedure (a keyword/coll/proc held in a local) ;; can't statically resolve to a procedure (a keyword/coll/proc held in a local)

18
jolt-core/jolt/backend_scheme.clj
View file

@ -94,13 +94,18 @@
(def ^:private dbl-ops (def ^:private dbl-ops
{"+" "fl+" "-" "fl-" "*" "fl*" "/" "fl/" "min" "flmin" "max" "flmax" {"+" "fl+" "-" "fl-" "*" "fl*" "/" "fl/" "min" "flmin" "max" "flmax"
"<" "fl<?" ">" "fl>?" "<=" "fl<=?" ">=" "fl>=?" "=" "fl=?" "==" "fl=?"}) "<" "fl<?" ">" "fl>?" "<=" "fl<=?" ">=" "fl>=?" "=" "fl=?" "==" "fl=?"})
;; A ^long is 64-bit; a Chez fixnum is only 61-bit. Arithmetic +/-/* keep the raw
;; fx ops (the fast-arith path; under *unchecked-math* they're already rewritten to
;; the wrapping unchecked-*). The comparisons / min/max / quot/rem/mod use the
;; jolt-l* fast-path-with-fallback macros (host/chez/seq.ss) so a full 64-bit
;; operand falls back to the generic op instead of raising.
(def ^:private lng-ops (def ^:private lng-ops
{"+" "fx+" "-" "fx-" "*" "fx*" "min" "fxmin" "max" "fxmax" {"+" "fx+" "-" "fx-" "*" "fx*" "min" "jolt-l-min" "max" "jolt-l-max"
;; unchecked-* WRAP to signed 64 bits (Java long), so they can't use the raising ;; unchecked-* WRAP to signed 64 bits (Java long), so they can't use the raising
;; fx ops — the backend emits the wrapping jolt-unc* helpers (host/chez/seq.ss). ;; fx ops — the backend emits the wrapping jolt-unc* helpers (host/chez/seq.ss).
"unchecked-add" "jolt-uncadd2" "unchecked-subtract" "jolt-uncsub2" "unchecked-multiply" "jolt-uncmul2" "unchecked-add" "jolt-uncadd2" "unchecked-subtract" "jolt-uncsub2" "unchecked-multiply" "jolt-uncmul2"
"quot" "fxquotient" "rem" "fxremainder" "mod" "fxmodulo" "quot" "jolt-l-quot" "rem" "jolt-l-rem" "mod" "jolt-l-mod"
"<" "fx<?" ">" "fx>?" "<=" "fx<=?" ">=" "fx>=?" "=" "fx=?" "==" "fx=?"}) "<" "jolt-l<" ">" "jolt-l>" "<=" "jolt-l<=" ">=" "jolt-l>=" "=" "jolt-l=" "==" "jolt-l="})
;; BigDecimal ops. jolt.passes.numeric tags an arithmetic/comparison invoke ;; BigDecimal ops. jolt.passes.numeric tags an arithmetic/comparison invoke
;; :num-kind :bigdec when every operand is a bigdec (or an integer literal); these ;; :num-kind :bigdec when every operand is a bigdec (or an integer literal); these
@ -487,9 +492,10 @@
(cond (cond
(and (= kind :double) (= nm "inc")) (str "(fl+ " (first args) " 1.0)") (and (= kind :double) (= nm "inc")) (str "(fl+ " (first args) " 1.0)")
(and (= kind :double) (= nm "dec")) (str "(fl- " (first args) " 1.0)") (and (= kind :double) (= nm "dec")) (str "(fl- " (first args) " 1.0)")
(and (= kind :long) (= nm "inc")) (str "(fx1+ " (first args) ")") ;; inc/dec tolerate a 64-bit operand (jolt-l-inc/dec fall back past fixnum range);
(and (= kind :long) (= nm "dec")) (str "(fx1- " (first args) ")") ;; unchecked-inc/dec wrap (Java long). Neither can use the raising fx1+/fx1-.
;; unchecked-inc/dec wrap (Java long), so the raising fx1+/fx1- can't be used. (and (= kind :long) (= nm "inc")) (str "(jolt-l-inc " (first args) ")")
(and (= kind :long) (= nm "dec")) (str "(jolt-l-dec " (first args) ")")
(and (= kind :long) (= nm "unchecked-inc")) (str "(jolt-uncinc " (first args) ")") (and (= kind :long) (= nm "unchecked-inc")) (str "(jolt-uncinc " (first args) ")")
(and (= kind :long) (= nm "unchecked-dec")) (str "(jolt-uncdec " (first args) ")") (and (= kind :long) (= nm "unchecked-dec")) (str "(jolt-uncdec " (first args) ")")
:else :else

3
test/chez/corpus.edn
View file

@ -3375,4 +3375,7 @@
{:suite "numbers / unchecked wraps to signed 64-bit" :label "unchecked-negate of MIN wraps to MIN" :expected "-9223372036854775808" :actual "(unchecked-negate -9223372036854775808)"} {:suite "numbers / unchecked wraps to signed 64-bit" :label "unchecked-negate of MIN wraps to MIN" :expected "-9223372036854775808" :actual "(unchecked-negate -9223372036854775808)"}
{:suite "numbers / unchecked wraps to signed 64-bit" :label "unchecked-inc of MAX wraps to MIN" :expected "-9223372036854775808" :actual "(unchecked-inc 9223372036854775807)"} {:suite "numbers / unchecked wraps to signed 64-bit" :label "unchecked-inc of MAX wraps to MIN" :expected "-9223372036854775808" :actual "(unchecked-inc 9223372036854775807)"}
{:suite "host-interop / Long bit statics" :label "Long/bitCount, numberOfLeadingZeros, reverse" :expected "[10 63 0 -2]" :actual "[(Long/bitCount 1023) (Long/numberOfLeadingZeros 1) (Long/bitCount 0) (Long/reverse 9223372036854775807)]"} {:suite "host-interop / Long bit statics" :label "Long/bitCount, numberOfLeadingZeros, reverse" :expected "[10 63 0 -2]" :actual "[(Long/bitCount 1023) (Long/numberOfLeadingZeros 1) (Long/bitCount 0) (Long/reverse 9223372036854775807)]"}
{:suite "numbers / unsigned-bit-shift-right is logical over 64 bits" :label "shift of a negative shifts in zeros" :expected "[9223372036854775807 4611686018427387902]" :actual "[(unsigned-bit-shift-right -1 1) (unsigned-bit-shift-right -8 2)]"}
{:suite "numbers / ^long is 64-bit" :label "^long comparison on a full-width long" :expected "false" :actual "((fn* ([^long a ^long b] (< a b))) 9223372036854775807 1)"}
{:suite "numbers / ^long is 64-bit" :label "^long quot on a full-width long" :expected "3074457345618258602" :actual "((fn* ([^long a] (quot a 3))) 9223372036854775807)"}
] ]

18
test/chez/numeric-test.ss
View file

@ -41,14 +41,16 @@
(ok "long + lowers to fx+" (has? (emitf "u" "(fn* ([^long a ^long b] (+ a b)))") "(fx+")) (ok "long + lowers to fx+" (has? (emitf "u" "(fn* ([^long a ^long b] (+ a b)))") "(fx+"))
(ok "long * lowers to fx*" (has? (emitf "u" "(fn* ([^long a ^long b] (* a b)))") "(fx*")) (ok "long * lowers to fx*" (has? (emitf "u" "(fn* ([^long a ^long b] (* a b)))") "(fx*"))
(ok "double < lowers to fl<?" (has? (emitf "u" "(fn* ([^double x] (< x 1.0)))") "(fl<?")) (ok "double < lowers to fl<?" (has? (emitf "u" "(fn* ([^double x] (< x 1.0)))") "(fl<?"))
(ok "long < lowers to fx<?" (has? (emitf "u" "(fn* ([^long a ^long b] (< a b)))") "(fx<?")) ;; ^long comparisons / inc / dec / quot use the jolt-l* fast-path-with-fallback
(ok "long inc lowers to fx1+" (has? (emitf "u" "(fn* ([^long n] (inc n)))") "(fx1+")) ;; helpers so a full 64-bit operand (past the 61-bit fixnum range) is handled.
(ok "long < lowers to jolt-l<" (has? (emitf "u" "(fn* ([^long a ^long b] (< a b)))") "(jolt-l<"))
(ok "long inc lowers to jolt-l-inc" (has? (emitf "u" "(fn* ([^long n] (inc n)))") "(jolt-l-inc"))
(ok "double inc lowers to fl+ 1.0" (has? (emitf "u" "(fn* ([^double x] (inc x)))") "(fl+")) (ok "double inc lowers to fl+ 1.0" (has? (emitf "u" "(fn* ([^double x] (inc x)))") "(fl+"))
(ok "long dec lowers to fx1-" (has? (emitf "u" "(fn* ([^long n] (dec n)))") "(fx1-")) (ok "long dec lowers to jolt-l-dec" (has? (emitf "u" "(fn* ([^long n] (dec n)))") "(jolt-l-dec"))
;; unchecked-* WRAP to signed 64 bits (Java long), so they emit the wrapping ;; unchecked-* WRAP to signed 64 bits (Java long), so they emit the wrapping
;; jolt-unc* helpers, not the raising fx ops. ;; jolt-unc* helpers, not the raising fx ops.
(ok "unchecked-add lowers to jolt-uncadd2" (has? (emitf "u" "(fn* ([^long n] (unchecked-add n 1)))") "(jolt-uncadd2")) (ok "unchecked-add lowers to jolt-uncadd2" (has? (emitf "u" "(fn* ([^long n] (unchecked-add n 1)))") "(jolt-uncadd2"))
(ok "long quot lowers to fxquotient" (has? (emitf "u" "(fn* ([^long a ^long b] (quot a b)))") "(fxquotient")) (ok "long quot lowers to jolt-l-quot" (has? (emitf "u" "(fn* ([^long a ^long b] (quot a b)))") "(jolt-l-quot"))
(ok "double == lowers to fl=?" (has? (emitf "u" "(fn* ([^double a ^double b] (== a b)))") "(fl=?")) (ok "double == lowers to fl=?" (has? (emitf "u" "(fn* ([^double a ^double b] (== a b)))") "(fl=?"))
;; integer literal in a double op is coerced to a flonum (fl+ never sees an exact int) ;; integer literal in a double op is coerced to a flonum (fl+ never sees an exact int)
@ -69,11 +71,11 @@
(ok "loop integer accumulator is NOT fx-specialized" (not (has? e "(fx*")))) (ok "loop integer accumulator is NOT fx-specialized" (not (has? e "(fx*"))))
;; a literal-init increment counter types as a fixnum (fx1+), even with no hint. ;; a literal-init increment counter types as a fixnum (fx1+), even with no hint.
(let ((e (emitf "u" "(fn* ([] (loop [i 0] (if (< i 5) (recur (inc i)) i))))"))) (let ((e (emitf "u" "(fn* ([] (loop [i 0] (if (< i 5) (recur (inc i)) i))))")))
(ok "literal-init increment counter lowers to fx1+" (has? e "(fx1+"))) (ok "literal-init increment counter lowers to jolt-l-inc" (has? e "(jolt-l-inc")))
;; but a multiplicative accumulator in the SAME loop stays generic (bignum-safe); ;; but a multiplicative accumulator in the SAME loop stays generic (bignum-safe);
;; only the counter types. ;; only the counter types.
(let ((e (emitf "u" "(fn* ([] (loop [acc 1 i 0] (if (< i 100) (recur (* acc i) (inc i)) acc))))"))) (let ((e (emitf "u" "(fn* ([] (loop [acc 1 i 0] (if (< i 100) (recur (* acc i) (inc i)) acc))))")))
(ok "counter beside a * accumulator: counter is fx1+" (has? e "(fx1+")) (ok "counter beside a * accumulator: counter is jolt-l-inc" (has? e "(jolt-l-inc"))
(ok "the * accumulator is NOT fx-specialized (bignum-safe)" (not (has? e "(fx*")))) (ok "the * accumulator is NOT fx-specialized (bignum-safe)" (not (has? e "(fx*"))))
(ok "counter+bignum-accumulator stays exact (1*2*...*99 is a bignum)" (ok "counter+bignum-accumulator stays exact (1*2*...*99 is a bignum)"
(jolt-truthy? (ev "(< 1000000000000000000000 ((fn* ([] (loop [acc 1 i 1] (if (< i 100) (recur (* acc i) (inc i)) acc))))))"))) (jolt-truthy? (ev "(< 1000000000000000000000 ((fn* ([] (loop [acc 1 i 1] (if (< i 100) (recur (* acc i) (inc i)) acc))))))")))
@ -89,8 +91,8 @@
;; a ^long-seeded loop accumulator IS fx-typed (the hint is a fixnum promise, and ;; a ^long-seeded loop accumulator IS fx-typed (the hint is a fixnum promise, and
;; the value flows from a coerced ^long param). ;; the value flows from a coerced ^long param).
(let ((e (emitf "u" "(fn* ([^long start] (loop [acc start] (if (< acc 100) (recur (inc acc)) acc))))"))) (let ((e (emitf "u" "(fn* ([^long start] (loop [acc start] (if (< acc 100) (recur (inc acc)) acc))))")))
(ok "long-seeded loop accumulator lowers (inc acc) to fx1+" (has? e "(fx1+")) (ok "long-seeded loop accumulator lowers (inc acc) to jolt-l-inc" (has? e "(jolt-l-inc"))
(ok "long-seeded loop comparison lowers to fx<?" (has? e "(fx<?"))) (ok "long-seeded loop comparison lowers to jolt-l<" (has? e "(jolt-l<")))
;; --- soundness: un-hinted / integer-literal code stays generic --- ;; --- soundness: un-hinted / integer-literal code stays generic ---
(let ((e (emitf "u" "(fn* ([a b] (+ a b)))"))) (let ((e (emitf "u" "(fn* ([a b] (+ a b)))")))