mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Transform (evenp (1+ x)) to (oddp x)
And other similar combinations.
This commit is contained in:
Stas Boukarev
parent
9b55d0c6f8
commit
671e23e537
|
|
@ -292,13 +292,29 @@
|
|||
(defun combination-matches (name args combination)
|
||||
(and (combination-p combination)
|
||||
(let ((fun (combination-fun combination)))
|
||||
(when (eq (lvar-fun-name fun) name)
|
||||
(loop for arg in (combination-args combination)
|
||||
for arg-m in args
|
||||
always (or (eq arg arg-m)
|
||||
(eq arg-m '*)
|
||||
(and (constant-lvar-p arg)
|
||||
(eql (lvar-value arg) arg-m))))))))
|
||||
(when (and (eq (lvar-fun-name fun) name)
|
||||
(loop for arg in (combination-args combination)
|
||||
for arg-m in args
|
||||
always (or (eq arg arg-m)
|
||||
(eq arg-m '*)
|
||||
(and (constant-lvar-p arg)
|
||||
(or (eq arg-m 'constant)
|
||||
(eql (lvar-value arg) arg-m))))))
|
||||
name))))
|
||||
|
||||
(defun combination-matches* (names args combination)
|
||||
(and (combination-p combination)
|
||||
(let* ((fun (combination-fun combination))
|
||||
(name (lvar-fun-name fun)))
|
||||
(when (and (memq name names)
|
||||
(loop for arg in (combination-args combination)
|
||||
for arg-m in args
|
||||
always (or (eq arg arg-m)
|
||||
(eq arg-m '*)
|
||||
(and (constant-lvar-p arg)
|
||||
(or (eq arg-m 'constant)
|
||||
(eql (lvar-value arg) arg-m))))))
|
||||
name))))
|
||||
|
||||
(defun erase-lvar-type (lvar &optional nth-value)
|
||||
(let (seen)
|
||||
|
|
|
|||
|
|
@ -43,12 +43,19 @@
|
|||
;; or if another transform could be applied with the right policy.
|
||||
(policy nil :type (or null function)))
|
||||
|
||||
;;; A normal transform inserted before VOP-TRANSFORMs
|
||||
(defstruct (before-vop-transform (:copier nil)
|
||||
(:predicate nil)
|
||||
(:include transform)))
|
||||
|
||||
;;; A transform inserted at the front of fun-info-transforms and stops
|
||||
;;; other from firing if it has a VOP that can do the job.
|
||||
(defstruct (vop-transform (:copier nil)
|
||||
(:predicate nil)
|
||||
(:include transform)))
|
||||
|
||||
(declaim (freeze-type transform))
|
||||
|
||||
(defun transform-note (transform)
|
||||
(or #+sb-xc-host (documentation (transform-function transform) 'function)
|
||||
#-sb-xc-host (and (fboundp 'sb-pcl::fun-doc)
|
||||
|
|
@ -69,9 +76,13 @@
|
|||
(info (fun-info-or-lose name))
|
||||
(transforms (fun-info-transforms info))
|
||||
(old (find-if (lambda (transform)
|
||||
(and (if (eq important :vop)
|
||||
(typep transform 'vop-transform)
|
||||
(not (typep transform 'vop-transform)))
|
||||
(and (case important (eq important :vop)
|
||||
(:vop
|
||||
(typep transform 'vop-transform))
|
||||
(:before-vop
|
||||
(typep transform 'before-vop-transform))
|
||||
(t
|
||||
(not (typep transform '(or vop-transform before-vop-transform)))))
|
||||
(type= (transform-type transform)
|
||||
ctype)))
|
||||
transforms)))
|
||||
|
|
@ -79,22 +90,34 @@
|
|||
(style-warn 'redefinition-with-deftransform :transform old)
|
||||
(setf (transform-function old) fun
|
||||
(transform-policy old) policy)
|
||||
(unless (eq important :vop)
|
||||
(unless (or (eq important :vop)
|
||||
(eq important :before-vop))
|
||||
(setf (transform-important old) important)))
|
||||
(t
|
||||
;; Put vop-transform at the front.
|
||||
(if (eq important :vop)
|
||||
(push (make-vop-transform :type ctype :function fun
|
||||
:policy policy)
|
||||
(fun-info-transforms info))
|
||||
(let ((normal (member-if (lambda (transform)
|
||||
(not (typep transform 'vop-transform)))
|
||||
transforms))
|
||||
(transform (make-transform :type ctype :function fun
|
||||
:important important
|
||||
:policy policy)))
|
||||
(setf (fun-info-transforms info)
|
||||
(append (ldiff transforms normal) (list* transform normal)))))))
|
||||
(case important
|
||||
(:before-vop
|
||||
(push (make-before-vop-transform :type ctype :function fun
|
||||
:policy policy)
|
||||
(fun-info-transforms info)))
|
||||
(:vop
|
||||
(let ((normal (member-if (lambda (transform)
|
||||
(not (eq (type-of transform) 'before-vop-transform)))
|
||||
transforms))
|
||||
(transform (make-vop-transform :type ctype :function fun
|
||||
:policy policy)))
|
||||
(setf (fun-info-transforms info)
|
||||
(append (ldiff transforms normal) (list* transform normal)))))
|
||||
(t
|
||||
(let ((normal (member-if (lambda (transform)
|
||||
(not (typep transform '(or vop-transform
|
||||
before-vop-transform))))
|
||||
transforms))
|
||||
(transform (make-transform :type ctype :function fun
|
||||
:important important
|
||||
:policy policy)))
|
||||
(setf (fun-info-transforms info)
|
||||
(append (ldiff transforms normal) (list* transform normal))))))))
|
||||
name))
|
||||
|
||||
;;; Make a FUN-INFO structure with the specified type, attributes
|
||||
|
|
|
|||
|
|
@ -296,16 +296,19 @@
|
|||
;;; :VOP
|
||||
;;; - insert it at the front, stop other transforms from firing
|
||||
;;; if the function returns T.
|
||||
;;; :BEFORE-VOP
|
||||
;;; - an ordinary transform placed before VOP transforms.
|
||||
(defmacro deftransform (name (lambda-list &optional (arg-types '*)
|
||||
(result-type '*)
|
||||
&key result policy node defun-only
|
||||
(important :slightly)
|
||||
vop)
|
||||
vop
|
||||
before-vop)
|
||||
&body body-decls-doc)
|
||||
(declare (type (member nil :slightly t) important))
|
||||
(when defun-only
|
||||
(aver (eq important :slightly)) ; can't be specified
|
||||
(aver (not policy))) ; has no effect on the defun
|
||||
(aver (not policy))) ; has no effect on the defun
|
||||
(multiple-value-bind (body decls doc) (parse-body body-decls-doc t)
|
||||
(let ((n-node (or node '#:node))
|
||||
(n-decls '#:decls)
|
||||
|
|
@ -331,13 +334,13 @@
|
|||
:none
|
||||
:failure)))
|
||||
`(multiple-value-bind (,n-lambda ,n-decls)
|
||||
(progn ,@body)
|
||||
(if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
|
||||
,n-lambda
|
||||
`(lambda ,',lambda-list
|
||||
(declare (ignorable ,@',vars))
|
||||
,@,n-decls
|
||||
,,n-lambda))))))))
|
||||
(progn ,@body)
|
||||
(if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
|
||||
,n-lambda
|
||||
`(lambda ,',lambda-list
|
||||
(declare (ignorable ,@',vars))
|
||||
,@,n-decls
|
||||
,,n-lambda))))))))
|
||||
(cond
|
||||
((not defun-only)
|
||||
`(let ((fun (named-lambda (deftransform ,name) ,@stuff)))
|
||||
|
|
@ -348,13 +351,16 @@
|
|||
,(and policy `(lambda (,n-node) (policy ,n-node ,policy)))
|
||||
'(function ,types ,result-type)
|
||||
fun
|
||||
,(if vop
|
||||
:vop
|
||||
important)))))
|
||||
,(cond (vop
|
||||
:vop)
|
||||
(before-vop
|
||||
:before-vop)
|
||||
(t
|
||||
important))))))
|
||||
((eq defun-only 'lambda)
|
||||
`(named-lambda ,name ,@stuff))
|
||||
(defun-only
|
||||
`(defun ,name ,@stuff))))))))
|
||||
`(defun ,name ,@stuff))))))))
|
||||
|
||||
(defmacro deftransforms (names (lambda-list &optional (arg-types '*)
|
||||
(result-type '*)
|
||||
|
|
|
|||
|
|
@ -500,10 +500,34 @@
|
|||
(deffrob floor)
|
||||
(deffrob ceiling))
|
||||
|
||||
;;; This used to be a source transform (hence the lack of restrictions
|
||||
;;; on the argument types), but we make it a regular transform so that
|
||||
;;; the VM has a chance to see the bare LOGTEST and potentiall choose
|
||||
;;; to implement it differently. --njf, 06-02-2006
|
||||
(deftransform logtest ((x y) * * :node node :before-vop t)
|
||||
(let (name)
|
||||
(cond ((and (constant-lvar-p y)
|
||||
(= (logcount (lvar-value y)) 1)
|
||||
(splice-fun-args x 'lognot 1 nil))
|
||||
`(not (logtest x y)))
|
||||
;; (evenp (+ x even)) => (evenp x) and so on
|
||||
((and (constant-lvar-p y)
|
||||
(= (lvar-value y) 1)
|
||||
(setf name
|
||||
(combination-matches* '(+ - *) '(* constant) (lvar-uses x))))
|
||||
(destructuring-bind (l c) (combination-args (lvar-uses x))
|
||||
(declare (ignore l))
|
||||
(let ((c (lvar-value c)))
|
||||
(cond ((and (eq name '*)
|
||||
(evenp c))
|
||||
nil)
|
||||
(t
|
||||
(splice-fun-args x :any 2)
|
||||
`(lambda (x c y)
|
||||
(declare (ignore y c))
|
||||
,(if (or (eq name '*)
|
||||
(evenp c))
|
||||
`(logtest x 1)
|
||||
`(not (logtest x 1)))))))))
|
||||
(t
|
||||
(give-up-ir1-transform)))))
|
||||
|
||||
(deftransform logtest ((x y) * * :node node)
|
||||
(delay-ir1-transform node :ir1-phases)
|
||||
`(not (zerop (logand x y))))
|
||||
|
|
@ -520,27 +544,29 @@
|
|||
((type= type (specifier-type '(eql 0)))
|
||||
(specifier-type '(eql nil))))))))
|
||||
|
||||
(defun logbitp-to-minusp-p (index integer)
|
||||
(let* ((int (type-approximate-interval (lvar-type integer)))
|
||||
(length (max (integer-length (interval-low int))
|
||||
(integer-length (interval-high int))))
|
||||
(index-int (type-approximate-interval (lvar-type index))))
|
||||
(>= (interval-low index-int) length)))
|
||||
(deftransform logbitp ((index integer) * * :node node :before-vop t)
|
||||
(cond ((splice-fun-args integer 'lognot 1 nil)
|
||||
`(not (logbitp index integer)))
|
||||
((let* ((int (type-approximate-interval (lvar-type integer)))
|
||||
(length (and int
|
||||
(interval-low int)
|
||||
(interval-high int)
|
||||
(max (integer-length (interval-low int))
|
||||
(integer-length (interval-high int)))))
|
||||
(index-int (type-approximate-interval (lvar-type index))))
|
||||
(when (and length
|
||||
index-int)
|
||||
(>= (interval-low index-int) length)))
|
||||
`(< integer 0))
|
||||
(t
|
||||
(give-up-ir1-transform))))
|
||||
|
||||
(deftransform logbitp ((index integer) * * :node node)
|
||||
(let ((integer-type (lvar-type integer))
|
||||
(integer-value (and (constant-lvar-p integer)
|
||||
(lvar-value integer))))
|
||||
(cond ((eql integer-value 0)
|
||||
nil)
|
||||
((eql integer-value -1)
|
||||
t)
|
||||
((csubtypep integer-type (specifier-type '(or word
|
||||
sb-vm:signed-word)))
|
||||
(let ((integer-type (lvar-type integer)))
|
||||
(cond ((or (csubtypep integer-type (specifier-type 'word))
|
||||
(csubtypep integer-type (specifier-type 'sb-vm:signed-word)))
|
||||
(delay-ir1-transform node :ir1-phases)
|
||||
(if (logbitp-to-minusp-p index integer)
|
||||
`(minusp integer)
|
||||
`(logtest 1 (ash integer (- index)))))
|
||||
`(logtest 1 (ash integer (- index))))
|
||||
((csubtypep integer-type (specifier-type 'bignum))
|
||||
(if (csubtypep (lvar-type index)
|
||||
(specifier-type `(mod ,sb-vm:n-word-bits))) ; word-index
|
||||
|
|
@ -552,7 +578,6 @@
|
|||
(t
|
||||
(give-up-ir1-transform)))))
|
||||
|
||||
|
||||
(defoptimizer (logbitp derive-type) ((index integer))
|
||||
(let* ((one (specifier-type '(eql 1)))
|
||||
(and (two-arg-derive-type index integer
|
||||
|
|
|
|||
|
|
@ -2909,8 +2909,8 @@
|
|||
(cons #'vop-optimize-fast-logtest-c/fixnum-optimizer 'sb-c::select-representations))
|
||||
|
||||
(deftransform logbitp ((index integer) (:or ((signed-word signed-word) *)
|
||||
((word word) *)) * :vop t)
|
||||
(not (sb-c::logbitp-to-minusp-p index integer)))
|
||||
((word word) *)) * :vop t)
|
||||
t)
|
||||
|
||||
;;; TODO: The TEST instruction preceding this JEQ is entirely superfluous
|
||||
;;; and can be removed with a vop optimizer:
|
||||
|
|
|
|||
Loading…
Reference in a new issue