From cb9d90db775cf7d33f7ad374da1a97d644939dd0 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Wed, 9 May 1990 12:00:13 +0000
Subject: [PATCH] Merged in the VALUES and LOGXOR derive-type optimizers from
 the MIPS branch.

---
 compiler/srctran.lisp | 41 ++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 40 insertions(+), 1 deletion(-)

diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 828b11f2b..37f51e7d7 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.8 1990/05/09 12:00:13 ram Exp $
+;;;
 ;;;    This file contains macro-like source transformations which convert
 ;;; uses of certain functions into the canonical form desired within the
 ;;; compiler.  ### and other IR1 transforms and stuff.  Some code adapted from
@@ -330,6 +332,31 @@
 	       (values (if one-neg (lognot mag) 0) mag))
 	     (values (if one-neg nil 0) nil))))))
 
+;;; All we attempt to do is determine the maximum integer length that the
+;;; result can take on, as that is all that is interesting.
+
+(defoptimizer (logxor derive-type) ((x y))
+  (derive-integer-type
+   x y
+   #'(lambda (x y)
+       (let* ((x-high (numeric-type-high x))
+	      (x-pos (plusp (or x-high 1)))
+	      (y-high (numeric-type-high y))
+	      (y-pos (plusp (or y-high 1)))
+	      (x-low (numeric-type-low x))
+	      (x-neg (minusp (or x-low -1)))
+	      (y-low (numeric-type-low y))
+	      (y-neg (minusp (or y-low -1)))
+	      (signed (or (and x-pos y-neg) (and x-neg y-pos))))
+	 (if (and x-high y-high x-low y-low)
+	     (let ((max (max (integer-length x-high)
+			     (integer-length x-low)
+			     (integer-length y-high)
+			     (integer-length y-low))))
+	       (values (if signed (ash -1 max) 0)
+		       (1- (ash 1 max))))
+	     (values (if signed nil 0) nil))))))
+
 (macrolet ((frob (fun)
 	     `#'(lambda (type type2)
 		  (declare (ignore type2))
@@ -344,7 +371,7 @@
     (derive-integer-type int int (frob lognot))))
 
 
-;;;; Miscellaneous derive-type optimizers:
+;;;; Array derive-type optimizers:
 
 (defoptimizer (aref derive-type) ((array &rest indices))
   (let ((type (continuation-type array)))
@@ -359,6 +386,7 @@
 	(assert-continuation-type val eltype)
 	(continuation-type val)))))
 
+
 ;;; Unsupplied-Or-NIL  --  Internal
 ;;;
 ;;;    Return true if Arg is NIL, or is a constant-continuation whose value is
@@ -395,9 +423,20 @@
 	    (t
 	     '*)))))
 
+
+;;;; Miscellaneous derive-type methods:
+
+
 (defoptimizer (code-char derive-type) ((code))
   (specifier-type 'string-char))
 
+
+(defoptimizer (values derive-type) ((&rest values))
+  (specifier-type
+   `(values ,@(mapcar #'(lambda (x)
+			  (type-specifier (continuation-type x)))
+		      values))))
+
 
 ;;;; Byte operations:
 ;;;
-- 
GitLab