From 6a8fb906ba96395f2a60f821b2ec7649a2a3ae46 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Fri, 18 Jul 2003 05:47:23 +0000 Subject: [PATCH] 0.8.1.40: * Fix optimizer of BIT-NOT; * remove explicit type check in PEEK-CHAR. --- make.sh | 10 +++++----- src/code/class.lisp | 30 ++++++++++++++---------------- src/code/stream.lisp | 13 +------------ src/compiler/array-tran.lisp | 7 ++----- src/compiler/ir1-translators.lisp | 4 ---- src/compiler/ir1opt.lisp | 18 +++++------------- tests/compiler.pure.lisp | 9 +++++++++ version.lisp-expr | 2 +- 8 files changed, 37 insertions(+), 56 deletions(-) diff --git a/make.sh b/make.sh index df101ca..32066f7 100755 --- a/make.sh +++ b/make.sh @@ -113,11 +113,11 @@ sh make-config.sh || exit 1 # Or, if you can set up the files somewhere shared (with NFS, AFS, or # whatever) between the host machine and the target machine, the basic # procedure above should still work, but you can skip the "copy" steps. -sh make-host-1.sh || exit 1 -sh make-target-1.sh || exit 1 -sh make-host-2.sh || exit 1 -sh make-target-2.sh || exit 1 -sh make-target-contrib.sh || exit 1 +time sh make-host-1.sh || exit 1 +time sh make-target-1.sh || exit 1 +time sh make-host-2.sh || exit 1 +time sh make-target-2.sh || exit 1 +time sh make-target-contrib.sh || exit 1 # Sometimes people used to see the "No tests failed." output from the last # DEFTEST in contrib self-tests and thing that's all that is. So... diff --git a/src/code/class.lisp b/src/code/class.lisp index 91fb725..5ccc7ac 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -485,19 +485,18 @@ (setf (layout-invalid layout) nil (classoid-layout classoid) layout)) - (let ((inherits (layout-inherits layout))) - (dotimes (i (length inherits)) ; FIXME: should be DOVECTOR - (let* ((super (layout-classoid (svref inherits i))) - (subclasses (or (classoid-subclasses super) - (setf (classoid-subclasses super) - (make-hash-table :test 'eq))))) - (when (and (eq (classoid-state super) :sealed) - (not (gethash classoid subclasses))) - (warn "unsealing sealed class ~S in order to subclass it" - (classoid-name super)) - (setf (classoid-state super) :read-only)) - (setf (gethash classoid subclasses) - (or destruct-layout layout)))))) + (dovector (super-layout (layout-inherits layout)) + (let* ((super (layout-classoid super-layout)) + (subclasses (or (classoid-subclasses super) + (setf (classoid-subclasses super) + (make-hash-table :test 'eq))))) + (when (and (eq (classoid-state super) :sealed) + (not (gethash classoid subclasses))) + (warn "unsealing sealed class ~S in order to subclass it" + (classoid-name super)) + (setf (classoid-state super) :read-only)) + (setf (gethash classoid subclasses) + (or destruct-layout layout))))) (values)) ); EVAL-WHEN @@ -1282,9 +1281,8 @@ (let ((inherits (layout-inherits layout)) (classoid (layout-classoid layout))) (modify-classoid classoid) - (dotimes (i (length inherits)) ; FIXME: DOVECTOR - (let* ((super (svref inherits i)) - (subs (classoid-subclasses (layout-classoid super)))) + (dovector (super inherits) + (let ((subs (classoid-subclasses (layout-classoid super)))) (when subs (remhash classoid subs))))) (values)) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index ed66194..edfc4ed 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -332,20 +332,9 @@ eof-value recursive-p) (declare (ignore recursive-p)) - ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but - ;; the compiler doesn't seem to be smart enough to go from there to - ;; imposing a type check. Figure out why (because PEEK-TYPE is an - ;; &OPTIONAL argument?) and fix it, and then this explicit type - ;; check can go away. - (unless (typep peek-type '(or character boolean)) - (error 'simple-type-error - :datum peek-type - :expected-type '(or character boolean) - :format-control "~@" - :format-arguments (list peek-type '(or character boolean)))) (let ((stream (in-synonym-of stream))) (cond ((typep stream 'echo-stream) - (echo-misc stream + (echo-misc stream :peek-char peek-type (list eof-error-p eof-value))) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index b6b7c51..8f43179 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -736,7 +736,7 @@ (make-array (length bit-array-1) :element-type 'bit))) ;; If result is T, make it the first arg. (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array) - (bit-vector bit-vector (member t)) *) + (bit-vector bit-vector (eql t)) *) `(,',fun bit-array-1 bit-array-2 bit-array-1))))) (def bit-and) (def bit-ior) @@ -756,11 +756,8 @@ '(bit-not bit-array-1 (make-array (length bit-array-1) :element-type 'bit))) (deftransform bit-not ((bit-array-1 result-bit-array) - (bit-vector (constant-arg t))) + (bit-vector (eql t))) '(bit-not bit-array-1 bit-array-1)) -;;; FIXME: What does (CONSTANT-ARG T) mean? Is it the same thing -;;; as (CONSTANT-ARG (MEMBER T)), or does it mean any constant -;;; value? ;;; Pick off some constant cases. (defoptimizer (array-header-p derive-type) ((array)) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index fd4aa84..e82b3a4 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -694,10 +694,6 @@ ;;; Assert that FORM evaluates to the specified type (which may be a ;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE. -;;; -;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101, -;;; this didn't seem to expand into an assertion, at least for ALIEN -;;; values. Check that SBCL doesn't have this problem. (def-ir1-translator the ((type value) start cont) (the-in-policy type value (lexenv-policy *lexenv*) start cont)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index f527b05..221743f 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -785,16 +785,16 @@ ;;; the NODE's CONT to be a dummy continuation to prevent the use from ;;; confusing things. ;;; -;;; Except when called during IR1 [FIXME: What does this mean? Except -;;; during IR1 conversion? What about IR1 optimization?], we delete -;;; the continuation if it has no other uses. (If it does have other -;;; uses, we reoptimize.) +;;; Except when called during IR1 convertion, we delete the +;;; continuation if it has no other uses. (If it does have other uses, +;;; we reoptimize.) ;;; ;;; Termination on the basis of a continuation type is ;;; inhibited when: ;;; -- The continuation is deleted (hence the assertion is spurious), or ;;; -- We are in IR1 conversion (where THE assertions are subject to -;;; weakening.) +;;; weakening.) FIXME: Now THE assertions are not weakened, but new +;;; uses can(?) be added later. -- APD, 2003-07-17 (defun maybe-terminate-block (node ir1-converting-not-optimizing-p) (declare (type (or basic-combination cast) node)) (let* ((block (node-block node)) @@ -847,14 +847,6 @@ ;;; ;;; We return the leaf referenced (NIL if not a leaf) and the ;;; FUN-INFO assigned. -;;; -;;; FIXME: The IR1-CONVERTING-NOT-OPTIMIZING-P argument is what the -;;; old CMU CL code called IR1-P, without explanation. My (WHN -;;; 2002-01-09) tentative understanding of it is that we can call this -;;; operation either in initial IR1 conversion or in later IR1 -;;; optimization, and it tells which is which. But it would be good -;;; for someone who really understands it to check whether this is -;;; really right. (defun recognize-known-call (call ir1-converting-not-optimizing-p) (declare (type combination call)) (let* ((ref (continuation-use (basic-combination-fun call))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 928780c..d2e81c8 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -471,3 +471,12 @@ (declare (double-float x)) (let ((y (* x pi))) (atan y y)))) + +;; bogus optimization of BIT-NOT +(multiple-value-bind (result x) + (eval '(let ((x (eval #*1001))) + (declare (optimize (speed 2) (space 3)) + (type (bit-vector) x)) + (values (bit-not x nil) x))) + (assert (equal x #*1001)) + (assert (equal result #*0110))) diff --git a/version.lisp-expr b/version.lisp-expr index 4e7038f..584d481 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".) -"0.8.1.39" +"0.8.1.40" -- 1.7.10.4