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)))