Update of /cvsroot/sbcl/sbcl/src/compiler
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv21904/src/compiler
Modified Files:
ir1opt.lisp
Log Message:
1.0.30.2: more aggressive constant-folding
* Allow constant-folding on values of an EQL type.
* Fix a buggy :load-if in x86-64 float EQLs VOPs.
Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.138
retrieving revision 1.139
diff -u -d -r1.138 -r1.139
--- ir1opt.lisp 18 Jul 2009 16:58:38 -0000 1.138
+++ ir1opt.lisp 18 Jul 2009 17:44:42 -0000 1.139
@@ -23,15 +23,28 @@
(defun constant-lvar-p (thing)
(declare (type (or lvar null) thing))
(and (lvar-p thing)
- (let ((use (principal-lvar-use thing)))
- (and (ref-p use) (constant-p (ref-leaf use))))))
+ (or (let ((use (principal-lvar-use thing)))
+ (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)))))))
;;; Return the constant value for an LVAR whose only use is a constant
;;; node.
(declaim (ftype (function (lvar) t) lvar-value))
(defun lvar-value (lvar)
- (let ((use (principal-lvar-use lvar)))
- (constant-value (ref-leaf use))))
+ (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)))))
;;;; interface for obtaining results of type inference
|