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 '())
(every-set-type-suitable-p t))
(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)
(return-from %analyze-set-uses nil))
(let ((step-type (weaken-numeric-union-type (lvar-type step)))
(set-type (weaken-numeric-union-type (lvar-type value))))
;; In ({+,-} VAR STEP), the type of STEP must be a numeric
;; type matching INITIAL-TYPE.
(unless (and (numeric-type-p step-type)
(or (numtype-aspects-eq initial-type step-type)
;; Detect cases like (LOOP FOR 1.0 to 5.0
;; ...), where the initial and the step
;; are of different types, and the step
;; is less contagious.
(let ((contagion-type (numeric-contagion initial-type
step-type
;; Adding integers will produce integers
:rational nil)))
(and (numeric-type-p contagion-type)
(numtype-aspects-eq initial-type contagion-type)))))
(return-from %analyze-set-uses nil))
;; Track the directions of the increments/decrements.
(let ((non-negative-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)
(and (eq function '-) non-positive-p))
(setf some-plusp t))
((or (and (eq function '-) non-negative-p)
(and (eq function '+) non-positive-p))
(setf some-minusp t))
(t ; Can't tell direction
(setf some-plusp t some-minusp t))))
(dolist (step steps)
(let ((step-type (weaken-numeric-union-type (lvar-type step))))
;; In ({+,-} VAR STEP), the type of STEP must be a numeric
;; type matching INITIAL-TYPE.
(unless (and (numeric-type-p step-type)
(or (numtype-aspects-eq initial-type step-type)
;; Detect cases like (LOOP FOR 1.0 to 5.0
;; ...), where the initial and the step
;; are of different types, and the step
;; is less contagious.
(let ((contagion-type (numeric-contagion initial-type
step-type
;; Adding integers will produce integers
:rational nil)))
(and (numeric-type-p contagion-type)
(numtype-aspects-eq initial-type contagion-type)))))
(return-from %analyze-set-uses nil))
;; Track the directions of the increments/decrements.
(let ((non-negative-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)
(and (eq function '-) non-positive-p))
(setf some-plusp t))
((or (and (eq function '-) non-negative-p)
(and (eq function '+) non-positive-p))
(setf some-minusp t))
(t ; Can't tell direction
(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
;; match INITIAL-TYPE if we are going to derive new bounds.
(unless (and (numeric-type-p set-type)
@ -2490,32 +2491,48 @@
(defun sets-numeric-contagion (values var initial-type)
(let (union)
(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)
(return-from sets-numeric-contagion nil))
(let ((step-type (lvar-type step)))
(setf union (if union
(type-union union step-type)
step-type)))))
(dolist (step steps)
(let ((step-type (lvar-type step)))
(setf union (if union
(type-union union step-type)
step-type))))))
(type-union initial-type
(numeric-contagion initial-type union
;; Adding integers will produce integers
:rational nil))))
;;; If VALUE is computed as ({+,-} VAR STEP), one round of stepping a
;;; loop variable, return the STEP lvar and which function it is. VALUE
;;; is the lvar the new value arrives on: the value of a SETQ, or the
;;; If VALUE is computed by a chain of ({+,-} VAR STEP) operations,
;;; return the STEP lvars and which function they use. VALUE is 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.
(defun iteration-step-value (value var)
(let* ((use (principal-lvar-use value))
(function (%inc-or-dec-p use)))
(when function
(let ((args (basic-combination-args use)))
(when (and (proper-list-of-length-p args 2 2)
(let ((first (principal-lvar-use (first args))))
(and (ref-p first)
(eq (ref-leaf first) var))))
(values (second args) function))))))
(defun iteration-step-values (value var)
(labels ((walk (value seen)
(let* ((use (principal-lvar-use value))
(function (%inc-or-dec-p use)))
(when function
(let ((args (basic-combination-args use)))
(when (proper-list-of-length-p args 2 2)
(let ((first (principal-lvar-use (first args)))
(step (second args)))
(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,
;;; keeping the bound it moves away from and dropping the one it moves
@ -3161,8 +3178,10 @@
(eq (combination-kind use) :known)
(let ((info (combination-fun-info use)))
(and info (fun-info-derive-type info)))
(some (lambda (a) (eq (combination-arg-lambda-var a) var))
(combination-args use))
(or
(some (lambda (a) (eq (combination-arg-lambda-var a) var))
(combination-args use))
(and arg (iteration-step-values arg var)))
t)))
;;; 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)
'(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))
(checked-compile-and-assert ()
'(lambda (input-total missing-amount)