Menu
▾
▴
[Sbcl-commits] master: Optimize TYPEP of (MOD X) on x86/x86-64.
|
From: stassats <sta...@us...> - 2013-07-16 19:09:26
|
The branch "master" has been updated in SBCL:
via 953e2961a4e0f130d67da600d1c965d6794a8984 (commit)
from 220651c01541b357cfb478e0989aae646d953c51 (commit)
- Log -----------------------------------------------------------------
commit 953e2961a4e0f130d67da600d1c965d6794a8984
Author: Stas Boukarev <sta...@gm...>
Date: Tue Jul 16 05:12:51 2013 +0400
Optimize TYPEP of (MOD X) on x86/x86-64.
Optimize type-tests in the same vein as type-checks previously, and
implement type-checks by means of type-tests. Further optimize it by
avoiding doing fixnum tests on known fixnums and boxing of
signed/unsigned numbers.
---
package-data-list.lisp-expr | 4 +-
src/code/interr.lisp | 5 --
src/code/pred.lisp | 6 ++
src/compiler/fndb.lisp | 5 ++
src/compiler/generic/interr.lisp | 2 -
src/compiler/generic/vm-type.lisp | 6 --
src/compiler/ir2tran.lisp | 11 +---
src/compiler/meta-vmdef.lisp | 8 ++-
src/compiler/typetran.lisp | 10 +++-
src/compiler/x86-64/type-vops.lisp | 90 ++++++++++++++++++++++--------------
src/compiler/x86/type-vops.lisp | 84 ++++++++++++++++++++++-----------
11 files changed, 141 insertions(+), 90 deletions(-)
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index d0ced09..7e5e9b9 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -243,7 +243,6 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
"CHECK-SYMBOL"
;; FIXME: 32/64-bit issues
"CHECK-UNSIGNED-BYTE-32" "CHECK-UNSIGNED-BYTE-64"
- "CHECK-MOD-FIXNUM"
"CLOSURE-INIT" "CLOSURE-REF" "CLOSURE-INIT-FROM-FP"
"*CODE-COVERAGE-INFO*"
"COMPARE-AND-SWAP-SLOT"
@@ -1358,6 +1357,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF"
"%FIND-POSITION-IF-VECTOR-MACRO" "%FIND-POSITION-IF-NOT"
"%FIND-POSITION-IF-NOT-VECTOR-MACRO"
+ "FIXNUM-MOD-P"
"%HYPOT" "%LDB" "%LOG" "%LOGB" "%LOG10"
"%LAST0"
"%LAST1"
@@ -1617,7 +1617,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR"
"OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUN-ERROR"
"OBJECT-NOT-INSTANCE-ERROR" "OBJECT-NOT-INTEGER-ERROR"
- "OBJECT-NOT-LIST-ERROR" "OBJECT-NOT-MOD-ERROR"
+ "OBJECT-NOT-LIST-ERROR"
#!+long-float "OBJECT-NOT-LONG-FLOAT-ERROR"
"OBJECT-NOT-NUMBER-ERROR" "OBJECT-NOT-RATIO-ERROR"
"OBJECT-NOT-RATIONAL-ERROR" "OBJECT-NOT-REAL-ERROR"
diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index 18c571e..fb16a77 100644
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -106,11 +106,6 @@
:datum object
:expected-type 'fixnum))
-(deferr object-not-mod-error (object limit)
- (error 'type-error
- :datum object
- :expected-type `(mod ,(1+ limit))))
-
(deferr object-not-vector-error (object)
(error 'type-error
:datum object
diff --git a/src/code/pred.lisp b/src/code/pred.lisp
index 9f8ac78..f167505 100644
--- a/src/code/pred.lisp
+++ b/src/code/pred.lisp
@@ -149,6 +149,12 @@
(def-type-predicate-wrapper stringp)
(def-type-predicate-wrapper vectorp)
(def-type-predicate-wrapper vector-nil-p))
+
+#!+(or x86 x86-64)
+(defun fixnum-mod-p (x limit)
+ (and (fixnump x)
+ (<= 0 x limit)))
+
;;; Return the specifier for the type of object. This is not simply
;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index de4ce88..4089b77 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -76,6 +76,11 @@
(defknown (eq eql) (t t) boolean (movable foldable flushable))
(defknown (equal equalp) (t t) boolean (foldable flushable recursive))
+
+#!+(or x86 x86-64)
+(defknown fixnum-mod-p (t fixnum) boolean
+ (movable foldable flushable always-translatable))
+
;;;; classes
diff --git a/src/compiler/generic/interr.lisp b/src/compiler/generic/interr.lisp
index e1120b7..9ff81d3 100644
--- a/src/compiler/generic/interr.lisp
+++ b/src/compiler/generic/interr.lisp
@@ -55,8 +55,6 @@
"Object is not of type SIMPLE-STRING.")
(object-not-fixnum
"Object is not of type FIXNUM.")
- (object-not-mod
- "Object is not of type (MOD X).")
(object-not-vector
"Object is not of type VECTOR.")
(object-not-string
diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp
index 5764891..d5750cd 100644
--- a/src/compiler/generic/vm-type.lisp
+++ b/src/compiler/generic/vm-type.lisp
@@ -182,7 +182,6 @@
;;; If TYPE has a CHECK-xxx template, but doesn't have a corresponding
;;; PRIMITIVE-TYPE, then return the template's name. Otherwise, return NIL.
-;;; The second value is T if the template needs TYPE to be passed.
(defun hairy-type-check-template-name (type)
(declare (type ctype type))
(typecase type
@@ -209,11 +208,6 @@
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
((type= type (specifier-type '(unsigned-byte 64)))
'sb!c:check-unsigned-byte-64)
- #!+(or x86 x86-64) ; Not implemented yet on other platforms
- ((and (eql (numeric-type-class type) 'integer)
- (eql (numeric-type-low type) 0)
- (fixnump (numeric-type-high type)))
- (values 'sb!c:check-mod-fixnum t))
(t nil)))
(fun-type
'sb!c:check-fun)
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 275d2dc..026dd5f 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -31,16 +31,14 @@
;;; If there is any CHECK-xxx template for TYPE, then return it,
;;; otherwise return NIL.
-;;; The second value is T if the template needs TYPE to be passed
(defun type-check-template (type)
(declare (type ctype type))
(multiple-value-bind (check-ptype exact) (primitive-type type)
(if exact
(primitive-type-check check-ptype)
- (multiple-value-bind (name type-needed)
- (hairy-type-check-template-name type)
+ (let ((name (hairy-type-check-template-name type)))
(if name
- (values (template-or-lose name) type-needed)
+ (template-or-lose name)
nil)))))
;;; Emit code in BLOCK to check that VALUE is of the specified TYPE,
@@ -51,10 +49,7 @@
(defun emit-type-check (node block value result type)
(declare (type tn value result) (type node node) (type ir2-block block)
(type ctype type))
- (multiple-value-bind (template type-needed) (type-check-template type)
- (if type-needed
- (emit-load-template node block template value result (list type))
- (emit-move-template node block template value result)))
+ (emit-move-template node block (type-check-template type) value result)
(values))
;;; Allocate an indirect value cell.
diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp
index e29e5ba..37fb1fb 100644
--- a/src/compiler/meta-vmdef.lisp
+++ b/src/compiler/meta-vmdef.lisp
@@ -1407,14 +1407,18 @@
((symbolp type)
``(:or ,(primitive-type-or-lose ',type)))
(t
- (ecase (first type)
+ (ecase (car type)
(:or
``(:or ,,@(mapcar (lambda (type)
`(primitive-type-or-lose ',type))
(rest type))))
(:constant
``(:constant ,#'(lambda (x)
- (sb!xc:typep x ',(second type)))
+ ;; Can't handle SATISFIES during XC
+ ,(if (and (consp (second type))
+ (eq (caadr type) 'satisfies))
+ `(,(cadadr type) x)
+ `(sb!xc:typep x ',(second type))))
,',(second type)))))))
(defun specify-operand-types (types ops more-ops)
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 6f25b7d..8733eb4 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -232,8 +232,14 @@
(once-only ((n-object object))
(ecase (numeric-type-complexp type)
(:real
- `(and (typep ,n-object ',base)
- ,(transform-numeric-bound-test n-object type base)))
+ (if (and #!-(or x86 x86-64) ;; Not implemented elsewhere yet
+ nil
+ (eql (numeric-type-class type) 'integer)
+ (eql (numeric-type-low type) 0)
+ (fixnump (numeric-type-high type)))
+ `(fixnum-mod-p ,n-object ,(numeric-type-high type))
+ `(and (typep ,n-object ',base)
+ ,(transform-numeric-bound-test n-object type base))))
(:complex
`(and (complexp ,n-object)
,(once-only ((n-real `(realpart (truly-the complex ,n-object)))
diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp
index f5a50f6..589b2cb 100644
--- a/src/compiler/x86-64/type-vops.lisp
+++ b/src/compiler/x86-64/type-vops.lisp
@@ -385,42 +385,62 @@
(emit-label yep)
(move result value))))
-(define-vop (check-mod-fixnum check-type)
- (:info type)
- (:temporary (:sc any-reg) temp)
- (:generator 30
- (let* ((low (numeric-type-low type))
- (hi (numeric-type-high type))
- (fixnum-hi (fixnumize hi))
- (error (gen-label)))
- ;; FIXME: abstract
- (assemble (*elsewhere*)
- (emit-label error)
- ;; The general case uses the number directly,
- ;; and it will already have the number constantized
- ;; even though MOV can use 64-bit immediates,
- ;; using the same inlined constant will save space
- (if (= (logcount (1+ hi)) 1)
- (inst mov temp fixnum-hi)
- (inst mov temp (constantize fixnum-hi)))
- (emit-error-break vop error-trap
- (error-number-or-lose 'object-not-mod-error)
- (list value temp)))
- (aver (zerop low))
- (cond
- ;; Handle powers of two specially
- ;; The higher bits and the fixnum tag can be tested in one go
- ((= (logcount (1+ hi)) 1)
- (inst test value
- (constantize (lognot fixnum-hi)))
- (inst jmp :ne error))
- (t
- (generate-fixnum-test value)
- (inst jmp :ne error)
- (inst cmp value (constantize fixnum-hi))
- (inst jmp :a error)))
- (move result value))))
+(defun power-of-two-limit-p (x)
+ (and (fixnump x)
+ (= (logcount (1+ x)) 1)))
+(define-vop (test-fixnum-mod-power-of-two)
+ (:args (value :scs (any-reg descriptor-reg
+ unsigned-reg signed-reg
+ immediate)))
+ (:arg-types *
+ (:constant (satisfies power-of-two-limit-p)))
+ (:translate fixnum-mod-p)
+ (:conditional :e)
+ (:info hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (not (sc-is value immediate)))
+ (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
+ hi
+ (fixnumize hi))))
+ (inst test value (constantize (lognot fixnum-hi))))))
+
+(define-vop (test-fixnum-mod-tagged-unsigned)
+ (:args (value :scs (any-reg descriptor-reg
+ unsigned-reg signed-reg
+ immediate)))
+ (:arg-types (:or tagged-num unsigned-num signed-num)
+ (:constant fixnum))
+ (:translate fixnum-mod-p)
+ (:conditional :be)
+ (:info hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 5
+ (aver (not (sc-is value immediate)))
+ (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
+ hi
+ (fixnumize hi))))
+ (inst cmp value (constantize fixnum-hi)))))
+
+(define-vop (test-fixnum-mod-*)
+ (:args (value :scs (any-reg descriptor-reg)))
+ (:arg-types * (:constant fixnum))
+ (:translate fixnum-mod-p)
+ (:conditional)
+ (:info target not-p hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 6
+ (let* ((fixnum-hi (fixnumize hi))
+ (skip (gen-label)))
+ (generate-fixnum-test value)
+ (inst jmp :ne (if not-p target skip))
+ (inst cmp value (constantize fixnum-hi))
+ (inst jmp (if not-p :a :be) target)
+ (emit-label skip))))
;;;; list/symbol types
;;;
diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp
index a0223ff..aca94f3 100644
--- a/src/compiler/x86/type-vops.lisp
+++ b/src/compiler/x86/type-vops.lisp
@@ -371,34 +371,62 @@
(emit-label yep)
(move result value))))
-(define-vop (check-mod-fixnum check-type)
- (:info type)
- (:temporary (:sc any-reg) temp)
- (:generator 30
- (let* ((low (numeric-type-low type))
- (hi (numeric-type-high type))
- (fixnum-hi (fixnumize hi))
- (error (gen-label)))
- ;; FIXME: abstract
- (assemble (*elsewhere*)
- (emit-label error)
- (inst mov temp fixnum-hi)
- (emit-error-break vop error-trap
- (error-number-or-lose 'object-not-mod-error)
- (list value temp)))
- (aver (zerop low))
- (cond
- ;; Handle powers of two specially
- ;; The higher bits and the fixnum tag can be tested in one go
- ((= (logcount (1+ hi)) 1)
- (inst test value (lognot fixnum-hi))
- (inst jmp :ne error))
- (t
- (generate-fixnum-test value)
- (inst jmp :ne error)
- (inst cmp value fixnum-hi)
- (inst jmp :a error)))
- (move result value))))
+(defun power-of-two-limit-p (x)
+ (and (fixnump x)
+ (= (logcount (1+ x)) 1)))
+
+(define-vop (test-fixnum-mod-power-of-two)
+ (:args (value :scs (any-reg descriptor-reg
+ unsigned-reg signed-reg
+ immediate)))
+ (:arg-types *
+ (:constant (satisfies power-of-two-limit-p)))
+ (:translate sb!c::fixnum-mod-p)
+ (:conditional :e)
+ (:info hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (not (sc-is value immediate)))
+ (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
+ hi
+ (fixnumize hi))))
+ (inst test value (lognot fixnum-hi)))))
+
+(define-vop (test-fixnum-mod-tagged-unsigned)
+ (:args (value :scs (any-reg descriptor-reg
+ unsigned-reg signed-reg
+ immediate)))
+ (:arg-types (:or tagged-num unsigned-num signed-num)
+ (:constant fixnum))
+ (:translate sb!c::fixnum-mod-p)
+ (:conditional :be)
+ (:info hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 5
+ (aver (not (sc-is value immediate)))
+ (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
+ hi
+ (fixnumize hi))))
+ (inst cmp value fixnum-hi))))
+
+(define-vop (test-fixnum-mod-*)
+ (:args (value :scs (any-reg descriptor-reg)))
+ (:arg-types * (:constant fixnum))
+ (:translate sb!c::fixnum-mod-p)
+ (:conditional)
+ (:info target not-p hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 6
+ (let* ((fixnum-hi (fixnumize hi))
+ (skip (gen-label)))
+ (generate-fixnum-test value)
+ (inst jmp :ne (if not-p target skip))
+ (inst cmp value fixnum-hi)
+ (inst jmp (if not-p :a :be) target)
+ (emit-label skip))))
;;;; list/symbol types
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|