LOGBITP and LOGTEST optimizations from x86.

Copy Nathan Froyd's optimizations for LOGBITP and LOGTEST
on x86 architecture into x86-64.

Committing change submitted by Doug Katzman.

diff --git a/NEWS b/NEWS
index 91ec2be..0c96a2a 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,7 @@ changes relative to sbcl-1.1.6
     Signal a style-warning instead when trying to set documentation of NIL
     for all other documentation types.
     Reported by Zach Beane. Regression since 2e52fa05.
+  * LOGBITP and LOGTEST optimizations from x86 ported to x86_64.
 
 changes in sbcl-1.1.6 relative to sbcl-1.1.5:
   * enhancement: the continuable error when defknown-ing over extant

diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp
index 9d48e29..dc33d2c 100644 (file)
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -1155,6 +1155,79 @@ constant shift greater than word length")))
   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
   (:info y))
 
+;; Stolen liberally from the x86 32-bit implementation.
+(macrolet ((define-logtest-vops ()
+             `(progn
+               ,@(loop for suffix in '(/fixnum -c/fixnum
+                                       /signed -c/signed
+                                       /unsigned -c/unsigned)
+                       for cost in '(4 3 6 5 6 5)
+                       collect
+                       `(define-vop (,(symbolicate "FAST-LOGTEST" suffix)
+                                     ,(symbolicate "FAST-CONDITIONAL" suffix))
+                         (:translate logtest)
+                         (:conditional :ne)
+                         (:generator ,cost
+                          (emit-optimized-test-inst x
+                           ,(if (eq suffix '-c/fixnum)
+                                ;; See whether (fixnumize y) fits in signed 32
+                                ;; to avoid chip's sign-extension of imm32 val.
+                                `(if (typep y 'short-tagged-num)
+                                     (fixnumize y)
+                                     (register-inline-constant :qword (fixnumize y)))
+                                `(cond ((typep y '(signed-byte 32)) ; same
+                                        y)
+                                       ((typep y '(or (unsigned-byte 64) (signed-byte 64)))
+                                        (register-inline-constant :qword y))
+                                       (t
+                                        y))))))))))
+  (define-logtest-vops))
+
+(defknown %logbitp (integer unsigned-byte) boolean
+  (movable foldable flushable always-translatable))
+
+;;; only for constant folding within the compiler
+(defun %logbitp (integer index)
+  (logbitp index integer))
+
+;;; too much work to do the non-constant case (maybe?)
+(define-vop (fast-logbitp-c/fixnum fast-conditional-c/fixnum)
+  (:translate %logbitp)
+  (:conditional :c)
+  (:arg-types tagged-num (:constant (integer 0 #.(- 63 n-fixnum-tag-bits))))
+  (:generator 4
+    (inst bt x (+ y n-fixnum-tag-bits))))
+
+(define-vop (fast-logbitp/signed fast-conditional/signed)
+  (:args (x :scs (signed-reg signed-stack))
+         (y :scs (signed-reg)))
+  (:translate %logbitp)
+  (:conditional :c)
+  (:generator 6
+    (inst bt x y)))
+
+(define-vop (fast-logbitp-c/signed fast-conditional-c/signed)
+  (:translate %logbitp)
+  (:conditional :c)
+  (:arg-types signed-num (:constant (integer 0 63)))
+  (:generator 5
+    (inst bt x y)))
+
+(define-vop (fast-logbitp/unsigned fast-conditional/unsigned)
+  (:args (x :scs (unsigned-reg unsigned-stack))
+         (y :scs (unsigned-reg)))
+  (:translate %logbitp)
+  (:conditional :c)
+  (:generator 6
+    (inst bt x y)))
+
+(define-vop (fast-logbitp-c/unsigned fast-conditional-c/unsigned)
+  (:translate %logbitp)
+  (:conditional :c)
+  (:arg-types unsigned-num (:constant (integer 0 63)))
+  (:generator 5
+    (inst bt x y)))
+
 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
              `(progn
                 ,@(mapcar

diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp
index 15efc7d..0a982cd 100644 (file)
--- a/src/compiler/x86-64/insts.lisp
+++ b/src/compiler/x86-64/insts.lisp
@@ -2262,6 +2262,27 @@
              (t
               (error "bogus operands for TEST: ~S and ~S" this that)))))))
 
+;;; Emit the most compact form of the test immediate instruction,
+;;; using an 8 bit test when the immediate is only 8 bits and the
+;;; value is one of the four low registers (rax, rbx, rcx, rdx) or the
+;;; control stack.
+(defun emit-optimized-test-inst (x y)
+  (typecase y
+    ((unsigned-byte 7)
+     (let ((offset (tn-offset x)))
+       (cond ((and (sc-is x any-reg descriptor-reg)
+                   (or (= offset rax-offset) (= offset rbx-offset)
+                       (= offset rcx-offset) (= offset rdx-offset)))
+              (inst test (reg-in-size x :byte) y))
+             ((sc-is x control-stack)
+              (inst test (make-ea :byte :base rbp-tn
+                                  :disp (frame-byte-offset offset))
+                    y))
+             (t
+              (inst test x y)))))
+    (t
+     (inst test x y))))
+
 (define-instruction or (segment dst src)
   (:printer-list
    (arith-inst-printer-list #b001))

diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp
index 9295e4e..6c44424 100644 (file)
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -555,5 +555,33 @@
 (def!constant cfp-offset rbp-offset) ; pfw - needed by stuff in /code
 
 (!def-vm-support-routine combination-implementation-style (node)
-  (declare (type sb!c::combination node) (ignore node))
-  (values :default nil))
+  (declare (type sb!c::combination node))
+  (flet ((valid-funtype (args result)
+           (sb!c::valid-fun-use node
+                                (sb!c::specifier-type
+                                 `(function ,args ,result)))))
+    (case (sb!c::combination-fun-source-name node)
+      (logtest
+       (cond
+         ((or (valid-funtype '(fixnum fixnum) '*)
+              ;; todo: nothing prevents this from testing an unsigned word against
+              ;; a signed word, except for the mess of VOPs it would demand
+              (valid-funtype '((signed-byte 64) (signed-byte 64)) '*)
+              (valid-funtype '((unsigned-byte 64) (unsigned-byte 64)) '*))
+          (values :direct nil))
+         (t
+          (values :default nil))))
+      (logbitp
+       (cond
+         ((or (and (valid-funtype '#.`((integer 0 ,(- 63 n-fixnum-tag-bits))
+                                       fixnum) '*)
+                   (sb!c::constant-lvar-p
+                    (first (sb!c::basic-combination-args node))))
+              (valid-funtype '((integer 0 63) (signed-byte 64)) '*)
+              (valid-funtype '((integer 0 63) (unsigned-byte 64)) '*))
+          (values :transform '(lambda (index integer)
+                               (%logbitp integer index))))
+         (t
+          (values :default nil))))
+      (t
+       (values :default nil)))))