Devirt: fall back to dispatch when the static tag has no direct impl (#229)

The devirtualized protocol call emitted find-protocol-method on the inferred
record tag, but a record can satisfy a protocol via an Object/host-tag default
rather than a direct impl — find-protocol-method on its own tag misses that,
while protocol-resolve walks to the default. So a record relying on
(extend-protocol P Object ...) resolved under ordinary dispatch but applied #f
under devirt and crashed. Closed-world opt builds only; the gate previously
covered just direct inline/extend-type impls so it shipped green.

Emit devirt-resolve, which tries the static tag and falls back to
protocol-resolve on a miss — same fast path, correct regardless of how the
record satisfies the protocol. Mirrors jrec-field-at falling back to jolt-get.
The receiver binds to one temp so it feeds the resolve and the application
without double-evaluating a side-effecting arg 0.

Also widen the whole-program fixpoint to :any on hitting the iteration cap: a
non-converged pre-fixpoint is more specific than the least fixpoint, so seeding
it would be unsound. Not reached in practice (~2 passes); a defensive floor.

run-devirt.ss gains an Object-default case. make test / shakesmoke green,
selfhost holds, 0 new divergences.

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

host/chez/records.ss

@@ -579,6 +579,16 @@
   (let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
     (apply (protocol-resolve proto-name method-name obj) obj rest)))
 
+;; devirt-resolve: the impl for a call the inference proved monomorphic. Try the
+;; static type tag directly (the fast path that skips receiver-type computation),
+;; and fall back to ordinary dispatch when it misses — a record can satisfy a
+;; protocol via an Object/host-tag default rather than a direct impl, which
+;; find-protocol-method on its own tag wouldn't see. Mirrors jrec-field-at falling
+;; back to jolt-get: correct regardless of how precise the inference was.
+(define (devirt-resolve type-tag proto-name method-name obj)
+  (or (find-protocol-method type-tag proto-name method-name)
+      (protocol-resolve proto-name method-name obj)))
+
 ;; dot-dispatch fallback used by emit for (.method record args): find the method
 ;; in ANY protocol the record's type implements.
 ;; java.util.Iterator over a jolt seqable: (.iterator coll) returns a jiterator

host/chez/run-devirt.ss

@@ -54,7 +54,7 @@
 (define (run-emit scm) (eval (read (open-input-string scm)) (interaction-environment)))
 
 (let ((e (devirt-emit "user.Circle" "c")))
-  (check "emit uses find-protocol-method" (has-sub? e "find-protocol-method") #t)
+  (check "emit uses devirt-resolve" (has-sub? e "devirt-resolve") #t)
   (check "devirt inline impl == dispatch" (run-emit e) (evals "(area c)")))   ; 7
 
 (let ((e (devirt-emit "user.Square" "sq")))
@@ -63,9 +63,20 @@
 ;; a normal (no devirt) call still goes through dispatch and agrees — the path the
 ;; megamorphic / unknown-receiver site keeps.
 (let ((e (emit (analyze (make-analyze-ctx "user") (jolt-ce-read "(area c)")))))
-  (check "non-devirt path no find-protocol-method" (has-sub? e "find-protocol-method") #f)
+  (check "non-devirt path no devirt-resolve" (has-sub? e "devirt-resolve") #f)
   (check "non-devirt still dispatches" (run-emit e) 7))
 
+;; a record that relies on the protocol's Object default (no direct impl): the
+;; inference still types it as a concrete record and annotates devirt, so the
+;; emitted call must resolve the same value dispatch would. find-protocol-method
+;; on the record's own tag misses here, so the devirt path has to fall back to
+;; ordinary dispatch (else it applies #f and crashes).
+(evals "(extend-protocol Shape Object (area [s] :obj-default))")
+(evals "(defrecord Plain [n])")
+(evals "(def pl (->Plain 9))")
+(let ((e (devirt-emit "user.Plain" "pl")))
+  (check "devirt Object-default == dispatch" (run-emit e) (evals "(area pl)")))  ; :obj-default
+
 (if (= fails 0)
     (begin (printf "devirt gate: ~a/~a passed\n" total total) (exit 0))
     (begin (printf "devirt gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

jolt-core/jolt/backend_scheme.clj

@@ -509,15 +509,19 @@
       ;; devirtualized protocol call: the inference proved the receiver (arg 0) is
       ;; one record type, so resolve the impl by that static tag instead of routing
       ;; through the protocol var -> jolt-invoke -> protocol-resolve (which recomputes
-      ;; the tag and walks the type table). find-protocol-method does the same table
+      ;; the tag and walks the type table). devirt-resolve does the same table lookup
-      ;; lookup the dispatch would, but with no var-deref, no rest-cons, and no
+      ;; the dispatch would, but with no var-deref and no receiver-type computation;
-      ;; receiver-type computation. Fires only on a monomorphic site (a megamorphic
+      ;; it falls back to ordinary dispatch when the static tag has no direct impl (a
-      ;; receiver joins to :any and carries no :devirt-type).
+      ;; record satisfying the protocol via an Object/host-tag default). Fires only on
+      ;; a monomorphic site (a megamorphic receiver joins to :any, no :devirt-type).
+      ;; The receiver is bound once — it feeds both the resolve and the application.
       (:devirt-type node)
       (order-args (fn [as]
-                    (str "((find-protocol-method " (chez-str-lit (:devirt-type node)) " "
+                    (let [r (fresh-label "_r$")]
+                      (str "(let* ((" r " " (first as) ")) "
+                           "((devirt-resolve " (chez-str-lit (:devirt-type node)) " "
                            (chez-str-lit (:devirt-proto node)) " " (chez-str-lit (:devirt-method node))
-                         ") " (str/join " " as) ")")))
+                           " " r ") " (str/join " " (cons r (rest as))) "))"))))
       ;; 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)

jolt-core/jolt/passes/types.clj

@@ -740,17 +740,27 @@
                                  (if (contains? escaped k)
                                    (assoc m k (vec (repeat (count (get m k)) :any))) m))
                                (:ptypes pass) ks)
-            new-rets (:rets pass)]
+            new-rets (:rets pass)
-        (if (or (and (= new-ptypes ptypes) (= new-rets rets)) (>= iter 16))
+            converged? (and (= new-ptypes ptypes) (= new-rets rets))]
+        (if (or converged? (>= iter 16))
+          ;; On convergence new-ptypes is the least fixpoint (sound). On hitting the
+          ;; cap without convergence it's a pre-fixpoint — more specific than the
+          ;; fixpoint, so seeding it would be unsound; widen every param to :any
+          ;; (emit no seeds). The cap isn't reached in practice (~2 passes), this is
+          ;; a defensive floor.
+          (let [seed-ptypes (if converged?
+                              new-ptypes
+                              (reduce (fn [m k] (assoc m k (vec (repeat (count (get m k)) :any))))
+                                      new-ptypes ks))]
             (reset! wp-seeds-box
                     (reduce (fn [m k]
                               (let [s (get spec k)
                                     ptmap (reduce (fn [pm pr]
                                                     (let [nm (nth pr 0) t (nth pr 1)]
                                                       (if (and t (not= t :any)) (assoc pm nm t) pm)))
-                                                {} (map vector (:params s) (get new-ptypes k)))]
+                                                  {} (map vector (:params s) (get seed-ptypes k)))]
                                 (if (seq ptmap) (assoc m k ptmap) m)))
-                          {} ks))
+                            {} ks)))
           (recur (inc iter) new-ptypes new-rets))))))
 
 ;; Piggyback checking (jolt audit). In direct-link mode infer-top already runs