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>

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
-      ;; lookup the dispatch would, but with no var-deref, no rest-cons, and no
-      ;; receiver-type computation. Fires only on a monomorphic site (a megamorphic
-      ;; receiver joins to :any and carries no :devirt-type).
+      ;; the tag and walks the type table). devirt-resolve does the same table lookup
+      ;; the dispatch would, but with no var-deref and no receiver-type computation;
+      ;; it falls back to ordinary dispatch when the static tag has no direct impl (a
+      ;; 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)) " "
-                         (chez-str-lit (:devirt-proto node)) " " (chez-str-lit (:devirt-method node))
-                         ") " (str/join " " as) ")")))
+                    (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))
+                           " " 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)]
-        (if (or (and (= new-ptypes ptypes) (= new-rets rets)) (>= iter 16))
-          (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)))]
-                              (if (seq ptmap) (assoc m k ptmap) m)))
-                          {} ks))
+            new-rets (:rets pass)
+            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 seed-ptypes k)))]
+                                (if (seq ptmap) (assoc m k ptmap) m)))
+                            {} ks)))
           (recur (inc iter) new-ptypes new-rets))))))
 
 ;; Piggyback checking (jolt audit). In direct-link mode infer-top already runs