Optimize (mod FIXNUM) type-checks on x86oids.

Instead of two (and (>= x 0) (< x FIXNUM)) comparisons, do one
unsigned.
(mod power-of-two) is further optimized by doing one mask test
determine the range and fixnumness in one go.

diff --git a/NEWS b/NEWS
index a46a208..ffeca18 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,8 @@ changes relative to sbcl-1.1.8:
   * optimization: when referencing internal functions as #'x, don't go through
     an indirect fdefn structure.
   * optimization: SLEEP doesn't cons on non-immediate floats and on ratios.
+  * optimization: (mod fixnum) type-checks are performed using one unsigned
+    comparison, instead of two.
   * bug fix: problems with NCONC type derivation (reported by Jerry James).
   * bug fix: EXPT type derivation no longer constructs bogus floating-point
     types.  (reported by Vsevolod Dyomkin)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 4638b51..9dad11f 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -242,6 +242,7 @@ 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-CONSTANT-REF" "CODE-CONSTANT-SET"
                "*CODE-COVERAGE-INFO*"
@@ -1650,7 +1651,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-LIST-ERROR" "OBJECT-NOT-MOD-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 fb16a77..18c571e 100644 (file)
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -106,6 +106,11 @@
          :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/compiler/generic/interr.lisp b/src/compiler/generic/interr.lisp
index 9ff81d3..e1120b7 100644 (file)
--- a/src/compiler/generic/interr.lisp
+++ b/src/compiler/generic/interr.lisp
@@ -55,6 +55,8 @@
    "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 ccacc48..f447b9c 100644 (file)
--- a/src/compiler/generic/vm-type.lisp
+++ b/src/compiler/generic/vm-type.lisp
@@ -182,6 +182,7 @@
 
 ;;; 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
@@ -208,6 +209,11 @@
            #!+#.(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 f37fde5..e2b593e 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -31,14 +31,16 @@
 
 ;;; 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)
-        (let ((name (hairy-type-check-template-name type)))
+        (multiple-value-bind (name type-needed)
+            (hairy-type-check-template-name type)
           (if name
-              (template-or-lose name)
+              (values (template-or-lose name) type-needed)
               nil)))))
 
 ;;; Emit code in BLOCK to check that VALUE is of the specified TYPE,
@@ -49,7 +51,10 @@
 (defun emit-type-check (node block value result type)
   (declare (type tn value result) (type node node) (type ir2-block block)
            (type ctype type))
-  (emit-move-template node block (type-check-template type) value result)
+  (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)))
   (values))
 
 ;;; Allocate an indirect value cell.

diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp
index 04fa745..5c54135 100644 (file)
--- a/src/compiler/x86-64/type-vops.lisp
+++ b/src/compiler/x86-64/type-vops.lisp
@@ -384,6 +384,36 @@
 
       (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 (fixnumize (numeric-type-high type)))
+            (error (gen-label)))
+       ;; FIXME: abstract
+       (assemble (*elsewhere*)
+         (emit-label error)
+         (inst mov temp 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 hi)))
+          (inst jmp :ne error))
+         (t
+          (generate-fixnum-test value)
+          (inst jmp :ne error)
+          (inst cmp value (constantize hi))
+          (inst jmp :a error)))
+       (move result value))))
+
 \f
 ;;;; list/symbol types
 ;;;
@@ -429,7 +459,6 @@
 (progn
   (!define-type-vops simd-pack-p nil nil nil (simd-pack-widetag))
 
-  #!+x86-64
   (define-vop (check-simd-pack check-type)
     (:args (value :target result
                   :scs (any-reg descriptor-reg

diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp
index 38d6adc..4ad6d5d 100644 (file)
--- a/src/compiler/x86/type-vops.lisp
+++ b/src/compiler/x86/type-vops.lisp
@@ -370,6 +370,35 @@
 
       (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 (fixnumize (numeric-type-high type)))
+            (error (gen-label)))
+       ;; FIXME: abstract
+       (assemble (*elsewhere*)
+         (emit-label error)
+         (inst mov temp 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 hi))
+          (inst jmp :ne error))
+         (t
+          (generate-fixnum-test value)
+          (inst jmp :ne error)
+          (inst cmp value hi)
+          (inst jmp :a error)))
+       (move result value))))
+
 \f
 ;;;; list/symbol types
 ;;;