From c12b72591adbf77d62762de23bd557dd946cc536 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Thu, 5 Feb 2015 23:03:48 -0500 Subject: [PATCH] Make type caches perform better. This change "interns" a chosen few parsed type specifiers, importantly (CONS T T), NULL, and BOOLEAN, so that exactly one of each exists, thereby reducing TYPE= to EQ in the affirmative case. In addition to producing less garbage, the compiler runs 3% to 4% faster on several files from its own sources. --- NEWS | 6 ++++ src/code/early-type.lisp | 72 ++++++++++++++++++++++++++----------------- src/code/late-type.lisp | 64 ++++++++++++++++++++++++++++++++------ src/code/primordial-type.lisp | 30 +++++++++++++++++- src/code/xset.lisp | 10 +++++- src/compiler/node.lisp | 3 ++ tests/compiler.pure.lisp | 5 ++- tests/type.impure.lisp | 14 +++++++++ 8 files changed, 163 insertions(+), 41 deletions(-) diff --git a/NEWS b/NEWS index dcc925193..a29029e28 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,11 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.2.8: + * optimization: The compiler's treatment of type specifiers makes + it slightly faster and more memory-efficient. Portable code + should be indifferent to this change, however, users of + SB-INTROSPECT:FUNCTION-TYPE might notice that (MEMBER T NIL) + and (MEMBER NIL T) are both internally collapsed to the former, + so that the latter can never be obtained as part of an FTYPE. * bug fix: compiler no longer signals an error when compiling certain nested local calls. (lp#1416704, lp#404441) * bug fix: more robust debugger and backtraces. (lp#1413850, lp#1099500, diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 762f81d5b..2797eac27 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -19,6 +19,7 @@ ;;; the original type spec. (defstruct (hairy-type (:include ctype (class-info (type-class-or-lose 'hairy))) + (:constructor %make-hairy-type (specifier)) (:copier nil) #!+cmu (:pure nil)) ;; the Common Lisp type-specifier of the type we represent @@ -407,32 +408,41 @@ ;; compared by EQL). -- CSR, 2003-04-23 (let ((presence 0) (unpaired nil) - (union-types nil)) - (dotimes (pass 2) - (dolist (z fp-zeroes) - (let ((sign (if (minusp (nth-value 2 (integer-decode-float z))) 1 0)) - (pair-idx - (etypecase z - (single-float 0) - (double-float 2 - #!+long-float (long-float 4))))) - (if (= pass 0) - (setf (ldb (byte 1 (+ pair-idx sign)) presence) 1) - (if (= (ldb (byte 2 pair-idx) presence) #b11) - (when (= sign 0) - (push (ctype-of z) union-types)) - (push z unpaired)))))) + (float-types nil)) + (when fp-zeroes ; avoid doing two passes of nothing + (dotimes (pass 2) + (dolist (z fp-zeroes) + (let ((sign (if (minusp (nth-value 2 (integer-decode-float z))) 1 0)) + (pair-idx + (etypecase z + (single-float 0) + (double-float 2 + #!+long-float (long-float 4))))) + (if (= pass 0) + (setf (ldb (byte 1 (+ pair-idx sign)) presence) 1) + (if (= (ldb (byte 2 pair-idx) presence) #b11) + (when (= sign 0) + (push (ctype-of z) float-types)) + (push z unpaired))))))) ;; The actual member-type contains the XSET (with no FP zeroes), ;; and a list of unpaired zeroes. - (let ((member-type (unless (and (xset-empty-p xset) (not unpaired)) - (%make-member-type xset unpaired)))) - (cond (union-types - (make-union-type t (if member-type - (cons member-type union-types) - union-types))) - (member-type) - (t - *empty-type*))))) + (let ((member-type + (cond ((and (not unpaired) (equal (xset-data xset) '(nil))) + *null-type*) + ((and (not unpaired) + ;; Semantically this is fine - XSETs + ;; are not order-preserving except by accident + ;; (when not represented as a hash-table). + (or (equal (xset-data xset) '(t nil)) + (equal (xset-data xset) '(nil t)))) + *boolean-type*) + ((or unpaired (not (xset-empty-p xset))) + (%make-member-type xset unpaired))))) + (if float-types + (make-union-type t (if member-type + (cons member-type float-types) + float-types)) + (or member-type *empty-type*))))) (defun member-type-size (type) (+ (length (member-type-fp-zeroes type)) @@ -524,10 +534,16 @@ (defun make-cons-type (car-type cdr-type) (aver (not (or (eq car-type *wild-type*) (eq cdr-type *wild-type*)))) - (if (or (eq car-type *empty-type*) - (eq cdr-type *empty-type*)) - *empty-type* - (%make-cons-type car-type cdr-type))) + (cond ((or (eq car-type *empty-type*) + (eq cdr-type *empty-type*)) + *empty-type*) + ;; It's not a requirement that (CONS T T) be interned, + ;; but it improves the hit rate in the function caches. + ((and (type= car-type *universal-type*) + (type= cdr-type *universal-type*)) + *cons-t-t-type*) + (t + (%make-cons-type car-type cdr-type)))) (defun cons-type-length-info (type) (declare (type cons-type type)) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index d2526a5b8..beb6834ad 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -964,6 +964,11 @@ ;;; definitely correct. NIL is considered to intersect with any type. ;;; If T is a subtype of either type, then we also return T, T. This ;;; way we recognize that hairy types might intersect with T. +;;; +;;; Well now given the statement above that this is "useful for ..." +;;; a particular thing, I see how treating *empty-type* magically could +;;; be useful, however given all the _other_ calls to this function within +;;; this file, it seems suboptimal, because logically it is wrong. (defun types-equal-or-intersect (type1 type2) (declare (type ctype type1 type2)) (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) @@ -1082,10 +1087,8 @@ other-types))) (if distributed (apply #'type-union distributed) - (make-hairy-type - :specifier `(and ,@(map 'list - #'type-specifier - simplified-types))))) + (%make-hairy-type `(and ,@(map 'list #'type-specifier + simplified-types))))) (cond ((null simplified-types) *universal-type*) ((null (cdr simplified-types)) (car simplified-types)) @@ -1139,6 +1142,8 @@ ;; extended sequence hierarchy. (Might be removed later if we use ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.) (frob extended-sequence *extended-sequence-type*)) + (setf *satisfies-keywordp-type* (%make-hairy-type '(satisfies keywordp))) + (setf *fun-name-type* (%make-hairy-type '(satisfies legal-fun-name-p))) (setf *universal-fun-type* (make-fun-type :wild-args t :returns *wild-type*))) @@ -1430,9 +1435,31 @@ (!define-type-method (hairy :simple-intersection2 :complex-intersection2) (type1 type2) - (if (type= type1 type2) - type1 - nil)) + (cond ((type= type1 type2) + type1) + ((eq type2 *satisfies-keywordp-type*) + ;; (AND (MEMBER A) (SATISFIES KEYWORDP)) is possibly non-empty + ;; if A is re-homed as :A. However as a special case that really + ;; does occur, (AND (MEMBER NIL) (SATISFIES KEYWORDP)) + ;; is empty because of the illegality of changing NIL's package. + (if (eq type1 *null-type*) + *empty-type* + (multiple-value-bind (answer certain) + (types-equal-or-intersect type1 (specifier-type 'symbol)) + (if (and (not answer) certain) + *empty-type* + nil)))) + ((eq type2 *fun-name-type*) + (multiple-value-bind (answer certain) + (types-equal-or-intersect type1 (specifier-type 'symbol)) + (if (and (not answer) certain) + (multiple-value-bind (answer certain) + (types-equal-or-intersect type1 (specifier-type 'cons)) + (if (and (not answer) certain) + *empty-type* + nil)) + nil))) + (t nil))) (!define-type-method (hairy :simple-union2) (type1 type2) @@ -1456,9 +1483,12 @@ :datum predicate-name :expected-type 'symbol :format-control "The SATISFIES predicate name is not a symbol: ~S" - :format-arguments (list predicate-name)))) - ;; Create object. - (make-hairy-type :specifier whole)) + :format-arguments (list predicate-name))) + ;; Create object. + (case predicate-name + (keywordp *satisfies-keywordp-type*) + (legal-fun-name-p *fun-name-type*) + (t (%make-hairy-type whole))))) ;;;; negation types @@ -2779,6 +2809,16 @@ used for a COMPLEX component.~:@>" (!define-type-class member :enumerable t :might-contain-other-types nil) +;; this is ridiculously order-sensitive: the DEFSTRUCT is in 'early-type' +;; as is MAKE-MEMBER-TYPE, the only user of *NULL-TYPE*. +;; But the type-class is here, and you can't make a CTYPE object +;; until a type-class exists for it. Type-classes are akin to layouts, +;; and ought to be as primordial, and dumped during Genesis. +;; I have a patch to do exactly that, but until then... +(!cold-init-forms + (setf *null-type* (%make-member-type (xset-from-list '(nil)) nil) + *boolean-type* (%make-member-type (xset-from-list '(t nil)) nil))) + (!define-type-method (member :negate) (type) (let ((xset (member-type-xset type)) (fp-zeroes (member-type-fp-zeroes type))) @@ -3247,6 +3287,10 @@ used for a COMPLEX component.~:@>" (!define-type-class cons :enumerable nil :might-contain-other-types nil) +;; Another order-sensitive form. See related note at MEMBER type-class. +(!cold-init-forms + (setf *cons-t-t-type* (%make-cons-type *universal-type* *universal-type*))) + (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) (let ((car-type (single-value-specifier-type car-type-spec)) (cdr-type (single-value-specifier-type cdr-type-spec))) diff --git a/src/code/primordial-type.lisp b/src/code/primordial-type.lisp index 3e01d39b7..0696c07a1 100644 --- a/src/code/primordial-type.lisp +++ b/src/code/primordial-type.lisp @@ -14,14 +14,42 @@ (!defglobal *type-system-initialized* nil) ;; These are set by cold-init-forms in 'late-type' (look for "macrolet frob"). +;; It is a requirement of the type machinery that there be +;; exactly one instance of each of these, which is to say, +;; any type named T is exactly EQ to *UNIVERSAL-TYPE*, etc. (defglobal *wild-type* -1) (defglobal *empty-type* -1) (defglobal *universal-type* -1) -(defglobal *universal-fun-type* -1) (defglobal *instance-type* -1) (defglobal *funcallable-instance-type* -1) (defglobal *extended-sequence-type* -1) +;; Unlike the above, this one is not a NAMED-TYPE, and as such +;; does not have to be a singleton, but it improves efficiency. +;; (Except that we never really need it for anything) +(defglobal *universal-fun-type* -1) + +;; These need not be singletons, but again it is more efficient +;; when there is only a single instance of each. +(defglobal *cons-t-t-type* -1) +(defglobal *null-type* -1) +(defglobal *boolean-type* -1) + +;; This one is used when parsing (SATISFIES KEYWORDP) +;; so that simplifications can be made whe computing intersections, +;; without which we would see this kind of "empty-type in disguise" +;; (AND (SATISFIES KEYWORDP) CONS) +;; This isn't *keyword-type* because KEYWORD is implemented +;; as the intersection of SYMBOL and (SATISFIES KEYWORDP) +;; We could also intern the KEYWORD type but that would require +;; hacking the INTERSECTION logic. +(defglobal *satisfies-keywordp-type* -1) + +;; Here too I discovered more than 1000 instances in a particular +;; Lisp image, when really this is *EMPTY-TYPE*. +;; (AND (SATISFIES LEGAL-FUN-NAME-P) (SIMPLE-ARRAY CHARACTER (*))) +(defglobal *fun-name-type* -1) + ;;; a vector that maps type codes to layouts, used for quickly finding ;;; the layouts of built-in classes (defglobal **built-in-class-codes** #()) ; initialized in cold load diff --git a/src/code/xset.lisp b/src/code/xset.lisp index 4c65e71f8..6b754436b 100644 --- a/src/code/xset.lisp +++ b/src/code/xset.lisp @@ -9,7 +9,7 @@ ;;;; XSET ;;;; -;;;; A somewhat effcient set implementation that can store arbitrary +;;;; A somewhat efficient set implementation that can store arbitrary ;;;; objects. For small sets the data is stored in a list, but when ;;;; the amount of elements grows beyond +XSET-LIST-SIZE-LIMIT+, we ;;;; switch to a hash-table instead. @@ -69,6 +69,14 @@ (setf (xset-data xset) table))) (setf (gethash elt data) t)))) +;; items must be canonical - no duplicates - and few in number. +(defun xset-from-list (items) + (let ((n (length items))) + (aver (<= n +xset-list-size-limit+)) + (let ((xset (alloc-xset))) + (setf (xset-list-size xset) n (xset-data xset) items) + xset))) + (defun xset-union (a b) (let ((xset (alloc-xset))) (map-xset (lambda (x) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 226b8b598..dd5c12591 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -612,6 +612,9 @@ ;; See also the LEAF-DEBUG-NAME function and the ;; FUNCTIONAL-%DEBUG-NAME slot. (%source-name (missing-arg) + ;; I guess we state the type this way to avoid calling + ;; LEGAL-FUN-NAME-P unless absolutely necessary, + ;; but this seems a bit of a premature optimization. :type (or symbol (and cons (satisfies legal-fun-name-p))) :read-only t) ;; the type which values of this leaf must have diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index d3831f15c..a19c1507d 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3780,7 +3780,10 @@ (with-test (:name :bug-384892) (assert (equal - '(function (fixnum fixnum &key (:k1 (member nil t))) + ;; The assertion that BOOLEAN becomes (MEMBER T NIL) + ;; is slightly brittle, but the rest of the + ;; assertion is ok. + '(function (fixnum fixnum &key (:k1 (member t nil))) (values (member t) &optional)) (sb-kernel:%simple-fun-type (compile nil `(lambda (x y &key k1) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 95c8770b1..d628772e9 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -961,4 +961,18 @@ (or (typep ,g '(and array (not (array ,excluded-type)))) (typep ,g 'fixnum)))))))) +(with-test (:name :interned-type-specifiers) + (dolist (specifier '((satisfies keywordp) ; not the same as KEYWORD + boolean + cons + null)) + ;; In general specifiers can repeatedly parse the same due to + ;; the caching in VALUES-SPECIFIER-TYPE provided the entry was + ;; not evicted. Here we want to check a stronger condition, + ;; that they really always parse to the identical object. + (let ((parse1 (sb-kernel:specifier-type specifier))) + (sb-int:drop-all-hash-caches) + (let ((parse2 (sb-kernel:specifier-type specifier))) + (assert (eq parse1 parse2)))))) + ;;; success -- 2.11.4.GIT