From 953e2961a4e0f130d67da600d1c965d6794a8984 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Tue, 16 Jul 2013 05:12:51 +0400 Subject: [PATCH] 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 -- 1.7.10.4