From: Christophe Rhodes Date: Tue, 4 May 2004 17:25:58 +0000 (+0000) Subject: 0.8.10.11: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=25422d88edd9bf712206aee5143a4f952981b4d5;p=sbcl.git 0.8.10.11: Merge fixed version of "slightly faster compile/load" (CSR sbcl-devel 2004-04-22) ... fasls c. 10% smaller; ... make.sh build time c. 5% faster. --- diff --git a/NEWS b/NEWS index 786c2f8..cdc1a20 100644 --- a/NEWS +++ b/NEWS @@ -2418,6 +2418,10 @@ changes in sbcl-0.8.11 relative to sbcl-0.8.10: *PRINT-READABLY* is true, signal PRINT-NOT-READABLE if the string does not have array-element-type equal to the most general string type. + * optimization: rearranged the expansion of various defining macros + so that each expands into only one top-level form in a + :LOAD-TOPLEVEL context; this appears to decrease fasl sizes by + approximately 10%. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 7f66431..699bb23 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -272,7 +272,10 @@ ;;;; DEFINE-CONDITION (eval-when (:compile-toplevel :load-toplevel :execute) -(defun %compiler-define-condition (name direct-supers layout) +(defun %compiler-define-condition (name direct-supers layout + all-readers all-writers) + (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers)) + (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers)) (multiple-value-bind (class old-layout) (insured-find-classoid name #'condition-classoid-p @@ -313,7 +316,6 @@ (remove-if-not #'condition-classoid-p (std-compute-class-precedence-list class)))) (values)) - ) ; EVAL-WHEN ;;; Compute the effective slots of CLASS, copying inherited slots and @@ -365,7 +367,9 @@ (lambda (new-value condition) (condition-writer-function condition new-value slot-name)))) -(defun %define-condition (name slots documentation report default-initargs) +(defun %define-condition (name parent-types layout slots documentation + report default-initargs all-readers all-writers) + (%compiler-define-condition name parent-types layout all-readers all-writers) (let ((class (find-classoid name))) (setf (condition-classoid-slots class) slots) (setf (condition-classoid-report class) report) @@ -522,17 +526,19 @@ (error "unknown option: ~S" (first option))))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (%compiler-define-condition ',name ',parent-types ',layout)) - - (declaim (ftype (function (t) t) ,@(all-readers))) - (declaim (ftype (function (t t) t) ,@(all-writers))) - - (%define-condition ',name - (list ,@(slots)) - ,documentation - ,report - (list ,@default-initargs)))))) + (eval-when (:compile-toplevel) + (%compiler-define-condition ',name ',parent-types ',layout + ',(all-readers) ',(all-writers))) + (eval-when (:load-toplevel :execute) + (%define-condition ',name + ',parent-types + ',layout + (list ,@(slots)) + ,documentation + ,report + (list ,@default-initargs) + ',(all-readers) + ',(all-writers))))))) ;;;; DESCRIBE on CONDITIONs diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 149997f..625e979 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -151,7 +151,7 @@ "Define a function at top level." #+sb-xc-host (unless (symbol-package (fun-name-block-name name)) - (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name)) + (warn "DEFUN of uninterned function name ~S (tricky for GENESIS)" name)) (multiple-value-bind (forms decls doc) (parse-body body) (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA (lambda-guts `(,args @@ -159,7 +159,7 @@ (block ,(fun-name-block-name name) ,@forms))) (lambda `(lambda ,@lambda-guts)) - #-sb-xc-host + #-sb-xc-host (named-lambda `(named-lambda ,name ,@lambda-guts)) (inline-lambda (when (inline-fun-name-p name) @@ -172,9 +172,8 @@ name) nil))))) `(progn - - ;; In cross-compilation of toplevel DEFUNs, we arrange - ;; for the LAMBDA to be statically linked by GENESIS. + ;; In cross-compilation of toplevel DEFUNs, we arrange for + ;; the LAMBDA to be statically linked by GENESIS. ;; ;; It may seem strangely inconsistent not to use NAMED-LAMBDA ;; here instead of LAMBDA. The reason is historical: @@ -183,22 +182,25 @@ #+sb-xc-host (cold-fset ,name ,lambda) - (eval-when (:compile-toplevel :load-toplevel :execute) + (eval-when (:compile-toplevel) (sb!c:%compiler-defun ',name ',inline-lambda)) + (eval-when (:load-toplevel :execute) + (%defun ',name + ;; In normal compilation (not for cold load) this is + ;; where the compiled LAMBDA first appears. In + ;; cross-compilation, we manipulate the + ;; previously-statically-linked LAMBDA here. + #-sb-xc-host ,named-lambda + #+sb-xc-host (fdefinition ',name) + ,doc + ',inline-lambda)))))) - (%defun ',name - ;; In normal compilation (not for cold load) this is - ;; where the compiled LAMBDA first appears. In - ;; cross-compilation, we manipulate the - ;; previously-statically-linked LAMBDA here. - #-sb-xc-host ,named-lambda - #+sb-xc-host (fdefinition ',name) - ,doc))))) #-sb-xc-host -(defun %defun (name def doc) +(defun %defun (name def doc inline-lambda) (declare (type function def)) (declare (type (or null simple-string) doc)) (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN + (sb!c:%compiler-defun name inline-lambda) (when (fboundp name) (/show0 "redefining NAME in %DEFUN") (style-warn "redefining ~S in DEFUN" name)) @@ -223,13 +225,10 @@ value, the old value is not clobbered. The third argument is an optional documentation string for the variable." `(progn - (declaim (special ,var)) - ,@(when valp - `((unless (boundp ',var) - (set ',var ,val)))) - ,@(when docp - `((setf (fdocumentation ',var 'variable) ',doc ))) - ',var)) + (eval-when (:compile-toplevel) + (%compiler-defvar ',var)) + (eval-when (:load-toplevel :execute) + (%defvar ',var (unless (boundp ',var) ,val) ',valp ,doc ',docp)))) (defmacro-mundanely defparameter (var val &optional (doc nil docp)) #!+sb-doc @@ -239,11 +238,31 @@ previous value. The third argument is an optional documentation string for the parameter." `(progn - (declaim (special ,var)) - (set ',var ,val) - ,@(when docp - `((setf (fdocumentation ',var 'variable) ',doc))) - ',var)) + (eval-when (:compile-toplevel) + (%compiler-defvar ',var)) + (eval-when (:load-toplevel :execute) + (%defparameter ',var ,val ,doc ',docp)))) + +(defun %compiler-defvar (var) + (sb!xc:proclaim `(special ,var))) + +#-sb-xc-host +(defun %defvar (var val valp doc docp) + (%compiler-defvar var) + (when valp + (unless (boundp var) + (set var val))) + (when docp + (setf (fdocumentation var 'variable) doc)) + var) + +#-sb-xc-host +(defun %defparameter (var val doc docp) + (%compiler-defvar var) + (set var val) + (when docp + (setf (fdocumentation var 'variable) doc)) + var) ;;;; iteration constructs @@ -632,8 +651,11 @@ ;; functions appearing in fundamental defining ;; macro expansions: %compiler-deftype + %compiler-defvar %defun %defsetf + %defparameter + %defvar sb!c:%compiler-defun sb!c::%define-symbol-macro sb!c::%defconstant diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index 22cc82f..15cf2d0 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -76,7 +76,7 @@ ;;; versions which break binary compatibility. But it certainly should ;;; be incremented for release versions which break binary ;;; compatibility. -(def!constant +fasl-file-version+ 48) +(def!constant +fasl-file-version+ 49) ;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so) ;;; 38: (2003-01-05) changed names of internal SORT machinery ;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to @@ -105,7 +105,8 @@ ;;; 47: (2003-11-30) Static variables were rearranged in 0.8.6.11. ;;; 48: (2004-03-01) Renumbered all the widetags to allow for more ;;; microefficiency in sbcl-0.8.8.10 - +;;; 49: (2004-05-04) Changed implementation of DEFFOO macros and the +;;; functions they expand to. ;;; the conventional file extension for our fasl files (declaim (type simple-string *fasl-file-type*)) diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index e4634f8..943eb2e 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -112,7 +112,7 @@ ;; an encapsulation that no longer exists. (let ((info (make-encapsulation-info type (fdefn-fun fdefn)))) (setf (fdefn-fun fdefn) - (named-lambda encapsulate (&rest arg-list) + (named-lambda encapsulation (&rest arg-list) (declare (special arg-list)) (let ((basic-definition (encapsulation-info-definition info))) (declare (special basic-definition)) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 4226df5..ddd3f0a 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -99,20 +99,11 @@ *the-class-structure-class*)))))) (let ((defclass-form `(progn - ,@(mapcar (lambda (x) - `(declaim (ftype (function (t) t) ,x))) - *readers-for-this-defclass*) - ,@(mapcar (lambda (x) - `(declaim (ftype (function (t t) t) ,x))) - *writers-for-this-defclass*) - ,@(mapcar (lambda (x) - `(declaim (ftype (function (t) t) - ,(slot-reader-name x) - ,(slot-boundp-name x)) - (ftype (function (t t) t) - ,(slot-writer-name x)))) - *slot-names-for-this-defclass*) (let ,(mapcar #'cdr *initfunctions-for-this-defclass*) + (%compiler-defclass ',name + ',*readers-for-this-defclass* + ',*writers-for-this-defclass* + ',*slot-names-for-this-defclass*) (load-defclass ',name ',metaclass ',supers @@ -158,8 +149,21 @@ ;; full-blown class, so the "a class of this name is ;; coming" note we write here would be irrelevant. (eval-when (:compile-toplevel) - (preinform-compiler-about-class-type ',name)) - ,defclass-form)))))))) + (%compiler-defclass ',name + ',*readers-for-this-defclass* + ',*writers-for-this-defclass* + ',*slot-names-for-this-defclass*)) + (eval-when (:load-toplevel :execute) + ,defclass-form))))))))) + +(defun %compiler-defclass (name readers writers slot-names) + (preinform-compiler-about-class-type name) + (proclaim `(ftype (function (t) t) + ,@readers + ,@(mapcar #'slot-reader-name slot-names) + ,@(mapcar #'slot-boundp-name slot-names))) + (proclaim `(ftype (function (t t) t) + ,@writers ,@(mapcar #'slot-writer-name slot-names)))) (defun make-initfunction (initform) (cond ((or (eq initform t) diff --git a/version.lisp-expr b/version.lisp-expr index 5853163..d52bfde 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.10.10" +"0.8.10.11"