From: Alexey Dejneka Date: Sun, 2 Nov 2003 09:17:53 +0000 (+0000) Subject: 0.8.5.19: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=79c8aba8d1af834f7c1db289f33ede663fdbb7eb;p=sbcl.git 0.8.5.19: * Fix PFD bugs MISC.100, 102, 105, 107, 112; ... IR1-MERGE-CASTS: do not put merge asserted type contradicting the derived one; ... IR1-OPTIMIZE-COMBINATION: try terminate block after PROPAGATE-FUN-CHANGE; * FLUSH-DEAD-CODE: if the block is split under us, restart. --- diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index c78d83a..4dd2925 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -123,7 +123,14 @@ (cond ((and (cast-p dest) (not (cast-type-check dest)) (immediately-used-p lvar node)) - (derive-node-type node (cast-asserted-type dest))) + (when (values-types-equal-or-intersect + (node-derived-type node) + (cast-asserted-type dest)) + ;; FIXME: We do not perform pathwise CAST->type-error + ;; conversion, and type errors can later cause + ;; backend failures. On the other hand, this version + ;; produces less efficient code. + (derive-node-type node (cast-asserted-type dest)))) ((and (cast-p node) (eq (cast-type-check node) :external)) (aver (basic-combination-p dest)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 955f4c8..921e3e8 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -376,7 +376,7 @@ (defun flush-dead-code (block) (declare (type cblock block)) (setf (block-flush-p block) nil) - (do-nodes-backwards (node lvar block) + (do-nodes-backwards (node lvar block :restart-p t) (unless lvar (typecase node (ref @@ -625,7 +625,8 @@ (declaim (ftype (function (combination) (values)) ir1-optimize-combination)) (defun ir1-optimize-combination (node) (when (lvar-reoptimize (basic-combination-fun node)) - (propagate-fun-change node)) + (propagate-fun-change node) + (maybe-terminate-block node nil)) (let ((args (basic-combination-args node)) (kind (basic-combination-kind node))) (case kind @@ -1679,41 +1680,12 @@ ;;; - CAST chains; (defun ir1-optimize-cast (cast &optional do-not-optimize) (declare (type cast cast)) - (let* ((value (cast-value cast)) - (value-type (lvar-derived-type value)) - (atype (cast-asserted-type cast)) - (int (values-type-intersection value-type atype))) - (derive-node-type cast int) - (when (eq int *empty-type*) - (unless (eq value-type *empty-type*) - - ;; FIXME: Do it in one step. - (filter-lvar - value - `(multiple-value-call #'list 'dummy)) - (filter-lvar - (cast-value cast) - ;; FIXME: Derived type. - `(%compile-time-type-error 'dummy - ',(type-specifier atype) - ',(type-specifier value-type))) - ;; KLUDGE: FILTER-LVAR does not work for non-returning - ;; functions, so we declare the return type of - ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type - ;; here. - (setq value (cast-value cast)) - (derive-node-type (lvar-uses value) *empty-type*) - (maybe-terminate-block (lvar-uses value) nil) - ;; FIXME: Is it necessary? - (aver (null (block-pred (node-block cast)))) - (setf (block-delete-p (node-block cast)) t) - (return-from ir1-optimize-cast))) - (when (eq (node-derived-type cast) *empty-type*) - (maybe-terminate-block cast nil)) - + (let ((value (cast-value cast)) + (atype (cast-asserted-type cast))) (when (not do-not-optimize) (let ((lvar (node-lvar cast))) - (when (values-subtypep value-type (cast-asserted-type cast)) + (when (values-subtypep (lvar-derived-type value) + (cast-asserted-type cast)) (delete-filter cast lvar value) (when lvar (reoptimize-lvar lvar) @@ -1745,10 +1717,40 @@ (dolist (use (merges)) (merge-tail-sets use))))))) - (when (and (cast-%type-check cast) - (values-subtypep value-type - (cast-type-to-check cast))) - (setf (cast-%type-check cast) nil))) + (let* ((value-type (lvar-derived-type value)) + (int (values-type-intersection value-type atype))) + (derive-node-type cast int) + (when (eq int *empty-type*) + (unless (eq value-type *empty-type*) + + ;; FIXME: Do it in one step. + (filter-lvar + value + `(multiple-value-call #'list 'dummy)) + (filter-lvar + (cast-value cast) + ;; FIXME: Derived type. + `(%compile-time-type-error 'dummy + ',(type-specifier atype) + ',(type-specifier value-type))) + ;; KLUDGE: FILTER-LVAR does not work for non-returning + ;; functions, so we declare the return type of + ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type + ;; here. + (setq value (cast-value cast)) + (derive-node-type (lvar-uses value) *empty-type*) + (maybe-terminate-block (lvar-uses value) nil) + ;; FIXME: Is it necessary? + (aver (null (block-pred (node-block cast)))) + (setf (block-delete-p (node-block cast)) t) + (return-from ir1-optimize-cast))) + (when (eq (node-derived-type cast) *empty-type*) + (maybe-terminate-block cast nil)) + + (when (and (cast-%type-check cast) + (values-subtypep value-type + (cast-type-to-check cast))) + (setf (cast-%type-check cast) nil)))) (unless do-not-optimize (setf (node-reoptimize cast) nil))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index ad40031..1941881 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1341,25 +1341,25 @@ start next result (with-unique-names (bind unbind) (once-only ((n-save-bs '(%primitive current-binding-pointer))) - `(unwind-protect - (progn - (labels ((,unbind (vars) - (declare (optimize (speed 2) (debug 0))) - (dolist (var vars) - (%primitive bind nil var) - (makunbound var))) - (,bind (vars vals) - (declare (optimize (speed 2) (debug 0))) - (cond ((null vars)) - ((null vals) (,unbind vars)) - (t (%primitive bind - (car vals) - (car vars)) - (,bind (cdr vars) (cdr vals)))))) - (,bind ,vars ,vals)) - nil - ,@body) - (%primitive unbind-to-here ,n-save-bs)))))) + `(unwind-protect + (progn + (labels ((,unbind (vars) + (declare (optimize (speed 2) (debug 0))) + (dolist (var vars) + (%primitive bind nil var) + (makunbound var))) + (,bind (vars vals) + (declare (optimize (speed 2) (debug 0))) + (cond ((null vars)) + ((null vals) (,unbind vars)) + (t (%primitive bind + (car vals) + (car vars)) + (,bind (cdr vars) (cdr vals)))))) + (,bind ,vars ,vals)) + nil + ,@body) + (%primitive unbind-to-here ,n-save-bs)))))) ;;;; non-local exit diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index e96a92b..fe19264 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -631,11 +631,16 @@ ;;; Like DO-NODES, only iterating in reverse order. Should be careful ;;; with block being split under us. -(defmacro do-nodes-backwards ((node-var lvar block) &body body) +(defmacro do-nodes-backwards ((node-var lvar block &key restart-p) &body body) (let ((n-block (gensym)) (n-prev (gensym))) `(loop with ,n-block = ,block - for ,node-var = (block-last ,n-block) then (ctran-use ,n-prev) + for ,node-var = (block-last ,n-block) then + ,(if restart-p + `(if (eq ,n-block (ctran-block ,n-prev)) + (ctran-use ,n-prev) + (block-last ,n-block)) + `(ctran-use ,n-prev)) for ,n-prev = (when ,node-var (node-prev ,node-var)) and ,lvar = (when (and ,node-var (valued-node-p ,node-var)) (node-lvar ,node-var)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 1d17955..1305c5c 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -734,3 +734,59 @@ (if (logbitp 1 a) b (setq a -1522022182249)))))))) -1802767029877 -12374959963) -80)) + +;;; various MISC.*, related to NODEs/LVARs with derived type NIL +(assert (eql (funcall (compile nil '(lambda (c) + (declare (type (integer -3924 1001809828) c)) + (declare (optimize (speed 3))) + (min 47 (if (ldb-test (byte 2 14) c) + -570344431 + (ignore-errors -732893970))))) + 705347625) + -570344431)) +(assert (eql (funcall + (compile nil '(lambda (b) + (declare (type (integer -1598566306 2941) b)) + (declare (optimize (speed 3))) + (max -148949 (ignore-errors b)))) + 0) + 0)) +(assert (eql (funcall + (compile nil '(lambda (b c) + (declare (type (integer -4 -3) c)) + (block b7 + (flet ((%f1 (f1-1 f1-2 f1-3) + (if (logbitp 0 (return-from b7 + (- -815145138 f1-2))) + (return-from b7 -2611670) + 99345))) + (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2))) + b))))) + 2950453607 -4) + -815145134)) +(assert (eql (funcall + (compile nil + '(lambda (b c) + (declare (type (integer -29742055786 23602182204) b)) + (declare (type (integer -7409 -2075) c)) + (declare (optimize (speed 3))) + (floor + (labels ((%f2 () + (block b6 + (ignore-errors (return-from b6 + (if (= c 8) b 82674)))))) + (%f2))))) + 22992834060 -5833) + 82674)) +(assert (equal (multiple-value-list + (funcall + (compile nil '(lambda (a) + (declare (type (integer -944 -472) a)) + (declare (optimize (speed 3))) + (round + (block b3 + (return-from b3 + (if (= 55957 a) -117 (ignore-errors + (return-from b3 a)))))))) + -589)) + '(-589 0))) diff --git a/version.lisp-expr b/version.lisp-expr index 9378f24..2bad905 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".) -"0.8.5.18" +"0.8.5.19"