Menu
▾
▴
[Sbcl-commits] master: Similar to change 4bf626, dump STANDARD-OBJECTs using fasl ops, maybe.
|
From: Douglas K. <sn...@us...> - 2015-01-21 03:41:15
|
The branch "master" has been updated in SBCL:
via 428fd6f993fd2ede4f6f77f462ba47efef2ca55c (commit)
from 71e0191458d8ebfb433278c92d731bb421910884 (commit)
- Log -----------------------------------------------------------------
commit 428fd6f993fd2ede4f6f77f462ba47efef2ca55c
Author: Douglas Katzman <do...@go...>
Date: Tue Jan 20 22:31:25 2015 -0500
Similar to change 4bf626, dump STANDARD-OBJECTs using fasl ops, maybe.
Given a macro HAIRY that computes a tree of objects returned as literals
in a toplevel defvar such as (DEFVAR *X* (HAIRY)), this change has the
potential to reduce fasl size by 100:1 versus compiling to machine code,
and not just in a contrived case - it reflects how cl-protobufs represents
and stores its metadata after converting from '.proto' language.
In one example, compile time went from 3 minutes down to 2 seconds,
and another, 7 minutes to .5 seconds, depending on interwoven-ness.
Also make some tests more quiet.
---
src/code/fop.lisp | 25 ++++++++++++
src/code/target-defstruct.lisp | 8 +---
src/compiler/fopcompile.lisp | 80 ++++++++++++++++++++++++++++++++++++++++
src/compiler/main.lisp | 7 ++-
tests/dump.impure-cload.lisp | 61 ++++++++++++++++++++++++++----
tests/test-util.lisp | 3 +-
6 files changed, 165 insertions(+), 19 deletions(-)
diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index 2053ecf..68c4250 100644
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -205,6 +205,31 @@
(define-fop (fop-layout 45 (name inherits depthoid length metadata))
(find-and-init-or-check-layout name length inherits depthoid metadata))
+;; Allocate a CLOS object. This is used when the compiler detects that
+;; MAKE-LOAD-FORM returned a simple use of MAKE-LOAD-FORM-SAVING-SLOTS,
+;; or possibly a hand-written equivalent (however unlikely).
+(define-fop (fop-allocate-instance 50 (name) nil)
+ (let ((instance (allocate-instance (find-class (the symbol name)))))
+ (push-fop-table instance)
+ instance))
+
+;; Fill in object slots as dictated by the second return value from
+;; MAKE-LOAD-FORM-SAVING-SLOTS.
+;; This wants a 'count' as the first item in the SLOT-NAMES argument
+;; rather than using read-arg because many calls of this might share
+;; the list, which must be constructed into the fop-table no matter what.
+(define-fop (fop-initialize-instance 51 (slot-names obj) nil)
+ (let ((n-slots (pop slot-names)))
+ (multiple-value-bind (stack ptr) (fop-stack-pop-n n-slots)
+ (dotimes (i n-slots)
+ (let ((val (svref stack (+ ptr i)))
+ (slot-name (pop slot-names)))
+ (if (eq val 'sb!pcl::..slot-unbound..)
+ ;; SLOT-MAKUNBOUND-USING-CLASS might do something nonstandard.
+ (slot-makunbound obj slot-name)
+ ;; FIXME: the DEFSETF for this isn't defined until warm load
+ (sb!pcl::set-slot-value obj slot-name val)))))))
+
(define-fop (fop-end-group 64 () nil)
(/show0 "THROWing FASL-GROUP-END")
(throw 'fasl-group-end t))
diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 3366e43..47ce60d 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -359,13 +359,7 @@
;; or otherwise examined. So instead we scan the code and detect whether it is
;; identical to what was returned from a trivial use of M-L-F-S-S.
(defun canonical-slot-saving-forms-p (struct creation-form init-form)
- ;; check that creation-form is `(allocate-instance (find-class ',class))
- (and (typep creation-form
- '(cons (eql allocate-instance)
- (cons (cons (eql find-class)
- (cons (cons (eql quote) (cons symbol null))
- null))
- null)))
+ (and (sb!c::canonical-instance-maker-form-p creation-form)
(typep init-form '(cons (eql setf)))
(eq (cadr (cadr (cadr creation-form))) (class-name (class-of struct)))
(= (length (dd-slots (layout-info (%instance-layout struct))))
diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp
index 3faea50..3742566 100644
--- a/src/compiler/fopcompile.lisp
+++ b/src/compiler/fopcompile.lisp
@@ -491,3 +491,83 @@
;; with EMIT-MAKE-LOAD-FORM.
(let ((sb!fasl::*dump-only-valid-structures* nil))
(dump-object form *compile-object*))))
+
+;; Return CLASS if CREATION-FORM is `(allocate-instance (find-class ',CLASS))
+(defun canonical-instance-maker-form-p (creation-form)
+ (let ((arg (and (typep creation-form
+ '(cons (eql allocate-instance) (cons t null)))
+ (cadr creation-form))))
+ (when (and arg (typep arg '(cons (eql find-class) (cons t null))))
+ (let ((class (cadr arg)))
+ (when (typep class '(cons (eql quote) (cons symbol null)))
+ (cadr class))))))
+
+;; If FORM can be implemented by FOP-ALLOCATE-INSTANCE,
+;; then fopcompile it and return a table index, otherwise return NIL.
+(defun fopcompile-allocate-instance (form)
+ (let ((class-name (canonical-instance-maker-form-p form)))
+ (when class-name
+ (let ((file *compile-object*))
+ (dump-object class-name file)
+ (sb!fasl::dump-fop 'sb!fasl::fop-allocate-instance file)
+ (let ((index (sb!fasl::fasl-output-table-free file)))
+ (setf (sb!fasl::fasl-output-table-free file) (1+ index))
+ index)))))
+
+;; If FORM is one that we recognize as coming from MAKE-LOAD-FORM-SAVING-SLOTS,
+;; then return 3 values: the instance being affected, a slot name, and a value.
+;; Otherwise return three NILs.
+(defun trivial-load-form-initform-args (form)
+ (multiple-value-bind (args const)
+ ;; these expressions suck, but here goes...
+ (cond ((typep form
+ '(cons
+ (eql setf)
+ (cons (cons (eql slot-value)
+ (cons instance
+ (cons (cons (eql quote) (cons symbol null))
+ null)))
+ (cons (cons (eql quote) (cons t null)) null))))
+ (values (cdadr form) (second (third form))))
+ ((typep form
+ '(cons
+ (eql slot-makunbound)
+ (cons instance
+ (cons (cons (eql quote) (cons symbol null)) null))))
+ ;; FIXME: could define SB-PCL:+SLOT-UNBOUND+ much earlier,
+ ;; and put the symbol in the kernel package or something.
+ (values (cdr form) 'sb!pcl::..slot-unbound..)))
+ (if args
+ (values (car args) (cadadr args) const)
+ (values nil nil nil))))
+
+;; If FORMS contains exactly one PROGN with an expected shape,
+;; then dump it using fops and return T. Otherwise return NIL.
+(defun fopcompile-constant-init-forms (forms)
+ ;; It should be possible to extend this to allow FORMS to have
+ ;; any number of forms in the requisite shape.
+ (when (and (singleton-p forms)
+ (typep (car forms)
+ '(cons (eql progn) (satisfies list-length))))
+ (let ((forms (cdar forms))
+ (instance)
+ (slot-names)
+ (values))
+ (dolist (form forms
+ (let ((file *compile-object*))
+ (mapc (lambda (x) (dump-object x file)) (nreverse values))
+ (dump-object (cons (length slot-names) (nreverse slot-names))
+ file)
+ (dump-object instance file)
+ (sb!fasl::dump-fop 'sb!fasl::fop-initialize-instance file)
+ t))
+ (multiple-value-bind (obj slot val)
+ (trivial-load-form-initform-args form)
+ (unless (if instance
+ (eq obj instance)
+ (typep (setq instance obj) 'instance))
+ (return nil))
+ ;; invoke recursive MAKE-LOAD-FORM stuff as necessary
+ (find-constant val)
+ (push slot slot-names)
+ (push val values))))))
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index defcb20..2cbd0eb 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -2049,8 +2049,8 @@ SPEED and COMPILATION-SPEED optimization values, and the
(catch constant
(fasl-note-handle-for-constant
constant
- (compile-load-time-value
- creation-form)
+ (or (fopcompile-allocate-instance creation-form)
+ (compile-load-time-value creation-form))
*compile-object*)
nil)
(compiler-error "circular references in creation form for ~S"
@@ -2062,7 +2062,8 @@ SPEED and COMPILATION-SPEED optimization values, and the
(loop for (name form) on (cdr info) by #'cddr
collect name into names
collect form into forms
- finally (compile-make-load-form-init-forms forms))
+ finally (or (fopcompile-constant-init-forms forms)
+ (compile-make-load-form-init-forms forms)))
nil)))
(when circular-ref
(setf (cdr circular-ref)
diff --git a/tests/dump.impure-cload.lisp b/tests/dump.impure-cload.lisp
index 3ca7432..88a1e62 100644
--- a/tests/dump.impure-cload.lisp
+++ b/tests/dump.impure-cload.lisp
@@ -20,10 +20,10 @@
;;; an infinite loop. Douglas Crosher reported a patch 27 Dec 1999.
;;; The patch was tested on SBCL by Martin Atzmueller 2 Nov 2000, and
;;; merged in sbcl-0.6.8.11.
-(defun q-dg1999-1 () (dolist (x '#1=("A" "B" . #1#)) x))
-(defun q-dg1999-2 () (dolist (x '#1=("C" "D" . #1#)) x))
-(defun q-dg1999-3 () (dolist (x '#1=("E" "F" . #1#)) x))
-(defun q-dg1999-4 () (dolist (x '#1=("C" "D" . #1#)) x))
+(defun q-dg1999-1 () (dolist (x '#1=("A" "B" . #1#)) (progn x)))
+(defun q-dg1999-2 () (dolist (x '#1=("C" "D" . #1#)) (progn x)))
+(defun q-dg1999-3 () (dolist (x '#1=("E" "F" . #1#)) (progn x)))
+(defun q-dg1999-4 () (dolist (x '#1=("C" "D" . #1#)) (progn x)))
(defun useful-dg1999 (keys)
(declare (type list keys))
(loop
@@ -138,6 +138,9 @@
;; Preparation for more MAKE-LOAD-FORM tests
(eval-when (:compile-toplevel :load-toplevel :execute)
+ (locally
+ ;; this file's global SPEED proclamation generates a lot of unwanted noise
+ (declare (optimize (speed 1)))
(defstruct airport
name code
(latitude nil :type double-float)
@@ -218,7 +221,7 @@
(s1-friends c) (list a b))
(list a b c))))
-) ; end EVAL-WHEN
+)) ; end EVAL-WHEN
(with-test (:name :load-form-canonical-p)
(let ((foo (make-foo :x 'x :y 'y)))
@@ -243,11 +246,12 @@
(defparameter *metadata* '#.(compute-tangled-stuff))
(test-util:with-test (:name :make-load-form-huge-vector)
- (assert (equalp (compute-airports (length *airport-vector*))
+ (assert (equalp (compute-airports (length (the vector *airport-vector*)))
*airport-vector*)))
(test-util:with-test (:name :make-load-form-circular-hair)
(let ((testcase (compute-tangled-stuff)))
+ (declare (optimize (speed 1)))
;; MAKE-LOAD-FORM discards the value of the CDF slot of one structure.
;; This probably isn't something "reasonable" to do, but it indicates
;; that :JUST-DUMP-IT-NORMALLY was correctly not used.
@@ -262,6 +266,7 @@
(children :initarg :children :accessor node-children)))
(defmethod print-object ((self twp) stream)
+ (declare (optimize (speed 0))) ; silence noise
(format stream "#<Node ~A~@[->~A~]>"
(node-name self)
(handler-case (mapcar 'node-name (node-children self))
@@ -277,10 +282,11 @@
;; initialization form
`(setf (node-parent ',x) ',(slot-value x 'parent))))
- (defun make-tree-from-spec (specs)
+ (defun make-tree-from-spec (node-class specs)
(let ((tree (make-hash-table)))
(dolist (node-name (remove-duplicates (apply #'append specs)))
- (setf (gethash node-name tree) (make-instance 'twp :name node-name)))
+ (setf (gethash node-name tree)
+ (make-instance node-class :name node-name)))
(dolist (node-spec specs)
(let ((par (gethash (car node-spec) tree))
(kids (mapcar (lambda (x) (gethash x tree)) (cdr node-spec))))
@@ -301,6 +307,7 @@
(defvar *x*
#.(make-tree-from-spec
+ 'twp
'((root a b c f)
(a x y)
(b p q r s)
@@ -308,3 +315,41 @@
(with-test (:name :tree-with-parent-hand-made-load-form)
(verify-tree *x*))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass twp2 (twp) ())
+ (defmethod make-load-form ((x twp2) &optional environment)
+ (declare (ignore environment))
+ (make-load-form-saving-slots x))
+ (defvar *call-tracker* nil)
+ (defun call-tracker (f &rest args)
+ (push f *call-tracker*)
+ (apply (the function f) args))
+ (defvar *track-funs*
+ 'sb-c::(fopcompile-allocate-instance
+ fopcompile-constant-init-forms
+ compile-make-load-form-init-forms))
+ (dolist (f *track-funs*)
+ (sb-int:encapsulate f 'track #'call-tracker)))
+
+;; Same as *X* but the MAKE-LOAD-FORM method is different
+(defvar *y*
+ #.(make-tree-from-spec
+ 'twp2
+ '((root a b c f)
+ (a x y)
+ (b p q r s)
+ (c d e g))))
+
+(eval-when (:compile-toplevel)
+ (dolist (f *track-funs*)
+ (sb-int:unencapsulate f 'track))
+ (assert (= 14 (count #'sb-c::fopcompile-allocate-instance
+ *call-tracker*)))
+ (assert (= 14 (count #'sb-c::fopcompile-constant-init-forms
+ *call-tracker*)))
+ (assert (not (find #'sb-c::compile-make-load-form-init-forms
+ *call-tracker*))))
+
+(with-test (:name :tree-with-parent-m-l-f-s-s)
+ (verify-tree *y*))
diff --git a/tests/test-util.lisp b/tests/test-util.lisp
index 7ec458c..3596e3b 100644
--- a/tests/test-util.lisp
+++ b/tests/test-util.lisp
@@ -93,7 +93,8 @@
(ignore-errors (sb-thread:join-thread thread))))
(dolist (thread (sb-thread:list-all-threads))
(unless (or (not (sb-thread:thread-alive-p thread))
- (eql thread sb-thread:*current-thread*)
+ (eql (the sb-thread:thread thread)
+ sb-thread:*current-thread*)
(member thread ,threads)
(sb-thread:thread-ephemeral-p thread))
(setf any-leftover thread)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|