Changeset 14229

Timestamp:

Aug 30, 2010, 8:15:56 PM (14 years ago)

Author:

R. Matthew Emerson

Message:

Re-enable some changes that try to do a better job on LOGAND
and LOGIOR (particularly as generated by DPB) in some simple
cases.

Location:

trunk/source/compiler

Files:

• nx0.lisp (modified) (1 diff)
• nx1.lisp (modified) (2 diffs)

trunk/source/compiler/nx0.lisp

@@ -2767 +2767 @@
              (64 (subtypep *nx-form-type* '(unsigned-byte 64))))))))
 
-(defun nx-logand-2-op (arg-1 arg-2 env)
-  (let* ((form-1 (nx1-form arg-1))
-         (form-2 (nx1-form arg-2))
-         (fix-1 (nx-acode-fixnum-type-p form-1 env))
-         (fix-2 (nx-acode-fixnum-type-p form-2 env))
-         (nat-1 (nx-acode-natural-type-p form-1 env))
-         (nat-2 (nx-acode-natural-type-p form-2 env))
-         (natural-width (target-word-size-case (32 32) (64 64)))
-         (natural-mask (1- (ash 1 natural-width))))
-    (when (and nat-1
-               (not nat-2)
-               (acode-integer-constant-p form-2 natural-width))
-        (setq form-2 (nx1-form (logand natural-mask arg-2))
-              nat-2 t))
-    (when (and (not nat-1)
-               nat-2
-               (acode-integer-constant-p form-1 natural-width))
-        (setq form-1 (nx1-form (logand natural-mask arg-1))
-              nat-1 t))
-    (cond
-      ((and fix-1 fix-2)
-       (make-acode (%nx1-operator %ilogand2) form-1 form-2))
-      ((and nat-1 nat-2)
-       (make-acode (%nx1-operator typed-form)
-                   (target-word-size-case
-                    (32 '(unsigned-byte 32))
-                    (64 '(unsigned-byte 64)))
-                   (make-acode (%nx1-operator %natural-logand) form-1 form-2)))
-      ((and fix-1 nat-2)
-       (make-acode (%nx1-operator typed-form)
-                   (target-word-size-case
-                    (32 '(unsigned-byte 32))
-                    (64 '(unsigned-byte 64)))
-                   (make-acode (%nx1-operator %natural-logand)
-                               (make-acode (%nx1-operator %fixnum-mask-to-natural)
-                                           form-1)
-                               form-2)))
-      ((and nat-1 fix-2)
-       (make-acode (%nx1-operator typed-form)
-                   (target-word-size-case
-                    (32 '(unsigned-byte 32))
-                    (64 '(unsigned-byte 64)))
-                   (make-acode (%nx1-operator %natural-logand)
-                               form-1
-                               (make-acode (%nx1-operator %fixnum-mask-to-natural)
-                                                          form-2))))
-      (t
-       (make-acode (%nx1-operator logand2) form-1 form-2)))))
-
-(defun nx-logior-2-op (arg-1 arg-2 env)
-  (let* ((form-1 (nx1-form arg-1))
-         (form-2 (nx1-form arg-2))
-         (fix-1 (nx-acode-fixnum-type-p form-1 env))
-         (fix-2 (nx-acode-fixnum-type-p form-2 env))
-         (nat-1 (or (acode-natural-constant-p form-1)
-                    (nx-acode-natural-type-p form-1 env)))
-         (nat-2 (or (acode-natural-constant-p form-2)
-                    (nx-acode-natural-type-p form-2 env))))
-    (cond
-      ((and fix-1 fix-2)
-       (make-acode (%nx1-operator %ilogior2) form-1 form-2))
-      ((and nat-1 nat-2)
-       (make-acode (%nx1-operator typed-form)
-                   (target-word-size-case
-                    (32 '(unsigned-byte 32))
-                    (64 '(unsigned-byte 64)))
-                   (make-acode (%nx1-operator %natural-logior) form-1 form-2)))
-      (t
-       (make-acode (%nx1-operator logior2) form-1 form-2)))))
+(defun nx-logand-2-op (form1 form2 env)
+  (let* ((acode1 (nx1-form form1))
+         (acode2 (nx1-form form2))
+         (fix1 (nx-acode-fixnum-type-p acode1 env))
+         (fix2 (nx-acode-fixnum-type-p acode2 env)))
+    (if (and fix1 fix2)
+      (make-acode (%nx1-operator %ilogand2) acode1 acode2)
+      (let* ((natural-type (target-word-size-case
+                            (32 '(unsigned-byte 32))
+                            (64 '(unsigned-byte 64))))
+             (nat1 (or fix1 (nx-acode-form-typep acode1 natural-type env)))
+             (nat2 (or fix2 (nx-acode-form-typep acode2 natural-type env))))
+        (if (and nat1 nat2)
+          (make-acode (%nx1-operator typed-form) natural-type
+                      (make-acode (%nx1-operator %natural-logand)
+                                  acode1 acode2))
+          (make-acode (%nx1-operator logand2) acode1 acode2))))))
+
+(defun nx-logior-2-op (form1 form2 env)
+  (let* ((acode1 (nx1-form form1))
+         (acode2 (nx1-form form2))
+         (fix1 (nx-acode-fixnum-type-p acode1 env))
+         (fix2 (nx-acode-fixnum-type-p acode2 env)))
+    (if (and fix1 fix2)
+      (make-acode (%nx1-operator %ilogior2) acode1 acode2)
+      (let* ((natural-type (target-word-size-case
+                            (32 '(unsigned-byte 32))
+                            (64 '(unsigned-byte 64))))
+             (nat1 (or fix1 (nx-acode-form-typep acode1 natural-type env)))
+             (nat2 (or fix2 (nx-acode-form-typep acode2 natural-type env))))
+        (if (and nat1 nat2)
+          (make-acode (%nx1-operator typed-form) natural-type
+                      (make-acode (%nx1-operator %natural-logior)
+                                  acode1 acode2))
+          (make-acode (%nx1-operator logior2) acode1 acode2))))))
 
 (defun nx-binary-boole-op (whole env arg-1 arg-2 fixop intop naturalop)

trunk/source/compiler/nx1.lisp

@@ -450 +450 @@
                 (nx1-form newvalue)))
 
-(defnx1 nx1-logior-2 ((logior-2)) (&whole w &environment env arg-1 arg-2)
-  (nx-binary-boole-op w
-                      env
-                      arg-1
-                      arg-2
-                      (%nx1-operator %ilogior2)
-                      (%nx1-operator logior2)
-                      (%nx1-operator %natural-logior)))
+(defnx1 nx1-logior-2 ((logior-2)) (&environment env arg-1 arg-2)
+  (nx-logior-2-op arg-1 arg-2 env))
 
 (defnx1 nx1-logxor-2 ((logxor-2)) (&whole w &environment env arg-1 arg-2)
@@ -468 +462 @@
                       (%nx1-operator %natural-logxor)))
 
-(defnx1 nx1-logand-2 ((logand-2)) (&whole w &environment env arg-1 arg-2)
-  (nx-binary-boole-op w
-                      env
-                      arg-1
-                      arg-2
-                      (%nx1-operator %ilogand2)
-                      (%nx1-operator logand2)
-                      (%nx1-operator %natural-logand)))
+(defnx1 nx1-logand-2 ((logand-2)) (&environment env arg-1 arg-2)
+  (nx-logand-2-op arg-1 arg-2 env))
 
 (defnx1 nx1-require ((require-simple-vector)