From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Mon, 8 Sep 2003 15:47:45 +0000 (+0000)
Subject: 0.8.3.45.modular1:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=4b58efcd710097cf7cc9b1a1bed8b0e1bd6eb3b8;p=sbcl.git

0.8.3.45.modular1:
	Implement modular function optimization for PPC.
	... Haven't implemented modular - or *; they could be TODO.
	... probably doesn't build on anything but PPC currently, so
		onto a branch it goes.
---

diff --git a/NEWS b/NEWS
index fbbdb39..94f413c 100644
--- a/NEWS
+++ b/NEWS
@@ -2029,6 +2029,9 @@ changes in sbcl-0.8.4 relative to sbcl-0.8.3:
     performance of the compiler by about 20%.
   * optimization: performance of FILL (and :INITIAL-ELEMENT) on
     simple-base-strings and simple-bit-vectors is improved.
+  * optimization: the optimization of 32-bit logical and arithmetic
+    functions introduced in version 0.8.3 on the x86 has been
+    implemented on the ppc.
   * microoptimization: the compiler is better able to make use of the
     x86 LEA instruction for multiplication by constants.
   * bug fix: in some situations compiler did not report usage of
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 6abfe48..739f076 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1294,7 +1294,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "TWO-ARG-/" "TWO-ARG-/=" "TWO-ARG-<"
              "TWO-ARG-<=" "TWO-ARG-="
              "TWO-ARG->" "TWO-ARG->=" "TWO-ARG-AND"
-             "TWO-ARG-GCD" "TWO-ARG-IOR"
+             "TWO-ARG-EQV" "TWO-ARG-GCD" "TWO-ARG-IOR"
              "TWO-ARG-LCM" "TWO-ARG-XOR"
              "TYPE-DIFFERENCE" "TYPE-EXPAND"
              "TYPE-INTERSECTION" "TYPE-INTERSECTION2"
diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index c2a1a6b..f3adc3b 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -957,36 +957,6 @@
 	(declare (integer result)))
       -1))
 
-(defun lognand (integer1 integer2)
-  #!+sb-doc
-  "Return the complement of the logical AND of integer1 and integer2."
-  (lognand integer1 integer2))
-
-(defun lognor (integer1 integer2)
-  #!+sb-doc
-  "Return the complement of the logical OR of integer1 and integer2."
-  (lognor integer1 integer2))
-
-(defun logandc1 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical AND of (LOGNOT integer1) and integer2."
-  (logandc1 integer1 integer2))
-
-(defun logandc2 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical AND of integer1 and (LOGNOT integer2)."
-  (logandc2 integer1 integer2))
-
-(defun logorc1 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical OR of (LOGNOT integer1) and integer2."
-  (logorc1 integer1 integer2))
-
-(defun logorc2 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical OR of integer1 and (LOGNOT integer2)."
-  (logorc2 integer1 integer2))
-
 (defun lognot (number)
   #!+sb-doc
   "Return the bit-wise logical not of integer."
@@ -994,13 +964,39 @@
     (fixnum (lognot (truly-the fixnum number)))
     (bignum (bignum-logical-not number))))
 
-(macrolet ((def (name op big-op)
-	     `(defun ,name (x y)
-	       (number-dispatch ((x integer) (y integer))
-		 (bignum-cross-fixnum ,op ,big-op)))))
+(macrolet ((def (name op big-op &optional doc)
+	     `(defun ,name (integer1 integer2)
+		,@(when doc
+		    (list doc))
+		(let ((x integer1)
+		      (y integer2))
+		  (number-dispatch ((x integer) (y integer))
+		    (bignum-cross-fixnum ,op ,big-op))))))
   (def two-arg-and logand bignum-logical-and)
   (def two-arg-ior logior bignum-logical-ior)
-  (def two-arg-xor logxor bignum-logical-xor))
+  (def two-arg-xor logxor bignum-logical-xor)
+  ;; BIGNUM-LOGICAL-{AND,IOR,XOR} need not return a bignum, so must
+  ;; call the generic LOGNOT...
+  (def two-arg-eqv logeqv (lambda (x y) (lognot (bignum-logical-xor x y))))
+  (def lognand lognand 
+       (lambda (x y) (lognot (bignum-logical-and x y))) 
+       #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
+  (def lognor lognor
+       (lambda (x y) (lognot (bignum-logical-ior x y)))
+       #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
+  ;; ... but BIGNUM-LOGICAL-NOT on a bignum will always return a bignum
+  (def logandc1 logandc1
+       (lambda (x y) (bignum-logical-and (bignum-logical-not x) y))
+       #!+sb-doc "Bitwise AND (LOGNOT INTEGER1) with INTEGER2.")
+  (def logandc2 logandc2
+       (lambda (x y) (bignum-logical-and x (bignum-logical-not y)))
+       #!+sb-doc "Bitwise AND INTEGER1 with (LOGNOT INTEGER2).")
+  (def logorc1 logorc1
+       (lambda (x y) (bignum-logical-ior (bignum-logical-not x) y))
+       #!+sb-doc "Bitwise OR (LOGNOT INTEGER1) with INTEGER2.")
+  (def logorc2 logorc2
+       (lambda (x y) (bignum-logical-ior x (bignum-logical-not y)))
+       #!+sb-doc "Bitwise OR INTEGER1 with (LOGNOT INTEGER2)."))
 
 (defun logcount (integer)
   #!+sb-doc
diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 4bb3a9f..e74749a 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -440,7 +440,7 @@
 
 
 ;;;; 32-bit operations
-#!-x86 ; on X86 it is a modular function
+#!-(or ppc x86) ; on X86 it is a modular function
 (deftransform lognot ((x) ((unsigned-byte 32)) *
                       :node node
                       :result result)
diff --git a/src/compiler/ppc/arith.lisp b/src/compiler/ppc/arith.lisp
index 91f23bf..abba8aa 100644
--- a/src/compiler/ppc/arith.lisp
+++ b/src/compiler/ppc/arith.lisp
@@ -137,23 +137,36 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
-(defmacro define-var-binop (translate untagged-penalty op)
+(defmacro define-var-binop (translate untagged-penalty op 
+			    &optional arg-swap restore-fixnum-mask)
   `(progn
      (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
 		  fast-fixnum-binop)
+       ,@(when restore-fixnum-mask
+	   `((:temporary (:sc non-descriptor-reg) temp)))
        (:translate ,translate)
        (:generator 2
-	 (inst ,op r x y))) 
+	 ,(if arg-swap
+	     `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
+	     `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
+	 ;; FIXME: remind me what convention we used for 64bitizing
+	 ;; stuff?  -- CSR, 2003-08-27
+	 ,@(when restore-fixnum-mask
+	     `((inst clrrwi r temp (1- n-lowtag-bits))))))
      (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 		  fast-signed-binop)
        (:translate ,translate)
        (:generator ,(1+ untagged-penalty)
-	 (inst ,op r x y))) 
+         ,(if arg-swap
+	     `(inst ,op r y x)
+	     `(inst ,op r x y))))
      (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
 		  fast-unsigned-binop)
        (:translate ,translate)
        (:generator ,(1+ untagged-penalty)
-	 (inst ,op r x y)))))
+	 ,(if arg-swap
+	     `(inst ,op r y x)
+	     `(inst ,op r x y))))))
 
 
 (defmacro define-const-binop (translate untagged-penalty op)
@@ -199,11 +212,15 @@
 (define-var-binop + 4 add)
 (define-var-binop - 4 sub)
 (define-var-binop logand 2 and)
+(define-var-binop logandc1 2 andc t)
 (define-var-binop logandc2 2 andc)
 (define-var-binop logior 2 or)
-(define-var-binop logorc2 2 orc)
+(define-var-binop logorc1 2 orc t t)
+(define-var-binop logorc2 2 orc nil t)
 (define-var-binop logxor 2 xor)
-(define-var-binop logeqv 2 eqv)
+(define-var-binop logeqv 2 eqv nil t)
+(define-var-binop lognand 2 nand nil t)
+(define-var-binop lognor 2 nor nil t)
 
 (define-const-binop + 4 addi)
 (define-const-binop - 4 subi)
@@ -433,6 +450,42 @@
       (emit-label done))))
 
 
+;;;; Modular functions:
+(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-vop (lognot-mod32/unsigned=>unsigned)
+  (:translate lognot-mod32)
+  (:args (x :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 1
+    (inst not res x)))
+
+(macrolet 
+    ((define-modular-backend (fun &optional constantp)
+       (let ((mfun-name (symbolicate fun '-mod32))
+	     (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
+	     (modcvop (symbolicate 'fast- fun 'mod32-c/unsigned=>unsigned))
+	     (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
+	     (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
+	 `(progn
+	    (define-modular-fun ,mfun-name (x y) ,fun 32)
+	    (define-vop (,modvop ,vop)
+	      (:translate ,mfun-name))
+	    ,@(when constantp
+		`((define-vop (,modcvop ,cvop)
+		    (:translate ,mfun-name))))))))
+  (define-modular-backend + t)
+  (define-modular-backend logxor t)
+  (define-modular-backend logeqv)
+  (define-modular-backend lognand)
+  (define-modular-backend lognor)
+  (define-modular-backend logandc1)
+  (define-modular-backend logandc2)
+  (define-modular-backend logorc1)
+  (define-modular-backend logorc2))
+
 ;;;; Binary conditional VOPs:
 
 (define-vop (fast-conditional)
@@ -635,64 +688,38 @@
       (emit-label done)
       (move result res))))
 
+(define-source-transform 32bit-logical-not (x)
+  `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32))))
 
-(define-vop (32bit-logical)
-  (:args (x :scs (unsigned-reg zero))
-	 (y :scs (unsigned-reg zero)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:policy :fast-safe))
-
-(define-vop (32bit-logical-not 32bit-logical)
-  (:translate 32bit-logical-not)
-  (:args (x :scs (unsigned-reg zero)))
-  (:arg-types unsigned-num)
-  (:generator 1
-    (inst not r x)))
-
-(define-vop (32bit-logical-and 32bit-logical)
-  (:translate 32bit-logical-and)
-  (:generator 1
-    (inst and r x y)))
-
-(deftransform 32bit-logical-nand ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-and x y)))
+(deftransform 32bit-logical-and ((x y))
+  '(logand x y))
 
-(define-vop (32bit-logical-or 32bit-logical)
-  (:translate 32bit-logical-or)
-  (:generator 1
-    (inst or r x y)))
+(deftransform 32bit-logical-nand ((x y))
+  '(logand (lognand x y) #.(1- (ash 1 32))))
 
-(deftransform 32bit-logical-nor ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-or x y)))
+(deftransform 32bit-logical-or ((x y))
+  '(logior x y))
 
-(define-vop (32bit-logical-xor 32bit-logical)
-  (:translate 32bit-logical-xor)
-  (:generator 1
-    (inst xor r x y)))
+(deftransform 32bit-logical-nor ((x y))
+  '(logand (lognor x y) #.(1- (ash 1 32))))
 
-(define-vop (32bit-logical-eqv 32bit-logical)
-  (:translate 32bit-logical-eqv)
-  (:generator 1
-    (inst eqv r x y)))
+(deftransform 32bit-logical-xor ((x y))
+  '(logxor x y))
 
-(define-vop (32bit-logical-orc2 32bit-logical)
-  (:translate 32bit-logical-orc2)
-  (:generator 1
-    (inst orc r x y)))
+(deftransform 32bit-logical-eqv ((x y))
+  '(logand (logeqv x y) #.(1- (ash 1 32))))
 
-(deftransform 32bit-logical-orc1 ((x y) (* *))
-  '(32bit-logical-orc2 y x))
+(deftransform 32bit-logical-orc1 ((x y))
+  '(logand (logorc1 x y) #.(1- (ash 1 32))))
 
-(define-vop (32bit-logical-andc2 32bit-logical)
-  (:translate 32bit-logical-andc2)
-  (:generator 1
-    (inst andc r x y)))
+(deftransform 32bit-logical-orc2 ((x y))
+  '(logand (logorc2 x y) #.(1- (ash 1 32))))
 
-(deftransform 32bit-logical-andc1 ((x y) (* *))
-  '(32bit-logical-andc2 y x))
+(deftransform 32bit-logical-andc1 ((x y))
+  '(logand (logandc1 x y) #.(1- (ash 1 32))))
 
+(deftransform 32bit-logical-andc2 ((x y))
+  '(logand (logandc2 x y) #.(1- (ash 1 32))))
 
 (define-vop (shift-towards-someplace)
   (:policy :fast-safe)
@@ -715,9 +742,6 @@
   (:generator 1
     (inst rlwinm amount amount 0 27 31)
     (inst srw r num amount)))
-
-
-
 
 ;;;; Bignum stuff.
 
@@ -845,15 +869,8 @@
     (inst mullw lo x y)
     (inst mulhwu hi x y)))
 
-(define-vop (bignum-lognot)
-  (:translate sb!bignum::%lognot)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (inst not r x)))
+(define-vop (bignum-lognot lognot-mod32/unsigned=>unsigned)
+  (:translate sb!bignum::%lognot))
 
 (define-vop (fixnum-to-digit)
   (:translate sb!bignum::%fixnum-to-digit)
@@ -979,6 +996,7 @@
 (define-static-fun two-arg-and (x y) :translate logand)
 (define-static-fun two-arg-ior (x y) :translate logior)
 (define-static-fun two-arg-xor (x y) :translate logxor)
+(define-static-fun two-arg-eqv (x y) :translate logeqv)
 
 (in-package "SB!C")
 
diff --git a/src/compiler/ppc/parms.lisp b/src/compiler/ppc/parms.lisp
index 9a784d3..6a1377f 100644
--- a/src/compiler/ppc/parms.lisp
+++ b/src/compiler/ppc/parms.lisp
@@ -202,6 +202,7 @@
     sb!kernel:two-arg-and
     sb!kernel:two-arg-ior
     sb!kernel:two-arg-xor
+    sb!kernel:two-arg-eqv
     sb!kernel:two-arg-gcd
     sb!kernel:two-arg-lcm))
 
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index adb1dc2..a435801 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -172,12 +172,6 @@
   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
   (deffrob ceiling))
 
-(define-source-transform lognand (x y) `(lognot (logand ,x ,y)))
-(define-source-transform lognor (x y) `(lognot (logior ,x ,y)))
-(define-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
-(define-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
-(define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
-(define-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
 (define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
 (define-source-transform logbitp (index integer)
   `(not (zerop (logand (ash 1 ,index) ,integer))))
@@ -756,21 +750,24 @@
 ;;; the types of both X and Y are integer types, then we compute a new
 ;;; integer type with bounds determined Fun when applied to X and Y.
 ;;; Otherwise, we use Numeric-Contagion.
+(defun derive-integer-type-aux (x y fun)
+  (declare (type function fun))
+  (if (and (numeric-type-p x) (numeric-type-p y)
+	   (eq (numeric-type-class x) 'integer)
+	   (eq (numeric-type-class y) 'integer)
+	   (eq (numeric-type-complexp x) :real)
+	   (eq (numeric-type-complexp y) :real))
+      (multiple-value-bind (low high) (funcall fun x y)
+	(make-numeric-type :class 'integer
+			   :complexp :real
+			   :low low
+			   :high high))
+      (numeric-contagion x y)))
 (defun derive-integer-type (x y fun)
   (declare (type continuation x y) (type function fun))
   (let ((x (continuation-type x))
 	(y (continuation-type y)))
-    (if (and (numeric-type-p x) (numeric-type-p y)
-	     (eq (numeric-type-class x) 'integer)
-	     (eq (numeric-type-class y) 'integer)
-	     (eq (numeric-type-complexp x) :real)
-	     (eq (numeric-type-complexp y) :real))
-	(multiple-value-bind (low high) (funcall fun x y)
-	  (make-numeric-type :class 'integer
-			     :complexp :real
-			     :low low
-			     :high high))
-	(numeric-contagion x y))))
+    (derive-integer-type-aux x y fun)))
 
 ;;; simple utility to flatten a list
 (defun flatten-list (x)
@@ -1363,16 +1360,19 @@
   (defoptimizer (%negate derive-type) ((num))
     (derive-integer-type num num (frob -))))
 
+(defun lognot-derive-type-aux (int)
+  (derive-integer-type-aux int int
+			   (lambda (type type2)
+			     (declare (ignore type2))
+			     (let ((lo (numeric-type-low type))
+				   (hi (numeric-type-high type)))
+			       (values (if hi (lognot hi) nil)
+				       (if lo (lognot lo) nil)
+				       (numeric-type-class type)
+				       (numeric-type-format type))))))
+
 (defoptimizer (lognot derive-type) ((int))
-  (derive-integer-type int int
-		       (lambda (type type2)
-			 (declare (ignore type2))
-			 (let ((lo (numeric-type-low type))
-			       (hi (numeric-type-high type)))
-			   (values (if hi (lognot hi) nil)
-				   (if lo (lognot lo) nil)
-				   (numeric-type-class type)
-				   (numeric-type-format type))))))
+  (lognot-derive-type-aux (continuation-type int)))
 
 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (%negate derive-type) ((num))
@@ -2213,7 +2213,7 @@
 					     '*)))))
        ((or (and (not x-pos) (not y-neg))
 	    (and (not y-neg) (not y-pos)))
-	;; Either X is negative and Y is positive of vice-versa. The
+	;; Either X is negative and Y is positive or vice-versa. The
 	;; result will be negative.
 	(specifier-type `(integer ,(if (and x-len y-len)
 				       (ash -1 (max x-len y-len))
@@ -2233,6 +2233,43 @@
   (deffrob logand)
   (deffrob logior)
   (deffrob logxor))
+
+;;; FIXME: could actually do stuff with SAME-LEAF
+(defoptimizer (logeqv derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+			     (lognot-derive-type-aux 
+			      (logxor-derive-type-aux x y same-leaf))) 
+		       #'logeqv))
+(defoptimizer (lognand derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+			     (lognot-derive-type-aux
+			      (logand-derive-type-aux x y same-leaf)))
+		       #'lognand))
+(defoptimizer (lognor derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+			     (lognot-derive-type-aux
+			      (logior-derive-type-aux x y same-leaf)))
+		       #'lognor))
+(defoptimizer (logandc1 derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+			     (logand-derive-type-aux
+			      (lognot-derive-type-aux x) y nil))
+		       #'logandc1))
+(defoptimizer (logandc2 derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+			     (logand-derive-type-aux
+			      x (lognot-derive-type-aux y) nil))
+		       #'logandc2))
+(defoptimizer (logorc1 derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+			     (logior-derive-type-aux
+			      (lognot-derive-type-aux x) y nil))
+		       #'logorc1))
+(defoptimizer (logorc2 derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+			     (logior-derive-type-aux
+			      x (lognot-derive-type-aux y) nil))
+		       #'logorc2))
 
 ;;;; miscellaneous derive-type methods
 
@@ -3179,11 +3216,8 @@
   (source-transform-transitive 'logxor args 0 'integer))
 (define-source-transform logand (&rest args)
   (source-transform-transitive 'logand args -1 'integer))
-
 (define-source-transform logeqv (&rest args)
-  (if (evenp (length args))
-      `(lognot (logxor ,@args))
-      `(logxor ,@args)))
+  (source-transform-transitive 'logeqv args -1 'integer))
 
 ;;; Note: we can't use SOURCE-TRANSFORM-TRANSITIVE for GCD and LCM
 ;;; because when they are given one argument, they return its absolute
diff --git a/version.lisp-expr b/version.lisp-expr
index cefce68..57b4440 100644
--- 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".)
-"0.8.3.45"
+"0.8.3.45.modular1"