mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
combination-match: transition some logand and logtest transforms
This commit is contained in:
Stas Boukarev
parent
3ce92c6341
commit
39aa19ebee
|
|
@ -738,23 +738,36 @@
|
|||
(defvar *combination-match-aliases* (make-hash-table :test #'eq))
|
||||
|
||||
(defmacro def-combination-match-alias (name ll &body body)
|
||||
`(setf (gethash ',name *combination-match-aliases*)
|
||||
(lambda (.form.)
|
||||
(destructuring-bind ,ll .form.
|
||||
,@body))))
|
||||
`(pushnew ',(if (integerp ll)
|
||||
(cons ll body)
|
||||
`(lambda (.form.)
|
||||
(when (= (length .form.)
|
||||
,(length ll))
|
||||
(destructuring-bind ,ll .form.
|
||||
,@body))))
|
||||
(gethash ',name *combination-match-aliases*)
|
||||
:test #'equalp))
|
||||
|
||||
(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)
|
||||
(def-combination-match-alias - (a)
|
||||
(values
|
||||
`((%negate ,a))
|
||||
t)) ;; don't include (- x)
|
||||
|
||||
(defmacro combination-match2 ((node &key (transform t)) &body clauses)
|
||||
(let (bound-vars)
|
||||
(labels ((invert-relation (op)
|
||||
(labels ((clean-name-spec (list)
|
||||
(loop for tail = list then (cdr tail)
|
||||
while tail
|
||||
if (eq (car tail) :name)
|
||||
do (setf tail (cdr tail))
|
||||
else collect (car tail)))
|
||||
(extract-name-var (op)
|
||||
(and (consp op)
|
||||
(second (member :name op))))
|
||||
(invert-relation (op)
|
||||
(case op
|
||||
(< '>)
|
||||
(> '<)
|
||||
|
|
@ -770,22 +783,43 @@
|
|||
(list (invert-relation (car s))
|
||||
(second (cdr s))
|
||||
(first (cdr s))))
|
||||
(expand-aliases (specs)
|
||||
(expand-aliases (specs &optional exclude)
|
||||
(loop for spec in specs
|
||||
when (when (listp spec)
|
||||
(destructuring-bind (name . rest) spec
|
||||
(let ((alias (gethash name *combination-match-aliases*)))
|
||||
(when alias
|
||||
(multiple-value-bind (new exclude) (funcall alias rest)
|
||||
(if exclude
|
||||
new
|
||||
(list* spec new)))))))
|
||||
(destructuring-bind (names . rest) spec
|
||||
(let (name-aliases
|
||||
full-aliases
|
||||
(name-var (extract-name-var names))
|
||||
(names (ensure-or names))
|
||||
(excluded exclude))
|
||||
(loop for name in names
|
||||
do
|
||||
(let ((aliases (gethash name *combination-match-aliases*)))
|
||||
(loop for alias in aliases
|
||||
do
|
||||
(if (typep alias '(cons integer))
|
||||
(when (= (first alias) (length rest))
|
||||
(push (second alias) name-aliases))
|
||||
(multiple-value-bind (new exclude)
|
||||
(funcall (eval alias) rest)
|
||||
(when new
|
||||
(if exclude
|
||||
(setf excluded t))
|
||||
(setf full-aliases
|
||||
(append (expand-aliases new) full-aliases))))))))
|
||||
(let ((spec
|
||||
(if name-aliases
|
||||
`((:or ,@names ,@name-aliases ,@(when name-var `(:name ,name-var))) . ,rest)
|
||||
spec)))
|
||||
(append full-aliases
|
||||
(unless excluded
|
||||
(list spec)))))))
|
||||
append it
|
||||
else
|
||||
collect spec))
|
||||
(ensure-or (x)
|
||||
(let ((specs (if (typep x '(cons (eql :or)))
|
||||
(cdr x)
|
||||
(clean-name-spec (cdr x))
|
||||
(list x))))
|
||||
;; Expand (< x y) into (:or (< x y) (> y x))
|
||||
;; And = into eq eql =
|
||||
|
|
@ -809,8 +843,12 @@
|
|||
((typep s '(cons (member :+ :constant)))
|
||||
(add (second s)))
|
||||
((typep s '(cons (member :or :commutative)))
|
||||
(mapc #'walk (cdr s)))
|
||||
(let ((name-var (extract-name-var s)))
|
||||
(when name-var (add name-var)))
|
||||
(mapc #'walk (clean-name-spec (cdr s))))
|
||||
((consp s)
|
||||
(let ((name-var (extract-name-var (car s))))
|
||||
(when name-var (add name-var)))
|
||||
(pop s)
|
||||
(loop while s
|
||||
do
|
||||
|
|
@ -851,7 +889,7 @@
|
|||
(let ((old-bound-vars bound-vars)
|
||||
(spec (expand-aliases (ensure-or spec))))
|
||||
(labels ((gen (&optional sub)
|
||||
(destructuring-bind (name . args) (pop spec)
|
||||
(destructuring-bind (name-spec . args) (pop spec)
|
||||
(let* ((plus (position-if (lambda (x) (typep x '(cons (eql :+)))) args))
|
||||
(variable (or plus (position '&rest args)))
|
||||
(rest-var (and (not plus) (second (member '&rest args))))
|
||||
|
|
@ -860,7 +898,8 @@
|
|||
(bind-vars (if rest-var
|
||||
(append vars (list rest-var))
|
||||
vars))
|
||||
(names (ensure-or name))
|
||||
(name-var (extract-name-var name-spec))
|
||||
(names (ensure-or name-spec))
|
||||
(commutative (and (not plus)
|
||||
(loop for name in names
|
||||
always (or (typep name '(cons (eql :commutative)))
|
||||
|
|
@ -878,44 +917,54 @@
|
|||
(second name)
|
||||
name))))
|
||||
(setf bound-vars old-bound-vars)
|
||||
(let ((args
|
||||
`(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)
|
||||
(progn (aver rest-var)
|
||||
t))
|
||||
,(expand lvars specs
|
||||
(lambda ()
|
||||
(let ((old-bound-vars bound-vars))
|
||||
(cond (commutative
|
||||
(assert (= (length vars) 2))
|
||||
`(or ,(expand vars args body)
|
||||
,(progn
|
||||
(setf bound-vars old-bound-vars)
|
||||
(expand (list (second vars) (first vars)) args body))))
|
||||
(t
|
||||
(expand vars args body))))))))
|
||||
,@(unless sub
|
||||
(loop while (and spec
|
||||
(subsetp (ensure-or (caar spec))
|
||||
names))
|
||||
collect
|
||||
`(case name
|
||||
,(gen t)))))))
|
||||
(when name-var
|
||||
(push name-var bound-vars))
|
||||
(let* ((inner-body
|
||||
(lambda ()
|
||||
(let ((old-bound-vars bound-vars))
|
||||
(cond (commutative
|
||||
(assert (= (length vars) 2))
|
||||
`(or ,(expand vars args body)
|
||||
,(progn
|
||||
(setf bound-vars old-bound-vars)
|
||||
(expand (list (second vars) (first vars)) args body))))
|
||||
(t
|
||||
(expand vars args body))))))
|
||||
(match-args
|
||||
(expand lvars specs
|
||||
(if name-var
|
||||
(lambda ()
|
||||
`(let ((,name-var .name.))
|
||||
,(funcall inner-body)))
|
||||
inner-body)))
|
||||
(args
|
||||
`(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)
|
||||
(progn (aver rest-var)
|
||||
t))
|
||||
,match-args))
|
||||
,@(unless sub
|
||||
(loop while (and spec
|
||||
(subsetp (ensure-or (caar spec))
|
||||
names))
|
||||
collect
|
||||
`(case .name.
|
||||
,(gen t)))))))
|
||||
`(,names
|
||||
,args))))))
|
||||
(loop while spec
|
||||
|
|
@ -962,10 +1011,10 @@
|
|||
,(expand (cdr lvars) (cdr specs)
|
||||
body)))
|
||||
(t
|
||||
`(multiple-value-bind (name combination .args.) (lvar-combination/cast-name-args ,lvar)
|
||||
`(multiple-value-bind (.name. combination .args.) (lvar-combination/cast-name-args ,lvar)
|
||||
(declare (notinline lvar-value-is))
|
||||
(when combination
|
||||
(case name
|
||||
(case .name.
|
||||
,@(expand-node (cdr lvars) (cdr specs) spec body))))))))
|
||||
(funcall body)))
|
||||
(gen-1 (clauses node)
|
||||
|
|
@ -976,7 +1025,10 @@
|
|||
(dolist (clause clauses)
|
||||
(destructuring-bind (spec &body body) clause
|
||||
(setf bound-vars nil)
|
||||
(let* ((pattern-vars (collect-spec-vars spec))
|
||||
(let* ((top-name-var (extract-name-var (if (typep spec '(cons (eql :or)))
|
||||
(caar (ensure-or spec))
|
||||
(car spec))))
|
||||
(pattern-vars (collect-spec-vars spec))
|
||||
(restp (member '&rest pattern-vars))
|
||||
(body-fun (gensym "MATCH-BODY"))
|
||||
(var-names (if restp
|
||||
|
|
@ -984,19 +1036,20 @@
|
|||
pattern-vars))
|
||||
(matched (lambda ()
|
||||
`(,@(if restp
|
||||
`(apply #',body-fun)
|
||||
`(,body-fun))
|
||||
name combination .args. ,@var-names)))
|
||||
`(apply #',body-fun)
|
||||
`(,body-fun))
|
||||
combination .args. ,@var-names)))
|
||||
(branches (expand-node nil nil spec matched)))
|
||||
(push `(,body-fun (name combination .args. ,@pattern-vars)
|
||||
(declare (ignorable name combination .args.
|
||||
,@var-names))
|
||||
(let ((new (progn ,@body)))
|
||||
(push `(,body-fun (combination .args. ,@pattern-vars)
|
||||
(declare (ignorable combination .args. ,@var-names))
|
||||
(let (,@(when (and top-name-var (not (member top-name-var pattern-vars)))
|
||||
`((,top-name-var .name.)))
|
||||
(new (progn ,@body)))
|
||||
(when new
|
||||
,(if transform
|
||||
`(,@(if restp
|
||||
'(apply #'combination-match-transform)
|
||||
'(combination-match-transform))
|
||||
'(apply #'combination-match-transform)
|
||||
'(combination-match-transform))
|
||||
.node.
|
||||
',(if restp
|
||||
(butlast pattern-vars)
|
||||
|
|
@ -1021,16 +1074,16 @@
|
|||
(let ((case-branches
|
||||
(loop for (forms . names) in (nreverse form-groups)
|
||||
collect `(,(if (member :* names)
|
||||
t
|
||||
(nreverse names))
|
||||
t
|
||||
(nreverse names))
|
||||
,(if (cdr forms)
|
||||
`(or ,@forms)
|
||||
(car forms))))))
|
||||
`(let ((.node. ,node))
|
||||
(flet ,flets
|
||||
(multiple-value-bind (name combination .args.) (combination/cast-name-args .node.)
|
||||
(declare (ignorable name combination .args.))
|
||||
(case name
|
||||
(multiple-value-bind (.name. combination .args.) (combination/cast-name-args .node.)
|
||||
(declare (ignorable combination .args.))
|
||||
(case .name.
|
||||
,@case-branches))))))))
|
||||
(let ((dest (member :dest clauses)))
|
||||
`(progn
|
||||
|
|
@ -1113,6 +1166,13 @@
|
|||
(flush-combination dest)))
|
||||
(steal-lvar next-lvar final-node all-lvars))))))
|
||||
|
||||
;;; Are two lvars the same or one is coming from a cast?
|
||||
(defun lvar-from-lvar-p (lvar casted-lvar)
|
||||
(or (eq lvar casted-lvar)
|
||||
(let ((cast (lvar-uses casted-lvar)))
|
||||
(when (cast-p cast)
|
||||
(lvar-from-lvar-p lvar (cast-value cast))))))
|
||||
|
||||
(defun erase-node-type (node type &optional nth-value erase-calls)
|
||||
(setf (node-derived-type node)
|
||||
(cond ((eq type t)
|
||||
|
|
@ -1712,6 +1772,8 @@
|
|||
(placeholder (make-constant 0))
|
||||
(form (funcall function placeholder))
|
||||
(*transforming* (1+ *transforming*)))
|
||||
(when *show-transforms-p*
|
||||
(show-transform 'filter-lvar (generate-combination-tree lvar) form))
|
||||
(with-ir1-environment-from-node dest
|
||||
(ensure-block-start ctran)
|
||||
(let* ((old-block (ctran-block ctran))
|
||||
|
|
|
|||
|
|
@ -128,7 +128,9 @@
|
|||
,@(and (ir1-attributep (fun-info-attributes (fun-info-or-lose prototype))
|
||||
commutative)
|
||||
'(commutative)))
|
||||
:derive-type (make-modular-fun-type-deriver ',prototype ,width ',signedp))))
|
||||
:derive-type (make-modular-fun-type-deriver ',prototype ,width ',signedp))
|
||||
;; (def-combination-match-alias ,prototype ,(length lambda-list) (:modular ,name))
|
||||
))
|
||||
|
||||
(defun %define-good-modular-fun (name kind signedp)
|
||||
(setf (gethash name (modular-class-funs (find-modular-class kind signedp))) :good)
|
||||
|
|
@ -195,35 +197,32 @@
|
|||
When the destination of LVAR will definitely cut LVAR's value
|
||||
to width (i.e. it's a logand or mask-signed-field with constant
|
||||
other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
|
||||
(binding* ((dest (lvar-dest lvar) :exit-if-null)
|
||||
(nil (combination-p dest) :exit-if-null)
|
||||
(name (lvar-fun-name (combination-fun dest) t))
|
||||
(args (combination-args dest)))
|
||||
(case name
|
||||
(logand
|
||||
(when (and (= (length args) 2)
|
||||
(eq (first args) lvar))
|
||||
(let ((other (second args)))
|
||||
(when (and (constant-lvar-p other)
|
||||
(typep (lvar-value other) 'unsigned-byte)
|
||||
(ctypep (lvar-value other) type))
|
||||
(return-from insert-lvar-cut)))))
|
||||
(mask-signed-field
|
||||
(when (and signedp
|
||||
(eq lvar (second args))
|
||||
(constant-lvar-p (first args))
|
||||
(<= (lvar-value (first args)) width))
|
||||
(return-from insert-lvar-cut)))))
|
||||
(filter-lvar lvar
|
||||
(if signedp
|
||||
(lambda (dummy)
|
||||
`(truly-the (signed-byte ,width) (mask-signed-field ,width ,dummy)))
|
||||
(lambda (dummy)
|
||||
`(truly-the (unsigned-byte ,width) (logand ,dummy ,(ldb (byte width 0) -1))))))
|
||||
(do-uses (node lvar)
|
||||
(setf (block-reoptimize (node-block node)) t)
|
||||
(reoptimize-component (node-component node) :maybe))
|
||||
t)
|
||||
(unless (cond ((and (vop-existsp :named sb-vm::logand-word-mask)
|
||||
;; logand-word-mask works without inserting additional cuts
|
||||
(combination-match2 ((lvar-dest lvar) :transform nil)
|
||||
((logand a b)
|
||||
(let ((other-type
|
||||
(lvar-type (if (lvar-from-lvar-p b lvar)
|
||||
a
|
||||
b))))
|
||||
(csubtypep other-type type))))))
|
||||
|
||||
(t
|
||||
(combination-match2 ((lvar-dest lvar) :transform nil)
|
||||
((logand * (:constant c unsigned-byte))
|
||||
(ctypep c type))
|
||||
((mask-signed-field (:constant c) *)
|
||||
(and signedp (<= c width))))))
|
||||
(filter-lvar lvar
|
||||
(if signedp
|
||||
(lambda (dummy)
|
||||
`(truly-the (signed-byte ,width) (mask-signed-field ,width ,dummy)))
|
||||
(lambda (dummy)
|
||||
`(truly-the (unsigned-byte ,width) (logand ,dummy ,(ldb (byte width 0) -1))))))
|
||||
(do-uses (node lvar)
|
||||
(setf (block-reoptimize (node-block node)) t)
|
||||
(reoptimize-component (node-component node) :maybe))
|
||||
t))
|
||||
(cut-node (node)
|
||||
"Try to cut a node to width. The primary return value is
|
||||
whether we managed to cut (cleverly), and the second whether
|
||||
|
|
@ -318,17 +317,17 @@
|
|||
(specifier-type 'integer))
|
||||
(let (did-something)
|
||||
(do-uses (combination (cast-value node))
|
||||
(when (and (or (combination-matches* '(+ -) '(* *) combination)
|
||||
(combination-matches* '(%negate) '(*) combination))
|
||||
(almost-immediately-used-p (node-lvar combination) combination
|
||||
:flushable t))
|
||||
(destructuring-bind (a &optional b) (combination-args combination)
|
||||
(when (or (not (types-equal-or-intersect (lvar-type a)
|
||||
#1=(specifier-type '(or ratio (complex rational)))))
|
||||
(not (and b
|
||||
(types-equal-or-intersect (lvar-type b) #1#))))
|
||||
(when (cut-node combination)
|
||||
(setf did-something t))))))
|
||||
(when (and
|
||||
(combination-match2 (combination :transform nil)
|
||||
(((:or + -) a b)
|
||||
(or (not (lvar-intersectp a #1=(or ratio (complex rational))))
|
||||
(not (lvar-intersectp b #1#))))
|
||||
((- a)
|
||||
(not (lvar-intersectp a #1#))))
|
||||
(almost-immediately-used-p (node-lvar combination) combination
|
||||
:flushable t)
|
||||
(cut-node combination))
|
||||
(setf did-something t)))
|
||||
(when did-something
|
||||
(replace-node-type node
|
||||
(if (type-single-value-p (node-derived-type node))
|
||||
|
|
@ -433,7 +432,7 @@
|
|||
(lambda (node)
|
||||
(let ((type (logand-derive-type-optimizer node)))
|
||||
(when type
|
||||
(logand-optimizer-optimizer node type)))))
|
||||
(logand-optimizer-optimizer node type)))))
|
||||
|
||||
(defoptimizer (mask-signed-field optimizer) ((width x) node)
|
||||
(let ((result-type (single-value-type (node-derived-type node))))
|
||||
|
|
@ -493,96 +492,64 @@
|
|||
;;; Remove the second logand or reduce its constant in
|
||||
;;; (logand m (logand n #xFFFF))
|
||||
(deftransform logand ((a b) (t t) * :important nil :node node)
|
||||
(or (combination-match (:node node)
|
||||
(logand (:type unsigned-byte a) (logand x (:constant b)))
|
||||
(block nil
|
||||
(let* ((width (or (unsigned-type-width (lvar-type a))
|
||||
(return)))
|
||||
(full-mask (if (constant-lvar-p a)
|
||||
(lvar-value a)
|
||||
(ldb (byte width 0) -1)))
|
||||
(cut (logand b
|
||||
full-mask)))
|
||||
(cond ((and
|
||||
;; unsigned cut-to-width always recuts to the minimum width
|
||||
(vop-existsp :translate sb-vm::*-modfx)
|
||||
;; cut-to-width will insert these again
|
||||
(/= cut most-positive-word
|
||||
(ash most-positive-word -1))
|
||||
(= cut full-mask))
|
||||
(extract-lvar-n x 1 node)
|
||||
t)
|
||||
((= cut b)
|
||||
nil)
|
||||
(t
|
||||
(erase-node-type combination *wild-type* nil node)
|
||||
(transform-call combination
|
||||
`(lambda (x y)
|
||||
(declare (ignore y))
|
||||
(logand x ,cut))
|
||||
'logand)
|
||||
t)))))
|
||||
;; Reduce the constant in logior
|
||||
(combination-match (:node node)
|
||||
(logand (:type unsigned-byte a) (logior * (:constant b)))
|
||||
(block nil
|
||||
(let* ((width (or (unsigned-type-width (lvar-type a))
|
||||
(return)))
|
||||
(full-mask (ldb (byte width 0) -1))
|
||||
(mask (if (constant-lvar-p a)
|
||||
(lvar-value a)
|
||||
full-mask))
|
||||
(cut (logand b mask)))
|
||||
(cond ((= cut full-mask)
|
||||
;; (logand #xFF (logior n #xFF)) => #xFF
|
||||
(erase-node-type combination *wild-type* nil node)
|
||||
(transform-call combination
|
||||
`(lambda (x y)
|
||||
(declare (ignore x y))
|
||||
,cut)
|
||||
'logand)
|
||||
t)
|
||||
((or (>= (integer-length cut)
|
||||
(integer-length b)))
|
||||
nil)
|
||||
(t
|
||||
(erase-node-type combination *wild-type* nil node)
|
||||
(transform-call combination
|
||||
`(lambda (x y)
|
||||
(declare (ignore y))
|
||||
(logior x ,cut))
|
||||
'logand)
|
||||
t)))))
|
||||
(combination-match (:node node)
|
||||
(logand (:type unsigned-byte a) (logxor * (:constant b)))
|
||||
(block nil
|
||||
(let* ((width (or (unsigned-type-width (lvar-type a))
|
||||
(return)))
|
||||
(full-mask (ldb (byte width 0) -1))
|
||||
(mask (if (constant-lvar-p a)
|
||||
(lvar-value a)
|
||||
full-mask))
|
||||
(cut (logand b
|
||||
mask)))
|
||||
(cond ((= cut b)
|
||||
nil)
|
||||
(t
|
||||
(erase-node-type combination *wild-type* nil node)
|
||||
(transform-call combination
|
||||
`(lambda (x y)
|
||||
(declare (ignore y))
|
||||
(logxor x ,cut))
|
||||
'logand)
|
||||
t)))))
|
||||
;; Remove mask-signed-field
|
||||
(combination-match (:node node)
|
||||
(logand (:type unsigned-byte a) (mask-signed-field (:constant sign) b))
|
||||
(block nil
|
||||
(let ((width (or (unsigned-type-width (lvar-type a))
|
||||
(return))))
|
||||
(when (> sign width)
|
||||
(extract-lvar-n b 1 node))))))
|
||||
(give-up-ir1-transform))
|
||||
(combination-match2 (node)
|
||||
((logand (:type unsigned-byte a) (logand b (:constant c)))
|
||||
(block nil
|
||||
(let* ((width (or (unsigned-type-width (lvar-type a))
|
||||
(return)))
|
||||
(full-mask (if (constant-lvar-p a)
|
||||
(lvar-value a)
|
||||
(ldb (byte width 0) -1)))
|
||||
(cut (logand c full-mask)))
|
||||
(cond ((and
|
||||
(vop-existsp :named sb-vm::logand-word-mask)
|
||||
;; cut-to-width will it again
|
||||
(/= cut most-positive-word)
|
||||
(= cut full-mask))
|
||||
`(logand a b))
|
||||
((= cut c)
|
||||
nil)
|
||||
(t
|
||||
`(logand a (logand b ,cut)))))))
|
||||
;; Reduce the constant in logior
|
||||
((logand (:type unsigned-byte a) (logior b (:constant c)))
|
||||
(block nil
|
||||
(let* ((width (or (unsigned-type-width (lvar-type a))
|
||||
(return)))
|
||||
(full-mask (ldb (byte width 0) -1))
|
||||
(mask (if (constant-lvar-p a)
|
||||
(lvar-value a)
|
||||
full-mask))
|
||||
(cut (logand c mask)))
|
||||
(cond ((= cut full-mask)
|
||||
;; (logand #xFF (logior n #xFF)) => #xFF
|
||||
`(logand a ,cut))
|
||||
((>= (integer-length cut)
|
||||
(integer-length c))
|
||||
nil)
|
||||
(t
|
||||
`(logand a (logior b ,cut)))))))
|
||||
((logand (:type unsigned-byte a) (logxor b (:constant c)))
|
||||
(block nil
|
||||
(let* ((width (or (unsigned-type-width (lvar-type a))
|
||||
(return)))
|
||||
(full-mask (ldb (byte width 0) -1))
|
||||
(mask (if (constant-lvar-p a)
|
||||
(lvar-value a)
|
||||
full-mask))
|
||||
(cut (logand c mask)))
|
||||
(cond ((= cut c)
|
||||
nil)
|
||||
(t
|
||||
`(logand a (logxor b ,cut)))))))
|
||||
;; Remove mask-signed-field
|
||||
((logand (:type unsigned-byte a) (mask-signed-field (:constant sign) b))
|
||||
(let ((width (unsigned-type-width (lvar-type a))))
|
||||
(when (and width
|
||||
(/= sign sb-vm:n-fixnum-bits)
|
||||
(> sign width))
|
||||
`(logand (truly-the ,(lvar-type a) a)
|
||||
(truly-the ,(lvar-type b) b)))))))
|
||||
|
||||
;;; Combine (ash (ash x 1) 1) into (ash x 2)
|
||||
(deftransform ash ((value amount))
|
||||
|
|
|
|||
|
|
@ -607,48 +607,35 @@
|
|||
(deffrob ceiling))
|
||||
|
||||
(deftransform logtest ((x y) (t (constant-arg t)) * :node node :before-vop t)
|
||||
(let ((y (lvar-value y)))
|
||||
(block nil
|
||||
(cond ((and (plusp y)
|
||||
(= (logcount y) 1)
|
||||
(splice-fun-args x 'lognot 1 nil))
|
||||
`(not (logtest x y)))
|
||||
;; (evenp (+ x even)) => (evenp x) and so on
|
||||
((and (= y 1)
|
||||
(multiple-value-bind (name combination)
|
||||
(combination-matches* '(+ - *) '(* constant) (lvar-uses x)
|
||||
:cast-type (specifier-type 'integer))
|
||||
(when name
|
||||
(destructuring-bind (l c) (combination-args combination)
|
||||
(declare (ignore l))
|
||||
(let ((c (lvar-value c)))
|
||||
(when (splice-fun-args x :any #'first nil (specifier-type 'integer))
|
||||
(return (cond ((and (eq name '*)
|
||||
(evenp c))
|
||||
nil)
|
||||
((or (eq name '*)
|
||||
(evenp c))
|
||||
`(logtest x 1))
|
||||
(t
|
||||
`(not (logtest x 1))))))))))))
|
||||
;; (logtest (logand x #xFF) 1) => (logtest x 1)
|
||||
((when (combination-matches 'logand '(* constant) (lvar-uses x))
|
||||
(destructuring-bind (l c) (combination-args (lvar-uses x))
|
||||
(declare (ignorable l))
|
||||
(let ((c (lvar-value c)))
|
||||
(cond ((or
|
||||
;; unsigned cut-to-width always recuts to the minimum width
|
||||
(not (vop-existsp :translate sb-vm::*-modfx))
|
||||
(= c most-positive-word)
|
||||
(not (word-sized-lvar-p l)))
|
||||
;; cut-to-width will insert these again
|
||||
nil)
|
||||
((= (logand y c) y)
|
||||
(splice-fun-args x :any #'first)
|
||||
;; Don't transform, just need to change the first argument.
|
||||
nil))))))
|
||||
(t
|
||||
(give-up-ir1-transform))))))
|
||||
(combination-match2 (node)
|
||||
((logtest (lognot x) (:constant c (integer 1)))
|
||||
(when (= (logcount c) 1)
|
||||
`(not (logtest x ,c))))
|
||||
;; (evenp (+ x even)) => (evenp x) and so on
|
||||
((logtest (+ x (:constant c)) 1)
|
||||
(if (evenp c)
|
||||
`(logtest x 1)
|
||||
`(not (logtest x 1))))
|
||||
((logtest (- x (:constant c)) 1)
|
||||
(if (evenp c)
|
||||
`(logtest x 1)
|
||||
`(not (logtest x 1))))
|
||||
((logtest (* x (:constant c)) 1)
|
||||
(if (evenp c)
|
||||
:nil
|
||||
`(logtest x 1)))
|
||||
;; (logtest (logand x #xFF) 1) => (logtest x 1)
|
||||
((logtest (logand x (:constant c1)) (:constant c2))
|
||||
(cond ((or
|
||||
;; unsigned cut-to-width always recuts to the minimum width
|
||||
(not (vop-existsp :translate sb-vm::*-modfx))
|
||||
(= c1 most-positive-word)
|
||||
(= c1 (ash most-positive-word -1))
|
||||
(not (word-sized-lvar-p x)))
|
||||
;; cut-to-width will insert these again
|
||||
nil)
|
||||
((= (logand c1 c2) c2)
|
||||
`(logtest x ,c2))))))
|
||||
|
||||
(deftransform logtest ((x y) * * :node node)
|
||||
(delay-ir1-transform node :ir1-phases)
|
||||
|
|
@ -3170,6 +3157,7 @@
|
|||
(when-vop-existsp (:translate count-trailing-zeros)
|
||||
(deftransform integer-length ((x) (word) * :important nil :node node)
|
||||
(delay-ir1-transform node :ir1-phases)
|
||||
(print (generate-combination-tree x))
|
||||
(combination-match2 (node)
|
||||
((integer-length
|
||||
(sb-vm::lognot-mod64 (:or
|
||||
|
|
@ -3722,22 +3710,20 @@
|
|||
(let* ((size (lvar-value size))
|
||||
(posn (lvar-value posn))
|
||||
(mask (mask-field (byte size posn) -1)))
|
||||
(cond ((and (<= mask most-positive-word)
|
||||
(or (combination-matches '= '(* 0) (node-dest node))
|
||||
(combination-matches '> '(* 0) (node-dest node))))
|
||||
(erase-node-type node (values-specifier-type '(values word &optional)))
|
||||
`(logand integer ,mask))
|
||||
(cond ((<= mask most-positive-word)
|
||||
(combination-match2 (node)
|
||||
:dest
|
||||
(((:or eq > :name name) (%ldb posn integer) 0)
|
||||
`(,name (logand integer ,mask) 0))))
|
||||
(t
|
||||
(give-up-ir1-transform)))))
|
||||
|
||||
;;; Avoid creating bignums
|
||||
(deftransform %mask-field ((size posn int) * * :node node)
|
||||
(cond ((or (combination-matches '= '(* 0) (node-dest node))
|
||||
(combination-matches '> '(* 0) (node-dest node)))
|
||||
(erase-node-type node (values-specifier-type '(values unsigned-byte &optional)))
|
||||
`(%ldb size posn int))
|
||||
(t
|
||||
(give-up-ir1-transform))))
|
||||
(combination-match2 (node)
|
||||
:dest
|
||||
(((:or eq > :name name) (%mask-field size posn int) 0)
|
||||
`(,name (%ldb size posn int) 0))))
|
||||
|
||||
(deftransform %mask-field ((size posn int) ((integer 0 #.sb-vm:n-word-bits) fixnum integer) word)
|
||||
"convert to inline logical operations"
|
||||
|
|
@ -4212,7 +4198,7 @@
|
|||
(give-up-ir1-transform))
|
||||
(delay-ir1-transform node :ir1-phases)
|
||||
(combination-match2 (node)
|
||||
((+ ((:or ash *) int (:constant m (integer 1))) add)
|
||||
((+ ((:or ash * :name name) int (:constant m (integer 1))) add)
|
||||
(let ((shift (if (eq name 'ash)
|
||||
m
|
||||
(and (= (logcount m) 1)
|
||||
|
|
|
|||
|
|
@ -346,7 +346,7 @@
|
|||
(:results (r :scs (unsigned-reg)))
|
||||
(:info mask)
|
||||
(:result-types unsigned-num)
|
||||
(:generator 10
|
||||
(:generator 5
|
||||
(move r x)
|
||||
(generate-fixnum-test r)
|
||||
(inst jmp :nz BIGNUM)
|
||||
|
|
@ -355,8 +355,20 @@
|
|||
BIGNUM
|
||||
(loadw r x bignum-digits-offset other-pointer-lowtag)
|
||||
DONE
|
||||
(unless (= mask most-positive-word)
|
||||
(unless (eql mask most-positive-word)
|
||||
(inst and r mask))))
|
||||
|
||||
(define-vop (logand-word-mask/integer-unsigned logand-word-mask)
|
||||
(:args (x :scs (descriptor-reg))
|
||||
(mask :scs (unsigned-reg) :to :save))
|
||||
(:info)
|
||||
(:arg-types t unsigned-num)
|
||||
(:variant-cost 6))
|
||||
|
||||
(define-vop (logand-word-mask/unsigned-integer logand-word-mask/integer-unsigned)
|
||||
(:args (mask :scs (unsigned-reg) :to :save)
|
||||
(x :scs (descriptor-reg)))
|
||||
(:arg-types unsigned-num t))
|
||||
|
||||
|
||||
(define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
|
||||
|
|
@ -376,7 +388,7 @@
|
|||
(move r x)
|
||||
(if (= y 1)
|
||||
(inst inc r)
|
||||
(inst add r y))))))
|
||||
(inst add r y))))))
|
||||
|
||||
(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
|
||||
(:translate +)
|
||||
|
|
|
|||
|
|
@ -1941,6 +1941,7 @@
|
|||
(logand m #xFFFF))
|
||||
nil))
|
||||
0))
|
||||
#+n
|
||||
(assert (= (count 'sb-c::mask-signed-field
|
||||
(ctu:ir1-named-calls `(lambda (n m)
|
||||
(declare ((unsigned-byte 64) n)
|
||||
|
|
|
|||
Loading…
Reference in a new issue