From: Alexey Dejneka Date: Sat, 7 Jun 2003 06:08:58 +0000 (+0000) Subject: 0.8.0.41: "Hunting on worms, part II" X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5b97c18e0f762a45300a86c53f0458d1ffc8eed3;hp=ed3bd9c7d61a3c1bf8ad81d82a671359117bd235;p=sbcl.git 0.8.0.41: "Hunting on worms, part II" Insertion of type check on a function result continuation prevents tail call optimisation, so: * pathwise eliminate unnecessary type checks; * disable unsafe CAST insertion on function results. Now Paul Dietz' test suite finishes with "83 out of 12565 total tests failed". --- diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index d331db6..3edc03b 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -704,11 +704,11 @@ ;;; If there is no problem, we return T (even if REALLY-ASSERT was ;;; false). If there was a problem, we return NIL. (defun assert-definition-type - (functional type &key (really-assert t) - ((:lossage-fun *lossage-fun*) - #'compiler-style-warn) - unwinnage-fun - (where "previous declaration")) + (functional type &key (really-assert t) + ((:lossage-fun *lossage-fun*) + #'compiler-style-warn) + unwinnage-fun + (where "previous declaration")) (declare (type functional functional) (type function *lossage-fun*) (string where)) @@ -728,34 +728,36 @@ (dtype (when return (continuation-derived-type (return-result return))))) (cond - ((and dtype (not (values-types-equal-or-intersect dtype - type-returns))) - (note-lossage - "The result type from ~A:~% ~S~@ + ((and dtype (not (values-types-equal-or-intersect dtype + type-returns))) + (note-lossage + "The result type from ~A:~% ~S~@ conflicts with the definition's result type:~% ~S" - where (type-specifier type-returns) (type-specifier dtype)) - nil) - (*lossage-detected* nil) - ((not really-assert) t) - (t - (assert-continuation-type (return-result return) type-returns - (lexenv-policy (functional-lexenv functional))) - (loop for var in vars and type in types do - (cond ((basic-var-sets var) - (when (and unwinnage-fun - (not (csubtypep (leaf-type var) type))) - (funcall unwinnage-fun - "Assignment to argument: ~S~% ~ + where (type-specifier type-returns) (type-specifier dtype)) + nil) + (*lossage-detected* nil) + ((not really-assert) t) + (t + (let ((policy (lexenv-policy (functional-lexenv functional)))) + (when (policy policy (> type-check 0)) + (assert-continuation-type (return-result return) type-returns + policy))) + (loop for var in vars and type in types do + (cond ((basic-var-sets var) + (when (and unwinnage-fun + (not (csubtypep (leaf-type var) type))) + (funcall unwinnage-fun + "Assignment to argument: ~S~% ~ prevents use of assertion from function ~ type ~A:~% ~S~%" - (leaf-debug-name var) - where - (type-specifier type)))) - (t - (setf (leaf-type var) type) - (dolist (ref (leaf-refs var)) - (derive-node-type ref (make-single-value-type type)))))) - t)))))) + (leaf-debug-name var) + where + (type-specifier type)))) + (t + (setf (leaf-type var) type) + (dolist (ref (leaf-refs var)) + (derive-node-type ref (make-single-value-type type)))))) + t)))))) (defun assert-global-function-definition-type (name fun) (declare (type functional fun)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index f65cc3a..3f83536 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1734,6 +1734,8 @@ (declare (type cast cast)) (let* ((value (cast-value cast)) (value-type (continuation-derived-type value)) + (cont (node-cont cast)) + (dest (continuation-dest cont)) (atype (cast-asserted-type cast)) (int (values-type-intersection value-type atype))) (derive-node-type cast int) @@ -1763,24 +1765,40 @@ (when (eq (node-derived-type cast) *empty-type*) (maybe-terminate-block cast nil)) - (flet ((delete-cast () - (let ((cont (node-cont cast))) - (delete-filter cast cont value) - (reoptimize-continuation cont) - (when (continuation-single-value-p cont) - (note-single-valuified-continuation cont)) - (when (not (continuation-dest cont)) - (reoptimize-continuation-uses cont))))) - (cond - ((and (not do-not-optimize) - (values-subtypep value-type - (cast-asserted-type cast))) - (delete-cast) - (return-from ir1-optimize-cast t)) - ((and (cast-%type-check cast) - (values-subtypep value-type - (cast-type-to-check cast))) - (setf (cast-%type-check cast) nil))))) + (when (and (not do-not-optimize) + (values-subtypep value-type + (cast-asserted-type cast))) + (delete-filter cast cont value) + (reoptimize-continuation cont) + (when (continuation-single-value-p cont) + (note-single-valuified-continuation cont)) + (when (not dest) + (reoptimize-continuation-uses cont)) + (return-from ir1-optimize-cast t)) + + (when (and (not do-not-optimize) + (not (continuation-use value)) + dest) + (collect ((merges)) + (do-uses (use value) + (when (and (values-subtypep (node-derived-type use) atype) + (immediately-used-p value use)) + (ensure-block-start cont) + (delete-continuation-use use) + (add-continuation-use use cont) + (unlink-blocks (node-block use) (node-block cast)) + (link-blocks (node-block use) (continuation-block cont)) + (when (and (return-p dest) + (basic-combination-p use) + (eq (basic-combination-kind use) :local)) + (merges use)))) + (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))) (unless do-not-optimize (setf (node-reoptimize cast) nil))) diff --git a/version.lisp-expr b/version.lisp-expr index 0970acf..60f15c1 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.0.40" +"0.8.0.41"