simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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>
This commit is contained in:
Dmitri Sotnikov 2026-06-26 13:58:23 +00:00 • committed by GitHub
parent de31221573
commit e6e3612332
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
5 changed files with 273 additions and 238 deletions
Download patch file Download diff file Expand all files Collapse all files

15
host/chez/run-devirt.ss
View file

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