From cad1528204bdcefa2d3750dfd2e0ca19ee25d6ed Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Fri, 31 Jul 2026 21:22:24 +0200 Subject: [PATCH 1/2] fix(clos): eql-specialized generic functions never memoized Any generic function with an eql specializer took a full dispatch miss on every call: compute-applicable-methods, compute-effective-method and a fresh effective-method-function, every time. Measured on this tree (3.0.1-73-g2cf5bb5e4, boehm and boehmprecise identically): 2-method eql gf 6784 B/call, call history stays empty clasp-ffi:%mem-ref 19448 B/call, 321 us/call, call history empty class-specialized gf 0 B/call clasp-ffi:%mem-ref / %mem-set define one eql method per foreign type, so every CFFI foreign memory access paid this. After the fix both drop to 0 B/call and 137 ns, and the call history fills normally (27 entries for %mem-ref). Root cause is the guard in miss-info deciding whether an eql-specialized call may be memoized. It compared (class-of generic-function) against a read-time literal, #.(find-class 'standard-generic-function). In the built image that comparison is always false, so miss-info fell through to the (t nil) clause and never called memoize-eql-specialized. Nothing was ever added to the call history, so the next call missed again. The literal is not stale. In the running image the module literal, the live class and (class-of gf) are all eq to one another; the bytecode decodes correctly (jump-if-8 +12 lands exactly on the called-fdefinition of memoize-eql-specialized); and instrumenting outcome shows every input to the cond is correct, with ok nil and final-methods of length one. Yet witness counters on memoize-eql-specialized, specializers-combinate and call-history-find-key all stay at zero. Why the comparison evaluates false in cross-clasp-compiled code is not explained; recompiling the identical source at runtime makes it work. Filed separately. Replacing the read-time literal with a runtime find-class fixes it. The lookup is on the miss path only, which after this change is taken once per key rather than once per call. static-gfs::uncustomizable-slot-p carried the same read-time-literal guard and was dead the same way, silently disabling the static slot-value/slot-boundp optimization for every standard class: it returned NIL for a plain standard-class with a standard-effective-slot-definition even though both eq tests are true evaluated at runtime. This also explains why toggling clos::*optimize-slot-value* moved allocation by <0.1% -- the optimization was already off. Adds a regression test that fails before and passes after: an eql-specialized gf must leave a non-empty call history. --- src/lisp/kernel/clos/miss.lisp | 3 ++- src/lisp/kernel/clos/static-gfs/svuc.lisp | 7 ++++--- src/lisp/regression-tests/fastgf.lisp | 9 +++++++++ 3 files changed, 15 insertions(+), 4 deletions(-) diff --git a/src/lisp/kernel/clos/miss.lisp b/src/lisp/kernel/clos/miss.lisp index e39fe00046..d4dcb921b7 100644 --- a/src/lisp/kernel/clos/miss.lisp +++ b/src/lisp/kernel/clos/miss.lisp @@ -262,8 +262,9 @@ ;; another thread has already added this entry nil (list (cons key outcome))))) + ;; NOTE: must be a runtime lookup; a #. literal here never matches. ((eq (class-of generic-function) - #.(find-class 'standard-generic-function)) + (find-class 'standard-generic-function)) (memoize-eql-specialized generic-function method-combination call-history argument-classes)) (t diff --git a/src/lisp/kernel/clos/static-gfs/svuc.lisp b/src/lisp/kernel/clos/static-gfs/svuc.lisp index 98cb496e97..3dc25b53e7 100644 --- a/src/lisp/kernel/clos/static-gfs/svuc.lisp +++ b/src/lisp/kernel/clos/static-gfs/svuc.lisp @@ -16,11 +16,12 @@ TODO 2: Build a cell system like we do for make-instance. ;;;; NOTE: The static-foo macros may evaluate the instance form more than once. ;;;; (Because we know here that it's always just a variable.) +;;; NOTE: must be runtime lookups; #. literals here never match. (defun uncustomizable-slot-p (class slotd) (let ((metaclass (class-of class))) - (and (or (eq metaclass #.(find-class 'standard-class)) - (eq metaclass #.(find-class 'clos:funcallable-standard-class))) - (eq (class-of slotd) #.(find-class 'clos:standard-effective-slot-definition))))) + (and (or (eq metaclass (find-class 'standard-class)) + (eq metaclass (find-class 'clos:funcallable-standard-class))) + (eq (class-of slotd) (find-class 'clos:standard-effective-slot-definition))))) ;;; I said "constant slotd", but slotds aren't dumpable, so to satisfy ;;; COMPILE-FILE what we'll actually get is (ltv-slotd class slotd), diff --git a/src/lisp/regression-tests/fastgf.lisp b/src/lisp/regression-tests/fastgf.lisp index 5225ddf80e..24cf3ab5a1 100644 --- a/src/lisp/regression-tests/fastgf.lisp +++ b/src/lisp/regression-tests/fastgf.lisp @@ -5,3 +5,12 @@ (defmethod fgf-foo ((x symbol)) :symbol) (test dispatch-symbol (fgf-foo :yadda) (:symbol)) (test-expect-error dispatch-no-applicable-method (fgf-foo 1.2) :description "This should not dispatch") + +(defmethod fgf-eql ((x (eql :alpha))) :alpha) +(defmethod fgf-eql ((x (eql :beta))) :beta) +(test dispatch-eql-alpha (fgf-eql :alpha) (:alpha)) +(test dispatch-eql-beta (fgf-eql :beta) (:beta)) +;;; Without memoization every eql-specialized call is a full dispatch miss. +(test-true dispatch-eql-memoized + (progn (fgf-eql :alpha) + (plusp (length (clos::generic-function-call-history #'fgf-eql))))) From cf36ccc16f15f6a32b4b544e1b177eb73745a576 Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Sat, 1 Aug 2026 11:05:31 +0200 Subject: [PATCH 2/2] fix(clos): validate-superclass rejects AMOP-legal metaclass mixes validate-superclass permits a standard-class and a funcallable-standard-class to appear in each other's superclass chain, via two clauses guarded by read-time class literals. Both evaluate false in the built image, so the mixed case was rejected outright: (defclass plain-sc () ()) (defclass fsc-from-sc (plain-sc) () (:metaclass clos:funcallable-standard-class)) ;; => Class # is not a valid superclass for ;; # Called directly, both directions returned NIL where T is required. Same root cause as the eql-specializer memoization guard in this branch: a #.(find-class ...) literal that is eq to the live class yet compares false in cross-clasp-compiled code. Unlike that one, this is a correctness bug rather than a lost optimization -- Clasp refuses hierarchies AMOP permits. The lookups are deferred behind the (eq c1 c2) fast path and use errorp nil, so the common same-metaclass case does no lookup at all, and bootstrap cannot trip over a metaclass that is not yet registered. Verified by a clean Lisp bootstrap of boehmprecise -- kernel and both images regenerated from source, no errors, 1979 successes with zero unexpected failures. Adds two MOP tests: both directions of validate-superclass, and the defclass that previously failed. --- src/lisp/kernel/clos/class.lisp | 9 +++++---- src/lisp/regression-tests/mop.lisp | 17 +++++++++++++++++ 2 files changed, 22 insertions(+), 4 deletions(-) diff --git a/src/lisp/kernel/clos/class.lisp b/src/lisp/kernel/clos/class.lisp index f40b06ca16..eeee353856 100644 --- a/src/lisp/kernel/clos/class.lisp +++ b/src/lisp/kernel/clos/class.lisp @@ -168,13 +168,14 @@ argument was supplied for metaclass ~S." (class-of class)))))))) supplied-superclasses) (defmethod validate-superclass ((class class) (superclass class)) + ;; NOTE: runtime lookups (a #. literal never matches), deferred and errorp nil for bootstrap safety. (or (let ((c1 (class-of class)) (c2 (class-of superclass))) (or (eq c1 c2) - (and (eq c1 #.(find-class 'standard-class)) - (eq c2 #.(find-class 'funcallable-standard-class))) - (and (eq c2 #.(find-class 'standard-class)) - (eq c1 #.(find-class 'funcallable-standard-class))))) + (let ((std (find-class 'standard-class nil)) + (fstd (find-class 'funcallable-standard-class nil))) + (or (and (eq c1 std) (eq c2 fstd)) + (and (eq c2 std) (eq c1 fstd)))))) (or (typep class 'forward-referenced-class) (typep superclass 'forward-referenced-class)))) diff --git a/src/lisp/regression-tests/mop.lisp b/src/lisp/regression-tests/mop.lisp index 36749bc39f..a8b09cdca9 100644 --- a/src/lisp/regression-tests/mop.lisp +++ b/src/lisp/regression-tests/mop.lisp @@ -110,3 +110,20 @@ (loop for n in nonwriters when (fboundp `(setf ,n)) collect n))) + +;;; AMOP allows a standard-class and a funcallable-standard-class in each +;;; other's superclass chain; validate-superclass must accept both directions. +(defclass vsc-plain () ((a :initform 1))) + +(test-true validate-superclass-mixed-metaclasses + (and (clos:validate-superclass (find-class 'standard-generic-function) + (find-class 'vsc-plain)) + (clos:validate-superclass (find-class 'vsc-plain) + (find-class 'standard-generic-function)) + t)) + +(test-true validate-superclass-funcallable-from-standard + (progn (eval '(defclass vsc-funcallable (vsc-plain) () + (:metaclass clos:funcallable-standard-class))) + (eq (class-of (find-class 'vsc-funcallable)) + (find-class 'clos:funcallable-standard-class))))