From bc2c8e1fa9598d0e0ca266436796592bde931374 Mon Sep 17 00:00:00 2001 From: Charles Zhang Date: Sun, 6 Sep 2026 18:08:57 +0200 Subject: [PATCH] constraint: Handle equality constraints for local calls generally. Which allows us to do bounds elimination for the attached test cases. The constraint propagation code to handle general local calls now resembles something like a cross between the code that handles LET and SET, corresponding to the fact that local call binds variables as LET does but also must clear existing information while propagating some of the old information as SET does. --- src/compiler/constraint.lisp | 33 ++++++----- src/compiler/debug.lisp | 39 +++++++------ tests/constraint.pure.lisp | 109 +++++++++++++++++++++++++++++++++++ 3 files changed, 149 insertions(+), 32 deletions(-) diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 05d164bdc..1bf9464f3 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -1345,18 +1345,24 @@ (loop for var in vars for val in args when (and val (lambda-var-constraints var)) - do (conset-clear-lambda-var target var) - (let* ((arg-var (ok-lvar-lambda-var val constraints)) - (type (if arg-var - ;; Not strictly necessary to grab the - ;; type from constraints here straight - ;; away, but speeds up convergence. - (type-from-constraints arg-var constraints (lvar-type val)) - (lvar-type val)))) - (when (type-for-constraints-p type) - (conset-add-constraint target 'typep var type nil)) - (when arg-var - (inherit-constraints (list var) arg-var constraints target))))) + do (let ((new (add-set-constraints var val constraints))) + (conset-clear-lambda-var target var) + (when new + (conset-union target new)) + + (let* ((arg-var (ok-lvar-lambda-var val constraints)) + (type (if arg-var + ;; Not strictly necessary to grab the + ;; type from constraints here straight + ;; away, but speeds up convergence. + (type-from-constraints arg-var constraints (lvar-type val)) + (lvar-type val)))) + (when (type-for-constraints-p type) + (conset-add-constraint target 'typep var type nil)) + (when arg-var + (inherit-constraints (list var) arg-var constraints target)) + (add-eq-constraint var val target) + (add-var-result-constraints var val target target))))) ;;; Local propagation ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that @@ -1787,7 +1793,8 @@ #+sb-devel (when (and *compiler-trace-output* (memq :constraints *compile-trace-targets*)) - (print-constraints component)) + (do-blocks (block component) + (print-constraints block))) (loop for node in *blocks-to-terminate* do (maybe-terminate-block node nil)) (mapc #'delete-set *sets-to-delete*)) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index ce5138987..e20d3e458 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -1442,7 +1442,7 @@ is replaced with replacement." when pos do (write-string replacement out) while pos))) -(defun ir1-to-dot (component output-file) +(defun ir1-to-dot (component output-file &key show-constraints) (with-open-file (stream output-file :if-exists :supersede :if-does-not-exist :create :direction :output) @@ -1471,7 +1471,9 @@ is replaced with replacement." (block-label block) (replace-all (replace-all (with-output-to-string (*standard-output*) - (print-nodes block)) + (if show-constraints + (print-constraints block) + (print-nodes block))) (string #\Newline) "\\l") "\"" @@ -1527,20 +1529,19 @@ is replaced with replacement." (format t "Not in set2~%") (print-conset diff2))) -(defun print-constraints (component &optional kind) - (do-blocks (block component) - (handler-case (progn - (terpri) - (terpri) - ;(print-conset (block-in block) kind) - (print-nodes block) - (let ((last (block-last block))) - (cond ((if-p last) - (format t " CONSEQ~%") - (print-conset (if-consequent-constraints last) kind) - (format t " ALT~%") - (print-conset (if-alternative-constraints last) kind)) - (t - (print-conset (block-out block) kind))))) - (error (condition) - (format t "~&~A...~%" condition))))) +(defun print-constraints (block &optional kind) + (handler-case (progn + (terpri) + (terpri) + (print-conset (block-in block) kind) + (print-nodes block) + (let ((last (block-last block))) + (cond ((if-p last) + (format t " CONSEQ~%") + (print-conset (if-consequent-constraints last) kind) + (format t " ALT~%") + (print-conset (if-alternative-constraints last) kind)) + (t + (print-conset (block-out block) kind))))) + (error (condition) + (format t "~&~A...~%" condition)))) diff --git a/tests/constraint.pure.lisp b/tests/constraint.pure.lisp index 41642f858..835c0f82f 100644 --- a/tests/constraint.pure.lisp +++ b/tests/constraint.pure.lisp @@ -1016,6 +1016,50 @@ nil)) 0))) +(with-test (:name :bounds-check-down.ssa) + (assert (= (count 'sb-kernel:%check-bound + (ctu:ir1-named-calls + `(lambda (v) + (let ((end (1- (length v)))) + (labels ((after-decf (end-1) + (when (>= end-1 0) + (svref v end-1)))) + (after-decf (1- end))))) + nil)) + 0)) + (assert (= (count 'sb-kernel:%check-bound + (ctu:ir1-named-calls + `(lambda (v) + (declare (optimize (debug 2))) + (let ((end (1- (length v)))) + (labels ((after-decf (end-1) + (when (>= end-1 0) + (svref v end-1)))) + (after-decf (1- end))))) + nil)) + 0)) + (assert (= (count 'sb-kernel:%check-bound + (ctu:ir1-named-calls + `(lambda (v) + (labels ((loop-fn (i acc) + (if (>= i 0) + (loop-fn (1- i) (cons (svref v i) acc)) + acc))) + (loop-fn (1- (length v)) nil))) + nil)) + 0)) + (assert (= (count 'sb-kernel:%check-bound + (ctu:ir1-named-calls + `(lambda (v) + (declare (optimize (debug 2))) + (labels ((loop-fn (i acc) + (if (>= i 0) + (loop-fn (1- i) (cons (svref v i) acc)) + acc))) + (loop-fn (1- (length v)) nil))) + nil)) + 0))) + (with-test (:name :reoptimize) (assert-type (lambda () @@ -1230,6 +1274,39 @@ (< bbb j)))) ((3) t))) +(with-test (:name :constraint-amount.ssa) + (assert (= (count 'sb-kernel:%check-bound + (ctu:ir1-named-calls + `(lambda (v) + (labels ((loop-fn (i acc) + (if (< i (- (length v) 2)) + (loop-fn (+ i 2) (+ acc (svref v (1+ i)))) + acc))) + (loop-fn 0 0))) + nil)) + 0)) + (assert (= (count 'sb-kernel:%check-bound + (ctu:ir1-named-calls + `(lambda (v) + (labels ((loop-fn (i acc) + (if (>= i 0) + (loop-fn (1- i) (cons (svref v (1+ i)) acc)) + acc))) + (loop-fn (- (length v) 2) nil))) + nil)) + 0)) + (checked-compile-and-assert + () + `(lambda (a) + (declare (type fixnum a)) + (let ((j (+ a most-positive-fixnum))) + (labels ((loop-fn (i bbb) + (if (< i a) + (loop-fn (1+ i) (1+ bbb)) + (< bbb j)))) + (loop-fn 0 a)))) + ((3) t))) + (with-test (:name :constraint-multiple-eql-variables) (assert-type (lambda (x y) @@ -2241,3 +2318,35 @@ ((0) 0) ((1) 1) ((2) 2))) + + +(with-test (:name :constraint-bounds-preserve-correct.ssa) + (checked-compile-and-assert + () + `(lambda (dst-start-word nwords) + (declare (type (mod 50) dst-start-word nwords)) + (let ((count 0)) + (when (plusp nwords) + (let ((dst-end-word (the (mod 100) (+ dst-start-word nwords)))) + (labels ((rec (dst-index) + (unless (>= dst-index dst-end-word) + (incf count 1) + (rec (the (mod 100) (1+ dst-index)))))) + (rec dst-start-word)))) + count)) + ((0 7) 7))) + +(with-test (:name :constraint-bounds-preserve-correct) + (checked-compile-and-assert + () + `(lambda (dst-start-word nwords) + (declare (type (mod 50) dst-start-word nwords)) + (let ((count 0)) + (when (plusp nwords) + (let ((dst-end-word (the (mod 100) (+ dst-start-word nwords)))) + (do ((dst-index dst-start-word (the (mod 100) (1+ dst-index)))) + ((>= dst-index dst-end-word)) + (declare (type (mod 100) dst-index)) + (incf count 1)))) + count)) + ((0 7) 7)))