Changeset 13887

Timestamp:

Jun 24, 2010, 7:33:40 PM (14 years ago)

Author:

R. Matthew Emerson

Message:

Make the compiler work a little harder to identify cases where
LOGAND and LOGIOR can use natural-sized operations.

Location:

trunk/source

Files:

• . (modified) (1 prop)
• compiler/PPC/ppc2.lisp (modified) (1 diff)
• compiler/X86/x862.lisp (modified) (1 diff)
• compiler/nx0.lisp (modified) (4 diffs)
• compiler/nx1.lisp (modified) (3 diffs)
• compiler/nxenv.lisp (modified) (1 diff)

trunk/source/compiler/PPC/ppc2.lisp

@@ -9116 +9116 @@
       (^))))
 
+(defppc2 ppc2-%fixnum-mask-to-natural %fixnum-mask-to-natural (seg vreg xfer arg)
+  (with-imm-target () (dreg :natural)
+    (let* ((r (ppc2-one-untargeted-reg-form seg arg ppc::arg_z)))
+      (unless (or (acode-fixnum-form-p arg)
+                  *ppc2-reckless*)
+        (! trap-unless-fixnum r))
+      (! fixnum->signed-natural dreg r)
+      (<- dreg)
+      (^))))
+
 (defppc2 ppc2-%double-float %double-float (seg vreg xfer arg)
   (let* ((real (or (acode-fixnum-form-p arg)

trunk/source/compiler/X86/x862.lisp

@@ -10094 +10094 @@
       (^))))
 
+(defx862 x862-%fixnum-mask-to-natural %fixnum-mask-to-natural (seg vreg xfer arg)
+  (with-imm-target () (target :natural)
+    (let ((r (x862-one-untargeted-reg-form seg arg *x862-arg-z*)))
+      (unless (or (acode-fixnum-form-p arg)
+                  *x862-reckless*)
+        (! trap-unless-finxum r))
+      (! fixnum->signed-natural target r)
+      (<- target)
+      (^))))
+
 (defx862 x862-%double-float %double-float (seg vreg xfer arg)
   (let* ((real (or (acode-fixnum-form-p arg)

trunk/source/compiler/nx0.lisp

@@ -589 +589 @@
          int)))
 
+(defun acode-natural-constant-p (x)
+  (let* ((int (or (acode-fixnum-form-p x)
+                  (progn
+                    (setq x (acode-unwrapped-form x))
+                    (if (acode-p x)
+                      (if (and (eq (acode-operator x) (%nx1-operator immediate))
+                               (typep (cadr x) 'fixnum))
+                        (cadr x)))))))
+    (and int
+         (target-word-size-case
+          (32 (typep int '(unsigned-byte 32)))
+          (64 (typep int '(unsigned-byte 64))))
+         int)))
+
+
+
 (defun acode-real-constant-p (x)
   (or (acode-fixnum-form-p x)
@@ -692 +708 @@
 (defun nx-acode-fixnum-type-p (form env)
     (acode-fixnum-type-p form (nx-trust-declarations env)))
+
+(defun acode-natural-type-p (form trust-decls)
+  (and trust-decls
+       (acode-p form)
+       (eq (acode-operator form) (%nx1-operator typed-form))
+       (subtypep (cadr form) (target-word-size-case
+                              (32 '(unsigned-byte 32))
+                              (64 '(unsigned-byte 64))))))
+
+(defun nx-acode-natural-type-p (form env)
+  (acode-natural-type-p form (nx-trust-declarations env)))
 
 ; Is acode-expression the result of alphatizing (%int-to-ptr <integer>) ?
@@ -2713 +2740 @@
     (subtypep (nx-form-type arg env) type env)))
 
-
 (defun nx-binary-fixnum-op-p (form1 form2 env &optional ignore-result-type)
   (setq form1 (nx-transform form1 env)
@@ -2746 +2772 @@
              (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)))
+    (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-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)
@@ -2198 +2186 @@
               (nx1-form arg)))
 
+(defnx1 nx1-%fixnum-mask-to-natural ((%fixnum-mask-to-natural)) (arg)
+  (make-acode (%nx1-operator %fixnum-mask-to-natural)
+              (nx1-form arg)))
+
 (defnx1 nx1-%double-float ((%double-float)) (&whole whole arg &optional (result nil result-p))
   (declare (ignore result))

trunk/source/compiler/nxenv.lisp

@@ -370 +370 @@
      (%double-float . #. #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
      (i386-ff-call . 0)
-     (i386-syscall . 0))))
+     (i386-syscall . 0)
+     (%fixnum-mask-to-natural  . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)))))
 
 (defmacro %nx1-operator (sym)