From c705f0cb8b1eaf60edf0066ba08406b3e7503af9 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Thu, 4 Jan 2001 05:49:10 +0000
Subject: [PATCH] o Rework the 'ash derive-type optimizer so better handle
 large negative bounds.   Based on suggestions from Raymond Toy.

---
 compiler/srctran.lisp | 121 +++++++++++++++++++++++++++---------------
 1 file changed, 77 insertions(+), 44 deletions(-)

diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index e4ea72390..e2c472711 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.103 2000/09/26 15:13:31 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.104 2001/01/04 05:49:10 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1484,58 +1484,91 @@
 ) ;end progn
 
 
+;;; 'ash derive type optimizer.
+;;;
+;;; Large resulting bounds are easy to generate but are not particularly
+;;; useful, so an open outer bound is returned for a shift greater than 64 -
+;;; the largest word size of any of the ports. Large negative shifts are also
+;;; problematic as the 'ash implementation only accepts shifts greater than
+;;; the most-negative-fixnum. These issues are handled by two local functions:
+;;;
+;;; ash-outer: performs the shift when within an acceptable range, otherwise
+;;; returns an open bound.
+;;;
+;;; ash-inner: performs the shift when within range, limited to a maximum of
+;;; 64, otherwise returns the inner limit.
+;;;
 #-propagate-fun-type
 (defoptimizer (ash derive-type) ((n shift))
-  (or (let ((n-type (continuation-type n)))
-	(when (numeric-type-p n-type)
-	  (let ((n-low (numeric-type-low n-type))
-		(n-high (numeric-type-high n-type)))
-	    (if (constant-continuation-p shift)
-		(let ((shift (continuation-value shift)))
-		  (make-numeric-type :class 'integer  :complexp :real
-				     :low (when n-low (ash n-low shift))
-				     :high (when n-high (ash n-high shift))))
-		(let ((s-type (continuation-type shift)))
-		  (when (numeric-type-p s-type)
-		    (let ((s-low (numeric-type-low s-type))
-			  (s-high (numeric-type-high s-type)))
-		      (if (and s-low s-high (<= s-low 64) (<= s-high 64))
-			  (make-numeric-type :class 'integer  :complexp :real
-					     :low (when n-low
-						    (min (ash n-low s-high)
-							 (ash n-low s-low)))
-					     :high (when n-high
-						     (max (ash n-high s-high)
-							  (ash n-high s-low))))
-			  (make-numeric-type :class 'integer
-					     :complexp :real)))))))))
-      *universal-type*))
-
+  (flet ((ash-outer (n s)
+	   (when (and (fixnump s)
+		      (<= s 64)
+		      (> s most-negative-fixnum))
+	     (ash n s)))
+	 (ash-inner (n s)
+	   (if (and (fixnump s)
+		    (> s most-negative-fixnum))
+	       (ash n (min s 64))
+	       (if (minusp n) -1 0))))
+    (or (let ((n-type (continuation-type n)))
+	  (when (numeric-type-p n-type)
+	    (let ((n-low (numeric-type-low n-type))
+		  (n-high (numeric-type-high n-type)))
+	      (if (constant-continuation-p shift)
+		  (let ((shift (continuation-value shift)))
+		    (make-numeric-type :class 'integer  :complexp :real
+				       :low (when n-low (ash n-low shift))
+				       :high (when n-high (ash n-high shift))))
+		  (let ((s-type (continuation-type shift)))
+		    (when (numeric-type-p s-type)
+		      (let ((s-low (numeric-type-low s-type))
+			    (s-high (numeric-type-high s-type)))
+			(make-numeric-type :class 'integer  :complexp :real
+					   :low (when n-low
+						  (if (minusp n-low)
+						      (ash-outer n-low s-high)
+						      (ash-inner n-low s-low)))
+					   :high (when n-high
+						   (if (minusp n-high)
+						       (ash-inner n-high s-low)
+						       (ash-outer n-high s-high)))))))))))
+	*universal-type*)))
+;;;
 #+propagate-fun-type
 (defun ash-derive-type-aux (n-type shift same-arg)
   (declare (ignore same-arg))
-  (or (and (csubtypep n-type (specifier-type 'integer))
-	   (csubtypep shift (specifier-type 'integer))
-	   (let ((n-low (numeric-type-low n-type))
-		 (n-high (numeric-type-high n-type))
-		 (s-low (numeric-type-low shift))
-		 (s-high (numeric-type-high shift)))
-	     (if (and s-low s-high (<= s-low 64) (<= s-high 64))
-		 (make-numeric-type :class 'integer  :complexp :real
-				    :low (when n-low
-					   (min (ash n-low s-high)
-						(ash n-low s-low)))
-				    :high (when n-high
-					    (max (ash n-high s-high)
-						 (ash n-high s-low))))
-		 (make-numeric-type :class 'integer
-				    :complexp :real))))
-      *universal-type*))
-
+  (flet ((ash-outer (n s)
+	   (when (and (fixnump s)
+		      (<= s 64)
+		      (> s most-negative-fixnum))
+	     (ash n s)))
+	 (ash-inner (n s)
+	   (if (and (fixnump s)
+		    (> s most-negative-fixnum))
+	       (ash n (min s 64))
+	       (if (minusp n) -1 0))))
+    (or (and (csubtypep n-type (specifier-type 'integer))
+	     (csubtypep shift (specifier-type 'integer))
+	     (let ((n-low (numeric-type-low n-type))
+		   (n-high (numeric-type-high n-type))
+		   (s-low (numeric-type-low shift))
+		   (s-high (numeric-type-high shift)))
+	       (make-numeric-type :class 'integer  :complexp :real
+				  :low (when n-low
+					 (if (minusp n-low)
+					     (ash-outer n-low s-high)
+					     (ash-inner n-low s-low)))
+				  :high (when n-high
+					  (if (minusp n-high)
+					      (ash-inner n-high s-low)
+					      (ash-outer n-high s-high))))))
+	*universal-type*)))
+;;;
 #+propagate-fun-type
 (defoptimizer (ash derive-type) ((n shift))
   (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
 
+
 #-propagate-float-type
 (macrolet ((frob (fun)
 	     `#'(lambda (type type2)
-- 
GitLab