common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

constraint: Handle equality constraints for local calls generally.

Browse source 
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.
This commit is contained in:
Charles Zhang 2026-09-06 18:08:57 +02:00
parent 4a1cbf4f1a
commit bc2c8e1fa9
3 changed files with 149 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
src/compiler/constraint.lisp
View file

@ -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*))

39
src/compiler/debug.lisp
View file

@ -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))))

109
tests/constraint.pure.lisp
View file

@ -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)))