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

Remove defstruct tlf queuing.

Browse source 
Also explicitly block compile the two files it was used for.

Block compilation accomplishes the same thing and handles more cases,
as top level ir1 converted lambdas can be delayed arbitrarily in a
file, unlike forms. All the type tests that should be open-coded,
are, (the build would warn otherwise), but the cross-typep ambiguity
stuff needs to be disabled during cross compile, since there is no way
to know a priori whether a forward referenced type will get resolved
later.
This commit is contained in:
Charles Zhang 2020-04-19 18:05:04 -07:00
parent 7b575d4d5f
commit d24767e3b6
7 changed files with 43 additions and 150 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
NEWS
View file

@ -6,7 +6,12 @@ changes relative to sbcl-2.0.3:
is entirely shared with 64-bit RISC-V.
** native threads are now supported on RISC-V.
* enchancement: forward-referenced type tests can now be open-coded by using
block compilation.
block compilation. The result is that mutually referential defstructs are
now efficiently compiled in block compilation mode, superseding a lighter
mechanism that worked in fewer contexts. However, that lighter mechanism
has been removed, so for now, users who want to efficiently compile
mutually referential defstructs must explicitly opt-in using block
compilation.
* bug fix: defstructs with empty initforms in the sbcl source are now
explicitly intiialized with NIL, as that is undefined behavior under
ANSI. This helps cross compilation hosts which do not implicitly

4
build-order.lisp-expr
View file

@ -231,7 +231,7 @@
("src/code/share-vm" :not-host)
("src/code/thread" :not-host) ; provides *CURRENT-THREAD* for target-signal
("src/code/thread" :not-host :block-compile) ; provides *CURRENT-THREAD* for target-signal
("src/code/target-signal-common" :not-host)
("src/code/bignum" :not-host)
@ -623,7 +623,7 @@
; "code/bignum"
("src/code/target-hash-table" :not-host) ; needs "code/hash-table"
("src/code/final" :not-host)
("src/code/pprint" :not-host) ; defines WITH-PRETTY-STREAM needed by 'print'
("src/code/pprint" :not-host :block-compile) ; defines WITH-PRETTY-STREAM needed by 'print'
("src/code/reader" :not-host) ; needs "code/readtable"
("src/code/print" :not-host)

11
src/code/cross-type.lisp
View file

@ -237,7 +237,11 @@
(t
(uncertain))))
(unimplemented)))))
(when (and (not certain) *xtypep-uncertainty-action*)
(when (and (not certain) *xtypep-uncertainty-action*
;; KLUDGE: Allow some slack while block compiling, as we are
;; hoping that forward referenced types get resolved.
(not (and (boundp 'sb-c::*compilation*)
(sb-c::block-compile sb-c::*compilation*))))
;; can't even backtrace if the printing of a something involving
;; uncertainty involves uncertainty.
(let* ((action *xtypep-uncertainty-action*)
@ -291,7 +295,10 @@
(typep (hairy-type-specifier type)
'(cons (eql satisfies))))
(return-from contains-satisfies t)))
ctype)))
ctype))
;; KLUDGE: Allow uncertainty while block compiling.
(and (boundp 'sb-c::*compilation*)
(sb-c::block-compile sb-c::*compilation*)))
(values answer certain)
(warn 'cross-type-giving-up :call `(ctypep ,obj ,ctype)))))

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

@ -475,10 +475,7 @@
;; 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)
;; A list of forms that are pending compilation. Delaying compilation helps
;; with defstruct constructors that involve type dependency cycles.
(queued-tlfs nil))
(style-warning-tracker nil :type list))
;;; The SOURCE-INFO structure provides a handle on all the source
;;; information for an entire compilation.

124
src/compiler/main.lisp
View file

@ -975,109 +975,6 @@ 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)))
;; (%DEFUN 'THING #<lambda> INLINE-LAMBDA EXTRA-INFO)
(member (fifth form) '(:copier :predicate :accessor :constructor)))
;; 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)))))
;;; Return the INDEX'th source form read from INFO and the position
;;; where it was read.
(defun find-source-root (index info)
@ -1097,9 +994,6 @@ 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)))
@ -1368,8 +1262,6 @@ 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*)
@ -1474,17 +1366,8 @@ necessary, since type inference may take arbitrarily long to converge.")
(t
(when compile-time-too
(eval-compile-toplevel (list form) path))
(cond ((deferrable-tlf-p form)
(push (vector (copy-hash-table *source-paths*)
*policy* *handled-conditions*
*disabled-package-locks* *lexenv* form path)
(queued-tlfs)))
(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)))))))))))
(let (*top-level-form-p*)
(convert-and-maybe-compile form path)))))))))
(values))
@ -1769,8 +1652,7 @@ necessary, since type inference may take arbitrarily long to converge.")
(process-toplevel-form
form `(original-source-start 0 ,current-index) nil))))
(let ((*source-info* info))
(finish-block-compilation)
(process-queued-tlfs)))
(finish-block-compilation)))
(let ((code-coverage-records
(code-coverage-records (coverage-metadata *compilation*))))
(unless (zerop (hash-table-count code-coverage-records))

16
tests/block-compile-defstruct-test.lisp Normal file
View file

@ -0,0 +1,16 @@
;;; 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)))

26
tests/defstruct.impure-cload.lisp
View file

@ -12,24 +12,10 @@
(eval-when (:compile-toplevel)
(load "compiler-test-util.lisp"))
;;; 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)
(with-test (:name (:block-compile :defstruct-slot-type-circularity))
(with-scratch-file (fasl "fasl")
(compile-file "block-compile-defstruct-test.lisp" :output-file fasl :block-compile t)
(load fasl))
(dolist (symbol '(make-s1 make-s2 make-s3))
(let ((constants
(ctu:find-code-constants (symbol-function symbol)
@ -54,7 +40,7 @@
(let ((layouts
(ctu:find-code-constants #'(setf sb-thread::mutex-%owner)
:type 'sb-kernel:layout)))
;; expect 2 layouts: one for THREAD, one for MUTEX
(assert (= (length layouts) 2))
;; expect 3 layouts: one for THREAD, one for MUTEX, and one for FOREIGN-THREAD
(assert (= (length layouts) 3))
(assert (find (sb-kernel:find-layout 'sb-thread:thread)
layouts))))