From 2174fc1993a79f16da7af72ad3a4068bc6c40906 Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Fri, 24 Jul 2026 18:46:17 +0200 Subject: [PATCH] opt(clos): slot-value/-boundp 0-cons via class location-table slot-value/(setf slot-value)/slot-boundp went through the metaobject slot-definition readers (%find-slot's slot-definition-name + slot-value-using-class's slot-definition-location) -- un-optimized STANDARD-READER-METHODs on bootstrap MOP classes that cons ~96 B each (192 B/call). Route the standard case through the class's existing LOCATION-TABLE (name->location, rack slot 17 on STD-CLASS) for 0-cons access. Fast path is gated on %INSTANCE-FAST-TABLE: taken only for a CURRENT standard instance (core:instancep + instance stamp = class STAMP-FOR-INSTANCES, rack slot 18). An OBSOLETE instance (redefined class), a built-in/unfinalized class, or *OPTIMIZE-SLOT-VALUE* nil (custom slot-value-using-class) falls back to the full MOP dispatch, whose SLOT-VALUE-USING-CLASS discrimination runs the stamp check + UPDATE-INSTANCE. Reading the rack slots directly avoids the CLASS-LOCATION-TABLE reader (itself a consing metaobject reader). --- src/lisp/kernel/clos/slot-value.lisp | 77 ++++++++++++++++++++++++---- 1 file changed, 68 insertions(+), 9 deletions(-) diff --git a/src/lisp/kernel/clos/slot-value.lisp b/src/lisp/kernel/clos/slot-value.lisp index 76dc625fdf..60383e3e0a 100644 --- a/src/lisp/kernel/clos/slot-value.lisp +++ b/src/lisp/kernel/clos/slot-value.lisp @@ -18,30 +18,89 @@ when (eql prospect-name slot-name) return prospect)) -(defun slot-value (object slot-name) - (let* ((class (class-of object)) - (slotd (%find-slot class slot-name))) +;;; --- zero-cons fast path ------------------------------------------------------------------- +;;; The generic SLOT-VALUE/-BOUNDP path consed ~192 B/call: %FIND-SLOT and the standard +;;; SLOT-VALUE-USING-CLASS method call the metaobject readers SLOT-DEFINITION-NAME / +;;; SLOT-DEFINITION-LOCATION, which are un-optimized STANDARD-READER-METHODs on bootstrap MOP +;;; classes and allocate ~96 B each. The standard case is routed through the class's +;;; LOCATION-TABLE (name->location, rack slot 17 on STD-CLASS -- hierarchy.lisp) so the hot path +;;; allocates 0. Fallback to the full MOP dispatch when the class has no populated table +;;; (built-in / unfinalized -> the rack slot is not a hash-table) or when *OPTIMIZE-SLOT-VALUE* +;;; is disabled (e.g. a program defines a custom SLOT-VALUE-USING-CLASS and wants it honored). +(defvar *optimize-slot-value* t) +(defvar *slot-value-not-found* (list '#:not-found)) +(defconstant +class-location-table-rack-index+ 17) ; STD-CLASS LOCATION-TABLE slot, hierarchy.lisp:83 +(defconstant +stamp-for-instances-rack-index+ 18) ; STD-CLASS STAMP-FOR-INSTANCES slot, hierarchy.lisp:84 + +(declaim (inline %instance-fast-table)) +(defun %instance-fast-table (object) + ;; OBJECT's class name->location hash IFF OBJECT is a CURRENT standard instance, else NIL so the + ;; caller takes the full MOP path. Read the class rack slots directly (the CLASS-LOCATION-TABLE / + ;; STAMP-FOR-INSTANCES readers are themselves un-optimized consing metaobject readers). The + ;; currency check (instance stamp = class STAMP-FOR-INSTANCES, cf. MAYBE-UPDATE-INSTANCE) is + ;; MANDATORY: an OBSOLETE instance must take the generic path, whose SLOT-VALUE-USING-CLASS dispatch + ;; runs the stamp check + UPDATE-INSTANCE; skipping it reads a stale rack (wrong slots on a redefined class). + (when (core:instancep object) + (let* ((class (core:instance-class object)) + (rack (core:instance-rack class)) + (table (core:rack-ref rack +class-location-table-rack-index+))) + (when (and (hash-table-p table) + (eql (core:instance-stamp object) + (core:rack-ref rack +stamp-for-instances-rack-index+))) + table)))) + +(defun %slot-value-generic (class object slot-name) + (let ((slotd (%find-slot class slot-name))) (if slotd (slot-value-using-class class object slotd) ;; Only the primary value of SLOT-MISSING is returned. (values (slot-missing class object slot-name 'slot-value))))) -(defun (setf slot-value) (value object slot-name) - (let* ((class (class-of object)) - (slotd (%find-slot class slot-name))) +(defun slot-value (object slot-name) + (let ((table (and *optimize-slot-value* (%instance-fast-table object)))) + (if table + (let ((location (gethash slot-name table *slot-value-not-found*))) + (if (eq location *slot-value-not-found*) + (%slot-value-generic (class-of object) object slot-name) + (let ((value (standard-location-access object location))) + (if (core:sl-boundp value) + value + (values (slot-unbound (class-of object) object slot-name)))))) + (%slot-value-generic (class-of object) object slot-name)))) + +(defun %setf-slot-value-generic (value class object slot-name) + (let ((slotd (%find-slot class slot-name))) (if slotd (setf (slot-value-using-class class object slotd) value) (slot-missing class object slot-name 'setf value))) ;; 7.7.12: value of slot-missing is ignored for setf. value) -(defun slot-boundp (object slot-name) - (let* ((class (class-of object)) - (slotd (%find-slot class slot-name))) +(defun (setf slot-value) (value object slot-name) + (let ((table (and *optimize-slot-value* (%instance-fast-table object)))) + (if table + (let ((location (gethash slot-name table *slot-value-not-found*))) + (if (eq location *slot-value-not-found*) + (%setf-slot-value-generic value (class-of object) object slot-name) + (progn (setf (standard-location-access object location) value) + value))) + (%setf-slot-value-generic value (class-of object) object slot-name)))) + +(defun %slot-boundp-generic (class object slot-name) + (let ((slotd (%find-slot class slot-name))) (if slotd (slot-boundp-using-class class object slotd) (values (slot-missing class object slot-name 'slot-boundp))))) +(defun slot-boundp (object slot-name) + (let ((table (and *optimize-slot-value* (%instance-fast-table object)))) + (if table + (let ((location (gethash slot-name table *slot-value-not-found*))) + (if (eq location *slot-value-not-found*) + (%slot-boundp-generic (class-of object) object slot-name) + (core:sl-boundp (standard-location-access object location)))) + (%slot-boundp-generic (class-of object) object slot-name)))) + (defun slot-makunbound (object slot-name) (let* ((class (class-of object)) (slotd (%find-slot class slot-name)))