From 4898febe4d3ab2eaa83c26cd4c1ff113772100c4 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 18 Feb 2008 10:05:40 +0000 Subject: [PATCH] 1.0.14.34: slightly less and slightly faster constraint propagation * For negated EQL constaints, don't cons up multiple MEMBER-TYPE instances during a single pass through CONSTRAIN-REF-TYPE: accumulate a single XSET, and turn it into a MEMBER-TYPE only at the end. * Don't construct (NOT (MEMBER ...TON-OF-SYMBOLS...)) types at all, unless SPEED > COMPILATION speed. Knowing that a variable is not in a set of symbols is seldom useful, and compiling large CASE statements with symbols as keys can end up spending huge amounts of time just building these sets. * Adjust FD-STREAMS to use an ECASE in the single place in SBCL where without the aforementioned constraint propagation the compiler is not able to determine sufficiently constrain the result type. (Not needed since the build has SPEED > COMPILATION-SPEED, but keeps things non-brittle.) --- src/code/fd-stream.lisp | 2 +- src/compiler/constraint.lisp | 109 +++++++++++++++++++++++++----------------- version.lisp-expr | 2 +- 3 files changed, 68 insertions(+), 45 deletions(-) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 8d369bd..f6eb756 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -2380,7 +2380,7 @@ ;; Calculate useful stuff. (multiple-value-bind (input output mask) - (case direction + (ecase direction (:input (values t nil sb!unix:o_rdonly)) (:output (values nil t sb!unix:o_wronly)) (:io (values t t sb!unix:o_rdwr)) diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 7c4d623..0b9b694 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -352,57 +352,80 @@ ;;; accordingly. (defun constrain-ref-type (ref constraints in) (declare (type ref ref) (type sset constraints in)) + ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to + ;; cons up endless union types when propagating large number of EQL + ;; constraints -- eg. from large CASE forms -- instead we just + ;; directly accumulate one XSET, and a set of fp zeroes, which we at + ;; the end turn into a MEMBER-TYPE. + ;; + ;; Since massive symbol cases are an especially atrocious pattern + ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into + ;; a more useful type, don't propagate their negation except for NIL + ;; unless SPEED > COMPILATION-SPEED. (let ((res (single-value-type (node-derived-type ref))) + (constrain-symbols (policy ref (> speed compilation-speed))) + (not-set (alloc-xset)) + (not-fpz nil) (not-res *empty-type*) (leaf (ref-leaf ref))) - (do-sset-elements (con constraints) - (when (sset-member con in) - (let* ((x (constraint-x con)) - (y (constraint-y con)) - (not-p (constraint-not-p con)) - (other (if (eq x leaf) y x)) - (kind (constraint-kind con))) - (case kind - (typep - (if not-p - (setq not-res (type-union not-res other)) - (setq res (type-approx-intersection2 res other)))) - (eql - (unless (lvar-p other) - (let ((other-type (leaf-type other))) - (if not-p - (when (and (constant-p other) - (member-type-p other-type)) - (setq not-res (type-union not-res other-type))) - (let ((leaf-type (leaf-type leaf))) - (cond - ((or (constant-p other) - (and (leaf-refs other) ; protect from + (flet ((note-not (x) + (if (fp-zero-p x) + (push x not-fpz) + (when (or constrain-symbols (null x) (not (symbolp x))) + (add-to-xset x not-set))))) + (do-sset-elements (con constraints) + (when (sset-member con in) + (let* ((x (constraint-x con)) + (y (constraint-y con)) + (not-p (constraint-not-p con)) + (other (if (eq x leaf) y x)) + (kind (constraint-kind con))) + (case kind + (typep + (if not-p + (if (member-type-p other) + (mapc-member-type-members #'note-not other) + (setq not-res (type-union not-res other))) + (setq res (type-approx-intersection2 res other)))) + (eql + (unless (lvar-p other) + (let ((other-type (leaf-type other))) + (if not-p + (when (and (constant-p other) + (member-type-p other-type)) + (note-not (constant-value other))) + (let ((leaf-type (leaf-type leaf))) + (cond + ((or (constant-p other) + (and (leaf-refs other) ; protect from ; deleted vars - (csubtypep other-type leaf-type) - (not (type= other-type leaf-type)))) - (change-ref-leaf ref other) - (when (constant-p other) (return))) - (t - (setq res (type-approx-intersection2 - res other-type))))))))) - ((< >) - (cond - ((and (integer-type-p res) (integer-type-p y)) - (let ((greater (eq kind '>))) - (let ((greater (if not-p (not greater) greater))) - (setq res - (constrain-integer-type res y greater not-p))))) - ((and (float-type-p res) (float-type-p y)) - (let ((greater (eq kind '>))) - (let ((greater (if not-p (not greater) greater))) - (setq res - (constrain-float-type res y greater not-p))))))))))) + (csubtypep other-type leaf-type) + (not (type= other-type leaf-type)))) + (change-ref-leaf ref other) + (when (constant-p other) (return))) + (t + (setq res (type-approx-intersection2 + res other-type))))))))) + ((< >) + (cond + ((and (integer-type-p res) (integer-type-p y)) + (let ((greater (eq kind '>))) + (let ((greater (if not-p (not greater) greater))) + (setq res + (constrain-integer-type res y greater not-p))))) + ((and (float-type-p res) (float-type-p y)) + (let ((greater (eq kind '>))) + (let ((greater (if not-p (not greater) greater))) + (setq res + (constrain-float-type res y greater not-p)))))))))))) (cond ((and (if-p (node-dest ref)) - (csubtypep (specifier-type 'null) not-res)) + (or (xset-member-p nil not-set) + (csubtypep (specifier-type 'null) not-res))) (setf (node-derived-type ref) *wild-type*) (change-ref-leaf ref (find-constant t))) (t + (setf not-res + (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz))) (derive-node-type ref (make-single-value-type (or (type-difference res not-res) diff --git a/version.lisp-expr b/version.lisp-expr index 86c2240..61c4a77 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".) -"1.0.14.33" +"1.0.14.34" -- 1.7.10.4