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

ir1opt: Allow %analyze-set-uses to look through let bindings as well
Some checks are pending
CL-host / ecl (push) Waiting to run
Details
CL-host / clisp (push) Waiting to run
Details
CL-host / ccl (push) Waiting to run
Details
CL-host / cmucl (push) Waiting to run
Details
CL-host / sbcl (push) Waiting to run
Details
CL-host / compare-xc-host-fasls (ccl, false) (push) Blocked by required conditions
Details
CL-host / compare-xc-host-fasls (clisp, false) (push) Blocked by required conditions
Details
CL-host / compare-xc-host-fasls (cmucl, false) (push) Blocked by required conditions
Details
CL-host / compare-xc-host-fasls (self, false) (push) Blocked by required conditions
Details
Linux arm / build (push) Waiting to run
Details
Linux arm64 / build () (push) Waiting to run
Details
Linux qemu / build (ppc64le) (push) Waiting to run
Details
Linux qemu / build (riscv64) (push) Waiting to run
Details
Linux / build (x86, --with-sb-thread, ) (push) Waiting to run
Details
Linux / build (x86, --without-sb-thread, ) (push) Waiting to run
Details
Linux / build (x86, --without-sb-unicode, ) (push) Waiting to run
Details
Linux / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call) (push) Waiting to run
Details
Linux / build (x86-64, --with-sb-fasteval --without-sb-eval --with-nonstop-foreign-call, fasteval) (push) Waiting to run
Details
Linux / build (x86-64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return, sse4) (push) Waiting to run
Details
Linux / build (x86-64, --with-sb-thread, ) (push) Waiting to run
Details
Linux / build (x86-64, --without-sb-thread, ) (push) Waiting to run
Details
Linux / build (x86-64, --without-sb-unicode, ) (push) Waiting to run
Details
Mac / build (arm64, --with-mark-region-gc --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Details
Mac / build (arm64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Details
Mac / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Details
Mac / build (x86-64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Details
Windows arm64 / build (arm64, clang-aarch64, clangarm64) (push) Waiting to run
Details
Windows / build (x86-64, ucrt-x86_64, ucrt64) (push) Waiting to run
Details

Browse source 
Which helps loops where the index wrapped around or transformed by
intermediate immutable variable bindings.

This particularly helps type inference for SSA form programs where
multiple sets correspond to fresh variable bindings that are related
through the bindings.
This commit is contained in:
Charles Zhang 2026-09-07 18:15:52 +02:00
parent fe75c79a88
commit d57ec16e2a
2 changed files with 154 additions and 49 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

117
src/compiler/ir1opt.lisp
View file

@ -2445,37 +2445,38 @@
(set-types '()) (set-types '())
(every-set-type-suitable-p t)) (every-set-type-suitable-p t))
(dolist (value values) (dolist (value values)
(multiple-value-bind (step function) (iteration-step-value value var) (multiple-value-bind (steps function) (iteration-step-values value var)
(unless function ; every value must be ({+,-} VAR STEP) (unless function ; every value must be ({+,-} VAR STEP)
(return-from %analyze-set-uses nil)) (return-from %analyze-set-uses nil))
(let ((step-type (weaken-numeric-union-type (lvar-type step))) (dolist (step steps)
(set-type (weaken-numeric-union-type (lvar-type value)))) (let ((step-type (weaken-numeric-union-type (lvar-type step))))
;; In ({+,-} VAR STEP), the type of STEP must be a numeric ;; In ({+,-} VAR STEP), the type of STEP must be a numeric
;; type matching INITIAL-TYPE. ;; type matching INITIAL-TYPE.
(unless (and (numeric-type-p step-type) (unless (and (numeric-type-p step-type)
(or (numtype-aspects-eq initial-type step-type) (or (numtype-aspects-eq initial-type step-type)
;; Detect cases like (LOOP FOR 1.0 to 5.0 ;; Detect cases like (LOOP FOR 1.0 to 5.0
;; ...), where the initial and the step ;; ...), where the initial and the step
;; are of different types, and the step ;; are of different types, and the step
;; is less contagious. ;; is less contagious.
(let ((contagion-type (numeric-contagion initial-type (let ((contagion-type (numeric-contagion initial-type
step-type step-type
;; Adding integers will produce integers ;; Adding integers will produce integers
:rational nil))) :rational nil)))
(and (numeric-type-p contagion-type) (and (numeric-type-p contagion-type)
(numtype-aspects-eq initial-type contagion-type))))) (numtype-aspects-eq initial-type contagion-type)))))
(return-from %analyze-set-uses nil)) (return-from %analyze-set-uses nil))
;; Track the directions of the increments/decrements. ;; Track the directions of the increments/decrements.
(let ((non-negative-p (csubtypep step-type (specifier-type '(real 0 *)))) (let ((non-negative-p (csubtypep step-type (specifier-type '(real 0 *))))
(non-positive-p (csubtypep step-type (specifier-type '(real * 0))))) (non-positive-p (csubtypep step-type (specifier-type '(real * 0)))))
(cond ((or (and (eq function '+) non-negative-p) (cond ((or (and (eq function '+) non-negative-p)
(and (eq function '-) non-positive-p)) (and (eq function '-) non-positive-p))
(setf some-plusp t)) (setf some-plusp t))
((or (and (eq function '-) non-negative-p) ((or (and (eq function '-) non-negative-p)
(and (eq function '+) non-positive-p)) (and (eq function '+) non-positive-p))
(setf some-minusp t)) (setf some-minusp t))
(t ; Can't tell direction (t ; Can't tell direction
(setf some-plusp t some-minusp t)))) (setf some-plusp t some-minusp t))))))
(let ((set-type (weaken-numeric-union-type (lvar-type value))))
;; Ultimately, the derived types of the stepped values must ;; Ultimately, the derived types of the stepped values must
;; match INITIAL-TYPE if we are going to derive new bounds. ;; match INITIAL-TYPE if we are going to derive new bounds.
(unless (and (numeric-type-p set-type) (unless (and (numeric-type-p set-type)
@ -2490,32 +2491,48 @@
(defun sets-numeric-contagion (values var initial-type) (defun sets-numeric-contagion (values var initial-type)
(let (union) (let (union)
(dolist (value values) (dolist (value values)
(multiple-value-bind (step function) (iteration-step-value value var) (multiple-value-bind (steps function) (iteration-step-values value var)
(unless function ; every value must be ({+,-} VAR STEP) (unless function ; every value must be ({+,-} VAR STEP)
(return-from sets-numeric-contagion nil)) (return-from sets-numeric-contagion nil))
(let ((step-type (lvar-type step))) (dolist (step steps)
(setf union (if union (let ((step-type (lvar-type step)))
(type-union union step-type) (setf union (if union
step-type))))) (type-union union step-type)
step-type))))))
(type-union initial-type (type-union initial-type
(numeric-contagion initial-type union (numeric-contagion initial-type union
;; Adding integers will produce integers ;; Adding integers will produce integers
:rational nil)))) :rational nil))))
;;; If VALUE is computed as ({+,-} VAR STEP), one round of stepping a ;;; If VALUE is computed by a chain of ({+,-} VAR STEP) operations,
;;; loop variable, return the STEP lvar and which function it is. VALUE ;;; return the STEP lvars and which function they use. VALUE is the
;;; is the lvar the new value arrives on: the value of a SETQ, or the ;;; lvar the new value arrives on: the value of a SETQ, or the
;;; argument a local call passes to VAR's own parameter position. ;;; argument a local call passes to VAR's own parameter position.
(defun iteration-step-value (value var) (defun iteration-step-values (value var)
(let* ((use (principal-lvar-use value)) (labels ((walk (value seen)
(function (%inc-or-dec-p use))) (let* ((use (principal-lvar-use value))
(when function (function (%inc-or-dec-p use)))
(let ((args (basic-combination-args use))) (when function
(when (and (proper-list-of-length-p args 2 2) (let ((args (basic-combination-args use)))
(let ((first (principal-lvar-use (first args)))) (when (proper-list-of-length-p args 2 2)
(and (ref-p first) (let ((first (principal-lvar-use (first args)))
(eq (ref-leaf first) var)))) (step (second args)))
(values (second args) function)))))) (cond ((and (ref-p first)
(eq (ref-leaf first) var))
(values (list step) function))
((and (ref-p first)
(lambda-var-p (ref-leaf first))
(not (memq (ref-leaf first) seen)))
(let ((next (lambda-var-ref-lvar first)))
(when next
(multiple-value-bind
(steps inner-function)
(walk next
(cons (ref-leaf first) seen))
(when (and steps
(eq function inner-function))
(values (cons step steps) function))))))))))))))
(walk value nil)))
;;; Infer the type of VAR from the direction in which it is stepped, ;;; Infer the type of VAR from the direction in which it is stepped,
;;; keeping the bound it moves away from and dropping the one it moves ;;; keeping the bound it moves away from and dropping the one it moves
@ -3161,8 +3178,10 @@
(eq (combination-kind use) :known) (eq (combination-kind use) :known)
(let ((info (combination-fun-info use))) (let ((info (combination-fun-info use)))
(and info (fun-info-derive-type info))) (and info (fun-info-derive-type info)))
(some (lambda (a) (eq (combination-arg-lambda-var a) var)) (or
(combination-args use)) (some (lambda (a) (eq (combination-arg-lambda-var a) var))
(combination-args use))
(and arg (iteration-step-values arg var)))
t))) t)))
;;; Return the optimistic type of VAR, given BASE, the union of what ;;; Return the optimistic type of VAR, given BASE, the union of what

86
tests/compiler-2.pure.lisp
View file

@ -1663,6 +1663,92 @@
(assert (equal (sb-impl::%simple-fun-type f) (assert (equal (sb-impl::%simple-fun-type f)
'(function ((integer 3 10)) (values (integer 0 0) &optional)))))) '(function ((integer 3 10)) (values (integer 0 0) &optional))))))
(with-test (:name (:infer-iteration-var-type :multiple-sets :ssa))
(let ((f (checked-compile
'(lambda (x)
(declare (optimize speed)
(type (integer 3 10) x))
(let ((y x))
(labels ((start (y1)
(if (plusp y1)
(let ((y2 (1- y1)))
(if (plusp y2)
(start (1- y2))
y2))
y1)))
(start y))))
:allow-notes nil)))
(assert (equal (sb-impl::%simple-fun-type f)
'(function ((integer 3 10)) (values (integer 0 0) &optional))))))
(with-test (:name (:infer-iteration-var-type :multiple-sets :ssa :deep-chain))
(let ((f (checked-compile
'(lambda (x)
(declare (optimize speed)
(type (integer 3 10) x))
(let ((y x))
(labels ((start (y1)
(if (plusp y1)
(let ((y2 (1- y1)))
(if (plusp y2)
(let ((y3 (1- y2)))
(if (plusp y3)
(start (1- y3))
y3))
y2))
y1)))
(start y))))
:allow-notes nil)))
(assert (equal (sb-impl::%simple-fun-type f)
'(function ((integer 3 10))
(values (integer 0 0) &optional))))))
(with-test (:name (:infer-iteration-var-type :multiple-sets :ssa :deep-chain-3))
(let ((f (checked-compile
'(lambda (x)
(declare (optimize speed)
(type (integer 4 12) x))
(let ((y x))
(labels ((start (y1)
(if (plusp y1)
(let ((y2 (1- y1)))
(if (plusp y2)
(let ((y3 (1- y2)))
(if (plusp y3)
(let ((y4 (1- y3)))
(if (plusp y4)
(start (1- y4))
y4))
y3))
y2))
y1)))
(start y))))
:allow-notes nil)))
(assert (equal (sb-impl::%simple-fun-type f)
'(function ((integer 4 12))
(values (integer 0 0) &optional))))))
(with-test (:name (:infer-iteration-var-type :multiple-sets :ssa :mixed-direction))
(let ((f (checked-compile
'(lambda (x)
(declare (optimize speed)
(type (integer 3 10) x))
(let ((y x))
(labels ((start (y1)
(if (plusp y1)
(let ((y2 (1- y1)))
(if (plusp y2)
(start (1+ y2))
y2))
y1)))
(start y)))))))
;; The two recurrence steps have opposite directions, so the
;; iteration-specific numeric widening must not infer the exact
;; lower bound.
(assert (not (equal (sb-impl::%simple-fun-type f)
'(function ((integer 3 10))
(values (integer 0 0) &optional)))))))
(with-test (:name (:infer-iteration-var-type :incompatible-sets)) (with-test (:name (:infer-iteration-var-type :incompatible-sets))
(checked-compile-and-assert () (checked-compile-and-assert ()
'(lambda (input-total missing-amount) '(lambda (input-total missing-amount)