Changeset 14375

Timestamp:

Oct 26, 2010, 10:16:37 AM (14 years ago)

Author:

Gary Byers

Message:

In the frontend:

binary boolean operations assert their result's type.
logand of an unsigned natural integer and an integer constant is always
an unsigned natural (and the constant can be truncated to the word size.)

This helps with some examples involving (e.g.) DPB on word-sized integers;
it's likely that handling other cases require improvements in later phases.

Location:

trunk/source/compiler

Files:

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

trunk/source/compiler/nx0.lisp

@@ -2739 +2739 @@
          (use-naturalop (nx-binary-natural-op-p arg-1 arg-2 env)))
     (if (or use-fixop use-naturalop intop)
-      (make-acode (if use-fixop fixop (if use-naturalop naturalop intop))
-                  (nx1-form arg-1)
-                  (nx1-form arg-2))
+      (make-acode (%nx1-operator typed-form)
+                  (if use-fixop *nx-target-fixnum-type*
+                    (if use-naturalop *nx-target-natural-type* 'integer))
+                  (make-acode (if use-fixop fixop (if use-naturalop naturalop intop))
+                              (nx1-form arg-1)
+                              (nx1-form arg-2)))
       (nx1-treat-as-call whole))))
 

trunk/source/compiler/nx1.lisp

@@ -475 +475 @@
                       (%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)
+  (let* ((nat1 (nx-form-typep arg-1 *nx-target-natural-type* env))
+         (nat2 (nx-form-typep arg-2 *nx-target-natural-type* env)))
+    (cond ((and (nx-form-typep arg-1 *nx-target-fixnum-type* env)
+                (nx-form-typep arg-2 *nx-target-fixnum-type* env))
+           (make-acode (%nx1-operator typed-form)
+                       *nx-target-fixnum-type*
+                       (make-acode (%nx1-operator %ilogand2)
+                                   (nx1-form arg-1 env)
+                                   (nx1-form arg-2 env))))
+          ((and nat1 (typep arg-2 'integer))
+           (make-acode (%nx1-operator typed-form)
+                       *nx-target-natural-type*
+                       (make-acode (%nx1-operator %natural-logand)
+                                   (nx1-form arg-1 env)
+                                   (nx1-form (logand arg-2
+                                                     (1- (ash 1 (target-word-size-case
+                                                                 (32 32)
+                                                                 (64 64)))))
+                                             env))))
+          ((and nat2 (typep arg-1 'integer))
+           (make-acode (%nx1-operator typed-form)
+                       *nx-target-natural-type*
+                       (make-acode (%nx1-operator %natural-logand)
+                                   (nx1-form arg-2 env)
+                                   (nx1-form (logand arg-1
+                                                     (1- (ash 1 (target-word-size-case
+                                                                 (32 32)
+                                                                 (64 64)))))
+                                             env))))
+          ((and nat1 nat2)
+           (make-acode (%nx1-operator typed-form)
+                       *nx-target-natural-type*
+                       (make-acode (%nx1-operator %natural-logand)
+                                   (nx1-form arg-1 env)
+                                   (nx1-form arg-2 env))))
+          (t
+           (make-acode (%nx1-operator typed-form)
+                       'integer
+                       (make-acode (%nx1-operator logand2)
+                                   (nx1-form arg-1 env)
+                                   (nx1-form arg-2 env)))))))
+
 
 (defnx1 nx1-require ((require-simple-vector)