1.0.15.16: New modular arithmetic representation decision

	Prefers any exactly-matching modular implementation, then tagged
	if possible, then untagged.  Should make code of the form
          (logand xxx most-positive-fixnum)
	more tolerable.

	Also includes better lognot/fixnum implementation on all
	platforms.

Squashed commit of the following:

commit 81776d9aab531db20711320ecea920453e058cef
Author: Christophe Rhodes <csr21@cantab.net>
Date:   Fri Mar 7 04:54:03 2008 -0700

    Fix lognot for fixnums on alpha.

commit 27ce80579851bf9227d7d1121cf1554dc383049d
Author: SBCL devs <sbcl-dev@aleph.math.ualberta.ca>
Date:   Thu Mar 6 15:02:03 2008 -0700

    New modular arithmetic ported to alpha

    (as yet untested beyond make-genesis-2: lognot/fixnum is buggy)

commit d6ae6339374983ae874d85f3c52103c77ccad222
Author: Christophe Rhodes <csr21@localhost.localdomain>
Date:   Fri Jan 11 17:38:19 2008 +0000

    New modular arithmetic ported to mips.

    Tested by Thiemo Seufer.

commit 50e2e51d25bb3d3997e4b884b7a15f7ba1992391
Author: Christophe Rhodes <csr21@localhost.localdomain>
Date:   Fri Jan 11 17:37:41 2008 +0000

    Make find-modular-class get signed and unsigned the right way round.

    As it happened, this all worked by accident anyway, because the only
    other user of the *foo-modular-class* specials didn't rely on the
    separation between the classes, but instead used other data.  Hmm...

    (Noticed by Nikodemus Siivola)

commit d3de3d27b212999672644d8a4fccfce9676dbf4f
Author: Christophe Rhodes <csr21@zeus.jesus.cam.ac.uk>
Date:   Tue Jan 1 14:25:33 2008 +0000

    New modular arithmetic ported to sparc.

    As with ppc, the signed modular arithmetic is not terribly useful, as
    only good functions have been implemented (so no +, -, * and ash)

commit e99c204ab165139f4c8f8aacb59d4a825b90b7d1
Author: Christophe Rhodes <mas01cr@gibbons.doc.gold.ac.uk>
Date:   Mon Dec 31 18:15:41 2007 +0000

    Fix for fixnum LOGNOT on PPC

    Use subfic res, x, -4 rather than xori res, x, -4 -- xori's immediate
    argument is not sign-extended.

    (Thanks to Andy Hefner for the idea to use subfic rather than xori+xoris)

commit db8ffb719750c8bc655519b03c2081cc3b8d0b2e
Author: Christophe Rhodes <mas01cr@gibbons.doc.gold.ac.uk>
Date:   Mon Dec 31 18:13:21 2007 +0000

    New modular arithmetic ported to ppc.

    Simple modifications only.  It remains for someone to add signed modular
    definitions of +, -, * and so on for this to become useful on ppc.

commit 5c7562fc1e2a96a81d9bc32fb77ad70ed1794e6e
Author: Christophe Rhodes <crhodes@gibbons.doc.gold.ac.uk>
Date:   Mon Dec 31 10:12:26 2007 +0000

    New modular arithmetic choice for x86-64

    Simply adapt x86-64/arith.lisp by

    * removing logxor implementation (as it's now :good)
    * adapting %LEA implementation

commit 39054fae6e5a2e55856a506ad497978adcbbd6c2
Author: Christophe Rhodes <csr21@omega.localdomain>
Date:   Sun Dec 30 21:50:16 2007 +0000

    Better fixnum LOGNOT implementations.

    Apparently inherited from cmucl, our fixnum and signed LOGNOT VOPs had
    generator costs that preferred the signed representation over the tagged.
    Fix this (on all backends; tested only on x86)

commit 6eee19de7a49762ea2f3bbfe89d9ea1b0dcee47f
Author: Christophe Rhodes <csr21@omega.localdomain>
Date:   Sun Dec 30 21:29:39 2007 +0000

    Better signed modular arithmetic.

    All the LOGFOO functions are :good modular functions for signed
    modular arithmetic.

    LOGXOR is a :good modular function for untagged unsigned modular
    arithmetic.

commit 32961ecb51bcfea655f985d1f774a8fc46bd155b
Author: Christophe Rhodes <csr21@omega.localdomain>
Date:   Sun Dec 30 19:30:57 2007 +0000

    Split untagged modular class into unsigned and signed variants.

    FIND-MODULAR-VERSION now takes both KIND and SIGNEDP arguments.

commit e3b88693c3721cd84d9fb4a01d624d450c120cdd
Author: Christophe Rhodes <csr21@omega.localdomain>
Date:   Sun Dec 30 17:58:49 2007 +0000

    Choice of modular version, initial commit

    Commit of approximately September vintage work, x86-only.

diff --git a/NEWS b/NEWS
index 49d208a..42a22ac 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,10 @@ changes in sbcl-1.0.16 relative to 1.0.15:
   * optimization: MEMBER and ASSOC are over 50% faster for :TEST #'EQ
     and cases where no :TEST is given but the compiler can infer that
     the element to search is of type (OR FIXNUM (NOT NUMBER)).
+  * optimization: better LOGNOT on fixnums.
+  * optimization: modular arithmetic for a particular requested width
+    is implemented using a tagged representation unless a better 
+    representation is available.
   * bug fix: periodic polling was broken. (thanks to Espen S Johnsen)
   * bug fix: copying output from RUN-PROGRAM to a stream signalled
     bogus errors if select() was interrupted.

diff --git a/src/code/cross-modular.lisp b/src/code/cross-modular.lisp
index b89d151..931a90f 100644 (file)
--- a/src/code/cross-modular.lisp
+++ b/src/code/cross-modular.lisp
@@ -22,30 +22,27 @@
 
 #.
 (collect ((forms))
-  (flet ((definition (name lambda-list prototype width)
+  (flet ((unsigned-definition (name lambda-list prototype width)
            `(defun ,name ,lambda-list
-              (ldb (byte ,width 0) (,prototype ,@lambda-list)))))
-    (loop for infos being each hash-value of (modular-class-funs *unsigned-modular-class*) using (hash-key prototype)
-          when (listp infos)
-          do (loop for info in infos
-                   for name = (modular-fun-info-name info)
-                   and width = (modular-fun-info-width info)
-                   and lambda-list = (modular-fun-info-lambda-list info)
-                   do (forms (definition name lambda-list prototype width)))))
-  `(progn ,@(forms)))
-
-#.
-(collect ((forms))
-  (flet ((definition (name lambda-list prototype width)
+              (ldb (byte ,width 0) (,prototype ,@lambda-list))))
+         (signed-definition (name lambda-list prototype width)
            `(defun ,name ,lambda-list
               (mask-signed-field ,width (,prototype ,@lambda-list)))))
-    (loop for infos being each hash-value of (modular-class-funs *signed-modular-class*) using (hash-key prototype)
-          when (listp infos)
-          do (loop for info in infos
-                   for name = (modular-fun-info-name info)
-                   and width = (modular-fun-info-width info)
-                   and lambda-list = (modular-fun-info-lambda-list info)
-                   do (forms (definition name lambda-list prototype width)))))
+    (flet ((do-mfuns (class)
+             (loop for infos being each hash-value of (modular-class-funs class) using (hash-key prototype)
+                   when (listp infos)
+                   do (loop for info in infos
+                            for name = (modular-fun-info-name info)
+                            and width = (modular-fun-info-width info)
+                            and signedp = (modular-fun-info-signedp info)
+                            and lambda-list = (modular-fun-info-lambda-list info)
+                            if signedp
+                            do (forms (signed-definition name lambda-list prototype width))
+                            else
+                            do (forms (unsigned-definition name lambda-list prototype width))))))
+      (do-mfuns *untagged-unsigned-modular-class*)
+      (do-mfuns *untagged-signed-modular-class*)
+      (do-mfuns *tagged-modular-class*)))
   `(progn ,@(forms)))
 
 #!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 32) '(and) '(or))

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 3f02be2..3ac83fa 100644 (file)
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -1425,30 +1425,18 @@ the first."
 ;;;; modular functions
 #.
 (collect ((forms))
-  (flet ((definition (name lambda-list width pattern)
-           `(defun ,name ,lambda-list
-              (flet ((prepare-argument (x)
-                       (declare (integer x))
-                       (etypecase x
-                         ((unsigned-byte ,width) x)
-                         (fixnum (logand x ,pattern))
-                         (bignum (logand x ,pattern)))))
-                (,name ,@(loop for arg in lambda-list
-                               collect `(prepare-argument ,arg)))))))
-    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*unsigned-modular-class*)
-          ;; FIXME: We need to process only "toplevel" functions
-          when (listp infos)
-          do (loop for info in infos
-                   for name = (sb!c::modular-fun-info-name info)
-                   and width = (sb!c::modular-fun-info-width info)
-                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
-                   for pattern = (1- (ash 1 width))
-                   do (forms (definition name lambda-list width pattern)))))
-  `(progn ,@(forms)))
-
-#.
-(collect ((forms))
-  (flet ((definition (name lambda-list width)
+  (flet ((unsigned-definition (name lambda-list width)
+           (let ((pattern (1- (ash 1 width))))
+             `(defun ,name ,lambda-list
+               (flet ((prepare-argument (x)
+                        (declare (integer x))
+                        (etypecase x
+                          ((unsigned-byte ,width) x)
+                          (fixnum (logand x ,pattern))
+                          (bignum (logand x ,pattern)))))
+                 (,name ,@(loop for arg in lambda-list
+                                collect `(prepare-argument ,arg)))))))
+         (signed-definition (name lambda-list width)
            `(defun ,name ,lambda-list
               (flet ((prepare-argument (x)
                        (declare (integer x))
@@ -1458,14 +1446,22 @@ the first."
                          (bignum (sb!c::mask-signed-field ,width x)))))
                 (,name ,@(loop for arg in lambda-list
                                collect `(prepare-argument ,arg)))))))
-    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*)
-          ;; FIXME: We need to process only "toplevel" functions
-          when (listp infos)
-          do (loop for info in infos
-                   for name = (sb!c::modular-fun-info-name info)
-                   and width = (sb!c::modular-fun-info-width info)
-                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
-                   do (forms (definition name lambda-list width)))))
+    (flet ((do-mfuns (class)
+             (loop for infos being each hash-value of (sb!c::modular-class-funs class)
+                   ;; FIXME: We need to process only "toplevel" functions
+                   when (listp infos)
+                   do (loop for info in infos
+                            for name = (sb!c::modular-fun-info-name info)
+                            and width = (sb!c::modular-fun-info-width info)
+                            and signedp = (sb!c::modular-fun-info-signedp info)
+                            and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+                            if signedp
+                            do (forms (signed-definition name lambda-list width))
+                            else
+                            do (forms (unsigned-definition name lambda-list width))))))
+      (do-mfuns sb!c::*untagged-unsigned-modular-class*)
+      (do-mfuns sb!c::*untagged-signed-modular-class*)
+      (do-mfuns sb!c::*tagged-modular-class*)))
   `(progn ,@(forms)))
 
 ;;; KLUDGE: these out-of-line definitions can't use the modular

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 7cd6358..efdf628 100644 (file)
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -527,7 +527,7 @@
          (count-low-order-zeros (lvar-uses thing))))
     (combination
      (case (let ((name (lvar-fun-name (combination-fun thing))))
-             (or (modular-version-info name :unsigned) name))
+             (or (modular-version-info name :untagged nil) name))
        ((+ -)
         (let ((min most-positive-fixnum)
               (itype (specifier-type 'integer)))
@@ -584,7 +584,7 @@
       (give-up-ir1-transform))
     (let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
       (multiple-value-bind (prototype width)
-          (modular-version-info inside-fun-name :unsigned)
+          (modular-version-info inside-fun-name :untagged nil)
         (unless (eq (or prototype inside-fun-name) 'ash)
           (give-up-ir1-transform))
         (when (and width (not (constant-lvar-p amount)))

diff --git a/src/compiler/alpha/arith.lisp b/src/compiler/alpha/arith.lisp
index 919b33d..a52bb1d 100644 (file)
--- a/src/compiler/alpha/arith.lisp
+++ b/src/compiler/alpha/arith.lisp
@@ -41,12 +41,12 @@
 
 (define-vop (fast-lognot/fixnum fixnum-unop)
   (:translate lognot)
-  (:generator 2
-    (inst eqv x zero-tn res)))
+  (:generator 1
+    (inst eqv x fixnum-tag-mask res)))
 
 (define-vop (fast-lognot/signed signed-unop)
   (:translate lognot)
-  (:generator 1
+  (:generator 2
     (inst not x res)))
 \f
 ;;;; binary fixnum operations
@@ -389,7 +389,7 @@
     (inst mulq x y r)))
 \f
 ;;;; Modular functions:
-(define-modular-fun lognot-mod64 (x) lognot :unsigned 64)
+(define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
 (define-vop (lognot-mod64/unsigned=>unsigned)
   (:translate lognot-mod64)
   (:args (x :scs (unsigned-reg)))
@@ -419,7 +419,7 @@
              (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
              (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
          `(progn
-            (define-modular-fun ,mfun-name (x y) ,fun :unsigned 64)
+            (define-modular-fun ,mfun-name (x y) ,fun :untagged nil 64)
             (define-vop (,modvop ,vop)
               (:translate ,mfun-name))
             ,@(when constantp
@@ -427,7 +427,6 @@
                     (:translate ,mfun-name))))))))
   (define-modular-backend + t)
   (define-modular-backend - t)
-  (define-modular-backend logxor t)
   (define-modular-backend logeqv t)
   (define-modular-backend logandc1)
   (define-modular-backend logandc2 t)

diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp
index 184861f..a3863c8 100644 (file)
--- a/src/compiler/generic/vm-macs.lisp
+++ b/src/compiler/generic/vm-macs.lisp
@@ -174,52 +174,63 @@
   ;; FIXME: Reimplement with generic function names of kind
   ;; (MODULAR-VERSION prototype width)
   (versions (make-hash-table :test 'eq))
-  ;; list of increasing widths
+  ;; list of increasing widths + signedps
   (widths nil))
-(defvar *unsigned-modular-class* (make-modular-class))
-(defvar *signed-modular-class* (make-modular-class))
-(defun find-modular-class (kind)
+(defvar *untagged-unsigned-modular-class* (make-modular-class))
+(defvar *untagged-signed-modular-class* (make-modular-class))
+(defvar *tagged-modular-class* (make-modular-class))
+(defun find-modular-class (kind signedp)
   (ecase kind
-    (:unsigned *unsigned-modular-class*)
-    (:signed *signed-modular-class*)))
+    (:untagged
+     (ecase signedp
+       ((nil) *untagged-unsigned-modular-class*)
+       (t *untagged-signed-modular-class*)))
+    (:tagged
+     (aver signedp)
+     *tagged-modular-class*)))
 
 (defstruct modular-fun-info
   (name (missing-arg) :type symbol)
   (width (missing-arg) :type (integer 0))
+  (signedp (missing-arg) :type boolean)
   (lambda-list (missing-arg) :type list)
   (prototype (missing-arg) :type symbol))
 
-(defun find-modular-version (fun-name class width)
-  (let ((infos (gethash fun-name (modular-class-funs (find-modular-class class)))))
+(defun find-modular-version (fun-name kind signedp width)
+  (let ((infos (gethash fun-name (modular-class-funs (find-modular-class kind signedp)))))
     (if (listp infos)
-        (find-if (lambda (item-width) (>= item-width width))
-                 infos
-                 :key #'modular-fun-info-width)
+        (find-if (lambda (mfi)
+                   (aver (eq (modular-fun-info-signedp mfi) signedp))
+                   (>= (modular-fun-info-width mfi) width))
+                 infos)
         infos)))
 
 ;;; Return (VALUES prototype-name width)
-(defun modular-version-info (name class)
-  (values-list (gethash name (modular-class-versions (find-modular-class class)))))
+(defun modular-version-info (name kind signedp)
+  (values-list (gethash name (modular-class-versions (find-modular-class kind signedp)))))
 
-(defun %define-modular-fun (name lambda-list prototype class width)
-  (let* ((class (find-modular-class class))
+(defun %define-modular-fun (name lambda-list prototype kind signedp width)
+  (let* ((class (find-modular-class kind signedp))
          (funs (modular-class-funs class))
          (versions (modular-class-versions class))
          (infos (the list (gethash prototype funs)))
-         (info (find-if (lambda (item-width) (= item-width width))
-                        infos
-                        :key #'modular-fun-info-width)))
+         (info (find-if (lambda (mfi)
+                          (and (eq (modular-fun-info-signedp mfi) signedp)
+                               (= (modular-fun-info-width mfi) width)))
+                        infos)))
     (if info
         (unless (and (eq name (modular-fun-info-name info))
                      (= (length lambda-list)
                         (length (modular-fun-info-lambda-list info))))
           (setf (modular-fun-info-name info) name)
-          (style-warn "Redefining modular version ~S of ~S for width ~S."
-                      name prototype width))
+          (style-warn "Redefining modular version ~S of ~S for ~
+                       ~:[un~;~]signed width ~S."
+                      name prototype signedp width))
         (setf (gethash prototype funs)
               (merge 'list
                      (list (make-modular-fun-info :name name
                                                   :width width
+                                                  :signedp signedp
                                                   :lambda-list lambda-list
                                                   :prototype prototype))
                      infos
@@ -227,51 +238,52 @@
               (gethash name versions)
               (list prototype width)))
     (setf (modular-class-widths class)
-          (merge 'list (list width) (modular-class-widths class) #'<))))
+          (merge 'list (list (cons width signedp)) (modular-class-widths class)
+                 #'< :key #'car))))
 
-(defmacro define-modular-fun (name lambda-list prototype class width)
+(defmacro define-modular-fun (name lambda-list prototype kind signedp width)
   (check-type name symbol)
   (check-type prototype symbol)
-  (check-type class (member :unsigned :signed))
+  (check-type kind (member :untagged :tagged))
   (check-type width unsigned-byte)
   (dolist (arg lambda-list)
     (when (member arg lambda-list-keywords)
       (error "Lambda list keyword ~S is not supported for ~
               modular function lambda lists." arg)))
   `(progn
-     (%define-modular-fun ',name ',lambda-list ',prototype ',class ,width)
+     (%define-modular-fun ',name ',lambda-list ',prototype ',kind ',signedp ,width)
      (defknown ,name ,(mapcar (constantly 'integer) lambda-list)
-               (,(ecase class
-                   (:unsigned 'unsigned-byte)
-                   (:signed 'signed-byte))
+               (,(ecase signedp
+                   ((nil) 'unsigned-byte)
+                   (t 'signed-byte))
                  ,width)
                (foldable flushable movable)
                :derive-type (make-modular-fun-type-deriver
-                             ',prototype ',class ,width))))
+                             ',prototype ',kind ,width ',signedp))))
 
-(defun %define-good-modular-fun (name class)
-  (setf (gethash name (modular-class-funs (find-modular-class class))) :good)
+(defun %define-good-modular-fun (name kind signedp)
+  (setf (gethash name (modular-class-funs (find-modular-class kind signedp))) :good)
   name)
 
-(defmacro define-good-modular-fun (name class)
+(defmacro define-good-modular-fun (name kind signedp)
   (check-type name symbol)
-  (check-type class (member :unsigned :signed))
-  `(%define-good-modular-fun ',name ',class))
+  (check-type kind (member :untagged :tagged))
+  `(%define-good-modular-fun ',name ',kind ',signedp))
 
 (defmacro define-modular-fun-optimizer
-    (name ((&rest lambda-list) class &key (width (gensym "WIDTH")))
+    (name ((&rest lambda-list) kind signedp &key (width (gensym "WIDTH")))
      &body body)
   (check-type name symbol)
-  (check-type class (member :unsigned :signed))
+  (check-type kind (member :untagged :tagged))
   (dolist (arg lambda-list)
     (when (member arg lambda-list-keywords)
       (error "Lambda list keyword ~S is not supported for ~
               modular function lambda lists." arg)))
   (with-unique-names (call args)
-    `(setf (gethash ',name (modular-class-funs (find-modular-class ',class)))
+    `(setf (gethash ',name (modular-class-funs (find-modular-class ',kind ',signedp)))
            (lambda (,call ,width)
              (declare (type basic-combination ,call)
-                      (type (integer 0) width))
+                      (type (integer 0) ,width))
              (let ((,args (basic-combination-args ,call)))
                (when (= (length ,args) ,(length lambda-list))
                  (destructuring-bind ,lambda-list ,args

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index a4fb8fd..43a7b11 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -616,40 +616,58 @@
 
 \f
 ;;;; modular functions
-(define-good-modular-fun logand :unsigned)
-(define-good-modular-fun logior :unsigned)
-;;; FIXME: XOR? ANDC1, ANDC2?  -- CSR, 2003-09-16
+;;;
+;;; FIXME: I think that the :GOODness of a modular function boils down
+;;; to whether the normal definition can be used in the middle of a
+;;; modular arrangement.  LOGAND and LOGIOR can be for all unsigned
+;;; modular implementations, I believe, because for all unsigned
+;;; arguments of a given size the result of the ordinary definition is
+;;; the right one.  This should follow through to other logical
+;;; functions, such as LOGXOR, should it not?  -- CSR, 2007-12-29,
+;;; trying to understand a comment he wrote over four years
+;;; previously: "FIXME: XOR? ANDC1, ANDC2?  -- CSR, 2003-09-16"
+(define-good-modular-fun logand :untagged nil)
+(define-good-modular-fun logior :untagged nil)
+(define-good-modular-fun logxor :untagged nil)
+(macrolet ((define-good-signed-modular-funs (&rest funs)
+             (let (result)
+               `(progn
+                 ,@(dolist (fun funs (nreverse result))
+                     (push `(define-good-modular-fun ,fun :untagged t) result)
+                     (push `(define-good-modular-fun ,fun :tagged t) result))))))
+  (define-good-signed-modular-funs
+      logand logandc1 logandc2 logeqv logior lognand lognor lognot
+      logorc1 logorc2 logxor))
 
 (macrolet
-    ((def (name class width)
-       (let ((type (ecase class
-                     (:unsigned 'unsigned-byte)
-                     (:signed 'signed-byte))))
+    ((def (name kind width signedp)
+       (let ((type (ecase signedp
+                     ((nil) 'unsigned-byte)
+                     (t 'signed-byte))))
          `(progn
             (defknown ,name (integer (integer 0)) (,type ,width)
                       (foldable flushable movable))
-            (define-modular-fun-optimizer ash ((integer count) ,class :width width)
+            (define-modular-fun-optimizer ash ((integer count) ,kind ,signedp :width width)
               (when (and (<= width ,width)
                          (or (and (constant-lvar-p count)
                                   (plusp (lvar-value count)))
                              (csubtypep (lvar-type count)
                                         (specifier-type '(and unsigned-byte fixnum)))))
-                (cut-to-width integer ,class width)
+                (cut-to-width integer ,kind width ,signedp)
                 ',name))
-            (setf (gethash ',name (modular-class-versions (find-modular-class ',class)))
+            (setf (gethash ',name (modular-class-versions (find-modular-class ',kind ',signedp)))
                   `(ash ,',width))))))
   ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
   ;; don't have a true Alpha64 port yet, we'll have to stick to
   ;; SB!VM:N-MACHINE-WORD-BITS for the time being.  --njf, 2004-08-14
   #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
   (progn
-    #!+x86 (def sb!vm::ash-left-smod30 :signed 30)
-    (def sb!vm::ash-left-mod32 :unsigned 32))
+    #!+x86 (def sb!vm::ash-left-smod30 :tagged 30 t)
+    (def sb!vm::ash-left-mod32 :untagged 32 nil))
   #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
   (progn
-    #!+x86-64 (def sb!vm::ash-left-smod61 :signed 61)
-    (def sb!vm::ash-left-mod64 :unsigned 64)))
-
+    #!+x86-64 (def sb!vm::ash-left-smod61 :tagged 61 t)
+    (def sb!vm::ash-left-mod64 :untagged 64 nil)))
 \f
 ;;;; word-wise logical operations
 

diff --git a/src/compiler/hppa/arith.lisp b/src/compiler/hppa/arith.lisp
index c1d4a4d..8d9ae19 100644 (file)
--- a/src/compiler/hppa/arith.lisp
+++ b/src/compiler/hppa/arith.lisp
@@ -43,13 +43,13 @@
   (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
               temp)
   (:translate lognot)
-  (:generator 2
+  (:generator 1
     (inst li (fixnumize -1) temp)
     (inst xor x temp res)))
 
 (define-vop (fast-lognot/signed signed-unop)
   (:translate lognot)
-  (:generator 1
+  (:generator 2
     (inst uaddcm zero-tn x res)))
 \f
 ;;;; Binary fixnum operations.

diff --git a/src/compiler/mips/arith.lisp b/src/compiler/mips/arith.lisp
index f5ed4cc..8be4e93 100644 (file)
--- a/src/compiler/mips/arith.lisp
+++ b/src/compiler/mips/arith.lisp
@@ -46,13 +46,13 @@
   (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
               temp)
   (:translate lognot)
-  (:generator 2
+  (:generator 1
     (inst li temp (fixnumize -1))
     (inst xor res x temp)))
 
 (define-vop (fast-lognot/signed signed-unop)
   (:translate lognot)
-  (:generator 1
+  (:generator 2
     (inst nor res x zero-tn)))
 \f
 ;;;; Binary fixnum operations.
@@ -668,12 +668,12 @@
        (inst sll r num amount)))))
 \f
 ;;;; Modular arithmetic
-(define-modular-fun +-mod32 (x y) + :unsigned 32)
+(define-modular-fun +-mod32 (x y) + :untagged nil 32)
 (define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
   (:translate +-mod32))
 (define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
   (:translate +-mod32))
-(define-modular-fun --mod32 (x y) - :unsigned 32)
+(define-modular-fun --mod32 (x y) - :untagged nil 32)
 (define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
   (:translate --mod32))
 (define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
@@ -692,7 +692,7 @@
   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 
 ;;; logical operations
-(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
+(define-modular-fun lognot-mod32 (x) lognot :untagged nil 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)
   (:translate lognot-mod32)
   (:args (x :scs (unsigned-reg)))
@@ -703,15 +703,7 @@
   (:generator 1
     (inst nor r x zero-tn)))
 
-(define-modular-fun logxor-mod32 (x y) logxor :unsigned 32)
-(define-vop (fast-logxor-mod32/unsigned=>unsigned
-             fast-logxor/unsigned=>unsigned)
-  (:translate logxor-mod32))
-(define-vop (fast-logxor-mod32-c/unsigned=>unsigned
-             fast-logxor-c/unsigned=>unsigned)
-  (:translate logxor-mod32))
-
-(define-modular-fun lognor-mod32 (x y) lognor :unsigned 32)
+(define-modular-fun lognor-mod32 (x y) lognor :untagged nil 32)
 (define-vop (fast-lognor-mod32/unsigned=>unsigned
              fast-lognor/unsigned=>unsigned)
   (:translate lognor-mod32))

diff --git a/src/compiler/ppc/arith.lisp b/src/compiler/ppc/arith.lisp
index 67365c1..9f8c2f3 100644 (file)
--- a/src/compiler/ppc/arith.lisp
+++ b/src/compiler/ppc/arith.lisp
@@ -44,12 +44,12 @@
 
 (define-vop (fast-lognot/fixnum fixnum-unop)
   (:translate lognot)
-  (:generator 2
-    (inst xori res x (fixnumize -1))))
+  (:generator 1
+    (inst subfic res x (fixnumize -1))))
 
 (define-vop (fast-lognot/signed signed-unop)
   (:translate lognot)
-  (:generator 1
+  (:generator 2
     (inst not res x)))
 \f
 ;;;; Binary fixnum operations.
@@ -714,7 +714,7 @@
 
 \f
 ;;;; Modular functions:
-(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
+(define-modular-fun lognot-mod32 (x) lognot :untagged nil 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)
   (:translate lognot-mod32)
   (:args (x :scs (unsigned-reg)))
@@ -745,7 +745,7 @@
              (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
              (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
          `(progn
-            (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
+            (define-modular-fun ,mfun-name (x y) ,fun :untagged nil 32)
             (define-vop (,modvop ,vop)
               (:translate ,mfun-name))
             ,@(when constantp
@@ -754,7 +754,6 @@
   (define-modular-backend + t)
   (define-modular-backend - t)
   (define-modular-backend * t)
-  (define-modular-backend logxor t)
   (define-modular-backend logeqv)
   (define-modular-backend lognand)
   (define-modular-backend lognor)

diff --git a/src/compiler/sparc/arith.lisp b/src/compiler/sparc/arith.lisp
index a7f45f8..8be93de 100644 (file)
--- a/src/compiler/sparc/arith.lisp
+++ b/src/compiler/sparc/arith.lisp
@@ -44,12 +44,12 @@
 
 (define-vop (fast-lognot/fixnum fixnum-unop)
   (:translate lognot)
-  (:generator 2
+  (:generator 1
     (inst xor res x (fixnumize -1))))
 
 (define-vop (fast-lognot/signed signed-unop)
   (:translate lognot)
-  (:generator 1
+  (:generator 2
     (inst not res x)))
 \f
 ;;;; Binary fixnum operations.
@@ -647,7 +647,7 @@
 
 \f
 ;;;; Modular functions:
-(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
+(define-modular-fun lognot-mod32 (x) lognot :untagged nil 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)
   (:translate lognot-mod32)
   (:args (x :scs (unsigned-reg)))
@@ -666,7 +666,7 @@
              (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
              (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
          `(progn
-            (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
+            (define-modular-fun ,mfun-name (x y) ,fun :untagged nil 32)
             (define-vop (,modvop ,vop)
               (:translate ,mfun-name))
             ,@(when constantp
@@ -674,7 +674,6 @@
                     (:translate ,mfun-name))))))))
   (define-modular-backend + t)
   (define-modular-backend - t)
-  (define-modular-backend logxor t)
   (define-modular-backend logeqv t)
   (define-modular-backend logandc1)
   (define-modular-backend logandc2 t)

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index bdab82c..4309045 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2816,19 +2816,20 @@
 ;;;
 ;;; and similar for other arguments.
 
-(defun make-modular-fun-type-deriver (prototype class width)
+(defun make-modular-fun-type-deriver (prototype kind width signedp)
+  (declare (ignore kind))
   #!-sb-fluid
   (binding* ((info (info :function :info prototype) :exit-if-null)
              (fun (fun-info-derive-type info) :exit-if-null)
              (mask-type (specifier-type
-                         (ecase class
-                             (:unsigned (let ((mask (1- (ash 1 width))))
-                                          `(integer ,mask ,mask)))
-                             (:signed `(signed-byte ,width))))))
+                         (ecase signedp
+                             ((nil) (let ((mask (1- (ash 1 width))))
+                                      `(integer ,mask ,mask)))
+                             (t `(signed-byte ,width))))))
     (lambda (call)
       (let ((res (funcall fun call)))
         (when res
-          (if (eq class :unsigned)
+          (if (eq signedp nil)
               (logand-derive-type-aux res mask-type))))))
   #!+sb-fluid
   (lambda (call)
@@ -2836,11 +2837,11 @@
                (fun (fun-info-derive-type info) :exit-if-null)
                (res (funcall fun call) :exit-if-null)
                (mask-type (specifier-type
-                           (ecase class
-                             (:unsigned (let ((mask (1- (ash 1 width))))
-                                          `(integer ,mask ,mask)))
-                             (:signed `(signed-byte ,width))))))
-      (if (eq class :unsigned)
+                           (ecase signedp
+                             ((nil) (let ((mask (1- (ash 1 width))))
+                                      `(integer ,mask ,mask)))
+                             (t `(signed-byte ,width))))))
+      (if (eq signedp nil)
           (logand-derive-type-aux res mask-type)))))
 
 ;;; Try to recursively cut all uses of LVAR to WIDTH bits.
@@ -2855,12 +2856,13 @@
 ;;; modular version, if it exists, or NIL. If we have changed
 ;;; anything, we need to flush old derived types, because they have
 ;;; nothing in common with the new code.
-(defun cut-to-width (lvar class width)
+(defun cut-to-width (lvar kind width signedp)
   (declare (type lvar lvar) (type (integer 0) width))
   (let ((type (specifier-type (if (zerop width)
                                   '(eql 0)
-                                  `(,(ecase class (:unsigned 'unsigned-byte)
-                                            (:signed 'signed-byte))
+                                  `(,(ecase signedp
+                                       ((nil) 'unsigned-byte)
+                                       (t 'signed-byte))
                                      ,width)))))
     (labels ((reoptimize-node (node name)
                (setf (node-derived-type node)
@@ -2876,7 +2878,7 @@
                           (eq (basic-combination-kind node) :known))
                  (let* ((fun-ref (lvar-use (combination-fun node)))
                         (fun-name (leaf-source-name (ref-leaf fun-ref)))
-                        (modular-fun (find-modular-version fun-name class width)))
+                        (modular-fun (find-modular-version fun-name kind signedp width)))
                    (when (and modular-fun
                               (not (and (eq fun-name 'logand)
                                         (csubtypep
@@ -2909,6 +2911,30 @@
                did-something))
       (cut-lvar lvar))))
 
+(defun best-modular-version (width signedp)
+  ;; 1. exact width-matched :untagged
+  ;; 2. >/>= width-matched :tagged
+  ;; 3. >/>= width-matched :untagged
+  (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
+         (uswidths (modular-class-widths *untagged-signed-modular-class*))
+         (uwidths (merge 'list uuwidths uswidths #'< :key #'car))
+         (twidths (modular-class-widths *tagged-modular-class*)))
+    (let ((exact (find (cons width signedp) uwidths :test #'equal)))
+      (when exact
+        (return-from best-modular-version (values width :untagged signedp))))
+    (flet ((inexact-match (w)
+             (cond
+               ((eq signedp (cdr w)) (<= width (car w)))
+               ((eq signedp nil) (< width (car w))))))
+      (let ((tgt (find-if #'inexact-match twidths)))
+        (when tgt
+          (return-from best-modular-version
+            (values (car tgt) :tagged (cdr tgt)))))
+      (let ((ugt (find-if #'inexact-match uwidths)))
+        (when ugt
+          (return-from best-modular-version
+            (values (car ugt) :untagged (cdr ugt))))))))
+
 (defoptimizer (logand optimizer) ((x y) node)
   (let ((result-type (single-value-type (node-derived-type node))))
     (when (numeric-type-p result-type)
@@ -2918,13 +2944,14 @@
                    (numberp high)
                    (>= low 0))
           (let ((width (integer-length high)))
-            (when (some (lambda (x) (<= width x))
-                        (modular-class-widths *unsigned-modular-class*))
-              ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
-              (cut-to-width x :unsigned width)
-              (cut-to-width y :unsigned width)
-              nil ; After fixing above, replace with T.
-              )))))))
+            (multiple-value-bind (w kind signedp)
+                (best-modular-version width nil)
+              (when w
+                ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
+                (cut-to-width x kind width signedp)
+                (cut-to-width y kind width signedp)
+                nil ; After fixing above, replace with T.
+                ))))))))
 
 (defoptimizer (mask-signed-field optimizer) ((width x) node)
   (let ((result-type (single-value-type (node-derived-type node))))
@@ -2933,12 +2960,13 @@
             (high (numeric-type-high result-type)))
         (when (and (numberp low) (numberp high))
           (let ((width (max (integer-length high) (integer-length low))))
-            (when (some (lambda (x) (<= width x))
-                        (modular-class-widths *signed-modular-class*))
-              ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
-              (cut-to-width x :signed width)
-              nil ; After fixing above, replace with T.
-              )))))))
+            (multiple-value-bind (w kind)
+                (best-modular-version width t)
+              (when w
+                ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T).
+                (cut-to-width x kind width t)
+                nil ; After fixing above, replace with T.
+                ))))))))
 \f
 ;;; miscellanous numeric transforms
 
@@ -4134,4 +4162,3 @@
                (policy-quality-name-p (lvar-value quality-name)))
     (give-up-ir1-transform))
   '(%policy-quality policy quality-name))
-

diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp
index 1f63042..c02e9d7 100644 (file)
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -1,4 +1,4 @@
-;;;; the VM definition of arithmetic VOPs for the x86
+;;;; the VM definition of arithmetic VOPs for the x86-64
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
@@ -46,13 +46,13 @@
 
 (define-vop (fast-lognot/fixnum fixnum-unop)
   (:translate lognot)
-  (:generator 2
+  (:generator 1
     (move res x)
     (inst xor res (fixnumize -1))))
 
 (define-vop (fast-lognot/signed signed-unop)
   (:translate lognot)
-  (:generator 1
+  (:generator 2
     (move res x)
     (inst not res)))
 \f
@@ -1263,8 +1263,8 @@
                    (svop61f (intern (format nil "FAST-~S-SMOD61/FIXNUM=>FIXNUM" name)))
                    (svop61cf (intern (format nil "FAST-~S-SMOD61-C/FIXNUM=>FIXNUM" name))))
                `(progn
-                  (define-modular-fun ,fun64 (x y) ,name :unsigned 64)
-                  (define-modular-fun ,sfun61 (x y) ,name :signed 61)
+                  (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
+                  (define-modular-fun ,sfun61 (x y) ,name :tagged t 61)
                   (define-mod-binop (,vop64u ,vopu) ,fun64)
                   (define-vop (,vop64f ,vopf) (:translate ,fun64))
                   (define-vop (,svop61f ,vopf) (:translate ,sfun61))
@@ -1307,19 +1307,19 @@
   (signed-byte 61)
   (foldable flushable movable))
 
-(define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
+(define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
   (when (and (<= width 64)
              (constant-lvar-p scale)
              (constant-lvar-p disp))
-    (cut-to-width base :unsigned width)
-    (cut-to-width index :unsigned width)
+    (cut-to-width base :untagged width nil)
+    (cut-to-width index :untagged width nil)
     'sb!vm::%lea-mod64))
-(define-modular-fun-optimizer %lea ((base index scale disp) :signed :width width)
+(define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
   (when (and (<= width 61)
              (constant-lvar-p scale)
              (constant-lvar-p disp))
-    (cut-to-width base :signed width)
-    (cut-to-width index :signed width)
+    (cut-to-width base :tagged width t)
+    (cut-to-width index :tagged width t)
     'sb!vm::%lea-smod61))
 
 #+sb-xc-host
@@ -1353,7 +1353,7 @@
   (:translate %lea-smod61))
 
 ;;; logical operations
-(define-modular-fun lognot-mod64 (x) lognot :unsigned 64)
+(define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
 (define-vop (lognot-mod64/unsigned=>unsigned)
   (:translate lognot-mod64)
   (:args (x :scs (unsigned-reg unsigned-stack) :target r
@@ -1371,20 +1371,6 @@
     (move r x)
     (inst not r)))
 
-(define-modular-fun logxor-mod64 (x y) logxor :unsigned 64)
-(define-mod-binop (fast-logxor-mod64/word=>unsigned
-                   fast-logxor/unsigned=>unsigned)
-    logxor-mod64)
-(define-mod-binop-c (fast-logxor-mod64-c/word=>unsigned
-                     fast-logxor-c/unsigned=>unsigned)
-    logxor-mod64)
-(define-vop (fast-logxor-mod64/fixnum=>fixnum
-             fast-logxor/fixnum=>fixnum)
-  (:translate logxor-mod64))
-(define-vop (fast-logxor-mod64-c/fixnum=>fixnum
-             fast-logxor-c/fixnum=>fixnum)
-  (:translate logxor-mod64))
-
 (define-source-transform logeqv (&rest args)
   (if (oddp (length args))
       `(logxor ,@args)

diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp
index 7511b32..e7ec031 100644 (file)
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -46,13 +46,13 @@
 
 (define-vop (fast-lognot/fixnum fixnum-unop)
   (:translate lognot)
-  (:generator 2
+  (:generator 1
     (move res x)
     (inst xor res (fixnumize -1))))
 
 (define-vop (fast-lognot/signed signed-unop)
   (:translate lognot)
-  (:generator 1
+  (:generator 2
     (move res x)
     (inst not res)))
 \f
@@ -1320,8 +1320,8 @@
                    (svop30f (intern (format nil "FAST-~S-SMOD30/FIXNUM=>FIXNUM" name)))
                    (svop30cf (intern (format nil "FAST-~S-SMOD30-C/FIXNUM=>FIXNUM" name))))
                `(progn
-                  (define-modular-fun ,fun32 (x y) ,name :unsigned 32)
-                  (define-modular-fun ,sfun30 (x y) ,name :signed 30)
+                  (define-modular-fun ,fun32 (x y) ,name :untagged nil 32)
+                  (define-modular-fun ,sfun30 (x y) ,name :tagged t 30)
                   (define-mod-binop (,vop32u ,vopu) ,fun32)
                   (define-vop (,vop32f ,vopf) (:translate ,fun32))
                   (define-vop (,svop30f ,vopf) (:translate ,sfun30))
@@ -1367,19 +1367,19 @@
   (signed-byte 30)
   (foldable flushable movable))
 
-(define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
+(define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
   (when (and (<= width 32)
              (constant-lvar-p scale)
              (constant-lvar-p disp))
-    (cut-to-width base :unsigned width)
-    (cut-to-width index :unsigned width)
+    (cut-to-width base :untagged width nil)
+    (cut-to-width index :untagged width nil)
     'sb!vm::%lea-mod32))
-(define-modular-fun-optimizer %lea ((base index scale disp) :signed :width width)
+(define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
   (when (and (<= width 30)
              (constant-lvar-p scale)
              (constant-lvar-p disp))
-    (cut-to-width base :signed width)
-    (cut-to-width index :signed width)
+    (cut-to-width base :tagged width t)
+    (cut-to-width index :tagged width t)
     'sb!vm::%lea-smod30))
 
 #+sb-xc-host
@@ -1413,7 +1413,7 @@
   (:translate %lea-smod30))
 
 ;;; logical operations
-(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
+(define-modular-fun lognot-mod32 (x) lognot :untagged nil 32)
 (define-vop (lognot-mod32/word=>unsigned)
   (:translate lognot-mod32)
   (:args (x :scs (unsigned-reg signed-reg unsigned-stack signed-stack) :target r
@@ -1436,20 +1436,6 @@
     (move r x)
     (inst not r)))
 
-(define-modular-fun logxor-mod32 (x y) logxor :unsigned 32)
-(define-mod-binop (fast-logxor-mod32/word=>unsigned
-                   fast-logxor/unsigned=>unsigned)
-    logxor-mod32)
-(define-mod-binop-c (fast-logxor-mod32-c/word=>unsigned
-                     fast-logxor-c/unsigned=>unsigned)
-    logxor-mod32)
-(define-vop (fast-logxor-mod32/fixnum=>fixnum
-             fast-logxor/fixnum=>fixnum)
-  (:translate logxor-mod32))
-(define-vop (fast-logxor-mod32-c/fixnum=>fixnum
-             fast-logxor-c/fixnum=>fixnum)
-  (:translate logxor-mod32))
-
 (define-source-transform logeqv (&rest args)
   (if (oddp (length args))
       `(logxor ,@args)

diff --git a/version.lisp-expr b/version.lisp-expr
index 370f8a0..6d205eb 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.15.15"
+"1.0.15.16"