From: Nikodemus Siivola Date: Sun, 19 Jun 2011 21:32:05 +0000 (+0300) Subject: globaldb: add source-transforms for INFO functions on host X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=19088e271f3a8566454bc868eaa6acd33f877467;p=sbcl.git globaldb: add source-transforms for INFO functions on host Regular compiler macros defined on host do not take effect when XC is building the target -- so INFO calls in the build before globaldb got the slow path up to now. Using source-transforms we get the fast path for all INFO calls on target. Speeds up globaldb bound functions like FDEFINITION by 20% or so. --- diff --git a/NEWS b/NEWS index 9dae3df..05db33f 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,8 @@ changes relative to sbcl-1.0.56: * optimization: fewer uses of full calls to signed modular functions. (lp#903821) * optimization: typechecking alien values is typically 5 x faster. + * optimization: FDEFINITION, SYMBOL-FUNCTION, MACRO-FUNCTION, and FBOUNDP + are 20% faster. * bug fix: fixed disassembly of some SSE instructions on x86-64. * bug fix: SB-SIMPLE-STREAMS signals an error for bogus :CLASS arguments in OPEN. (lp#969352, thanks to Kambiz Darabi) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index da77f64..d6066c3 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -730,12 +730,6 @@ (volatile-info-env-threshold new))))))))) new-value)) -;;; FIXME: It should be possible to eliminate the hairy compiler macros below -;;; by declaring INFO and (SETF INFO) inline and making a simple compiler macro -;;; for TYPE-INFO-OR-LOSE. (If we didn't worry about efficiency of the -;;; cross-compiler, we could even do it by just making TYPE-INFO-OR-LOSE -;;; foldable.) - ;;; INFO is the standard way to access the database. It's settable. ;;; ;;; Return the information of the specified TYPE and CLASS for NAME. @@ -743,36 +737,18 @@ ;;; recorded. If there is no information, the first value returned is ;;; the default and the second value returned is NIL. (defun info (class type name &optional (env-list nil env-list-p)) - ;; FIXME: At some point check systematically to make sure that the - ;; system doesn't do any full calls to INFO or (SETF INFO), or at - ;; least none in any inner loops. (let ((info (type-info-or-lose class type))) (if env-list-p (get-info-value name (type-info-number info) env-list) (get-info-value name (type-info-number info))))) -#!-sb-fluid -(define-compiler-macro info - (&whole whole class type name &optional (env-list nil env-list-p)) - ;; Constant CLASS and TYPE is an overwhelmingly common special case, - ;; and we can implement it much more efficiently than the general case. - (if (and (keywordp class) (keywordp type)) - (let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*) - (info (type-info-or-lose class type))) - (with-unique-names (value foundp) - `(multiple-value-bind (,value ,foundp) - (get-info-value ,name - ,(type-info-number info) - ,@(when env-list-p `(,env-list))) - (declare (type ,(type-info-type info) ,value)) - (values ,value ,foundp)))) - whole)) (defun (setf info) (new-value class type name &optional (env-list nil env-list-p)) (let* ((info (type-info-or-lose class type)) - (tin (type-info-number info))) - (when (type-info-validate-function info) - (funcall (type-info-validate-function info) name new-value)) + (tin (type-info-number info)) + (validate (type-info-validate-function info))) + (when validate + (funcall validate name new-value)) (if env-list-p (set-info-value name tin @@ -782,45 +758,6 @@ tin new-value))) new-value) -#!-sb-fluid -(progn - ;; Not all xc hosts are happy about SETF compiler macros: CMUCL 19 - ;; does not accept them at all, and older SBCLs give a full warning. - ;; So the easy thing is to hide this optimization from all xc hosts. - #-sb-xc-host - (define-compiler-macro (setf info) - (&whole whole new-value class type name &optional (env-list nil env-list-p)) - ;; Constant CLASS and TYPE is an overwhelmingly common special case, - ;; and we can resolve it much more efficiently than the general - ;; case. - (if (and (keywordp class) (keywordp type)) - (let* ((info (type-info-or-lose class type)) - (tin (type-info-number info))) - (if env-list-p - `(set-info-value ,name - ,tin - ,new-value - (get-write-info-env ,env-list)) - `(set-info-value ,name - ,tin - ,new-value)))) - whole)) - -;;; the maximum density of the hashtable in a volatile env (in -;;; names/bucket) -;;; -;;; FIXME: actually seems to be measured in percent, should be -;;; converted to be measured in names/bucket -(def!constant volatile-info-environment-density 50) - -;;; Make a new volatile environment of the specified size. -(defun make-info-environment (&key (size 42) (name "Unknown")) - (declare (type (integer 1) size)) - (let ((table-size (primify (truncate (* size 100) - volatile-info-environment-density)))) - (make-volatile-info-env :name name - :table (make-array table-size :initial-element nil) - :threshold size))) ;;; Clear the information of the specified TYPE and CLASS for NAME in ;;; the current environment, allowing any inherited info to become @@ -828,14 +765,7 @@ (defun clear-info (class type name) (let ((info (type-info-or-lose class type))) (clear-info-value name (type-info-number info)))) -#!-sb-fluid -(define-compiler-macro clear-info (&whole whole class type name) - ;; Constant CLASS and TYPE is an overwhelmingly common special case, and - ;; we can resolve it much more efficiently than the general case. - (if (and (keywordp class) (keywordp type)) - (let ((info (type-info-or-lose class type))) - `(clear-info-value ,name ,(type-info-number info))) - whole)) + (defun clear-info-value (name type) (declare (type type-number type) (inline assoc)) (with-info-bucket (table index name (get-write-info-env)) @@ -845,6 +775,22 @@ (setf (cdr types) (delete type (cdr types) :key #'car)) t)))) + +;;; the maximum density of the hashtable in a volatile env (in +;;; names/bucket) +;;; +;;; FIXME: actually seems to be measured in percent, should be +;;; converted to be measured in names/bucket +(def!constant volatile-info-environment-density 50) + +;;; Make a new volatile environment of the specified size. +(defun make-info-environment (&key (size 42) (name "Unknown")) + (declare (type (integer 1) size)) + (let ((table-size (primify (truncate (* size 100) + volatile-info-environment-density)))) + (make-volatile-info-env :name name + :table (make-array table-size :initial-element nil) + :threshold size))) ;;;; *INFO-ENVIRONMENT* @@ -1352,6 +1298,62 @@ ,@(reverse *!reversed-type-info-init-forms*)))) (frob)) +;;; Source transforms / compiler macros for INFO functions. +;;; +;;; When building the XC, we give it a source transform, so that it can +;;; compile INFO calls in the target efficiently; we also give it a compiler +;;; macro, so that at least those INFO calls compiled after this file can be +;;; efficient. (Host compiler-macros do not fire when compiling the target, +;;; and source transforms don't fire when building the XC, so we need both.) +;;; +;;; Target needs just one, since there compiler macros and source-transforms +;;; are equivalent. +(macrolet ((def (name lambda-list form) + (aver (member 'class lambda-list)) + (aver (member 'type lambda-list)) + `(progn + #+sb-xc-host + (define-source-transform ,name ,lambda-list + (if (and (keywordp class) (keywordp type)) + ,form + (values nil t))) + (define-compiler-macro ,name ,(append '(&whole .whole.) lambda-list) + (if (and (keywordp class) (keywordp type)) + ,form + .whole.))))) + + (def info (class type name &optional (env-list nil env-list-p)) + (let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*) + (info (type-info-or-lose class type))) + (with-unique-names (value foundp) + `(multiple-value-bind (,value ,foundp) + (get-info-value ,name + ,(type-info-number info) + ,@(when env-list-p (list env-list))) + (declare (type ,(type-info-type info) ,value)) + (values ,value ,foundp))))) + + (def (setf info) (new-value class type name &optional (env-list nil env-list-p)) + (let* (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*) + (info (type-info-or-lose class type)) + (tin (type-info-number info)) + (validate (type-info-validate-function info))) + (with-unique-names (new check) + `(let ((,new ,new-value) + ,@(when validate + `((,check (type-info-validate-function (svref *info-types* ,tin)))))) + ,@(when validate + `((funcall ,check ',name ,new))) + (set-info-value ,name + ,tin + ,new + ,@(when env-list-p + (list `(get-write-info-env ,env-list)))))))) + + (def clear-info (class type name) + (let ((info (type-info-or-lose class type))) + `(clear-info-value ,name ,(type-info-number info))))) + ;;;; a hack for detecting ;;;; (DEFUN FOO (X Y) ;;;; ..