Hintless whole-program double inference (#230)

The closed-world fixpoint (#226) flowed record types across fn boundaries; this
adds a numeric refinement so a hintless fn whose every call site passes a flonum
has its param unboxed to fl-ops, no ^double hint needed.

Lattice gains :double, a flonum refinement of :num: two doubles join to :double,
a double joined with anything else widens to :num — so a param is :double only
when every contributing value is a flonum, which is what makes the fl-op sound.
infer types a flonum literal and flonum arithmetic (+ - * / min max inc dec over
double/int-literal operands) as :double, and the fixpoint joins those across call
sites and return types like any other lattice value.

The bridge to the existing hint-directed pass is a synthetic [param :double]
nhint: wp-infer! stashes the :double params separately from the structural seeds,
and run-passes injects them as nhints before numeric/annotate, so the fl-op
emission and the exact->inexact entry coercion (a no-op on a proven flonum) apply
unchanged.

Sound subset only: :double, never :long — an untyped integer can be a bignum and
fx-ops would overflow/diverge from jolt's arbitrary precision. So an integer
caller leaves a param generic; an escaped fn (unknown callers) keeps :any.

run-numwp.ss gate: cross-fn :double propagation incl. through a flonum-returning
helper, the integer-caller and escape negatives, and the full run-passes path
emitting fl* + entry coercion. make test / shakesmoke green, selfhost holds, 0
new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>

Makefile

@@ -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 wp devirt fieldread directlink numeric inline shakesmoke remint
+.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer wp devirt fieldread numwp directlink numeric inline shakesmoke 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 wp devirt fieldread directlink numeric inline certify
+ci: values corpus unit smoke buildsmoke sci ffi transient infer wp devirt fieldread numwp directlink numeric inline certify
 	@echo "OK: CI gates passed"
 
 # Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
@@ -79,6 +79,13 @@ devirt:
 fieldread:
 	@chez --script host/chez/run-fieldread.ss
 
+# Hintless whole-program double inference: a fn whose every call site passes a
+# flonum has its param typed :double by the closed-world fixpoint and unboxed to
+# fl-ops with no ^double hint; an integer caller leaves it generic, an escaped fn
+# keeps :any.
+numwp:
+	@chez --script host/chez/run-numwp.ss
+
 # Direct-linking emission: a closed-world build binds top-level app defs to jv$
 # Scheme bindings and routes app->app calls/refs to them, skipping var-deref +
 # jolt-invoke; ^:dynamic/^:redef and nested defs opt out.

host/chez/run-numwp.ss

@@ -0,0 +1,108 @@
+;; run-numwp.ss — hintless whole-program :double inference gate (jolt-evr9 R3).
+;;
+;; run-wp.ss drives the structural (record) fixpoint; this drives its numeric
+;; refinement: a hintless fn whose every call site passes a flonum has its param
+;; typed :double, which the back end then unboxes to fl-ops — no ^double hint. The
+;; bridge is a synthetic [param :double] nhint (jolt.passes/inject-wp-nhints) that
+;; the existing hint-directed pass + entry coercion consume unchanged.
+;;
+;; Soundness pinned here: :double only (never :long — an untyped integer can be a
+;; bignum), so a caller passing an integer leaves the param generic; an escaped fn
+;; keeps :any.
+;;
+;;   chez --script host/chez/run-numwp.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 analyze              (var-deref "jolt.analyzer" "analyze"))
+(define set-record-shapes!   (var-deref "jolt.passes.types" "set-record-shapes!"))
+(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
+(define wp-infer!            (var-deref "jolt.passes.types" "wp-infer!"))
+(define param-num-seeds-for  (var-deref "jolt.passes.types" "param-num-seeds-for"))
+(define inject-wp-nhints     (var-deref "jolt.passes" "inject-wp-nhints"))
+(define annotate             (var-deref "jolt.passes.numeric" "annotate"))
+(define run-passes           (var-deref "jolt.passes" "run-passes"))
+(define emit                 (var-deref "jolt.backend-scheme" "emit"))
+(define pr-str               (var-deref "clojure.core" "pr-str"))
+
+(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
+(define (contains-sub? s sub)
+  (let ((n (string-length s)) (m (string-length sub)))
+    (let loop ((i 0))
+      (cond ((> (+ i m) n) #f)
+            ((string=? (substring s i (+ i m)) sub) #t)
+            (else (loop (+ i 1)))))))
+
+(define fails 0) (define total 0)
+(define (check label actual expected)
+  (set! total (+ total 1))
+  (unless (equal? actual expected)
+    (set! fails (+ fails 1))
+    (printf "  FAIL ~a: got ~s expected ~s\n" label actual expected)))
+
+(set-record-shapes! (jolt-hash-map))
+(set-protocol-methods! (jolt-hash-map))
+
+;; sq is hintless; its only caller passes a flonum literal, so the fixpoint must
+;; type x :double across the fn boundary.
+(define sq   (anode "(def sq (fn [x] (* x x)))"))
+(define usef (anode "(def usef (fn [] (sq 2.0)))"))
+(wp-infer! (jolt-vector sq usef))
+
+(define nseed (param-num-seeds-for "user/sq"))
+(check "sq has a numeric param seed" (jolt-truthy? nseed) #t)
+(when (jolt-truthy? nseed)
+  (check "x seeded :double" (contains-sub? (pr-str nseed) ":double") #t))
+
+;; the bridge: inject the derived nhint, run the numeric pass, emit -> fl*.
+(define sq-opt (annotate (inject-wp-nhints sq)))
+(check "sq body unboxes to fl*" (contains-sub? (emit sq-opt) "fl*") #t)
+;; and the param is coerced at entry like a ^double param (no-op on a real flonum).
+(check "sq coerces param at entry" (contains-sub? (emit sq-opt) "exact->inexact") #t)
+
+;; a caller passing an INTEGER must NOT make the param :double — an untyped integer
+;; can be a bignum, so fl-ops would diverge. The param stays generic.
+(define sqi  (anode "(def sqi (fn [x] (* x x)))"))
+(define usei (anode "(def usei (fn [] (sqi 2)))"))
+(wp-infer! (jolt-vector sqi usei))
+(check "integer caller leaves param generic"
+       (jolt-truthy? (param-num-seeds-for "user/sqi")) #f)
+
+;; a fn used in value position (escapes) has unknown callers -> no double seed.
+(define esc  (anode "(def esc (fn [x] (* x x)))"))
+(define hof  (anode "(def hof (fn [g] (g 2.0)))"))
+(define ecl  (anode "(def ecaller (fn [] (hof esc)))"))   ; esc escapes
+(wp-infer! (jolt-vector esc hof ecl))
+(check "escaped fn keeps no double seed"
+       (jolt-truthy? (param-num-seeds-for "user/esc")) #f)
+
+;; :double flows through a returning helper: mag returns a flonum, so a param fed
+;; only (mag _) results types :double too (cross-fn return propagation).
+(define mag  (anode "(def mag (fn [a] (* a 2.0)))"))
+(define dist (anode "(def dist (fn [b] (+ b b)))"))
+(define dcl  (anode "(def dcaller (fn [] (dist (mag 3.0))))"))
+(wp-infer! (jolt-vector mag dist dcl))
+(check "param fed a flonum-returning call types :double"
+       (jolt-truthy? (param-num-seeds-for "user/dist")) #t)
+
+;; end to end through the real build pipeline: with optimize on, run-passes wires
+;; the WP fixpoint's :double seeds into the numeric pass (inject-wp-nhints) so the
+;; emitted def unboxes — proves the production path fires, not just the bridge in
+;; isolation.
+(set-optimize! #t)
+(define sq2 (anode "(def sq2 (fn [x] (* x x)))"))
+(define use2 (anode "(def use2 (fn [] (sq2 4.0)))"))
+(wp-infer! (jolt-vector sq2 use2))
+(check "run-passes unboxes a hintless double fn"
+       (contains-sub? (emit (run-passes sq2 (make-analyze-ctx "user"))) "fl*") #t)
+
+(if (= fails 0)
+    (begin (printf "numwp gate: ~a/~a passed\n" total total) (exit 0))
+    (begin (printf "numwp gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

jolt-core/jolt/passes.clj

@@ -22,7 +22,7 @@
                                        set-rtenv! set-vtypes! join-types
                                        set-record-shapes! set-map-shapes! set-protocol-methods!
                                        reset-escapes! collected-escapes
-                                       wp-infer! param-seeds-for
+                                       wp-infer! param-seeds-for param-num-seeds-for
                                        set-check-mode! take-diags!]]))
 
 ;; Cap on inline -> flatten -> scalar-replace -> const-fold iterations. Each pass
@@ -40,6 +40,22 @@
   (let [a (first (:arities (:init node)))]
     {:params (:params a) :body (:body a) :nhints (:nhints a) :ret (:ret-nhint a)}))
 
+(defn inject-wp-nhints
+  "Merge the whole-program :double param seeds into a def's arity :nhints as
+  synthetic ^double hints, so the numeric pass unboxes a hintless fn whose callers
+  all pass flonums (the entry coercion exact->inexact is a no-op on a proven
+  flonum). Only un-hinted params are added — an explicit hint wins. A no-op unless
+  the closed-world fixpoint typed a param :double (param-num-seeds-for)."
+  [node]
+  (let [seeds (when (= :def (:op node)) (param-num-seeds-for (str (:ns node) "/" (:name node))))
+        f (:init node)]
+    (if (and seeds (= :fn (:op f)) (= 1 (count (:arities f))))
+      (let [a (first (:arities f))
+            have (into #{} (map first (:nhints a)))
+            add (for [[p k] seeds :when (not (have p))] [p k])]
+        (assoc node :init (assoc f :arities [(assoc a :nhints (vec (concat (:nhints a) add)))])))
+      node)))
+
 (defn run-passes
   "All passes, in order. The back end applies this to every analyzed form. When
   inlining is enabled for the unit (user code under direct-linking),
@@ -75,6 +91,7 @@
             ;; everything else takes the ordinary per-form inference.
             seeds (when (= :def (:op opt)) (param-seeds-for (str (:ns opt) "/" (:name opt))))]
         ;; a final const-fold after inference propagates any predicate folded to a
-        ;; constant, collapsing the `if` it gates to the taken branch.
+        ;; constant, collapsing the `if` it gates to the taken branch; then inject
-        (const-fold (if seeds (reinfer-def opt seeds) (run-inference opt))))
+        ;; any whole-program :double param hints for the numeric pass that follows.
+        (inject-wp-nhints (const-fold (if seeds (reinfer-def opt seeds) (run-inference opt)))))
       (const-fold node))))

jolt-core/jolt/passes/types.clj

@@ -135,7 +135,7 @@
       (if (and (seq vs) (not (nil? (first vs))) (apply = vs)) (first vs) nil))
     :else
     (case pname
-      "number?"  (= t :num)
+      "number?"  (or (= t :num) (= t :double))
       "string?"  (= t :str)
       "keyword?" (= t :kw)
       "record?"  (record-t? t)
@@ -154,6 +154,23 @@
 (defn- ty [r] (nth r 0))
 (defn- nd [r] (nth r 1))
 
+;; arithmetic core ops that yield a flonum when their operands are flonums — a
+;; mirror of jolt.passes.numeric/dbl-spec's arithmetic set, used to flow :double
+;; across fn boundaries so a hintless fn whose callers all pass doubles is unboxed.
+;; Comparisons are excluded: they yield a boolean, not a number.
+(def ^:private dbl-arith-ops #{"+" "-" "*" "/" "min" "max" "inc" "dec"})
+(defn- int-lit-node? [n]
+  (and (= :const (get n :op)) (let [v (get n :val)] (and (number? v) (integer? v)))))
+;; an arithmetic result is :double when every operand is a proven flonum or an
+;; integer literal (a wildcard the fl-op coerces) and at least one is a flonum — so
+;; (* x 2) with x:double is :double, but (* a b) with both :num stays :num (no
+;; flonum proof, no fl-op).
+(defn- dbl-arith? [ares argnodes]
+  (and (pos? (count ares))
+       (every? (fn [i] (or (= :double (ty (nth ares i))) (int-lit-node? (nth argnodes i))))
+               (range (count ares)))
+       (some (fn [r] (= :double (ty r))) ares)))
+
 ;; HOFs that apply their fn arg to the ELEMENTS of a collection. :epos is which
 ;; param of the fn receives an element. reduce is
 ;; handled separately (its arity changes the coll position, and its closure
@@ -310,6 +327,9 @@
          (= cn "range") (mk-vec :num)
          (and cn (contains? elem-fns cn) (> n 0))
          (let [a0 (ty (nth ares 0))] (if (vec-type? a0) (velem a0) :any))
+         ;; flonum arithmetic yields a flonum — flows :double into a callee param
+         ;; (and into the fixpoint's return type) so hintless double code unboxes.
+         (and cn (contains? dbl-arith-ops cn) (dbl-arith? ares args)) :double
          :else (call-ret-type fnode env))
        (if rtype
          (assoc base :devirt-type rtype :devirt-proto (nth pm 0) :devirt-method (nth pm 1))
@@ -355,7 +375,8 @@
     (cond
       (= op :const)
       [(let [v (get node :val)]
-         (cond (number? v) :num
+         (cond (and (number? v) (float? v)) :double   ; a flonum literal is :double
+               (number? v) :num
                (string? v) :str
                (keyword? v) :kw
                (or (nil? v) (= false v)) :any   ; nil/false are not struct-eligible
@@ -676,6 +697,15 @@
   nil. Set by wp-infer!, read by run-passes during the final per-def emit."
   [k] (get @wp-seeds-box k))
 
+;; numeric refinement of the same fixpoint: params the closed-world join proved
+;; are always flonums. Kept SEPARATE from the structural box — these don't reinfer
+;; (field-read/devirt), they become synthetic ^double nhints (jolt.passes/inject-
+;; wp-nhints) so the hint-directed pass unboxes the arithmetic.
+(def ^:private wp-num-seeds-box (atom {}))
+(defn param-num-seeds-for
+  "The param-name -> :double seed map for a def's hintless flonum params, or nil."
+  [k] (get @wp-num-seeds-box k))
+
 ;; var-key -> {:params [names] :body ir} for each single-fixed-arity fn def.
 (defn- wp-specializable [nodes]
   (reduce (fn [m d]
@@ -751,16 +781,21 @@
           (let [seed-ptypes (if converged?
                               new-ptypes
                               (reduce (fn [m k] (assoc m k (vec (repeat (count (get m k)) :any))))
-                                      new-ptypes ks))]
+                                      new-ptypes ks))
-            (reset! wp-seeds-box
+                ;; build both seed maps from the same converged ptypes: the
-                    (reduce (fn [m k]
+                ;; structural one (struct/vec, drives reinfer-def's field-read/
-                              (let [s (get spec k)
+                ;; devirt) excludes :double; the numeric one keeps only :double.
-                                    ptmap (reduce (fn [pm pr]
+                pick (fn [keep?]
+                       (reduce (fn [m k]
+                                 (let [s (get spec k)
+                                       pm (reduce (fn [pm pr]
                                                     (let [nm (nth pr 0) t (nth pr 1)]
-                                                      (if (and t (not= t :any)) (assoc pm nm t) pm)))
+                                                      (if (and t (keep? t)) (assoc pm nm t) pm)))
                                                   {} (map vector (:params s) (get seed-ptypes k)))]
-                                (if (seq ptmap) (assoc m k ptmap) m)))
+                                   (if (seq pm) (assoc m k pm) m)))
-                            {} ks)))
+                               {} ks))]
+            (reset! wp-seeds-box (pick (fn [t] (and (not= t :any) (not= t :double)))))
+            (reset! wp-num-seeds-box (pick (fn [t] (= t :double)))))
           (recur (inc iter) new-ptypes new-rets))))))
 
 ;; Piggyback checking (jolt audit). In direct-link mode infer-top already runs

jolt-core/jolt/passes/types/lattice.clj

@@ -79,6 +79,12 @@
     (= a b) a
     (nil? a) b
     (nil? b) a
+    ;; :double is a flonum refinement of :num: two doubles stay :double (caught by
+    ;; = above), but a double joined with anything else loses the flonum guarantee
+    ;; and widens to :num before joining — so a param is :double only when EVERY
+    ;; contributing value is a flonum, which is what makes the hintless fl-op sound.
+    (or (= a :double) (= b :double))
+      (join-t (if (= a :double) :num a) (if (= b :double) :num b))
     (and (struct-type? a) (struct-type? b))
       (let [merged (mk-struct (merge-fields (sfields a) (sfields b)))]
         ;; joining two values of the SAME complete shape preserves it — the
@@ -145,7 +151,7 @@
 ;; (vs a phm) when every value is non-nil/non-false, so a map literal is a struct
 ;; only when all its values have such a type. Collections are non-nil.
 (defn truthy-type? [t]
-  (or (= t :num) (= t :str) (= t :kw) (= t :truthy) (= t :phm)
+  (or (= t :num) (= t :double) (= t :str) (= t :kw) (= t :truthy) (= t :phm)
       (struct-type? t) (vec-type? t) (set-type? t)))
 
 ;; core fns whose result is a number (so it is non-nil/non-false and, for the