mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Better &rest and cast handling in combination-match
Some checks are pending
CL-host / compare-xc-host-fasls (ccl, false) (push) Blocked by required conditions
CL-host / ecl (push) Waiting to run
CL-host / clisp (push) Waiting to run
CL-host / ccl (push) Waiting to run
CL-host / cmucl (push) Waiting to run
CL-host / sbcl (push) Waiting to run
CL-host / compare-xc-host-fasls (clisp, false) (push) Blocked by required conditions
CL-host / compare-xc-host-fasls (cmucl, false) (push) Blocked by required conditions
CL-host / compare-xc-host-fasls (self, false) (push) Blocked by required conditions
Linux arm / build (push) Waiting to run
Linux arm64 / build () (push) Waiting to run
Linux qemu / build (ppc64le) (push) Waiting to run
Linux qemu / build (riscv64) (push) Waiting to run
Linux / build (x86, --with-sb-thread, ) (push) Waiting to run
Linux / build (x86, --without-sb-thread, ) (push) Waiting to run
Linux / build (x86, --without-sb-unicode, ) (push) Waiting to run
Linux / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call) (push) Waiting to run
Linux / build (x86-64, --with-sb-fasteval --without-sb-eval --with-nonstop-foreign-call, fasteval) (push) Waiting to run
Linux / build (x86-64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return, sse4) (push) Waiting to run
Linux / build (x86-64, --with-sb-thread, ) (push) Waiting to run
Linux / build (x86-64, --without-sb-thread, ) (push) Waiting to run
Linux / build (x86-64, --without-sb-unicode, ) (push) Waiting to run
Mac / build (arm64, --with-mark-region-gc --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Mac / build (arm64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Mac / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Mac / build (x86-64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Windows arm64 / build (arm64, clang-aarch64, clangarm64) (push) Waiting to run
Windows / build (x86-64, ucrt-x86_64, ucrt64) (push) Waiting to run
Some checks are pending
CL-host / compare-xc-host-fasls (ccl, false) (push) Blocked by required conditions
CL-host / ecl (push) Waiting to run
CL-host / clisp (push) Waiting to run
CL-host / ccl (push) Waiting to run
CL-host / cmucl (push) Waiting to run
CL-host / sbcl (push) Waiting to run
CL-host / compare-xc-host-fasls (clisp, false) (push) Blocked by required conditions
CL-host / compare-xc-host-fasls (cmucl, false) (push) Blocked by required conditions
CL-host / compare-xc-host-fasls (self, false) (push) Blocked by required conditions
Linux arm / build (push) Waiting to run
Linux arm64 / build () (push) Waiting to run
Linux qemu / build (ppc64le) (push) Waiting to run
Linux qemu / build (riscv64) (push) Waiting to run
Linux / build (x86, --with-sb-thread, ) (push) Waiting to run
Linux / build (x86, --without-sb-thread, ) (push) Waiting to run
Linux / build (x86, --without-sb-unicode, ) (push) Waiting to run
Linux / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call) (push) Waiting to run
Linux / build (x86-64, --with-sb-fasteval --without-sb-eval --with-nonstop-foreign-call, fasteval) (push) Waiting to run
Linux / build (x86-64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return, sse4) (push) Waiting to run
Linux / build (x86-64, --with-sb-thread, ) (push) Waiting to run
Linux / build (x86-64, --without-sb-thread, ) (push) Waiting to run
Linux / build (x86-64, --without-sb-unicode, ) (push) Waiting to run
Mac / build (arm64, --with-mark-region-gc --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Mac / build (arm64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Mac / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Mac / build (x86-64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Windows arm64 / build (arm64, clang-aarch64, clangarm64) (push) Waiting to run
Windows / build (x86-64, ucrt-x86_64, ucrt64) (push) Waiting to run
This commit is contained in:
Stas Boukarev
parent
731c203ff2
commit
3ce92c6341
|
|
@ -1795,8 +1795,9 @@
|
|||
|
||||
(deftransform sb-vm::%make-simple-array ((dims widetag n-bits) * * :node node)
|
||||
(combination-match2 (node)
|
||||
((sb-vm::%make-simple-array (array-dimensions (:type simple-array array)) widetag n-bits)
|
||||
(when (almost-immediately-used-p array nil :flushable t)
|
||||
((sb-vm::%make-simple-array (array-dimensions array) widetag n-bits)
|
||||
(when (or (lvar-subtypep array simple-array)
|
||||
(almost-immediately-used-p dims nil :flushable t))
|
||||
`(sb-vm::%make-simple-array-array-dimensions array widetag n-bits)))))
|
||||
|
||||
(deftransform sb-vm::%make-simple-array-array-dimensions ((array widetag n-bits) (vector t t) * :node node)
|
||||
|
|
|
|||
|
|
@ -364,129 +364,98 @@
|
|||
(specifier-type 'integer))))))
|
||||
|
||||
(defoptimizer (logxor derive-type) ((x y) node)
|
||||
(let ((type (two-arg-derive-type x y #'logxor-derive-type-aux)))
|
||||
(flet ((try (x y)
|
||||
;; If it's (logxor x (1- x)) then it will be a positive number,
|
||||
;; except for 0 => -1. This is used to count unset bits.
|
||||
(or (multiple-value-bind (name combination args)
|
||||
(combination-matches* '(-) '(* 1) (lvar-uses y) :cast-type (specifier-type 'integer))
|
||||
(declare (ignore name))
|
||||
(when combination
|
||||
(when (same-leaf-ref-p x (car args))
|
||||
(if (types-equal-or-intersect (lvar-type x) (specifier-type '(eql 0)))
|
||||
(specifier-type '(integer -1))
|
||||
(specifier-type '(integer 1))))))
|
||||
;; (logxor x (1+ x)) is positive, except -1 => -1.
|
||||
(multiple-value-bind (name combination args)
|
||||
(combination-matches* '(+) '(* 1) (lvar-uses y) :cast-type (specifier-type 'integer))
|
||||
(declare (ignore name))
|
||||
(when combination
|
||||
(when (same-leaf-ref-p x (car args))
|
||||
(if (types-equal-or-intersect (lvar-type x) (specifier-type '(eql -1)))
|
||||
(specifier-type '(integer -1))
|
||||
(specifier-type '(integer 1))))))
|
||||
;; (logxor x (- x)) is <= 0
|
||||
(combination-case (x :cast (specifier-type 'integer))
|
||||
(%negate (*)
|
||||
(when (same-leaf-ref-p (car args) y)
|
||||
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type y))
|
||||
(declare (ignore pos neg))
|
||||
(if len
|
||||
(make-numeric-type 'integer
|
||||
(ash -1 (integer-length (max (abs low) (abs high))))
|
||||
(if (<= low 0 high)
|
||||
0
|
||||
-2))
|
||||
(if (types-equal-or-intersect (lvar-type y) (specifier-type '(eql 0)))
|
||||
(specifier-type '(integer * 0))
|
||||
(specifier-type '(integer * -2))))))))
|
||||
;; (logxor x (ash x -63))
|
||||
(combination-match (:node node)
|
||||
(logxor x (ash x (:constant shift (integer * -1))))
|
||||
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type x))
|
||||
(declare (ignore pos neg))
|
||||
(when len
|
||||
;; The result is unsigned
|
||||
(let* ((m (max 0 high (lognot low)))
|
||||
(max (if (or (<= len (- shift))
|
||||
(= m (1- (ash 1 len))))
|
||||
m
|
||||
(1- (ash 1 len))))
|
||||
(min (min (cond ((> low 0)
|
||||
(ash 1 (1- (integer-length low))))
|
||||
((< high -1)
|
||||
(ash 1 (1- (integer-length (lognot high)))))
|
||||
(t 0)))))
|
||||
(make-numeric-type 'integer min max)))))))
|
||||
(add (add)
|
||||
(if (and add type)
|
||||
(type-intersection type add)
|
||||
add)))
|
||||
(or (add (try x y))
|
||||
(add (try y x))
|
||||
type))))
|
||||
(add-type-intersection
|
||||
(two-arg-derive-type x y #'logxor-derive-type-aux)
|
||||
(combination-match2 (node :transform nil)
|
||||
;; If it's (logxor x (1- x)) then it will be a positive number,
|
||||
;; except for 0 => -1. This is used to count unset bits.
|
||||
((logxor x (- x 1))
|
||||
(if (lvar-intersectp x (eql 0))
|
||||
(specifier-type '(integer -1))
|
||||
(specifier-type '(integer 1))))
|
||||
;; (logxor x (1+ x)) is positive, except -1 => -1.
|
||||
((logxor x (+ x 1))
|
||||
(if (lvar-intersectp x (eql -1))
|
||||
(specifier-type '(integer -1))
|
||||
(specifier-type '(integer 1))))
|
||||
;; (logxor x (- x)) is <= 0
|
||||
((logxor x (- x))
|
||||
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type x))
|
||||
(declare (ignore pos neg))
|
||||
(if len
|
||||
(make-numeric-type 'integer
|
||||
(ash -1 (integer-length (max (abs low) (abs high))))
|
||||
(if (<= low 0 high)
|
||||
0
|
||||
-2))
|
||||
(if (lvar-intersectp x (eql 0))
|
||||
(specifier-type '(integer * 0))
|
||||
(specifier-type '(integer * -2))))))
|
||||
;; (logxor x (ash x -63))
|
||||
((logxor x (ash x (:constant shift (integer * -1))))
|
||||
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type x))
|
||||
(declare (ignore pos neg))
|
||||
(when len
|
||||
;; The result is unsigned
|
||||
(let* ((m (max 0 high (lognot low)))
|
||||
(max (if (or (<= len (- shift))
|
||||
(= m (1- (ash 1 len))))
|
||||
m
|
||||
(1- (ash 1 len))))
|
||||
(min (min (cond ((> low 0)
|
||||
(ash 1 (1- (integer-length low))))
|
||||
((< high -1)
|
||||
(ash 1 (1- (integer-length (lognot high)))))
|
||||
(t 0)))))
|
||||
(make-numeric-type 'integer min max))))))))
|
||||
|
||||
(defoptimizer (logior derive-type) ((x y))
|
||||
(let ((type (two-arg-derive-type x y #'logior-derive-type-aux)))
|
||||
(flet ((try (x y)
|
||||
;; (logior x (- x)) has the same width as X and is <= 0
|
||||
(combination-case (x :cast (specifier-type 'integer))
|
||||
(%negate (*)
|
||||
(when (same-leaf-ref-p (car args) y)
|
||||
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type y))
|
||||
(declare (ignore pos neg))
|
||||
(let ((int (if len
|
||||
(make-numeric-type 'integer
|
||||
(let ((positive (if (plusp high)
|
||||
(1- (integer-length high))
|
||||
0))
|
||||
(negative (if (minusp low)
|
||||
(if (= low (- (ash 1 len)))
|
||||
len
|
||||
(1- len))
|
||||
0)))
|
||||
(- (ash 1 (max positive negative))))
|
||||
0)
|
||||
(specifier-type '(integer * 0)))))
|
||||
(if type
|
||||
(type-intersection type int)
|
||||
int))))))))
|
||||
(or (try x y)
|
||||
(try y x)
|
||||
type))))
|
||||
(defoptimizer (logior derive-type) ((x y) node)
|
||||
(add-type-intersection
|
||||
(two-arg-derive-type x y #'logior-derive-type-aux)
|
||||
(combination-match2 (node :transform nil)
|
||||
;; (logior x (- x)) has the same width as X and is <= 0
|
||||
((logior x (- x))
|
||||
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type x))
|
||||
(declare (ignore pos neg))
|
||||
(if len
|
||||
(make-numeric-type 'integer
|
||||
(let ((positive (if (plusp high)
|
||||
(1- (integer-length high))
|
||||
0))
|
||||
(negative (if (minusp low)
|
||||
(if (= low (- (ash 1 len)))
|
||||
len
|
||||
(1- len))
|
||||
0)))
|
||||
(- (ash 1 (max positive negative))))
|
||||
0)
|
||||
(specifier-type '(integer * 0))))))))
|
||||
|
||||
(defoptimizer (logand derive-type) ((x y))
|
||||
(let ((type (two-arg-derive-type x y #'logand-derive-type-aux)))
|
||||
(flet ((try (x y)
|
||||
;; (logand x (- x)) has the same width as (abs most-negative-X) and is >= 0
|
||||
(combination-case (x :cast (specifier-type 'integer))
|
||||
(%negate (*)
|
||||
(when (same-leaf-ref-p (car args) y)
|
||||
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type y))
|
||||
(declare (ignore pos neg))
|
||||
(let ((int (if len
|
||||
(make-numeric-type 'integer
|
||||
(if (<= low 0 high)
|
||||
0
|
||||
1)
|
||||
(let ((positive (if (plusp high)
|
||||
(1- (integer-length high))
|
||||
0))
|
||||
(negative (if (minusp low)
|
||||
(if (= low (- (ash 1 len)))
|
||||
(1+ len)
|
||||
(1- len))
|
||||
0)))
|
||||
(ash 1 (max positive negative))))
|
||||
(if (types-equal-or-intersect (lvar-type y) (specifier-type '(eql 0)))
|
||||
(specifier-type '(integer 0))
|
||||
(specifier-type '(integer 1))))))
|
||||
(if type
|
||||
(type-intersection type int)
|
||||
int))))))))
|
||||
(or (try x y)
|
||||
(try y x)
|
||||
type))))
|
||||
(defoptimizer (logand derive-type) ((x y) node)
|
||||
(add-type-intersection
|
||||
(two-arg-derive-type x y #'logand-derive-type-aux)
|
||||
;; (logand x (- x)) has the same width as (abs most-negative-X) and is >= 0
|
||||
(combination-match2 (node :transform nil)
|
||||
((logand x (- x))
|
||||
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type y))
|
||||
(declare (ignore pos neg))
|
||||
(if len
|
||||
(make-numeric-type 'integer
|
||||
(if (<= low 0 high)
|
||||
0
|
||||
1)
|
||||
(let ((positive (if (plusp high)
|
||||
(1- (integer-length high))
|
||||
0))
|
||||
(negative (if (minusp low)
|
||||
(if (= low (- (ash 1 len)))
|
||||
(1+ len)
|
||||
(1- len))
|
||||
0)))
|
||||
(ash 1 (max positive negative))))
|
||||
(if (types-equal-or-intersect (lvar-type y) (specifier-type '(eql 0)))
|
||||
(specifier-type '(integer 0))
|
||||
(specifier-type '(integer 1)))))))))
|
||||
|
||||
(defoptimizer (logeqv derive-type) ((x y))
|
||||
(two-arg-derive-type x y (lambda (x y same-leaf)
|
||||
|
|
|
|||
|
|
@ -330,16 +330,13 @@
|
|||
|
||||
(deftransform #-(or x86 x86-64) data-vector-ref
|
||||
#+(or x86 x86-64) data-vector-ref-with-offset
|
||||
((array index #+(or x86 x86-64) offset) (vector (constant-arg t) #+(or x86 x86-64) (constant-arg t)))
|
||||
(let ((index (+ (lvar-value index)
|
||||
#+(or x86 x86-64) (lvar-value offset))))
|
||||
(or (combination-case array
|
||||
(initialize-vector *
|
||||
(when (< index (length (cdr args)))
|
||||
(splice-fun-args array :any (lambda (args)
|
||||
(elt (cdr args) index)))
|
||||
'array)))
|
||||
(give-up-ir1-transform))))
|
||||
((array index #+(or x86 x86-64) offset)
|
||||
(vector (constant-arg t) #+(or x86 x86-64) (constant-arg t)) * :node node)
|
||||
(let ((index (+ (lvar-value index) #+(or x86 x86-64) (lvar-value offset))))
|
||||
(combination-match2 (node)
|
||||
((:* (initialize-vector * &rest args) &rest)
|
||||
(when (< index (length args))
|
||||
(elt args index))))))
|
||||
|
||||
;;; Transform data vector access to a form that opens up optimization
|
||||
;;; opportunities. On platforms that support DATA-VECTOR-REF-WITH-OFFSET
|
||||
|
|
|
|||
|
|
@ -496,13 +496,15 @@
|
|||
(if (listp uses)
|
||||
(list* 'or (mapcar #'gen-use uses))
|
||||
(gen-use uses))))))
|
||||
(gen-lvar lvar))))
|
||||
(if (node-p lvar)
|
||||
(gen-lvar (node-lvar lvar))
|
||||
(gen-lvar lvar)))))
|
||||
|
||||
(declaim (ftype (function * (values t (or null combination) list &optional))
|
||||
(declaim (ftype (function * (values t (or null combination) list &optional t))
|
||||
lvar-combination/cast-name-args combination/cast-name-args))
|
||||
(defun lvar-combination/cast-name-args (lvar)
|
||||
(defun lvar-combination/cast-name-args (lvar &optional cast-type)
|
||||
(if lvar
|
||||
(multiple-value-bind (name combination) (combination/cast-name (lvar-uses lvar))
|
||||
(multiple-value-bind (name combination) (combination/cast-name (lvar-uses lvar) cast-type)
|
||||
(if name
|
||||
(values name combination (combination-args combination))
|
||||
(values nil nil nil)))
|
||||
|
|
@ -532,6 +534,37 @@
|
|||
(append (subseq args 0 n-args)
|
||||
(list (nthcdr n-args args)))))))
|
||||
|
||||
(defun unravel-casts-typed (lvar type)
|
||||
(labels ((rec (lvar)
|
||||
(let ((use (lvar-uses lvar)))
|
||||
(if (and (cast-p use)
|
||||
(cast-type-check use)
|
||||
(csubtypep (single-value-type (cast-type-to-check use)) type))
|
||||
(rec (cast-value use))
|
||||
lvar))))
|
||||
(rec lvar)))
|
||||
|
||||
(defun check-typed-args (args types n-args)
|
||||
(when (= (length args) n-args)
|
||||
(values-list (loop for arg in args
|
||||
for type in types
|
||||
collect (unravel-casts-typed arg type)))))
|
||||
|
||||
|
||||
(defun check-typed-min-args (args types n-args &optional plus-pos)
|
||||
(when (>= (length args) n-args)
|
||||
(if plus-pos
|
||||
(let ((n-after (- n-args plus-pos 1)))
|
||||
(values-list
|
||||
(append (subseq args 0 plus-pos)
|
||||
(list (subseq args plus-pos (- (length args) n-after)))
|
||||
(last args n-after))))
|
||||
(values-list
|
||||
(append (loop for arg in args
|
||||
for type in types
|
||||
collect (unravel-casts-typed arg type))
|
||||
(list (nthcdr n-args args)))))))
|
||||
|
||||
(defmacro combination-match (lvar spec &body body)
|
||||
(let (bound-vars)
|
||||
(labels ((ensure-or (x)
|
||||
|
|
@ -713,6 +746,12 @@
|
|||
(def-combination-match-alias lognot (x)
|
||||
`((- -1 ,x)))
|
||||
|
||||
(def-combination-match-alias - (&rest rest)
|
||||
(when (= (length rest) 1)
|
||||
(values
|
||||
`((%negate ,(car rest)))
|
||||
t))) ;; don't include (- x)
|
||||
|
||||
(defmacro combination-match2 ((node &key (transform t)) &body clauses)
|
||||
(let (bound-vars)
|
||||
(labels ((invert-relation (op)
|
||||
|
|
@ -737,8 +776,12 @@
|
|||
(destructuring-bind (name . rest) spec
|
||||
(let ((alias (gethash name *combination-match-aliases*)))
|
||||
(when alias
|
||||
(funcall alias rest)))))
|
||||
(multiple-value-bind (new exclude) (funcall alias rest)
|
||||
(if exclude
|
||||
new
|
||||
(list* spec new)))))))
|
||||
append it
|
||||
else
|
||||
collect spec))
|
||||
(ensure-or (x)
|
||||
(let ((specs (if (typep x '(cons (eql :or)))
|
||||
|
|
@ -768,7 +811,16 @@
|
|||
((typep s '(cons (member :or :commutative)))
|
||||
(mapc #'walk (cdr s)))
|
||||
((consp s)
|
||||
(mapc #'walk (cdr s)))
|
||||
(pop s)
|
||||
(loop while s
|
||||
do
|
||||
(let ((v (pop s)))
|
||||
(cond ((and (eq v '&rest)
|
||||
s)
|
||||
(push '&rest vars)
|
||||
(add (pop s)))
|
||||
(t
|
||||
(walk v))))))
|
||||
(t
|
||||
(add s)))))
|
||||
(walk spec)
|
||||
|
|
@ -787,6 +839,14 @@
|
|||
(= (length a)
|
||||
(length b))
|
||||
(every #'equal-spec a b)))))
|
||||
(fun-types (arg-count name)
|
||||
(let* ((fun-type (info :function :type name))
|
||||
(types (and (fun-type-p fun-type)
|
||||
(fun-type-n-arg-types arg-count fun-type))))
|
||||
(when (find *universal-type* types :test-not #'eq)
|
||||
`(load-time-value
|
||||
(list ,@(loop for type in types
|
||||
collect `(specifier-type ',(type-specifier type))))))))
|
||||
(expand-node (lvars specs spec body)
|
||||
(let ((old-bound-vars bound-vars)
|
||||
(spec (expand-aliases (ensure-or spec))))
|
||||
|
|
@ -804,24 +864,35 @@
|
|||
(commutative (and (not plus)
|
||||
(loop for name in names
|
||||
always (or (typep name '(cons (eql :commutative)))
|
||||
(ir1-attributep (fun-info-attributes (fun-info-or-lose name))
|
||||
commutative)))
|
||||
(unless (eq name :*)
|
||||
(ir1-attributep (fun-info-attributes (fun-info-or-lose name))
|
||||
commutative))))
|
||||
(not (or (integerp (car (last args)))
|
||||
(typep (car (last args)) '(cons (eql :constant)))
|
||||
(equal-spec (first args)
|
||||
(second args))))))
|
||||
(casts (when (singleton-p names)
|
||||
(fun-types arg-count (car names))))
|
||||
(names (loop for name in names
|
||||
collect (if (typep name '(cons (eql :commutative)))
|
||||
(second name)
|
||||
name))))
|
||||
(setf bound-vars old-bound-vars)
|
||||
(let ((args
|
||||
`(or (multiple-value-bind ,bind-vars ,(cond (plus
|
||||
`(check-min-args .args. ,arg-count ,plus))
|
||||
(variable
|
||||
`(check-min-args .args. ,arg-count))
|
||||
(t
|
||||
`(check-args .args. ,arg-count)))
|
||||
`(or (multiple-value-bind ,bind-vars
|
||||
,(if casts
|
||||
(cond (plus
|
||||
(error "todo"))
|
||||
(variable
|
||||
`(check-typed-min-args .args. ,casts ,arg-count))
|
||||
(t
|
||||
`(check-typed-args .args. ,casts ,arg-count)))
|
||||
(cond (plus
|
||||
`(check-min-args .args. ,arg-count ,plus))
|
||||
(variable
|
||||
`(check-min-args .args. ,arg-count))
|
||||
(t
|
||||
`(check-args .args. ,arg-count))))
|
||||
(declare (ignorable ,@bind-vars))
|
||||
(when ,(if vars
|
||||
(car vars)
|
||||
|
|
@ -845,7 +916,8 @@
|
|||
collect
|
||||
`(case name
|
||||
,(gen t)))))))
|
||||
`(,names ,args))))))
|
||||
`(,names
|
||||
,args))))))
|
||||
(loop while spec
|
||||
collect (gen)))))
|
||||
(expand (lvars specs body)
|
||||
|
|
@ -898,41 +970,59 @@
|
|||
(funcall body)))
|
||||
(gen-1 (clauses node)
|
||||
(let ((flets nil)
|
||||
(sym-forms (make-hash-table :test 'eq))
|
||||
sym-order
|
||||
(name-forms (make-hash-table :test 'eq))
|
||||
name-order
|
||||
form-groups)
|
||||
(dolist (clause clauses)
|
||||
(destructuring-bind (spec &body body) clause
|
||||
(setf bound-vars nil)
|
||||
(let* ((pattern-vars (collect-spec-vars spec))
|
||||
(restp (member '&rest pattern-vars))
|
||||
(body-fun (gensym "MATCH-BODY"))
|
||||
(var-names (if restp
|
||||
(remove '&rest pattern-vars)
|
||||
pattern-vars))
|
||||
(matched (lambda ()
|
||||
`(,body-fun name combination .args. ,@pattern-vars)))
|
||||
`(,@(if restp
|
||||
`(apply #',body-fun)
|
||||
`(,body-fun))
|
||||
name combination .args. ,@var-names)))
|
||||
(branches (expand-node nil nil spec matched)))
|
||||
(push `(,body-fun (name combination .args. ,@pattern-vars)
|
||||
(declare (ignorable name combination .args. ,@pattern-vars))
|
||||
(declare (ignorable name combination .args.
|
||||
,@var-names))
|
||||
(let ((new (progn ,@body)))
|
||||
(when new
|
||||
,(if transform
|
||||
`(combination-match-transform .node. ',pattern-vars new ,@pattern-vars)
|
||||
`(,@(if restp
|
||||
'(apply #'combination-match-transform)
|
||||
'(combination-match-transform))
|
||||
.node.
|
||||
',(if restp
|
||||
(butlast pattern-vars)
|
||||
pattern-vars)
|
||||
new ,@var-names)
|
||||
`(return-from .combination-match. new)))))
|
||||
flets)
|
||||
(dolist (branch branches)
|
||||
(destructuring-bind (names form) branch
|
||||
(dolist (name names)
|
||||
(unless (gethash name sym-forms)
|
||||
(push name sym-order))
|
||||
(push form (gethash name sym-forms))))))))
|
||||
(setf sym-order (nreverse sym-order))
|
||||
(dolist (sym sym-order)
|
||||
(let* ((forms (nreverse (gethash sym sym-forms)))
|
||||
(when (listp names)
|
||||
(dolist (name names)
|
||||
(unless (gethash name name-forms)
|
||||
(push name name-order))
|
||||
(push form (gethash name name-forms)))))))))
|
||||
(setf name-order (nreverse name-order))
|
||||
(dolist (name name-order)
|
||||
(let* ((forms (nreverse (gethash name name-forms)))
|
||||
(entry (assoc forms form-groups :test #'equal)))
|
||||
(if entry
|
||||
(push sym (cdr entry))
|
||||
(push (cons forms (list sym)) form-groups))))
|
||||
(push name (cdr entry))
|
||||
(push (cons forms (list name)) form-groups))))
|
||||
(let ((case-branches
|
||||
(loop for (forms . syms) in (nreverse form-groups)
|
||||
collect `(,(nreverse syms)
|
||||
(loop for (forms . names) in (nreverse form-groups)
|
||||
collect `(,(if (member :* names)
|
||||
t
|
||||
(nreverse names))
|
||||
,(if (cdr forms)
|
||||
`(or ,@forms)
|
||||
(car forms))))))
|
||||
|
|
@ -957,14 +1047,39 @@
|
|||
(defun combination-match-transform (combination vars form &rest lvars)
|
||||
(when *show-transforms-p*
|
||||
(show-transform :combination-match (generate-combination-tree (node-lvar combination)) form combination))
|
||||
(loop for var in vars
|
||||
for lvar in lvars
|
||||
when (lvar-p lvar) ;; ignore constants
|
||||
collect lvar into lvars*
|
||||
and
|
||||
collect var into vars*
|
||||
finally (setf vars vars*
|
||||
lvars lvars*))
|
||||
;; Handle &rest by finding literal LVARs and replacing them with variables
|
||||
(let ((restp (position '&rest vars)))
|
||||
(when restp
|
||||
(let ((rest-args (nthcdr restp lvars))
|
||||
(added-vars))
|
||||
(setf vars (subseq vars 0 restp))
|
||||
(labels ((walk (form)
|
||||
(cond ((listp form)
|
||||
(mapcar #'walk form))
|
||||
((lvar-p form)
|
||||
(or (getf added-vars form)
|
||||
(let ((var (gensym)))
|
||||
(aver (member form rest-args))
|
||||
(setf (getf added-vars form) var)
|
||||
(push var vars)
|
||||
(push form lvars)
|
||||
var)))
|
||||
(t
|
||||
form))))
|
||||
(setf form (walk form))))))
|
||||
(labels ((skip-cast (lvar)
|
||||
(let ((dest (lvar-dest lvar)))
|
||||
(if (cast-p dest)
|
||||
(skip-cast (node-lvar dest))
|
||||
lvar))))
|
||||
(loop for var in vars
|
||||
for lvar in lvars
|
||||
when (lvar-p lvar) ;; ignore constants
|
||||
collect (skip-cast lvar) into lvars*
|
||||
and
|
||||
collect var into vars*
|
||||
finally (setf vars vars*
|
||||
lvars lvars*)))
|
||||
(let ((old-args (combination-args combination)))
|
||||
(loop for lvar in lvars
|
||||
do
|
||||
|
|
@ -988,11 +1103,14 @@
|
|||
(unless (eq final-node dest)
|
||||
(let ((next-lvar (node-lvar dest)))
|
||||
(when next-lvar
|
||||
(setf (combination-args dest)
|
||||
(remove-if (lambda (l) (memq l all-lvars))
|
||||
(combination-args dest)))
|
||||
(%delete-lvar-use dest)
|
||||
(flush-combination dest)
|
||||
(cond ((cast-p dest)
|
||||
(unlink-node dest))
|
||||
(t
|
||||
(setf (combination-args dest)
|
||||
(remove-if (lambda (l) (memq l all-lvars))
|
||||
(combination-args dest)))
|
||||
(flush-combination dest)))
|
||||
(steal-lvar next-lvar final-node all-lvars))))))
|
||||
|
||||
(defun erase-node-type (node type &optional nth-value erase-calls)
|
||||
|
|
@ -4658,3 +4776,8 @@ is :ANY, the function name is not checked."
|
|||
|
||||
(defun lvar-single-value-type (lvar)
|
||||
(sb-kernel::convert-to-single-value-type (lvar-derived-type lvar)))
|
||||
|
||||
(defun add-type-intersection (type1 type2)
|
||||
(if (and type1 type2)
|
||||
(type-intersection type1 type2)
|
||||
(or type1 type2)))
|
||||
|
|
|
|||
|
|
@ -1965,5 +1965,11 @@
|
|||
(#(56B428A2 C4F34DDE C6F35104 C7F35297 DC33E6FC)
|
||||
"(> < = EQL EQ)"
|
||||
"((& (^ (>> val 2) (>> val 7)) 7))")
|
||||
(#(121068DD 37D0286E 4D61368F 58110E7F 67EE2D1A 6D9A883D 897B4656 A68A3965 F9BA9C52)
|
||||
"#(((:TYPE BIND)) ((:TYPE SB-C::REF)) ((:TYPE DELAY)) ((:TYPE SB-C::ARRAY-INDEX-CAST) (:TYPE CAST)) ((:TYPE SB-C::CSET)) ((:TYPE SB-C::COMBINATION) (:TYPE SB-C::MV-COMBINATION) (:TYPE SB-C::BASIC-COMBINATION)))"
|
||||
"((let ((tab #a((8) (unsigned-byte 8) 0 0 12 2 5 3 2 3)))
|
||||
(let ((b (& (>> val 27) #x7)))
|
||||
(let ((a (>> (<< val 31) 29)))
|
||||
(^ a (aref tab b))))))")
|
||||
)
|
||||
;; EOF
|
||||
|
|
|
|||
Loading…
Reference in a new issue