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

Do a better job with mutually referential defstruct constructors

Browse source 
Given:
 (defstruct foo (a nil :type (or null bar))
 (defstruct bar (a nil :type (or null foo))
there was no way to efficiently compile the type-check of BAR in the FOO
constructor, so it fell back to using cached-typep. Flipping the order of those
definitions doesn't help, since they're symmetric.

This change batches up forms produced by consecutive defstructs, compiling them
after digesting all the compiler metadata. It's sort of "block compilation lite"
though it's unclear if block compilation would have handled forward references
to undefined types any better than this. i.e. we might have needed this anyway,
though we pretty much gave up on block compilation, so it's irrelevant.

At the moment, no unrecognized forms may appear in between dependent defstructs;
however I think we can improve this to queue up any PROCLAIM or arbitrary DEFUN
as long as the order of compilation is preserved.
This commit is contained in:
Douglas Katzman 2019-01-28 01:22:02 -05:00
parent 825d4d0070
commit 5aec1ee8fa
7 changed files with 218 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
src/code/debug-info.lisp
View file

@ -459,7 +459,10 @@
;; the "&OPTIONAL and &KEY" warning is quite annoying to see repeated.
;; And I doubt it changes anyone's mind about coding style anyway.
;; Typically this matters for DEFTYPE and DEFMACRO.
(style-warning-tracker nil :type list))
(style-warning-tracker nil :type list)
;; A list of forms that are pending compilation. Delaying compilation helps
;; with defstruct constructors that involve type dependency cycles.
(queued-tlfs nil))
;;; The SOURCE-INFO structure provides a handle on all the source
;;; information for an entire compilation.

7
src/code/early-defmethod.lisp
View file

@ -34,7 +34,9 @@
(unspecialized-ll `(,(caar lambda-list) ,@(cdr lambda-list)))
((forms decls) (parse-body body nil))) ; Note: disallowing docstring
`(!trivial-defmethod
',name ',specializer ,qualifier ',unspecialized-ll
;; An extra NIL in front puts the GF name is the same position it would be in
;; for a normal LOAD-DEFMETHOD.
nil ',name ',specializer ,qualifier ',unspecialized-ll
;; OAOO problem: compute the same lambda name as real DEFMETHOD would
(named-lambda (fast-method ,name
(,specializer ,@(if (eq name 'print-object) '(t))))
@ -58,7 +60,8 @@
(defvar *!trivial-methods* '()) ; necessary methods for system startup
(defvar *!documentation-methods* nil) ; saved up for after PCL bootstrap
(defun !trivial-defmethod (name specializer qualifier lambda-list lambda source-loc)
(defun !trivial-defmethod (dummy name specializer qualifier lambda-list lambda source-loc)
(declare (ignore dummy)) ; this would be the method class in LOAD-DEFMETHOD
(let ((gf (assoc name *!trivial-methods*)))
;; Append the method but don't bother finding a predicate for it.
;; Methods occurring in early warm load (notably from SB-FASTEVAL)

62
src/compiler/fopcompile.lisp
View file

@ -179,37 +179,37 @@
;; this is probably where you need to make it happen.
#+sb-xc-host
(defun fopcompilable-p (form &optional (expand t))
(and expand
(or (and (self-evaluating-p form)
(constant-fopcompilable-p form))
(and (typep form '(cons (eql quote) (cons t null)))
(constant-fopcompilable-p (constant-form-value form)))
(and (listp form)
(let ((function (car form)))
;; It is assumed that uses of these three recognized functions
;; are carefully controlled, and recursion on fopcompilable-p
;; would say "yes" for each argument.
(or (member function '(sb-impl::%defun
sb-pcl::!trivial-defmethod
sb-kernel::%defstruct))
;; allow DEF{CONSTANT,PARAMETER} only if the value form is ok
(and (member function '(%defconstant sb-impl::%defparameter))
(fopcompilable-p (third form)))
(and (symbolp function) ; no ((lambda ...) ...)
(get-properties (symbol-plist function)
'(:sb-cold-funcall-handler/for-effect
:sb-cold-funcall-handler/for-value)))
(and (eq function 'setf)
(fopcompilable-p (%macroexpand form *lexenv*)))
(and (eq function 'sb-kernel:%svset)
(destructuring-bind (thing index value) (cdr form)
(and (symbolp thing)
(integerp index)
(eq (info :variable :kind thing) :global)
(typep value '(cons (member lambda function
named-lambda))))))
(and (eq function 'setq)
(setq-fopcompilable-p (cdr form)))))))))
(declare (ignore expand))
(or (and (self-evaluating-p form)
(constant-fopcompilable-p form))
(and (typep form '(cons (eql quote) (cons t null)))
(constant-fopcompilable-p (constant-form-value form)))
(and (listp form)
(let ((function (car form)))
;; It is assumed that uses of these three recognized functions
;; are carefully controlled, and recursion on fopcompilable-p
;; would say "yes" for each argument.
(or (member function '(sb-impl::%defun
sb-pcl::!trivial-defmethod
sb-kernel::%defstruct))
;; allow DEF{CONSTANT,PARAMETER} only if the value form is ok
(and (member function '(%defconstant sb-impl::%defparameter))
(fopcompilable-p (third form)))
(and (symbolp function) ; no ((lambda ...) ...)
(get-properties (symbol-plist function)
'(:sb-cold-funcall-handler/for-effect
:sb-cold-funcall-handler/for-value)))
(and (eq function 'setf)
(fopcompilable-p (%macroexpand form *lexenv*)))
(and (eq function 'sb-kernel:%svset)
(destructuring-bind (thing index value) (cdr form)
(and (symbolp thing)
(integerp index)
(eq (info :variable :kind thing) :global)
(typep value
'(cons (member lambda function named-lambda))))))
(and (eq function 'setq)
(setq-fopcompilable-p (cdr form))))))))
) ; end FLET
(defun let-fopcompilable-p (operator args)

3
src/compiler/generic/genesis.lisp
View file

@ -1927,7 +1927,8 @@ core and return a descriptor to it."
fdefn))
;;; Handle a DEFMETHOD in cold-load. "Very easily done". Right.
(defun cold-defmethod (name &rest stuff)
(defun cold-defmethod (method-class name &rest stuff)
(declare (ignore method-class))
(let ((gf (assoc name *cold-methods*)))
(unless gf
(setq gf (cons name nil))

2
src/compiler/ir1tran-lambda.lisp
View file

@ -1286,7 +1286,7 @@
inline-lambda name))
(setq inline-lambda nil))) ; will be cleared below
(t
;; Warn if stomping on a structure predicate or accessor
;; Warn if stomping on a structure copier, predicate, or accessor
;; whether or not we are about to install an inline-lambda.
(let ((info (info :function :source-transform name)))
(when (consp info)

150
src/compiler/main.lisp
View file

@ -988,6 +988,111 @@ necessary, since type inference may take arbitrarily long to converge.")
,@body)
,info ,on-error))))
;;; To allow proper optimization of the type-checks in defstruct constructors
;;; and slot setters in circular defstructs, compiling of out-of-line defuns
;;; can be deferred until after more than 1 defstruct form is seen, a la:
;;; (defstruct foo (x nil :type (or null foo bar)))
;;; (defstruct bar (x nil :type (or null bar foo)))
;;;
;;; A trivial example shows why only a very small set of compile-time-too forms
;;; are allowed - this defun of F1 can not be deferred past the second EVAL-WHEN.
;;;
;;; (eval-when (:compile-toplevel) (defvar *myvar* t))
;;; (defmacro foo (x) (if *myvar* `(list ,x) `(car ,x)))
;;; (defun f1 (x) (foo x))
;;; (eval-when (:compile-toplevel) (setq *myvar* nil))
;;; (defun f2 (x) (foo x))
;;;
;;; Additionally, it is important to preserve the relative order
;;; of arbitrary defuns for cases such as this:
;;; (defun thing () ...)
;;; (defun use-it () (... (load-time-value (thing))))
;;; Defstruct slot setters and constructors should be deferred.
;;; Readers, copiers, and predicates needn't be, but the implementation
;;; of the deferral mechanism is simplified by lumping defstruct-defined
;;; functions together in the deferral queue.
;;; We could try to queue up all DEFUNs until we see an unrecognized form
;;; (non-whitelisted) appears, but I'm insufficiently convinced of the
;;; correctness of the approach to blindly allow any DEFUN whatsoever.
(defglobal *debug-tlf-queueing* nil)
(defun deferrable-tlf-p (form)
(unless (consp form)
(return-from deferrable-tlf-p nil))
(cond ((or (and (eq (car form) 'sb-impl::%defun)
(typep (second form) '(cons (eql quote) (cons t null)))
(or (member (fourth form) '(:copier :predicate :accessor))
;; maybe a constructor
(typep (info :function :type (second (second form)))
'defstruct-description)))
;; Also defer %target-defstruct until after the readers/writers are made,
;; or else CLOS garbage hits sb-pcl::uninitialized-accessor-function.
(and (eq (car form) 'sb-kernel::%target-defstruct)))
(when *debug-tlf-queueing*
(let ((*print-pretty* nil)) (format t "~&Enqueue: ~A~%" form)))
t)
(t
nil)))
(defun whitelisted-compile-time-form-p (form)
(let ((answer
(typecase form
((cons (member sb-c:%compiler-defun
sb-c::warn-if-setf-macro
sb-kernel::%defstruct-package-locks
sb-kernel::%compiler-defstruct
sb-pcl::compile-or-load-defgeneric))
t)
((or cons symbol) nil)
(t t))))
(when *debug-tlf-queueing*
(let ((*print-pretty* nil) (*print-level* 2))
(format t "~&CT whitelist ~A => ~A~%" form answer)))
(not (null answer))))
(defun whitelisted-load-time-form-p (form)
(let ((answer (typecase form
((cons (member sb-pcl::load-defmethod
#+sb-xc-host sb-pcl::!trivial-defmethod))
(typep (third form) '(cons (eql quote) (cons (eql print-object) null))))
((cons (member sb-kernel::%defstruct-package-locks
sb-kernel::%defstruct
sb-kernel::%compiler-defstruct
quote))
t)
((or cons symbol) nil)
(t t))))
(when *debug-tlf-queueing*
(let ((*print-pretty* nil) (*print-level* 2))
(format t "~&LT whitelist ~A => ~A~%" form answer)))
(not (null answer))))
(defmacro queued-tlfs ()
'(file-info-queued-tlfs (source-info-file-info *source-info*)))
(defun process-queued-tlfs ()
(let ((list (nreverse (queued-tlfs))))
(setf (queued-tlfs) nil)
(dolist (item list)
(declare (type (simple-vector 7) item))
(let* ((*source-paths* (elt item 0))
(*policy* (elt item 1))
(*handled-conditions* (elt item 2))
(*disabled-package-locks* (elt item 3))
(*lexenv* (elt item 4))
(form (elt item 5))
(path (elt item 6))
(*top-level-form-p*)
;; binding *T-L-F-NOTED* to this form suppresses "; compiling (%DEFUN ...)"
(*top-level-form-noted* form)
(sb-xc:*gensym-counter* 0))
(when *debug-tlf-queueing*
(let ((*print-pretty* nil)) (format t "~&Dequeue: ~A~%" form)))
;; *SOURCE-PATHS* have been cleared. This is only a problem only if we
;; need to report an error. Probably should store the original form
;; and recompute paths, or just snapshot the hash-table.
;; (aver (plusp (hash-table-count *source-paths*)))
(convert-and-maybe-compile form path nil)))))
;;; Read and compile the source file.
(defun sub-sub-compile-file (info)
(do-forms-from-info ((form current-index) info
@ -997,6 +1102,8 @@ necessary, since type inference may take arbitrarily long to converge.")
(let ((sb-xc:*gensym-counter* 0))
(process-toplevel-form
form `(original-source-start 0 ,current-index) nil))))
(let ((*source-info* info))
(process-queued-tlfs))
;; It's easy to get into a situation where cold-init crashes and the only
;; backtrace you get from ldb is TOP-LEVEL-FORM, which means you're anywhere
;; within the 23000 or so blobs of code deferred until cold-init.
@ -1034,6 +1141,9 @@ necessary, since type inference may take arbitrarily long to converge.")
#+sb-xc-host
(when sb-cold::*compile-for-effect-only*
(return-from convert-and-maybe-compile))
(when *debug-tlf-queueing*
(let ((*print-pretty* nil) (*print-level* 2))
(format t "~&c/c ~A~%" form)))
(let ((*top-level-form-noted* (note-top-level-form form t)))
;; Don't bother to compile simple objects that just sit there.
(when (and form (or (symbolp form) (consp form)))
@ -1300,6 +1410,8 @@ necessary, since type inference may take arbitrarily long to converge.")
;;; compilation. Normally just evaluate in the appropriate
;;; environment, but also compile if outputting a CFASL.
(defun eval-compile-toplevel (body path)
(when (and (queued-tlfs) (notevery #'whitelisted-compile-time-form-p body))
(process-queued-tlfs))
(let ((*compile-time-eval* t))
(flet ((frob ()
(eval-tlf `(progn ,@body) (source-path-tlf-number path) *lexenv*)
@ -1339,7 +1451,12 @@ necessary, since type inference may take arbitrarily long to converge.")
path)
(throw 'process-toplevel-form-error-abort nil)))
(*top-level-form-p* t))
(flet ((default-processor (form)
(labels
((defer (form)
(push (vector *source-paths* *policy* *handled-conditions*
*disabled-package-locks* *lexenv* form path)
(queued-tlfs)))
(default-processor (form)
(let ((*top-level-form-noted* (note-top-level-form form)))
;; When we're cross-compiling, consider: what should we
;; do when we hit e.g.
@ -1365,8 +1482,11 @@ necessary, since type inference may take arbitrarily long to converge.")
#+sb-xc-host
(progn
(when compile-time-too
(when (and (queued-tlfs)
(not (whitelisted-compile-time-form-p form)))
(process-queued-tlfs))
(let ((*compile-time-eval* t))
(eval form))) ; letting xc host EVAL do its own macroexpansion
(eval form))) ; letting xc host EVAL do its own macroexpansion
(let* (;; (We uncross the operator name because things
;; like SB-XC:DEFCONSTANT and SB-XC:DEFTYPE
;; should be equivalent to their CL: counterparts
@ -1376,15 +1496,21 @@ necessary, since type inference may take arbitrarily long to converge.")
;; things inside EVAL-WHEN can't be uncrossed
;; until after we've EVALed them in the
;; cross-compilation host.)
(slightly-uncrossed (cons (uncross (first form))
(rest form)))
(expanded (preprocessor-macroexpand-1
slightly-uncrossed)))
(slightly-uncrossed
(cons (uncross (first form)) (rest form)))
(expanded
(preprocessor-macroexpand-1 slightly-uncrossed)))
(if (eq expanded slightly-uncrossed)
;; (Now that we're no longer processing toplevel
;; forms, and hence no longer need to worry about
;; EVAL-WHEN, we can uncross everything.)
(convert-and-maybe-compile expanded path)
(cond ((deferrable-tlf-p expanded)
(defer expanded))
(t
(when (and (queued-tlfs)
(not (whitelisted-load-time-form-p expanded)))
(process-queued-tlfs))
(convert-and-maybe-compile expanded path)))
;; (We have to demote COMPILE-TIME-TOO to NIL
;; here, no matter what it was before, since
;; otherwise we'd tend to EVAL subforms more than
@ -1400,8 +1526,14 @@ necessary, since type inference may take arbitrarily long to converge.")
(cond ((eq expanded form)
(when compile-time-too
(eval-compile-toplevel (list form) path))
(let (*top-level-form-p*)
(convert-and-maybe-compile form path nil)))
(cond ((deferrable-tlf-p form)
(defer form))
(t
(when (and (queued-tlfs)
(not (whitelisted-load-time-form-p form)))
(process-queued-tlfs))
(let (*top-level-form-p*)
(convert-and-maybe-compile form path nil)))))
(t
(process-toplevel-form expanded
path

34
tests/defstruct.pure-cload.lisp Normal file
View file

@ -0,0 +1,34 @@
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;;; Prior to the change that allowed forward-references to slot types,
;;; the MAKE-S1 constructor would have used a "cached typep" placeholder
;;; for structure types S2 and S3; and MAKE-S2 would have used one for S3.
;;; The placeholder lazily figures out that a symbol references a now-defined
;;; defstruct, and it tries to precompute a way to as-efficiently-as-possible
;;; test for that type, given that it couldn't wire in the test to start with.
;;; Only S3 would have been compiled correctly from the outset because it
;;; makes backwards references and no forward references.
;;;
;;; But now with the DEFSTRUCT improvements, the type checks for the slot
;;; named A all compile to basically the same thing in each MAKE- function,
;;; without use of placeholders nor just-in-time optimization attempts.
;;;
(defstruct s1 (a nil :type (or s1 s2 s3 null)))
(defstruct s2 (a nil :type (or s1 s2 s3 null)))
(defstruct s3 (a nil :type (or s1 s2 s3 null)))
(with-test (:name :defstruct-slot-type-circularity)
(dolist (symbol '(make-s1 make-s2 make-s3))
(let ((constants
(ctu:find-code-constants (symbol-function symbol)
:type 'sb-kernel:layout)))
(assert (= (length constants) 3)))))