Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv32482/src/compiler
Modified Files:
fndb.lisp main.lisp srctran.lisp
Log Message:
0.8.2.29:
* Fix bug in ASSQ, reported by Paul Dietz;
* FLOAT-RADIX IGNOREs its argument as was suggested by Clemens
Heitzinger;
* fix return type declaration for FFLOOR and friends (reported
by Paul Dietz);
* SB-C::DESCRIBE-COMPONENT prints blocks in IR1 component "as
is";
* introduced "good" (transparent) modular functions;
... LOGAND and LOGIOR are :GOOD;
* on X86: transform 32BIT-LOGICAL-xxx into LOGXXX; implement
LOGXOR-MOD32; change implementation of FAST-+-MOD32: inherit
without changes from FAST-+/UNSIGNED=>UNSIGNED :-).
(On X86 SB-MD5 may be implemented without 32BIT-LOGICAL-xxx
and evil TRULY-THE.)
Index: fndb.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v
retrieving revision 1.78
retrieving revision 1.79
diff -u -d -r1.78 -r1.79
--- fndb.lisp 14 Aug 2003 17:16:11 -0000 1.78
+++ fndb.lisp 15 Aug 2003 08:21:07 -0000 1.79
@@ -336,7 +336,7 @@
(movable foldable flushable explicit-check))
(defknown (ffloor fceiling fround ftruncate)
- (real &optional real) (values float float)
+ (real &optional real) (values float real)
(movable foldable flushable explicit-check))
(defknown decode-float (float) (values float float-exponent float)
Index: main.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/main.lisp,v
retrieving revision 1.76
retrieving revision 1.77
diff -u -d -r1.76 -r1.77
--- main.lisp 13 Aug 2003 09:40:25 -0000 1.76
+++ main.lisp 15 Aug 2003 08:21:07 -0000 1.77
@@ -631,7 +631,7 @@
(defun describe-component (component *standard-output*)
(declare (type component component))
(format t "~|~%;;;; component: ~S~2%" (component-name component))
- (print-blocks component)
+ (print-all-blocks component)
(values))
(defun describe-ir2-component (component *standard-output*)
Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.72
retrieving revision 1.73
diff -u -d -r1.72 -r1.73
--- srctran.lisp 14 Aug 2003 17:16:12 -0000 1.72
+++ srctran.lisp 15 Aug 2003 08:21:07 -0000 1.73
@@ -2440,39 +2440,60 @@
(logior (logand new mask)
(logand int (lognot mask)))))
-;;; modular functions
+;;; Modular functions
+
+;;; (ldb (byte s 0) (foo x y ...)) =
+;;; (ldb (byte s 0) (foo (ldb (byte s 0) x) y ...))
;;;
-;;; -- lower N bits of a result depend only on lower N bits of
-;;; arguments.
+;;; and similar for other arguments. If
+;;;
+;;; (ldb (byte s 0) (foo x y ...)) =
+;;; (foo (ldb (byte s 0) x) (ldb (byte s 0) y) ...)
+;;;
+;;; the function FOO is :GOOD.
;;; Try to recursively cut all uses of the continuation CONT to WIDTH
;;; bits.
(defun cut-to-width (cont width)
(declare (type continuation cont) (type (integer 0) width))
- (labels ((cut-node (node)
+ (labels ((reoptimize-node (node name)
+ (setf (node-derived-type node)
+ (fun-type-returns
+ (info :function :type name)))
+ (setf (continuation-%derived-type (node-cont node)) nil)
+ (setf (node-reoptimize node) t)
+ (setf (block-reoptimize (node-block node)) t)
+ (setf (component-reoptimize (node-component node)) t))
+ (cut-node (node &aux did-something)
(when (and (combination-p node)
(fun-info-p (basic-combination-kind node)))
(let* ((fun-ref (continuation-use (combination-fun node)))
(fun-name (leaf-source-name (ref-leaf fun-ref)))
(modular-fun (find-modular-version fun-name width))
- (name (and modular-fun
+ (name (and (modular-fun-info-p modular-fun)
(modular-fun-info-name modular-fun))))
- (when modular-fun
- (change-ref-leaf fun-ref
- (find-free-fun name "in a strange place"))
- (setf (combination-kind node) :full)
- (setf (node-derived-type node)
- (fun-type-returns
- (info :function :type name)))
- (setf (continuation-%derived-type (node-cont node)) nil)
- (setf (node-reoptimize node) t)
- (setf (block-reoptimize (node-block node)) t)
- (setf (component-reoptimize (node-component node)) t)
+ (when (and modular-fun
+ (not (and (eq name 'logand)
+ (csubtypep
+ (single-value-type (node-derived-type node))
+ (specifier-type `(unsigned-byte ,width))))))
+ (unless (eq modular-fun :good)
+ (setq did-something t)
+ (change-ref-leaf
+ fun-ref
+ (find-free-fun name "in a strange place"))
+ (setf (combination-kind node) :full))
(dolist (arg (basic-combination-args node))
- (cut-continuation arg))))))
- (cut-continuation (cont)
+ (when (cut-continuation arg)
+ (setq did-something t)))
+ (when did-something
+ (reoptimize-node node fun-name))
+ did-something))))
+ (cut-continuation (cont &aux did-something)
(do-uses (node cont)
- (cut-node node))))
+ (when (cut-node node)
+ (setq did-something t)))
+ did-something))
(cut-continuation cont)))
(defoptimizer (logand optimizer) ((x y) node)
|