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

Hint-directed fast arithmetic: fl*/fx* from ^double/^long (round 1)

Browse source 
A ^double/^long param hint (or a float literal) now drives Chez flonum/fixnum
ops instead of generic arithmetic — JVM-style primitive hints, available in every
build and at -e (not gated on direct-linking or whole-program inference).

New pass jolt.passes.numeric: a local forward type-flow seeded from ^double/^long
fn-param hints (analyzer attaches :nhints per arity) and float literals,
propagated through let inits / arithmetic / if / do. It tags an arithmetic invoke
:num-kind :double|:long when every operand is that kind (an integer literal is a
wildcard, coerced to a flonum in a double op). The back end lowers a tagged node
to fl+/fl-/fl*/fl//fl<?/... or fx+/fx*/fx1+/fxquotient/... (unchecked-add etc.
join the fixnum path; == too). Runs last in run-passes, both branches.

Soundness: :long is seeded ONLY from an explicit ^long hint, never a bare integer
literal, so un-hinted integer code keeps jolt's arbitrary-precision numbers — no
fixnum-overflow surprise, no corpus divergence. :double comes from ^double hints
and float literals (flonum arithmetic is always flonum, matching the generic
result). A ^long hint is a promise the value is a fixnum: fx+ raises on overflow,
like a JVM fixed-width long.

Numeric-hinted params coerce at fn entry (exact->inexact / jolt->fx), the way the
JVM coerces a primitive parameter — so the body's fl*/fx* ops can rely on the
type even when a caller passes an exact int (e.g. Chez's (* 0 1.0) => exact 0).

Round 1 specializes hinted straight-line / fn-body arithmetic. fl-ops are ~4x
generic in a tight Chez loop, but realizing that on loop-carried accumulators
needs loop-var typing — round 2. Sound foundation, gated by test/chez/numeric-test.ss.
This commit is contained in:
Yogthos 2026-06-23 16:43:55 -04:00
parent 2c18fcdc61
commit 59905a71fd
9 changed files with 567 additions and 236 deletions
Download patch file Download diff file Expand all files Collapse all files

9
Makefile
View file

@ -4,7 +4,7 @@
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
# source change.
.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer directlink remint
.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer directlink numeric remint
# Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
# on the same Chez that minted the seed.
@ -15,7 +15,7 @@ test: selfhost ci
# lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a
# different Chez version may emit byte-different (gensym/order) output, so the
# byte-fixpoint is a dev-machine check, not a CI one (jolt-8479).
ci: values corpus unit smoke buildsmoke sci ffi transient infer directlink certify
ci: values corpus unit smoke buildsmoke sci ffi transient infer directlink numeric certify
@echo "OK: CI gates passed"
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
@ -67,6 +67,11 @@ infer:
directlink:
@chez --script test/chez/directlink-test.ss
# Hint-directed fast arithmetic: ^double/^long param hints (and float literals)
# lower arithmetic to Chez fl*/fx* ops; un-hinted integer code stays generic.
numeric:
@chez --script test/chez/numeric-test.ss
# JVM oracle: certify the corpus against reference Clojure. Skips if clojure absent.
certify:
@if command -v clojure >/dev/null 2>&1; then \

1
host/chez/emit-image.ss
View file

@ -96,6 +96,7 @@
(cons "jolt.analyzer" "jolt-core/jolt/analyzer.clj")
(cons "jolt.backend-scheme" "jolt-core/jolt/backend_scheme.clj")
(cons "jolt.passes.fold" "jolt-core/jolt/passes/fold.clj")
(cons "jolt.passes.numeric" "jolt-core/jolt/passes/numeric.clj")
(cons "jolt.passes.inline" "jolt-core/jolt/passes/inline.clj")
(cons "jolt.passes.types.lattice" "jolt-core/jolt/passes/types/lattice.clj")
(cons "jolt.passes.types" "jolt-core/jolt/passes/types.clj")

11
host/chez/rt.ss
View file

@ -17,6 +17,17 @@
;; --- rt arithmetic / logic shims (named in the emitter's native-ops) ----------
(define (jolt-inc x) (+ x 1))
(define (jolt-dec x) (- x 1))
;; Coerce a ^long-hinted argument to a fixnum at fn entry, the way the JVM's
;; longCast coerces a primitive-long parameter: truncate a flonum toward zero,
;; pass an exact integer through, error if it doesn't fit a fixnum or isn't a
;; number. The hint is a promise the value is a fixnum-range long; the body's fx*
;; ops rely on it. (^double params coerce with the built-in exact->inexact.)
(define (jolt->fx x)
(let ((n (cond ((fixnum? x) x)
((flonum? x) (exact (truncate x)))
((rational? x) (exact (truncate x)))
(else (error 'jolt "^long hint: not a number" x)))))
(if (fixnum? n) n (error 'jolt "^long hint: value out of fixnum range" x))))
;; jolt `not`: only nil and false are falsey.
(define (jolt-not x) (if (jolt-truthy? x) #f #t))

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

File diff suppressed because one or more lines are too long

24
jolt-core/jolt/analyzer.clj
View file

@ -80,6 +80,15 @@
(let [m (form-sym-meta sym)]
(when m (let [t (get m :tag)] (when t (record-ctor-key ctx t))))))
;; A primitive numeric hint (^long / ^double) on a binding symbol -> :long /
;; :double, else nil. Drives the fl*/fx* fast path (jolt.passes.numeric). The tag
;; is a string on the data reader; tolerate a symbol from macroexpansion too.
(defn- nhint-of [ctx sym]
(let [m (form-sym-meta sym)
t (when m (get m :tag))
s (cond (form-sym? t) (form-sym-name t) (string? t) t :else nil)]
(cond (= s "double") :double (= s "long") :long :else nil)))
(defn- analyze-seq [ctx forms env]
(let [v (mapv #(analyze ctx % env) forms)
n (count v)]
@ -104,19 +113,20 @@
;; folds it with a plain reduce — no reduce-over-map in the kernel subset).
;; :phints is the parallel vector of [name ctor-key] for record param hints,
;; carrying the specific type for the inference to seed.
(loop [i 0 fixed [] rest-name nil hints [] phints []]
(loop [i 0 fixed [] rest-name nil hints [] phints [] nhints []]
(if (< i (count pvec))
(let [p (nth pvec i)]
(when-not (form-sym? p) (uncompilable "destructuring fn param"))
(if (= "&" (form-sym-name p))
(let [r (nth pvec (inc i))]
(when-not (form-sym? r) (uncompilable "destructuring fn rest"))
(recur (+ i 2) fixed (form-sym-name r) hints phints))
(let [nm (form-sym-name p) h (hint-of ctx p) ph (phint-of ctx p)]
(recur (+ i 2) fixed (form-sym-name r) hints phints nhints))
(let [nm (form-sym-name p) h (hint-of ctx p) ph (phint-of ctx p) nh (nhint-of ctx p)]
(recur (inc i) (conj fixed nm) rest-name
(if h (conj hints [nm h]) hints)
(if ph (conj phints [nm ph]) phints)))))
{:fixed fixed :rest rest-name :hints hints :phints phints})))
(if ph (conj phints [nm ph]) phints)
(if nh (conj nhints [nm nh]) nhints)))))
{:fixed fixed :rest rest-name :hints hints :phints phints :nhints nhints})))
;; Clojure lets a later param shadow an earlier same-named one (a macro expander
;; uses _ for both its &form and &env slots, so its param list is (_ _ …)); the
@ -154,7 +164,9 @@
:body (analyze-seq ctx body env*)}
;; carry record param hints (name -> ctor-key) for the inference to seed
;; the param type; only when present so a hintless arity stays a struct.
arity (if (seq (:phints pp)) (assoc arity :phints (:phints pp)) arity)]
arity (if (seq (:phints pp)) (assoc arity :phints (:phints pp)) arity)
;; numeric param hints (name -> :long/:double) for jolt.passes.numeric.
arity (if (seq (:nhints pp)) (assoc arity :nhints (:nhints pp)) arity)]
;; :rest only when variadic — an absent :rest reads back nil, same as before,
;; but keeps a fixed arity a nil-free struct rather than a phm.
(if rst (assoc arity :rest rst) arity)))

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

@ -76,6 +76,19 @@
"jolt-even?" "jolt-odd?" "jolt-pos?" "jolt-neg?"
"jolt-zero?" "jolt-empty?" "jolt-contains?"})
;; Numeric-specialized op strings. jolt.passes.numeric tags an arithmetic invoke
;; :num-kind :double|:long when every operand is that kind; these are the Chez
;; flonum/fixnum ops it lowers to — no generic dispatch, fixnums unboxed. fl?/fx?
;; comparisons carry the question mark; fl+/fx+ don't.
(def ^:private dbl-ops
{"+" "fl+" "-" "fl-" "*" "fl*" "/" "fl/" "min" "flmin" "max" "flmax"
"<" "fl<?" ">" "fl>?" "<=" "fl<=?" ">=" "fl>=?" "=" "fl=?" "==" "fl=?"})
(def ^:private lng-ops
{"+" "fx+" "-" "fx-" "*" "fx*" "min" "fxmin" "max" "fxmax"
"unchecked-add" "fx+" "unchecked-subtract" "fx-" "unchecked-multiply" "fx*"
"quot" "fxquotient" "rem" "fxremainder" "mod" "fxmodulo"
"<" "fx<?" ">" "fx>?" "<=" "fx<=?" ">=" "fx>=?" "=" "fx=?" "==" "fx=?"})
;; PRELUDE MODE. The default (subset) mode rejects any clojure.core ref
;; that isn't a native-op — a clean "out of subset" signal for user-facing `-e`.
;; When emitting clojure.core ITSELF as a prelude, core fns reference each other
@ -335,8 +348,21 @@
;; let lets fn-level `recur` rebind this arity's params. A variadic arity takes a
;; Scheme rest arg coerced to a jolt seq (nil when empty); recur carries the rest
;; seq directly, and the named let's init only runs on first entry.
;; Coerce a numeric-hinted param at fn entry, the way the JVM coerces a primitive
;; parameter: ^double -> exact->inexact, ^long -> jolt->fx. Only the named-let init
;; (first entry) coerces — recur carries already-typed values, like a JVM goto. This
;; is what makes the hint a contract the body's fl*/fx* ops can rely on. `orig` is
;; the param's source name (the :nhints key); `munged` the emitted identifier.
(defn- nhint-init [nh orig munged]
(let [k (get nh orig)]
(cond (= k :double) (str "(exact->inexact " munged ")")
(= k :long) (str "(jolt->fx " munged ")")
:else munged)))
(defn- emit-arity-clause [a]
(let [params (map munge-name (:params a))
(let [orig (:params a)
nh (into {} (:nhints a))
params (map munge-name orig)
restp (when-let [r (:rest a)] (munge-name r))
label (fresh-label "fnrec")
body (binding [*recur-target* label] (emit (:body a)))
@ -344,10 +370,10 @@
(and restp (empty? params)) restp
restp (str "(" (str/join " " params) " . " restp ")")
:else (str "(" (str/join " " params) ")"))
pbind (map (fn [o p] (str "(" p " " (nhint-init nh o p) ")")) orig params)
binds (if restp
(concat (map (fn [p] (str "(" p " " p ")")) params)
[(str "(" restp " (list->cseq " restp "))")])
(map (fn [p] (str "(" p " " p ")")) params))]
(concat pbind [(str "(" restp " (list->cseq " restp "))")])
pbind)]
[paramlist (str "(let " label " (" (str/join " " binds) ") " body ")")]))
(defn- emit-fn [node]
@ -394,6 +420,19 @@
(defn- stdlib-var? [n]
(and (= :var (:op n)) (str/starts-with? (or (:ns n) "") "clojure.")))
;; Emit a :num-kind-tagged arithmetic call as a Chez flonum/fixnum op. inc/dec are
;; unary (fl +/- 1.0, fx1+/fx1-); the rest map through dbl-ops/lng-ops. Integer
;; literal operands of a :double op were coerced to flonums by jolt.passes.numeric.
(defn- emit-numeric [kind nm args order-args]
(cond
(and (= kind :double) (= nm "inc")) (str "(fl+ " (first args) " 1.0)")
(and (= kind :double) (= nm "dec")) (str "(fl- " (first args) " 1.0)")
(and (= kind :long) (or (= nm "inc") (= nm "unchecked-inc"))) (str "(fx1+ " (first args) ")")
(and (= kind :long) (or (= nm "dec") (= nm "unchecked-dec"))) (str "(fx1- " (first args) ")")
:else
(let [op (if (= kind :double) (dbl-ops nm) (lng-ops nm))]
(order-args (fn [as] (str "(" op " " (str/join " " as) ")"))))))
(defn- emit-invoke [node]
(let [fnode (:fn node)
arg-nodes (:args node)
@ -410,6 +449,9 @@
(fn [[f & as]]
(str "(jolt-invoke " f (if (seq as) (str " " (str/join " " as)) "") ")"))))]
(cond
;; hint-directed fast arithmetic: jolt.passes.numeric proved every operand a
;; flonum (^double) or fixnum (^long), so emit the Chez fl*/fx* op.
(:num-kind node) (emit-numeric (:num-kind node) (:name fnode) args order-args)
;; zero-arg + / * : exact integer identity (= JVM long: (+) -> 0, (*) -> 1).
(and nop (empty? args) (= nop "+")) "0"
(and nop (empty? args) (= nop "*")) "1"

9
jolt-core/jolt/passes.clj
View file

@ -15,6 +15,7 @@
Portable Clojure: kernel-tier fns + seed primitives only."
(:require [jolt.host :refer [inline-enabled? record-shapes]]
[jolt.passes.fold :refer [const-fold]]
[jolt.passes.numeric :as numeric]
[jolt.passes.inline :refer [inline-node flatten-lets scalar-replace dirty set-rec-shapes!]]
[jolt.passes.types :refer [run-inference
check-form infer-body reinfer-def phint-seed
@ -34,8 +35,12 @@
inlining exposes map literals to lookups, scalar-replace collapses them, which
may expose more — then a collection-type inference pass (optionally
also emitting success diagnostics) that auto-drops the lookup guard where the
type is proven. Otherwise (core + bootstrap) just const-fold, as before."
type is proven. Otherwise (core + bootstrap) just const-fold, as before.
numeric/annotate runs last in both branches (hint-directed fl*/fx* arithmetic);
it benefits open builds too, so it is not gated on inlining."
[node ctx]
(numeric/annotate
(if (inline-enabled? ctx)
(let [_ (set-rec-shapes! (record-shapes ctx)) ;; record ctor fold
;; resolve ^Record param hints (incl. defrecord/extend-type method
@ -51,4 +56,4 @@
;; a final const-fold after inference propagates any predicate folded to a
;; constant, collapsing the `if` it gates to the taken branch.
(const-fold (run-inference opt)))
(const-fold node)))
(const-fold node))))

141
jolt-core/jolt/passes/numeric.clj Normal file
View file

@ -0,0 +1,141 @@
(ns jolt.passes.numeric
"Hint-directed numeric specialization. A local forward type-flow that seeds
local kinds from `^double`/`^long` fn-param hints and float literals, propagates
them through let inits, arithmetic results, and if/do, and tags an arithmetic
`:invoke` node with `:num-kind :double` or `:long` when every operand is that
kind (an integer literal is a wildcard, valid in either). The back end then emits
Chez `fl*`/`fx*` ops instead of generic arithmetic.
Soundness: `:long` is seeded ONLY from an explicit `^long` hint — never a bare
integer literal — so un-hinted integer code keeps jolt's arbitrary-precision
numbers (no fixnum overflow surprise). `:double` is seeded from `^double` hints
and float literals; flonum arithmetic is always flonum, so this matches the
generic result. A `^long` hint is a promise the value is a fixnum: `fx+` raises
on overflow rather than promoting, exactly as a JVM primitive long is fixed-width.
Runs in every build and at `-e`/repl, but not the seed mint (which compiles with
the passes off), so it stays out of the self-host fixpoint and benefits open and
closed builds alike."
(:require [jolt.ir :refer [map-ir-children]]))
;; --- operand classification -------------------------------------------------
(defn- int-lit? [n]
(and (= :const (get n :op))
(let [v (get n :val)] (and (number? v) (integer? v)))))
(defn- float-lit? [n]
(and (= :const (get n :op))
(let [v (get n :val)] (and (number? v) (float? v)))))
;; result kind of a double-specialized op at this name/arity, or nil if N/A.
;; arithmetic -> :double; comparison -> :bool (operands specialized, result not numeric).
(defn- dbl-spec [nm n]
(cond
(and (>= n 1) (contains? #{"+" "-" "*" "/" "min" "max"} nm)) :double
(and (= n 1) (contains? #{"inc" "dec"} nm)) :double
(and (>= n 2) (contains? #{"<" ">" "<=" ">=" "=" "=="} nm)) :bool
:else nil))
;; result kind of a long-specialized op, or nil. `/` is absent on purpose:
;; (/ long long) is a Ratio in Clojure, not a long. unchecked-* join the fast path
;; (they aren't native ops otherwise).
(defn- lng-spec [nm n]
(cond
(and (>= n 1) (contains? #{"+" "-" "*" "min" "max"
"unchecked-add" "unchecked-subtract" "unchecked-multiply"} nm)) :long
(and (= n 1) (contains? #{"inc" "dec" "unchecked-inc" "unchecked-dec"} nm)) :long
(and (= n 2) (contains? #{"quot" "rem" "mod"} nm)) :long
(and (>= n 2) (contains? #{"<" ">" "<=" ">=" "=" "=="} nm)) :bool
:else nil))
;; A non-numeric result (a comparison) doesn't propagate a numeric kind.
(defn- propagate [spec] (if (= spec :bool) nil spec))
(declare an)
;; Seed a fn arity's local env from its numeric param hints; an unhinted param
;; shadows any same-named outer local to nil.
(defn- arity-env [tenv a]
(let [nh (into {} (get a :nhints))
pe (reduce (fn [e p] (assoc e p (get nh p))) tenv (get a :params))]
(if (get a :rest) (assoc pe (get a :rest) nil) pe)))
(defn- an-invoke [node tenv]
(let [fnode (get node :fn)
nm (when (and (= :var (get fnode :op)) (= "clojure.core" (get fnode :ns)))
(get fnode :name))
ars (mapv (fn [a] (an a tenv)) (get node :args))
argnodes (mapv (fn [r] (nth r 1)) ars)
node1 (assoc node :args argnodes)
n (count ars)]
(if (nil? nm)
[nil node1]
(let [;; per-operand class: :double / :long (typed), :wild (integer literal,
;; usable in either), or :no (anything else — blocks specialization).
cls (mapv (fn [r] (let [k (nth r 0) nd (nth r 1)]
(cond (= k :double) :double
(= k :long) :long
(int-lit? nd) :wild
:else :no)))
ars)
ok? (fn [allowed need]
(and (pos? n)
(every? (fn [c] (or (= c :wild) (= c allowed))) cls)
(some (fn [c] (= c need)) cls)))
ds (dbl-spec nm n)
ls (lng-spec nm n)]
(cond
(and ds (ok? :double :double))
;; coerce integer-literal operands to flonum so fl-ops never see an exact int.
(let [args' (mapv (fn [nd] (if (int-lit? nd) (assoc nd :val (double (get nd :val))) nd))
argnodes)]
[(propagate ds) (assoc node1 :args args' :num-kind :double)])
(and ls (ok? :long :long))
[(propagate ls) (assoc node1 :num-kind :long)]
:else [nil node1])))))
;; Returns [kind node'] — kind is :double, :long, or nil.
(defn- an [node tenv]
(let [op (get node :op)]
(cond
(= op :const) [(if (float-lit? node) :double nil) node]
(= op :local) [(get tenv (get node :name)) node]
(= op :invoke) (an-invoke node tenv)
(= op :let)
(let [res (reduce (fn [acc b]
(let [te (nth acc 0) binds (nth acc 1)
ir (an (nth b 1) te)]
[(assoc te (nth b 0) (nth ir 0)) (conj binds [(nth b 0) (nth ir 1)])]))
[tenv []] (get node :bindings))
br (an (get node :body) (nth res 0))]
[(nth br 0) (assoc node :bindings (nth res 1) :body (nth br 1))])
(= op :loop)
;; loop vars join across recur, untracked here, so they stay untyped; still
;; descend to specialize any non-loop arithmetic in the inits/body.
[nil (assoc node
:bindings (mapv (fn [b] [(nth b 0) (nth (an (nth b 1) tenv) 1)]) (get node :bindings))
:body (nth (an (get node :body) tenv) 1))]
(= op :if)
(let [tr (an (get node :test) tenv)
thn (an (get node :then) tenv)
els (an (get node :else) tenv)
tk (nth thn 0) ek (nth els 0)]
[(if (= tk ek) tk nil)
(assoc node :test (nth tr 1) :then (nth thn 1) :else (nth els 1))])
(= op :do)
(let [stmts (mapv (fn [s] (nth (an s tenv) 1)) (get node :statements))
r (an (get node :ret) tenv)]
[(nth r 0) (assoc node :statements stmts :ret (nth r 1))])
(= op :fn)
[nil (assoc node :arities
(mapv (fn [a] (assoc a :body (nth (an (get a :body) (arity-env tenv a)) 1)))
(get node :arities)))]
(= op :def) [nil (assoc node :init (nth (an (get node :init) tenv) 1))]
;; every other op introduces no bindings and isn't numeric: descend with the
;; same env to specialize nested arithmetic, no kind.
:else [nil (map-ir-children (fn [c] (nth (an c tenv) 1)) node)])))
(defn annotate
"Tag arithmetic nodes with :num-kind from local numeric type-flow. Returns the
rewritten IR (no kind escapes to the caller)."
[node]
(nth (an node {}) 1))

84
test/chez/numeric-test.ss Normal file
View file

@ -0,0 +1,84 @@
;; Hint-directed fast arithmetic (jolt.passes.numeric). A ^double/^long param hint
;; (or a float literal) drives Chez fl*/fx* emission instead of generic arithmetic;
;; un-hinted integer code stays generic (arbitrary-precision preserved). The pass
;; runs in run-passes with optimization OFF, so this is the open-build path. Run:
;; chez --script test/chez/numeric-test.ss
(import (chezscheme))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
(load "host/chez/post-prelude.ss")
(set-chez-ns! "user")
(load "host/chez/host-contract.ss")
(load "host/chez/seed/image.ss")
(load "host/chez/compile-eval.ss")
(define total 0) (define fails 0)
(define (ok name pred) (set! total (+ total 1)) (unless pred (set! fails (+ fails 1)) (printf "FAIL: ~a\n" name)))
(define (has? s sub)
(let ((ns (string-length s)) (nsub (string-length sub)))
(let loop ((i 0))
(cond ((> (+ i nsub) ns) #f)
((string=? (substring s i (+ i nsub)) sub) #t)
(else (loop (+ i 1)))))))
;; analyze + run-passes (optimization OFF — the always-on numeric pass still runs)
;; + emit one form to a Scheme string.
(define (emitf ns str)
(let-values (((f j) (rdr-read-form str 0 (string-length str))))
(let ((ctx (make-analyze-ctx ns)))
(jolt-ce-emit (jolt-ce-run-passes (jolt-ce-analyze ctx f) ctx)))))
;; --- emission: ^double -> fl-ops, ^long -> fx-ops ---
(let ((e (emitf "u" "(fn* ([^double a ^double b] (+ (* a a) (* b b))))")))
(ok "double + lowers to fl+" (has? e "(fl+"))
(ok "double * lowers to fl*" (has? e "(fl*"))
(ok "double arith is NOT generic +" (not (has? e "(jolt-invoke"))))
(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 "long < lowers to fx<?" (has? (emitf "u" "(fn* ([^long a ^long b] (< a b)))") "(fx<?"))
(ok "long inc lowers to fx1+" (has? (emitf "u" "(fn* ([^long n] (inc n)))") "(fx1+"))
(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 "unchecked-add lowers to fx+" (has? (emitf "u" "(fn* ([^long n] (unchecked-add n 1)))") "(fx+"))
(ok "long quot lowers to fxquotient" (has? (emitf "u" "(fn* ([^long a ^long b] (quot a b)))") "(fxquotient"))
(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)
(let ((e (emitf "u" "(fn* ([^double x] (+ x 1)))")))
(ok "double op with int literal coerces it to 1.0" (and (has? e "(fl+") (has? e "1.0"))))
;; let init kind propagates: d is double from (* x x)
(let ((e (emitf "u" "(fn* ([^double x] (let [d (* x x)] (+ d 1.0))))")))
(ok "let-bound double propagates (fl* then fl+)" (and (has? e "(fl*") (has? e "(fl+"))))
;; --- soundness: un-hinted / integer-literal code stays generic ---
(let ((e (emitf "u" "(fn* ([a b] (+ a b)))")))
(ok "un-hinted + stays generic (no fl/fx)" (and (not (has? e "(fl+")) (not (has? e "(fx+")))))
(let ((e (emitf "u" "(+ 1 2)")))
(ok "bare integer literals stay generic (arbitrary precision)" (not (has? e "(fx+"))))
;; a constant float op like (+ 1.0 2.0) is const-folded to 3.0 (no op at all); a
;; float-literal-bound local is double-typed and its body op isn't foldable (a
;; local operand), so numeric specializes it.
(ok "float-literal-bound local specializes to fl+"
(has? (emitf "u" "(fn* ([] (let [a 2.0] (+ a 3.0))))") "(fl+"))
;; (/ ^long ^long) is a Ratio in Clojure, not a long -> must NOT lower to a fixnum op
(let ((e (emitf "u" "(fn* ([^long a ^long b] (/ a b)))")))
(ok "long division is NOT specialized (stays generic /)" (not (has? e "(fx"))))
;; --- runtime values match the generic result ---
(define (ev s) (jolt-compile-eval s "u"))
(ok "double dot: 3^2+4^2 = 25" (= 25 (jnum->exact (ev "((fn* ([^double a ^double b] (+ (* a a) (* b b)))) 3.0 4.0)"))))
(ok "long sum: 2+3 = 5" (= 5 (jnum->exact (ev "((fn* ([^long a ^long b] (+ a b))) 2 3)"))))
(ok "double compare true" (jolt-truthy? (ev "((fn* ([^double x] (< x 5.0))) 3.0)")))
(ok "double unary negate" (= -5 (jnum->exact (ev "((fn* ([^double x] (- x))) 5.0)"))))
(ok "long unary negate" (= -5 (jnum->exact (ev "((fn* ([^long a] (- a))) 5)"))))
(ok "long quot 7/2 = 3" (= 3 (jnum->exact (ev "((fn* ([^long a ^long b] (quot a b))) 7 2)"))))
(ok "double + int literal = 4.5" (= 9 (jnum->exact (ev "((fn* ([^double x] (* (+ x 1) 2))) 3.5)"))))
(printf "~a/~a passed~n" (- total fails) total)
(exit (if (zero? fails) 0 1))