X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=812976e69d88a358a48da61241d7f3f2ec42d443;hb=6d36f2d6954cb79e3c88fef33fe0c3ad63deaea8;hp=1052d8c11413934b9f939c22c6f950f92b9e4a89;hpb=519b843c9d1af8138a5ec15516702249a71ffa92;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 1052d8c..812976e 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -136,8 +136,8 @@ ;; from the following declarations. Probably you'll want to ;; disable these declarations when debugging consets. (declare #-sb-xc-host (optimize (speed 3) (safety 0) (space 0))) - (declaim (inline constraint-number)) - (defun constraint-number (constraint) + (declaim (inline %constraint-number)) + (defun %constraint-number (constraint) (sset-element-number constraint)) (defstruct (conset (:constructor make-conset ()) @@ -149,17 +149,16 @@ :type simple-bit-vector) ;; Bit-vectors win over lightweight hashes for copy, union, ;; intersection, difference, but lose for iteration if you iterate - ;; over the whole vector. Tracking extrema helps a bit. Note - ;; that the CONSET-MIN is NIL when the set is known to be empty. - ;; CONSET-MAX is a normal end bounding index. - (min nil :type (or fixnum null)) + ;; over the whole vector. Tracking extrema helps a bit. + (min 0 :type fixnum) (max 0 :type fixnum)) (defmacro do-conset-elements ((constraint conset &optional result) &body body) (with-unique-names (vector index start end - ignore constraint-universe-end) + #-sb-xc-host ignore + #-sb-xc-host constraint-universe-end) (let* ((constraint-universe #+sb-xc-host '*constraint-universe* - #-sb-xc-host (gensym)) + #-sb-xc-host (sb!xc:gensym "UNIVERSE")) (with-array-data #+sb-xc-host '(progn) #-sb-xc-host `(with-array-data @@ -169,7 +168,7 @@ (declare (ignore ,ignore)) (aver (<= ,end ,constraint-universe-end))))) `(let* ((,vector (conset-vector ,conset)) - (,start (or (conset-min ,conset) 0)) + (,start (conset-min ,conset)) (,end (min (conset-max ,conset) (length ,vector)))) (,@with-array-data (do ((,index ,start (1+ ,index))) ((>= ,index ,end) ,result) @@ -186,7 +185,7 @@ ,@body))) (defun conset-empty (conset) - (or (null (conset-min conset)) + (or (= (conset-min conset) (conset-max conset)) ;; TODO: I bet FIND on bit-vectors can be optimized, if it ;; isn't. (not (find 1 (conset-vector conset) @@ -204,7 +203,7 @@ ret)) (defun %conset-grow (conset new-size) - (declare (index new-size)) + (declare (type index new-size)) (setf (conset-vector conset) (replace (the simple-bit-vector (make-array @@ -216,13 +215,13 @@ (declaim (inline conset-grow)) (defun conset-grow (conset new-size) - (declare (index new-size)) + (declare (type index new-size)) (when (< (length (conset-vector conset)) new-size) (%conset-grow conset new-size)) (values)) (defun conset-member (constraint conset) - (let ((number (constraint-number constraint)) + (let ((number (%constraint-number constraint)) (vector (conset-vector conset))) (when (< number (length vector)) (plusp (sbit vector number))))) @@ -230,11 +229,10 @@ (defun conset-adjoin (constraint conset) (prog1 (not (conset-member constraint conset)) - (let ((number (constraint-number constraint))) + (let ((number (%constraint-number constraint))) (conset-grow conset (1+ number)) (setf (sbit (conset-vector conset) number) 1) - (setf (conset-min conset) (min number (or (conset-min conset) - most-positive-fixnum))) + (setf (conset-min conset) (min number (conset-min conset))) (when (>= number (conset-max conset)) (setf (conset-max conset) (1+ number)))))) @@ -273,41 +271,26 @@ (declare (simple-bit-vector vector1 vector2)) (setf (conset-vector conset-1) (,bit-op vector1 vector2 t)) ;; Update the extrema. - (setf (conset-min conset-1) - ,(ecase name - ((conset-union) - `(min (or (conset-min conset-1) - most-positive-fixnum) - (or (conset-min conset-2) - most-positive-fixnum))) - ((conset-intersection) - `(let ((start (max (or (conset-min conset-1) 0) - (or (conset-min conset-2) 0))) - (end (min (conset-max conset-1) - (conset-max conset-1)))) + ,(ecase name + ((conset-union) + `(setf (conset-min conset-1) + (min (conset-min conset-1) + (conset-min conset-2)) + (conset-max conset-1) + (max (conset-max conset-1) + (conset-max conset-2)))) + ((conset-intersection) + `(let ((start (max (conset-min conset-1) + (conset-min conset-2))) + (end (min (conset-max conset-1) + (conset-max conset-2)))) + (setf (conset-min conset-1) (if (> start end) - nil - (position 1 (conset-vector conset-1) - :start start :end end)))) - ((conset-difference) - `(position 1 (conset-vector conset-1) - :start (or (conset-min conset-1) 0) - :end (conset-max conset-1) - ))) - (conset-max conset-1) - ,(ecase name - ((conset-union) - `(max (conset-max conset-1) - (conset-max conset-2))) - ((conset-intersection) - `(let ((start (max (or (conset-min conset-1) 0) - (or (conset-min conset-2) 0))) - (end (let ((minimum-maximum - (min (conset-max conset-1) - (conset-max conset-2)))) - (if (plusp minimum-maximum) - (1- minimum-maximum) - 0)))) + 0 + (or (position 1 (conset-vector conset-1) + :start start :end end) + 0)) + (conset-max conset-1) (if (> start end) 0 (let ((position @@ -316,12 +299,18 @@ :start start :end end :from-end t))) (if position (1+ position) - 0))))) - ((conset-difference) - `(let ((position + 0)))))) + ((conset-difference) + `(setf (conset-min conset-1) + (or (position 1 (conset-vector conset-1) + :start (conset-min conset-1) + :end (conset-max conset-1)) + 0) + (conset-max conset-1) + (let ((position (position 1 (conset-vector conset-1) - :start (or (conset-min conset-1) 0) + :start (conset-min conset-1) :end (conset-max conset-1) :from-end t))) (if position @@ -368,7 +357,7 @@ (let ((new (make-constraint (length *constraint-universe*) kind x y not-p))) (vector-push-extend new *constraint-universe* - (* 2 (length *constraint-universe*))) + (1+ (length *constraint-universe*))) (conset-adjoin new (lambda-var-constraints x)) (when (lambda-var-p y) (conset-adjoin new (lambda-var-constraints y))) @@ -479,7 +468,8 @@ (ok-lvar-lambda-var (first args) constraints) (if (ctype-p val) val - (specifier-type val)) + (let ((*compiler-error-context* use)) + (specifier-type val))) nil))))) ((eq eql) (let* ((arg1 (first args)) @@ -501,7 +491,11 @@ (var2 (add 'eql var1 var2 nil)) ((constant-lvar-p arg2) - (add 'eql var1 (ref-leaf (principal-lvar-use arg2)) + (add 'eql var1 + (let ((use (principal-lvar-use arg2))) + (if (ref-p use) + (ref-leaf use) + (find-constant (lvar-value arg2)))) nil)) (t (add-test-constraint 'typep var1 (lvar-type arg2) @@ -610,6 +604,24 @@ (modified-numeric-type x :low new-bound) (modified-numeric-type x :high new-bound))))) +;;; Return true if LEAF is "visible" from NODE. +(defun leaf-visible-from-node-p (leaf node) + (cond + ((lambda-var-p leaf) + ;; A LAMBDA-VAR is visible iif it is homed in a CLAMBDA that is an + ;; ancestor for NODE. + (let ((leaf-lambda (lambda-var-home leaf))) + (loop for lambda = (node-home-lambda node) + then (lambda-parent lambda) + while lambda + when (eq lambda leaf-lambda) + return t))) + ;; FIXME: Check on FUNCTIONALs (CLAMBDAs and OPTIONAL-DISPATCHes), + ;; not just LAMBDA-VARs. + (t + ;; Assume everything else is globally visible. + t))) + ;;; Given the set of CONSTRAINTS for a variable and the current set of ;;; restrictions from flow analysis IN, set the type for REF ;;; accordingly. @@ -665,7 +677,9 @@ (and (leaf-refs other) ; protect from ; deleted vars (csubtypep other-type leaf-type) - (not (type= other-type leaf-type)))) + (not (type= other-type leaf-type)) + ;; Don't change to a LEAF not visible here. + (leaf-visible-from-node-p other ref))) (change-ref-leaf ref other) (when (constant-p other) (return))) (t @@ -767,11 +781,11 @@ for var in (lambda-vars fun) and val in (combination-args call) when (and val (lambda-var-constraints var)) - do (let* ((type (lvar-type val)) - (con (find-or-create-constraint 'typep var type - nil))) - (conset-adjoin con gen)) - (maybe-add-eql-var-var-constraint var val gen))))) + do (let ((type (lvar-type val))) + (unless (eq type *universal-type*) + (let ((con (find-or-create-constraint 'typep var type nil))) + (conset-adjoin con gen)))) + (maybe-add-eql-var-var-constraint var val gen))))) (ref (when (ok-ref-lambda-var node) (maybe-add-eql-var-lvar-constraint node gen) @@ -784,17 +798,19 @@ (let ((var (ok-lvar-lambda-var lvar gen))) (when var (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME - (do-eql-vars (var (var gen)) - (let ((con (find-or-create-constraint 'typep var atype nil))) - (conset-adjoin con gen)))))))) + (unless (eq atype *universal-type*) + (do-eql-vars (var (var gen)) + (let ((con (find-or-create-constraint 'typep var atype nil))) + (conset-adjoin con gen))))))))) (cset (binding* ((var (set-var node)) (nil (lambda-var-p var) :exit-if-null) (cons (lambda-var-constraints var) :exit-if-null)) (conset-difference gen cons) - (let* ((type (single-value-type (node-derived-type node))) - (con (find-or-create-constraint 'typep var type nil))) - (conset-adjoin con gen)) + (let ((type (single-value-type (node-derived-type node)))) + (unless (eq type *universal-type*) + (let ((con (find-or-create-constraint 'typep var type nil))) + (conset-adjoin con gen)))) (maybe-add-eql-var-var-constraint var (set-value node) gen))))) gen) @@ -878,7 +894,7 @@ (frob let))))) ;;; Return the constraints that flow from PRED to SUCC. This is -;;; BLOCK-OUT unless PRED ends with and IF and test constraints were +;;; BLOCK-OUT unless PRED ends with an IF and test constraints were ;;; added. (defun block-out-for-successor (pred succ) (declare (type cblock pred succ))