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

10
host/chez/records.ss
View file

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

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

436
host/chez/seed/image.ss
View file

File diff suppressed because one or more lines are too long

18
jolt-core/jolt/backend_scheme.clj
View file

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

32
jolt-core/jolt/passes/types.clj
View file

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