common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Mitigate code bloat from PCL accessors on defstructs

Browse source 
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.
This commit is contained in:
Douglas Katzman 2022-04-26 00:59:41 -04:00
parent 28f8c2085e
commit e02e6bfa97
3 changed files with 31 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
src/code/defstruct.lisp
View file

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

7
src/pcl/braid.lisp
View file

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

6
tests/error-source-path.impure.lisp
View file

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