From e02e6bfa97304146f05b416a568e11e2a2afa60a Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Tue, 26 Apr 2022 00:59:41 -0400 Subject: [PATCH] Mitigate code bloat from PCL accessors on defstructs This essentially restores the state of things prior to rev d2ca90b6 but with the advantage of ahead-of-time compiling the anonymous (and oxymoronic) writer functions for readonly slots. --- src/code/defstruct.lisp | 41 +++++++++++++++++------------ src/pcl/braid.lisp | 7 ++--- tests/error-source-path.impure.lisp | 6 ++--- 3 files changed, 31 insertions(+), 23 deletions(-) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 3860ad7fe..82c7bd848 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -273,24 +273,31 @@ (dolist (dsd (dd-slots dd) (result)) (binding* ((key (cons dd dsd)) (name (string (dsd-name dsd))) ; anonymize by stringification - ((reader writer) (dsd-reader dsd (neq (dd-type dd) 'structure)))) + ;; reader and writer are the primitive operations + ((reader writer) (dsd-reader dsd (neq (dd-type dd) 'structure))) + ;; accessor is the global defun + (accessor (dsd-accessor-name dsd))) (declare (dynamic-extent key)) - (result `(named-lambda (setf ,name) (#1=#:v #2=#:x) - ,@(if (eql (dsd-type dsd) 't) - ;; no typecheck - `((,writer (truly-the ,(dd-name dd) #2#) ,(dsd-index dsd) #1#) #1#) - `(,(slot-access-transform :setf `(#1# (truly-the ,(dd-name dd) #2#)) - key :function)))) - `(named-lambda ,name (#2#) - ,(if (and (dsd-always-boundp dsd) (dsd-safe-p dsd)) - ;; Most slots are always-boundp (don't have a BOA constructor - ;; that omits slots) and safe-p (type-safe for reading), - ;; so we can be concise rather than use SLOT-ACCESS-TRANSFORM - ;; plus a rebinding of X with TRULY-THE. - `(,reader (truly-the ,(dd-name dd) #2#) ,(dsd-index dsd)) - ;; Don't check X, but do check the the fetched value. - (slot-access-transform :read `((truly-the ,(dd-name dd) #2#)) - key))))))))) + (result (if (dsd-read-only dsd) + `(named-lambda (setf ,name) (#1=#:v #2=#:x) + ,@(if (eql (dsd-type dsd) 't) + ;; no typecheck + `((,writer (truly-the ,(dd-name dd) #2#) ,(dsd-index dsd) #1#) #1#) + `(,(slot-access-transform :setf `(#1# (truly-the ,(dd-name dd) #2#)) + key :function)))) + `'(setf ,accessor)) + (if nil ; TODO: policy-based selection perhaps? + `(named-lambda ,name (#2#) + ,(if (and (dsd-always-boundp dsd) (dsd-safe-p dsd)) + ;; Most slots are always-boundp (don't have a BOA constructor + ;; that omits slots) and safe-p (type-safe for reading), + ;; so we can be concise rather than use SLOT-ACCESS-TRANSFORM + ;; plus a rebinding of X with TRULY-THE. + `(,reader (truly-the ,(dd-name dd) #2#) ,(dsd-index dsd)) + ;; Don't check X, but do check the the fetched value. + (slot-access-transform :read `((truly-the ,(dd-name dd) #2#)) + key))) + `',accessor))))))) ;;; shared logic for host macroexpansion for SB-XC:DEFSTRUCT and ;;; cross-compiler macroexpansion for CL:DEFSTRUCT diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index fb1d14ab2..739600bc7 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -132,15 +132,16 @@ :direct-superclasses supers :direct-slots slots))) (slot-initargs-from-structure-slotd (slotd writer-fn reader-fn) + (flet ((name->fun (f) (if (functionp f) f (fdefinition f)))) `(:name ,(dsd-name slotd) :defstruct-accessor-symbol ,(dsd-accessor-name slotd) - :internal-reader-function ,reader-fn - :internal-writer-function ,writer-fn + :internal-reader-function ,(name->fun reader-fn) + :internal-writer-function ,(name->fun writer-fn) :type ,(dsd-type slotd) :initform ,(dsd-default slotd) ;; This is nuts! any DEFAULT might need its lexical environment, ;; yet we EVAL in the null environment. - :initfunction ,(eval-form (dsd-default slotd)))) + :initfunction ,(eval-form (dsd-default slotd))))) (accessor-closures (dsd) (multiple-value-bind (reader-fn writer-fn) (sb-kernel::dsd-reader dsd nil) ;; This is for a structure class that exists only in its compile-time representation. diff --git a/tests/error-source-path.impure.lisp b/tests/error-source-path.impure.lisp index 8b862fcfd..f79d6eb59 100644 --- a/tests/error-source-path.impure.lisp +++ b/tests/error-source-path.impure.lisp @@ -137,17 +137,17 @@ (locally (declare (optimize (safety 0))) (defstruct f (x (print t) :type fixnum))) - (1 2 2) (2)) + (1 2 2)) (assert-condition-source-paths (locally (declare (optimize (safety 0))) (defstruct f (x 33 :type cons))) - (2 2) (2)) + (2 2)) (assert-condition-source-paths (locally (declare (optimize (safety 0))) (defstruct f (x mm))) - (2) (2 2))) + (2 2))) (with-test (:name (:source-path defgeneric :lambda-list)) (assert-condition-source-paths