From: Nikodemus S. <de...@us...> - 2007-12-09 14:37:41
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv3470/src/compiler Modified Files: checkgen.lisp ir1opt.lisp srctran.lisp Log Message: 1.0.12.18: faster member-type operations * XSET is a generic set implementation, that uses lists of small sets, and switches to hashes for larger ones. Current switchoff point is 12 -- but some operations would benefit from a larger one. TODO: There are other places in SBCL that will probably want to use XSET as well. * Instead of storing members directly in the set object, store them in an XSET -- except for floating point zeros which go into a list of their own, simplifying the canonicalization a bit. (By adding complexity elsewhere, of course. Maybe this is not TRT after all...) * ...now member type arithmetic is mostly O(1) or O(N), instead of O(BAD), but some operations cons more then before: old implemenation manageg eg. union without consing when either set was the subset of the other one -- not so anymore. Index: checkgen.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/checkgen.lisp,v retrieving revision 1.46 retrieving revision 1.47 diff -u -d -r1.46 -r1.47 --- checkgen.lisp 26 Nov 2007 18:06:07 -0000 1.46 +++ checkgen.lisp 9 Dec 2007 14:37:23 -0000 1.47 @@ -59,7 +59,7 @@ (compound-type (reduce #'+ (compound-type-types type) :key 'type-test-cost)) (member-type - (* (length (member-type-members type)) + (* (member-type-size type) (fun-guessed-cost 'eq))) (numeric-type (* (if (numeric-type-complexp type) 2 1) Index: ir1opt.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v retrieving revision 1.125 retrieving revision 1.126 diff -u -d -r1.125 -r1.126 --- ir1opt.lisp 19 Oct 2007 13:57:11 -0000 1.125 +++ ir1opt.lisp 9 Dec 2007 14:37:23 -0000 1.126 @@ -60,7 +60,7 @@ ((or (null current) (eq res *wild-type*)) res))) (t - (node-derived-type (lvar-uses lvar)))))) + (node-derived-type uses))))) ;;; Return the derived type for LVAR's first value. This is guaranteed ;;; not to be a VALUES or FUNCTION type. @@ -182,7 +182,7 @@ (lambda-var-p (ref-leaf node))) (let ((type (single-value-type int))) (when (and (member-type-p type) - (null (rest (member-type-members type)))) + (eql 1 (member-type-size type))) (change-ref-leaf node (find-constant (first (member-type-members type))))))) (reoptimize-lvar lvar))))) @@ -1444,8 +1444,8 @@ *policy*))) (setf (cast-type-to-check cast) *wild-type*) (substitute-lvar-uses value arg - ;; FIXME - t) + ;; FIXME + t) (%delete-lvar-use ref) (add-lvar-use cast lvar))))) (setf (node-derived-type ref) *wild-type*) @@ -1550,7 +1550,6 @@ ;;; right here. (defun propagate-local-call-args (call fun) (declare (type combination call) (type clambda fun)) - (unless (or (functional-entry-fun fun) (lambda-optional-dispatch fun)) (let* ((vars (lambda-vars fun)) Index: srctran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v retrieving revision 1.151 retrieving revision 1.152 diff -u -d -r1.151 -r1.152 --- srctran.lisp 30 Sep 2007 23:18:51 -0000 1.151 +++ srctran.lisp 9 Dec 2007 14:37:23 -0000 1.152 @@ -925,11 +925,13 @@ (if (member-type-p arg) ;; Run down the list of members and convert to a list of ;; member types. - (dolist (member (member-type-members arg)) - (push (if (numberp member) - (make-member-type :members (list member)) - *empty-type*) - new-args)) + (mapc-member-type-members + (lambda (member) + (push (if (numberp member) + (make-member-type :members (list member)) + *empty-type*) + new-args)) + arg) (push arg new-args))) (unless (member *empty-type* new-args) new-args))))) @@ -1088,25 +1090,23 @@ ;;; XXX This would be far simpler if the type-union methods could handle ;;; member/number unions. (defun make-canonical-union-type (type-list) - (let ((members '()) + (let ((xset (alloc-xset)) + (fp-zeroes '()) (misc-types '())) (dolist (type type-list) - (if (member-type-p type) - (setf members (union members (member-type-members type))) - (push type misc-types))) - #!+long-float - (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)) - (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) - (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) - (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) - (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) - (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) - (if members - (apply #'type-union (make-member-type :members members) misc-types) - (apply #'type-union misc-types)))) + (cond ((member-type-p type) + (mapc-member-type-members + (lambda (member) + (if (fp-zero-p member) + (unless (member member fp-zeroes) + (pushnew member fp-zeroes)) + (add-to-xset member xset))) + type)) + (t + (push type misc-types)))) + (if (and (xset-empty-p xset) (not fp-zeroes)) + (apply #'type-union misc-types) + (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types)))) ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) @@ -3888,17 +3888,16 @@ ;; we're prepared to handle which is basically something ;; that array-element-type can return. (or (and (member-type-p cons-type) - (null (rest (member-type-members cons-type))) + (eql 1 (member-type-size cons-type)) (null (first (member-type-members cons-type)))) (let ((car-type (cons-type-car-type cons-type))) (and (member-type-p car-type) - (null (rest (member-type-members car-type))) - (or (symbolp (first (member-type-members car-type))) - (numberp (first (member-type-members car-type))) - (and (listp (first (member-type-members - car-type))) - (numberp (first (first (member-type-members - car-type)))))) + (eql 1 (member-type-members car-type)) + (let ((elt (first (member-type-members car-type)))) + (or (symbolp elt) + (numberp elt) + (and (listp elt) + (numberp (first elt))))) (good-cons-type-p (cons-type-cdr-type cons-type)))))) (unconsify-type (good-cons-type) ;; Convert the "printed" respresentation of a cons @@ -3949,10 +3948,15 @@ ;; (DOUBLE-FLOAT 10d0 20d0) instead of just ;; double-float. (cond ((member-type-p type) - (let ((members (member-type-members type))) - (if (every #'coerceable-p members) - (specifier-type `(or ,@members)) - *universal-type*))) + (block punt + (let (members) + (mapc-member-type-members + (lambda (member) + (if (coerceable-p member) + (push member members) + (return-from punt *universal-type*))) + type) + (specifier-type `(or ,@members))))) ((and (cons-type-p type) (good-cons-type-p type)) (let ((c-type (unconsify-type (type-specifier type)))) |