From: Paul Khuong <pvk@pvk.ca>
Date: Tue, 12 Oct 2010 04:50:24 +0000 (+0000)
Subject: 1.0.43.45: More type-directed constant folding
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f2218c68ed978533fc46830ac81f4517fefe5a2a;p=sbcl.git

1.0.43.45: More type-directed constant folding

 * 1.0.30.2 introduced logic to use MEMBER-TYPEs during constant
   propagation.  This commit uses SINGLETON-TYPE-P to extend that
   logic to more types (NUMERIC and CHARACTER-SET).

 * This exposes additional constant-folding opportunities in
   src/code/bit-bash.lisp; the necessary definitions are now available
   at compile-time.
---

diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp
index ea61c32..bd25d4b 100644
--- a/src/code/bit-bash.lisp
+++ b/src/code/bit-bash.lisp
@@ -13,7 +13,8 @@
 
 ;;;; types
 
-(deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits))))
 
 ;;;; support routines
 
@@ -39,32 +40,34 @@
 ;;; at the "end" and removing bits from the "start". On big-endian
 ;;; machines this is a left-shift and on little-endian machines this
 ;;; is a right-shift.
-(defun shift-towards-start (number countoid)
-  (declare (type sb!vm:word number) (fixnum countoid))
-  (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid)))
-    (declare (type bit-offset count))
-    (if (zerop count)
-        number
-        (ecase sb!c:*backend-byte-order*
-          (:big-endian
-           (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))
-          (:little-endian
-           (ash number (- count)))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun shift-towards-start (number countoid)
+    (declare (type sb!vm:word number) (fixnum countoid))
+    (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid)))
+      (declare (type bit-offset count))
+      (if (zerop count)
+          number
+          (ecase sb!c:*backend-byte-order*
+            (:big-endian
+               (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))
+            (:little-endian
+               (ash number (- count))))))))
 
 ;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and
 ;;; removing bits from the "end". On big-endian machines this is a
 ;;; right-shift and on little-endian machines this is a left-shift.
-(defun shift-towards-end (number count)
-  (declare (type sb!vm:word number) (fixnum count))
-  (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count)))
-    (declare (type bit-offset count))
-    (if (zerop count)
-        number
-        (ecase sb!c:*backend-byte-order*
-          (:big-endian
-           (ash number (- count)))
-          (:little-endian
-           (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun shift-towards-end (number count)
+    (declare (type sb!vm:word number) (fixnum count))
+    (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count)))
+      (declare (type bit-offset count))
+      (if (zerop count)
+          number
+          (ecase sb!c:*backend-byte-order*
+            (:big-endian
+               (ash number (- count)))
+            (:little-endian
+               (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)))))))
 
 #!-sb-fluid (declaim (inline start-mask end-mask))
 
diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp
index 0a48bb4..94bf055 100644
--- a/src/code/type-class.lisp
+++ b/src/code/type-class.lisp
@@ -95,7 +95,7 @@
   ;; The default case (NIL) is interpreted as a function that always
   ;; returns NIL, NIL.
   (singleton-p nil :type (or function null))
-  
+
   #|
   Not used, and not really right. Probably we want a TYPE= alist for the
   unary operations, since there are lots of interesting unary predicates that
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 5e53ea3..96fb563 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -27,8 +27,7 @@
              (and (ref-p use) (constant-p (ref-leaf use))))
            ;; check for EQL types (but not singleton numeric types)
            (let ((type (lvar-type thing)))
-             (and (member-type-p type)
-                  (eql 1 (member-type-size type)))))))
+             (values (type-singleton-p type))))))
 
 ;;; Return the constant value for an LVAR whose only use is a constant
 ;;; node.
@@ -37,14 +36,13 @@
   (let ((use  (principal-lvar-use lvar))
         (type (lvar-type lvar))
         leaf)
-    (cond ((and (ref-p use)
-                (constant-p (setf leaf (ref-leaf use))))
-           (constant-value leaf))
-          ((and (member-type-p type)
-                (eql 1 (member-type-size type)))
-           (first (member-type-members type)))
-          (t
-           (error "~S used on non-constant LVAR ~S" 'lvar-value lvar)))))
+    (if (and (ref-p use)
+             (constant-p (setf leaf (ref-leaf use))))
+        (constant-value leaf)
+        (multiple-value-bind (constantp value) (type-singleton-p type)
+          (unless constantp
+            (error "~S used on non-constant LVAR ~S" 'lvar-value lvar))
+          value))))
 
 ;;;; interface for obtaining results of type inference
 
diff --git a/version.lisp-expr b/version.lisp-expr
index 602b4ef..c3b6308 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".)
-"1.0.43.44"
+"1.0.43.45"