Unbox ^double record field reads (#231)

A record field tagged ^double now reads back as a flonum and feeds the numeric
pass, so hintless arithmetic over those fields lowers to fl-ops — the leaf-numeric
analog of the ^Vec3 nested-field hints. Combined with the whole-program :double
param inference, a vec3-dot over a ^double-fielded record unboxes end to end with
no per-fn hints.

records.ss: a ^double field tag passes through resolution, and the ctor (and a
mutable-field set!) coerce a ^double field to a flonum — JVM primitive-field
parity (jolt returned an exact 1, not 1.0, before), and what makes reading the
field back as :double sound for an fl-op.

types.clj: field-type-from-tag maps "double" -> :double, and a keyword/get lookup
whose result is :double annotates the node :num-read :double. numeric.clj reads
that annotation and classifies the field read as a :double operand, so the
enclosing arithmetic specializes — the read itself keeps its jrec-field-at/jolt-get
emit.

run-fieldnum.ss gate: ctor coercion (int field -> flonum), field-field arithmetic
emitting fl*/fl+, and an untagged field staying generic. 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 numwp directlink numeric inline shakesmoke remint
+.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer wp devirt fieldread numwp fieldnum 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 numwp directlink numeric inline certify
+ci: values corpus unit smoke buildsmoke sci ffi transient infer wp devirt fieldread numwp fieldnum directlink numeric inline certify
 	@echo "OK: CI gates passed"
 
 # Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
@@ -86,6 +86,12 @@ fieldread:
 numwp:
 	@chez --script host/chez/run-numwp.ss
 
+# Double record fields: a ^double-tagged field reads back as a flonum (coerced at
+# construction and set!), so hintless arithmetic over those fields unboxes to fl-ops;
+# an untagged field stays generic.
+fieldnum:
+	@chez --script host/chez/run-fieldnum.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/records.ss

@@ -48,10 +48,17 @@
 (define chez-record-shapes-tbl (make-hashtable string-hash string=?))
 ;; method var-key "ns/method" -> (cons proto-name method-name).
 (define chez-protocol-methods-tbl (make-hashtable string-hash string=?))
+;; type-tag "ns.Name" -> #(bool ...) marking which fields are ^double, so the ctor
+;; and set! coerce them to flonums (JVM primitive-field semantics, and what makes
+;; reading the field back as :double sound for fl-ops).
+(define chez-record-dbl-tbl (make-hashtable string-hash string=?))
+(define (chez-double-tag? t) (and (string? t) (string=? t "double")))
 
 (define (register-record-shape! ctor-key field-kws field-tags type-tag)
   (hashtable-set! chez-record-shapes-tbl ctor-key
-                  (vector field-kws field-tags type-tag)))
+                  (vector field-kws field-tags type-tag))
+  (hashtable-set! chez-record-dbl-tbl type-tag
+                  (list->vector (map chez-double-tag? field-tags))))
 
 ;; simple name of a dotted/slashed string: the segment after the last . or /.
 (define (chez-shape-simple-name s)
@@ -67,6 +74,7 @@
 (define (chez-resolve-field-tag tag by-name)
   (cond ((or (not tag) (jolt-nil-t? tag)) jolt-nil)
         ((string=? tag "num") "num")
+        ((string=? tag "double") "double")   ; a ^double field reads back as a flonum
         (else (let ((ck (hashtable-ref by-name (chez-shape-simple-name tag) #f)))
                 (if ck ck jolt-nil)))))
 
@@ -163,7 +171,13 @@
 (define (jolt-set-field! inst k v)
   (if (jrec? inst)
       (let ((i (jrec-field-index inst k)))
-        (if i (begin (vector-set! (jrec-vals inst) i v) v)
+        (if i (let* ((flags (hashtable-ref chez-record-dbl-tbl (jrec-tag inst) #f))
+                     ;; a ^double field stays a flonum across set!, like the ctor —
+                     ;; keeps a later field read sound to unbox.
+                     (v2 (if (and flags (fx< i (vector-length flags)) (vector-ref flags i)
+                                  (number? v) (not (flonum? v)))
+                             (exact->inexact v) v)))
+                (vector-set! (jrec-vals inst) i v2) v2)
             (error #f "set! of an unknown field" k)))
       (error #f "set! of a field on a non-record" inst)))
 (define (jrec-ext=? ea eb)
@@ -431,6 +445,10 @@
   (let* ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym)))
          (kws (seq->list field-kws))
          (field-tags (if (pair? rest-args) (seq->list (car rest-args)) '()))
+         ;; which fields are ^double — coerced to a flonum on construction (JVM
+         ;; primitive-field parity), so reading them back is a genuine flonum.
+         (dbl-flags (list->vector (map chez-double-tag? field-tags)))
+         (ndbl (vector-length dbl-flags))
          (desc (make-jrdesc tag kws))
          (nf (length kws))
          (ctor (lambda args
@@ -439,7 +457,12 @@
                  (let ((v (make-vector nf jolt-nil)))
                    (let loop ((as args) (i 0))
                      (if (or (null? as) (= i nf)) (make-jrec desc v jolt-nil)
-                         (begin (vector-set! v i (car as)) (loop (cdr as) (+ i 1)))))))))
+                         (let ((a (car as)))
+                           (vector-set! v i
+                                        (if (and (fx< i ndbl) (vector-ref dbl-flags i)
+                                                 (number? a) (not (flonum? a)))
+                                            (exact->inexact a) a))
+                           (loop (cdr as) (+ i 1)))))))))
     ;; Register the ctor globally by simple class name (like StringBuilder) so
     ;; (Name. …) interop resolves ns-agnostically: a deftype used across files works
     ;; even when the runtime current ns is the caller's, not the defining ns

host/chez/run-fieldnum.ss

@@ -0,0 +1,73 @@
+;; run-fieldnum.ss — ^double record field reads unbox to fl-ops (jolt-evr9 R2).
+;;
+;; A record field tagged ^double reads back as a flonum (:double in the lattice),
+;; so hintless arithmetic over those fields — (* (:x a) (:x b)) — lowers to fl-ops,
+;; the same machinery as a ^double param. Two halves pinned here: (1) the ctor
+;; coerces a ^double field to a flonum at construction (JVM parity, and what makes
+;; the fl-op sound), and (2) field-field arithmetic over a record param (typed by
+;; the whole-program fixpoint) emits fl*.
+;;
+;;   chez --script host/chez/run-fieldnum.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 run-passes           (var-deref "jolt.passes" "run-passes"))
+(define emit                 (var-deref "jolt.backend-scheme" "emit"))
+
+(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
+(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
+(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)))
+
+;; a record with ^double fields; the ctor must coerce an integer arg to a flonum.
+(evals "(defrecord V [^double x ^double y])")
+(check "ctor coerces ^double field to flonum" (flonum? (evals "(:x (->V 1 2))")) #t)
+(check "coerced field value matches" (evals "(:x (->V 1 2))") 1.0)
+(check "a flonum arg passes through" (evals "(:y (->V 1.5 2.5))") 2.5)
+
+;; dot is hintless; its caller passes V instances, so the fixpoint types a/b as V
+;; records, the ^double fields read :double, and the field-field arithmetic unboxes.
+(define dot  (anode "(def dot (fn [a b] (+ (* (:x a) (:x b)) (* (:y a) (:y b)))))"))
+(define used (anode "(def used (fn [] (dot (->V 1.0 2.0) (->V 3.0 4.0))))"))
+(set-record-shapes! (chez-record-shapes-map))
+(set-protocol-methods! (jolt-hash-map))
+(wp-infer! (jolt-vector dot used))
+(set-optimize! #t)
+(define dot-emit (emit (run-passes dot (make-analyze-ctx "user"))))
+(check "field-field arithmetic unboxes to fl*" (contains-sub? dot-emit "fl*") #t)
+(check "field-field arithmetic unboxes to fl+" (contains-sub? dot-emit "fl+") #t)
+
+;; an UNTAGGED field stays generic — no fl-op (the read is :any, not :double).
+(evals "(defrecord W [p q])")
+(define dotw (anode "(def dotw (fn [a b] (* (:p a) (:p b))))"))
+(define usew (anode "(def usew (fn [] (dotw (->W 1.0 2.0) (->W 3.0 4.0))))"))
+(set-record-shapes! (chez-record-shapes-map))
+(wp-infer! (jolt-vector dotw usew))
+(check "untagged field stays generic (no fl*)"
+       (contains-sub? (emit (run-passes dotw (make-analyze-ctx "user"))) "fl*") #f)
+
+(if (= fails 0)
+    (begin (printf "fieldnum gate: ~a/~a passed\n" total total) (exit 0))
+    (begin (printf "fieldnum gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

jolt-core/jolt/passes/numeric.clj

@@ -156,6 +156,10 @@
         node1 (assoc node :args argnodes)
         n (count ars)]
     (cond
+      ;; a field read the structural inference proved is a flonum (a ^double record
+      ;; field) is a :double operand — so (* (:x v) (:x v)) unboxes. The read itself
+      ;; isn't lowered here; it keeps its keyword/jrec-field-at emit.
+      (= :double (get node :num-read)) [:double node1]
       ;; a call to a var with a declared numeric return (^double/^long) yields that
       ;; kind, so an accumulator over the result types. The call itself isn't an
       ;; arithmetic op to lower — its body already coerces the return.

jolt-core/jolt/passes/types.clj

@@ -69,6 +69,7 @@
   (cond
     (or (nil? tag) (<= depth 0)) :any
     (= tag "num") :num
+    (= tag "double") :double   ; a ^double field reads back as a flonum
     :else (let [e (get shapes tag)]
             (if e (record-type-from-entry e depth shapes) :any))))
 (defn- record-type-from-entry [rs depth shapes]
@@ -224,9 +225,13 @@
         mt (ty mr)
         msub (if (struct-safe? mt) (mark-struct (nd mr) mt) (nd mr))
         ft (field-type mt (get fnode :val))
-        dr (when (= n 2) (infer (nth args 1) tenv env))]
+        dr (when (= n 2) (infer (nth args 1) tenv env))
-    [(if dr (join ft (ty dr)) ft)
+        rt (if dr (join ft (ty dr)) ft)
-     (assoc node :args (if dr [msub (nd dr)] [msub]))]))
+        node' (assoc node :args (if dr [msub (nd dr)] [msub]))]
+    ;; a flonum field read is a :double operand for the numeric pass (fl-ops); the
+    ;; lookup itself still emits as a keyword/jrec-field-at read, this only feeds
+    ;; its kind up so (* (:x v) (:x v)) over a ^double-fielded record unboxes.
+    [rt (if (= rt :double) (assoc node' :num-read :double) node')]))
 
 (defn- infer-get-lookup
   "(get m :k [default]): the keyword-lookup result type, when the key is a constant
@@ -237,9 +242,10 @@
         msub (if (struct-safe? mt) (mark-struct (nd mr) mt) (nd mr))
         kr (infer (nth args 1) tenv env)
         ft (field-type mt (get (nth args 1) :val))
-        dr (when (= n 3) (infer (nth args 2) tenv env))]
+        dr (when (= n 3) (infer (nth args 2) tenv env))
-    [(if dr (join ft (ty dr)) ft)
+        rt (if dr (join ft (ty dr)) ft)
-     (assoc node :args (if dr [msub (nd kr) (nd dr)] [msub (nd kr)]))]))
+        node' (assoc node :args (if dr [msub (nd kr) (nd dr)] [msub (nd kr)]))]
+    [rt (if (= rt :double) (assoc node' :num-read :double) node')]))
 
 (defn- infer-reduce-hof
   "reduce over a typed vector with a fn-literal: seed the closure's accumulator