Hint-directed fast arithmetic: fl*/fx* from ^double/^long (round 1)
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
parent
2c18fcdc61
commit
59905a71fd
9 changed files with 567 additions and 236 deletions
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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,21 +35,25 @@
|
|||
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]
|
||||
(if (inline-enabled? ctx)
|
||||
(let [_ (set-rec-shapes! (record-shapes ctx)) ;; record ctor fold
|
||||
;; resolve ^Record param hints (incl. defrecord/extend-type method
|
||||
;; `this`) to bare field reads per-form, not only under whole-program.
|
||||
;; Same shapes the inline pass uses.
|
||||
_ (set-record-shapes! (record-shapes ctx))
|
||||
opt (loop [i 0 n (const-fold node)]
|
||||
(reset! dirty false)
|
||||
(let [n2 (const-fold (scalar-replace (flatten-lets (inline-node n ctx))))]
|
||||
(if (and @dirty (< i inline-fixpoint-cap))
|
||||
(recur (inc i) n2)
|
||||
n2)))]
|
||||
;; 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)))
|
||||
(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
|
||||
;; `this`) to bare field reads per-form, not only under whole-program.
|
||||
;; Same shapes the inline pass uses.
|
||||
_ (set-record-shapes! (record-shapes ctx))
|
||||
opt (loop [i 0 n (const-fold node)]
|
||||
(reset! dirty false)
|
||||
(let [n2 (const-fold (scalar-replace (flatten-lets (inline-node n ctx))))]
|
||||
(if (and @dirty (< i inline-fixpoint-cap))
|
||||
(recur (inc i) n2)
|
||||
n2)))]
|
||||
;; 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))))
|
||||
|
|
|
|||
141
jolt-core/jolt/passes/numeric.clj
Normal file
141
jolt-core/jolt/passes/numeric.clj
Normal 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))
|
||||
Loading…
Add table
Add a link
Reference in a new issue