Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7324

Modified Files:
	version.lisp-expr 
Log Message:
0.9.8.6:
        Make the count of fasl header counted strings a 32-bit value
        also on 64-bit platforms.  This ensures that a x86-64 SBCL can
        gracefully detect an error when trying to read a x86 fasl
        instead of choking on a ridiculously long counted string.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2616
retrieving revision 1.2617
diff -u -d -r1.2616 -r1.2617
--- version.lisp-expr	29 Dec 2005 22:48:01 -0000	1.2616
+++ version.lisp-expr	30 Dec 2005 00:21:40 -0000	1.2617
@@ -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.9.8.5"
+"0.9.8.6"

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7324/src/compiler

Modified Files:
	dump.lisp 
Log Message:
0.9.8.6:
        Make the count of fasl header counted strings a 32-bit value
        also on 64-bit platforms.  This ensures that a x86-64 SBCL can
        gracefully detect an error when trying to read a x86 fasl
        instead of choking on a ridiculously long counted string.


Index: dump.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/dump.lisp,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -d -r1.56 -r1.57
--- dump.lisp	21 Dec 2005 13:00:49 -0000	1.56
+++ dump.lisp	30 Dec 2005 00:21:42 -0000	1.57
@@ -113,6 +113,14 @@
     (dotimes (i sb!vm:n-word-bytes)
       (write-byte (ldb (byte 8 (* 8 i)) num) stream))))
 
+;; Dump a 32-bit integer.
+(defun dump-unsigned-byte-32 (num fasl-output)
+  (declare (type sb!vm:word num))
+  (declare (type fasl-output fasl-output))
+  (let ((stream (fasl-output-stream fasl-output)))
+    (dotimes (i 4)
+      (write-byte (ldb (byte 8 (* 8 i)) num) stream))))
+
 ;;; Dump NUM to the fasl stream, represented by N bytes. This works
 ;;; for either signed or unsigned integers. There's no range checking
 ;;; -- if you don't specify enough bytes for the number to fit, this
@@ -314,7 +322,12 @@
     ;; Finish the header by outputting fasl file implementation,
     ;; version, and key *FEATURES*.
     (flet ((dump-counted-string (string)
-             (dump-word (length string) res)
+             ;; The count is dumped as a 32-bit unsigned-byte even on 64-bit
+             ;; platforms. This ensures that a x86-64 SBCL can gracefully
+             ;; detect an error when trying to read a x86 fasl, instead
+             ;; of choking on a ridiculously long counted string.
+             ;;  -- JES, 2005-12-30
+             (dump-unsigned-byte-32 (length string) res)
              (dotimes (i (length string))
                (dump-byte (char-code (aref string i)) res))))
       (dump-counted-string (symbol-name +backend-fasl-file-implementation+))

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7324/src/code

Modified Files:
	load.lisp early-fasl.lisp 
Log Message:
0.9.8.6:
        Make the count of fasl header counted strings a 32-bit value
        also on 64-bit platforms.  This ensures that a x86-64 SBCL can
        gracefully detect an error when trying to read a x86 fasl
        instead of choking on a ridiculously long counted string.


Index: load.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/load.lisp,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- load.lisp	14 Jul 2005 16:30:36 -0000	1.38
+++ load.lisp	30 Dec 2005 00:21:42 -0000	1.39
@@ -114,6 +114,10 @@
   (declare (optimize (speed 0)))
   (read-arg #.sb!vm:n-word-bytes))
 
+(defun read-unsigned-byte-32-arg ()
+  (declare (optimize (speed 0)))
+  (read-arg 4))
+
 
 ;;;; the fop table
 
@@ -305,7 +309,7 @@
 
       ;; Read and validate version-specific compatibility stuff.
       (flet ((string-from-stream ()
-               (let* ((length (read-word-arg))
+               (let* ((length (read-unsigned-byte-32-arg))
                       (result (make-string length)))
                  (read-string-as-bytes stream result)
                  result)))

Index: early-fasl.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-fasl.lisp,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -d -r1.60 -r1.61
--- early-fasl.lisp	6 Nov 2005 08:40:31 -0000	1.60
+++ early-fasl.lisp	30 Dec 2005 00:21:42 -0000	1.61
@@ -76,7 +76,7 @@
 ;;; versions which break binary compatibility. But it certainly should
 ;;; be incremented for release versions which break binary
 ;;; compatibility.
-(def!constant +fasl-file-version+ 61)
+(def!constant +fasl-file-version+ 62)
 ;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so)
 ;;; 38: (2003-01-05) changed names of internal SORT machinery
 ;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to
@@ -128,6 +128,8 @@
 ;;; 60: (2005-10-24) Bumped for 0.9.6
 ;;; 61: (2005-11-06) Improved source location recording added extra parameters
 ;;;     to multiple %DEFMUMBLE functions.
+;;; 62: (2005-12-30) Make the count of FASL header counted strings
+;;;     a 32-bit value also on 64-bit platforms.
 
 ;;; the conventional file extension for our fasl files
 (declaim (type simple-string *fasl-file-type*))

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17056/src/runtime

Modified Files:
	bsd-os.c bsd-os.h interrupt.c 
Log Message:
0.9.8.5:
        Merge sbcl-devel "segmentation fault on recent FreeBSD-current" 
        by NIIMI Satoshi, 2005-28-12 (with minor changes).

        Add comments to document the reasoning behind a couple of
        odd constructs in the 0.9.8.3 EQUAL changes to make them
        look less like CMUCL-style black magic.


Index: bsd-os.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/bsd-os.c,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- bsd-os.c	4 Dec 2005 22:25:07 -0000	1.29
+++ bsd-os.c	29 Dec 2005 22:48:01 -0000	1.30
@@ -204,6 +204,10 @@
     SHOW("os_install_interrupt_handlers()/bsd-os/defined(GENCGC)");
     undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
                                                  memory_fault_handler);
+#ifdef SIG_MEMORY_FAULT2
+    undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT2,
+                                                 memory_fault_handler);
+#endif
     SHOW("leaving os_install_interrupt_handlers()");
 }
 
@@ -230,6 +234,10 @@
     SHOW("os_install_interrupt_handlers()/bsd-os/!defined(GENCGC)");
     undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
                                                  sigsegv_handler);
+#ifdef SIG_MEMORY_FAULT2
+    undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT2,
+                                                 sigsegv_handler);
+#endif
 }
 
 #endif /* defined GENCGC */

Index: bsd-os.h
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/bsd-os.h,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- bsd-os.h	17 Apr 2005 19:41:28 -0000	1.14
+++ bsd-os.h	29 Dec 2005 22:48:01 -0000	1.15
@@ -54,7 +54,16 @@
  * step flag bit by messing with the flags stored in a signal context,
  * so we need to implement single stepping in a more roundabout way. */
 #define CANNOT_GET_TO_SINGLE_STEP_FLAG
-#define SIG_MEMORY_FAULT SIGBUS
+#define SIG_MEMORY_FAULT SIGSEGV
+/* Sometime in late 2005 FreeBSD was changed to signal SIGSEGV instead
+ * of SIGBUS for memory faults, as required by POSIX. In order to
+ * support both new and old FreeBSD at the same time, both signals are
+ * hooked to the GC write barrier machinery. If you're reading this
+ * message in the far future where FreeBSD 6 and earlier are just
+ * quaint memories, feel free to delete this hack (and any code that's
+ * #ifdef SIG_MEMORY_FAULT2'ed). -- JES, 2005-12-30
+ */
+#define SIG_MEMORY_FAULT2 SIGBUS
 
 #elif defined __OpenBSD__
 

Index: interrupt.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/interrupt.c,v
retrieving revision 1.106
retrieving revision 1.107
diff -u -d -r1.106 -r1.107
--- interrupt.c	4 Dec 2005 22:25:07 -0000	1.106
+++ interrupt.c	29 Dec 2005 22:48:01 -0000	1.107
@@ -1140,6 +1140,9 @@
         (sigaction_nodefer_works ? SA_NODEFER : 0);
 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
     if((signal==SIG_MEMORY_FAULT)
+#ifdef SIG_MEMORY_FAULT2
+       || (signal==SIG_MEMORY_FAULT2)
+#endif
 #ifdef SIG_INTERRUPT_THREAD
        || (signal==SIG_INTERRUPT_THREAD)
 #endif

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17056/src/code

Modified Files:
	pred.lisp 
Log Message:
0.9.8.5:
        Merge sbcl-devel "segmentation fault on recent FreeBSD-current" 
        by NIIMI Satoshi, 2005-28-12 (with minor changes).

        Add comments to document the reasoning behind a couple of
        odd constructs in the 0.9.8.3 EQUAL changes to make them
        look less like CMUCL-style black magic.


Index: pred.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/pred.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- pred.lisp	28 Dec 2005 22:37:14 -0000	1.20
+++ pred.lisp	29 Dec 2005 22:48:01 -0000	1.21
@@ -216,6 +216,9 @@
   whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
   are the same length and have identical components. Other arrays must be
   EQ to be EQUAL."
+  ;; Non-tail self-recursion implemented with a local auxiliary function
+  ;; is a lot faster than doing it the straightforward way (at least
+  ;; on x86oids) due to calling convention differences. -- JES, 2005-12-30
   (labels ((equal-aux (x y)
              (cond ((%eql x y)
                     t)
@@ -231,6 +234,8 @@
                     (and (bit-vector-p y)
                          (bit-vector-= x y)))
                    (t nil))))
+    ;; Use MAYBE-INLINE to get the inline expansion only once (instead
+    ;; of 200 times with INLINE). -- JES, 2005-12-30
     (declare (maybe-inline equal-aux))
     (equal-aux x y)))

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17056

Modified Files:
	NEWS version.lisp-expr 
Log Message:
0.9.8.5:
        Merge sbcl-devel "segmentation fault on recent FreeBSD-current" 
        by NIIMI Satoshi, 2005-28-12 (with minor changes).

        Add comments to document the reasoning behind a couple of
        odd constructs in the 0.9.8.3 EQUAL changes to make them
        look less like CMUCL-style black magic.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.932
retrieving revision 1.933
diff -u -d -r1.932 -r1.933
--- NEWS	28 Dec 2005 22:37:14 -0000	1.932
+++ NEWS	29 Dec 2005 22:48:01 -0000	1.933
@@ -1,6 +1,7 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-0.9.9 relative to sbcl-0.9.8:
   * optimization: faster implementation of EQUAL
+  * fixed segfaults on x86 FreeBSD 7-current (thanks to NIIMI Satoshi)
 
 changes in sbcl-0.9.8 relative to sbcl-0.9.7:
   * minor incompatible change: (SETF CLASS-NAME) and (SETF

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2615
retrieving revision 1.2616
diff -u -d -r1.2615 -r1.2616
--- version.lisp-expr	29 Dec 2005 16:08:31 -0000	1.2615
+++ version.lisp-expr	29 Dec 2005 22:48:01 -0000	1.2616
@@ -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.9.8.4"
+"0.9.8.5"

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27243

Modified Files:
	version.lisp-expr make-genesis-2.sh make-host-1.sh 
	make-host-2.sh make-target-2.sh 
Added Files:
	make-genesis-2.lisp make-host-1.lisp make-host-2.lisp 
	make-target-2.lisp 
Log Message:
0.9.8.4:
	Beginnings of a Win32 merge.
	... rearrange the build scripts to use input from files rather
		than <<HERE documents.
	... (no other changes; just working to get the meaty changes
		isolated from the fluff)


--- NEW FILE: make-genesis-2.lisp ---
(setf *print-level* 5 *print-length* 5)
(load "src/cold/shared.lisp")
(in-package "SB-COLD")
(setf *host-obj-prefix* "obj/from-host/"
      *target-obj-prefix* "obj/from-xc/")
(load "src/cold/set-up-cold-packages.lisp")
(load "src/cold/defun-load-or-cload-xcompiler.lisp")
(load-or-cload-xcompiler #'host-load-stem)
(defparameter *target-object-file-names*
  (with-open-file (s "output/object-filenames-for-genesis.lisp-expr"
                     :direction :input)
    (read s)))
(host-load-stem "src/compiler/generic/genesis")
(sb!vm:genesis :object-file-names *target-object-file-names*
               :c-header-dir-name "output/genesis-2"
               :symbol-table-file-name "src/runtime/sbcl.nm"
               :core-file-name "output/cold-sbcl.core"
               ;; The map file is not needed by the system, but can be
               ;; very handy when debugging cold init problems.
               :map-file-name "output/cold-sbcl.map")
#+cmu (ext:quit)
#+clisp (ext:quit)
#+abcl (ext:quit)

--- NEW FILE: make-host-1.lisp ---
;;; (We want to have some limit on print length and print level during
;;; bootstrapping because PRINT-OBJECT only gets set up rather late,
;;; and running without PRINT-OBJECT it's easy to fall into printing
;;; enormous (or infinitely circular) low-level representations of
;;; things.)
(setf *print-level* 5 *print-length* 5)

(load "src/cold/shared.lisp")
(load "tools-for-build/ldso-stubs.lisp")
(in-package "SB-COLD")
(setf *host-obj-prefix* "obj/from-host/")
(load "src/cold/set-up-cold-packages.lisp")
(load "src/cold/defun-load-or-cload-xcompiler.lisp")
(load-or-cload-xcompiler #'host-cload-stem)

;;; Let's check that the type system, and various other things, are
;;; reasonably sane. (It's easy to spend a long time wandering around
;;; confused trying to debug cross-compilation if it isn't.)
(when (find :sb-test *shebang-features*)
  (load "tests/type.before-xc.lisp")
  (load "tests/info.before-xc.lisp")
  (load "tests/vm.before-xc.lisp"))
(load "tools-for-build/ucd.lisp")

;;; Generate character database tables.
(sb-cold::slurp-ucd)
(sb-cold::output)

;;; propagate structure offset and other information to the C runtime
;;; support code.
(host-cload-stem "src/compiler/generic/genesis")
(sb!vm:genesis :c-header-dir-name "src/runtime/genesis")
#+cmu (ext:quit)
#+clisp (ext:quit)
#+abcl (ext:quit)

--- NEW FILE: make-host-2.lisp ---
;;; Set up the cross-compiler.
(setf *print-level* 5 *print-length* 5)
(load "src/cold/shared.lisp")
(in-package "SB-COLD")
;;; FIXME: these prefixes look like non-pathnamy ways of defining a
;;; relative pathname.  Investigate whether they can be made relative
;;; pathnames.
(setf *host-obj-prefix* "obj/from-host/"
      *target-obj-prefix* "obj/from-xc/")
(load "src/cold/set-up-cold-packages.lisp")
(load "src/cold/defun-load-or-cload-xcompiler.lisp")
(load-or-cload-xcompiler #'host-load-stem)

(defun proclaim-target-optimization ()
  (let ((debug (if (position :sb-show *shebang-features*) 2 1)))
    (sb-xc:proclaim
     `(optimize
       (compilation-speed 1) (debug ,debug)
       ;; CLISP's pretty-printer is fragile and tends to cause stack
       ;; corruption or fail internal assertions, as of 2003-04-20; we
       ;; therefore turn off as many notes as possible.
       (sb!ext:inhibit-warnings #-clisp 2 #+clisp 3)
       ;; SAFETY = SPEED (and < 3) should provide reasonable safety,
       ;; but might skip some unreasonably expensive stuff
       ;; (e.g. %DETECT-STACK-EXHAUSTION in sbcl-0.7.2).
       (safety 2) (space 1) (speed 2)
       ;; sbcl-internal optimization declarations:
       ;;
       ;; never insert stepper conditions
       (sb!c:insert-step-conditions 0)
       ;; always stack-allocate if requested
       (sb!c::stack-allocate-dynamic-extent 3)))))
(compile 'proclaim-target-optimization)

(defun in-target-cross-compilation-mode (fun)
  "Call FUN with everything set up appropriately for cross-compiling
   a target file."
  (let (;; In order to increase microefficiency of the target Lisp,
        ;; enable old CMU CL defined-function-types-never-change
        ;; optimizations. (ANSI says users aren't supposed to
        ;; redefine our functions anyway; and developers can
        ;; fend for themselves.)
        #!-sb-fluid
        (sb!ext:*derive-function-types* t)
        ;; Let the target know that we're the cross-compiler.
        (*features* (cons :sb-xc *features*))
        ;; We need to tweak the readtable..
        (*readtable* (copy-readtable)))
    ;; ..in order to make backquotes expand into target code
    ;; instead of host code.
    ;; FIXME: Isn't this now taken care of automatically by
    ;; toplevel forms in the xcompiler backq.lisp file?
    (set-macro-character #\` #'sb!impl::backquote-macro)
    (set-macro-character #\, #'sb!impl::comma-macro)
    ;; Control optimization policy.
    (proclaim-target-optimization)
    ;; Specify where target machinery lives.
    (with-additional-nickname ("SB-XC" "SB!XC")
      (funcall fun))))
(compile 'in-target-cross-compilation-mode)

(setf *target-compile-file* #'sb-xc:compile-file)
(setf *target-assemble-file* #'sb!c:assemble-file)
(setf *in-target-compilation-mode-fn* #'in-target-cross-compilation-mode)

;;; Run the cross-compiler to produce cold fasl files.
(load "src/cold/compile-cold-sbcl.lisp")


;;; miscellaneous tidying up and saving results
(let ((filename "output/object-filenames-for-genesis.lisp-expr"))
  (ensure-directories-exist filename :verbose t)
  (with-open-file (s filename :direction :output :if-exists :supersede)
    (write *target-object-file-names* :stream s :readably t)))

;;; Let's check that the type system was reasonably sane. (It's easy
;;; to spend a long time wandering around confused trying to debug
;;; cold init if it wasn't.)
(when (position :sb-test *shebang-features*)
  (load "tests/type.after-xc.lisp"))

;;; If you're experimenting with the system under a cross-compilation
;;; host which supports CMU-CL-style SAVE-LISP, this can be a good
;;; time to run it. The resulting core isn't used in the normal build,
;;; but can be handy for experimenting with the system. (See slam.sh
;;; for an example.)
(when (position :sb-after-xc-core *shebang-features*)
  #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
  #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core")
  #+openmcl (ccl::save-application "output/after-xc.core")
  #+clisp (ext:saveinitmem "output/after-xc.core"))
#+cmu (ext:quit)
#+clisp (ext:quit)
#+abcl (ext:quit)

--- NEW FILE: make-target-2.lisp ---
;;; Now that we use the compiler for macros, interpreted /SHOW doesn't
;;; work until later in init.
#+sb-show (print "/hello, world!")

;;; Until PRINT-OBJECT and other machinery is set up, we want limits
;;; on printing to avoid infinite output.  (Don't forget to undo these
;;; tweaks after the printer is set up. It'd be cleaner to use LET to
;;; make sure that happens automatically, but LET is implemented in
;;; terms of the compiler, and the compiler isn't initialized yet.)
(setq *print-length* 10)
(setq *print-level* 5)
(setq *print-circle* t)

;;; Do warm init.
#+sb-show (print "/about to LOAD warm.lisp")
(load "src/cold/warm.lisp")

;;; Unintern no-longer-needed stuff before the possible PURIFY in
;;; SAVE-LISP-AND-DIE.
#-sb-fluid (sb-impl::!unintern-init-only-stuff)

;;; Now that the whole system is built, we don't need to hobble the
;;; printer any more, so we can restore printer control variables to
;;; their ANSI defaults.
(setq *print-length* nil)
(setq *print-level* nil)
(setq *print-circle* nil)

(sb-int:/show "done with warm.lisp, about to GC :FULL T")
(gc :full t)

;;; resetting compilation policy to neutral values in preparation for
;;; SAVE-LISP-AND-DIE as final SBCL core (not in warm.lisp because
;;; SB-C::*POLICY* has file scope)
(sb-int:/show "setting compilation policy to neutral values")
(proclaim
 '(optimize
   (compilation-speed 1) (debug 1) (inhibit-warnings 1)
   (safety 1) (space 1) (speed 1)))

;;; Lock internal packages
#+sb-package-locks
(dolist (p (list-all-packages))
  (unless (member p (mapcar #'find-package '(:keyword :cl-user)))
    (lock-package p)))

(sb-int:/show "done with warm.lisp, about to SAVE-LISP-AND-DIE")
;;; Even if /SHOW output was wanted during build, it's probably
;;; not wanted by default after build is complete. (And if it's
;;; wanted, it can easily be turned back on.)
#+sb-show (setf sb-int:*/show* nil)
;;; The system is complete now, all standard functions are
;;; defined.
(sb-kernel::ctype-of-cache-clear)
(setq sb-c::*flame-on-necessarily-undefined-function* t)
(sb-ext:save-lisp-and-die "output/sbcl.core")

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2614
retrieving revision 1.2615
diff -u -d -r1.2614 -r1.2615
--- version.lisp-expr	28 Dec 2005 22:37:14 -0000	1.2614
+++ version.lisp-expr	29 Dec 2005 16:08:31 -0000	1.2615
@@ -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.9.8.3"
+"0.9.8.4"

Index: make-genesis-2.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/make-genesis-2.sh,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- make-genesis-2.sh	16 Sep 2005 13:26:39 -0000	1.8
+++ make-genesis-2.sh	29 Dec 2005 16:08:31 -0000	1.9
@@ -30,31 +30,7 @@
 # file at that time; but we needed to run it earlier in order to 
 # get to where we can write a .core file.)
 echo //loading and running GENESIS to create cold-sbcl.core
-$SBCL_XC_HOST <<-'EOF'
-	(setf *print-level* 5 *print-length* 5)
-	(load "src/cold/shared.lisp")
-	(in-package "SB-COLD")
-	(setf *host-obj-prefix* "obj/from-host/"
-	      *target-obj-prefix* "obj/from-xc/")
-	(load "src/cold/set-up-cold-packages.lisp")
-	(load "src/cold/defun-load-or-cload-xcompiler.lisp")
-	(load-or-cload-xcompiler #'host-load-stem)
-	(defparameter *target-object-file-names*
-	  (with-open-file (s "output/object-filenames-for-genesis.lisp-expr"
-	                     :direction :input)
-	    (read s)))
-	(host-load-stem "src/compiler/generic/genesis")
-	(sb!vm:genesis :object-file-names *target-object-file-names*
-		       :c-header-dir-name "output/genesis-2"
-		       :symbol-table-file-name "src/runtime/sbcl.nm"
-		       :core-file-name "output/cold-sbcl.core"
-		       ;; The map file is not needed by the system, but can
-		       ;; be very handy when debugging cold init problems.
-		       :map-file-name "output/cold-sbcl.map")
-        #+cmu (ext:quit)
-        #+clisp (ext:quit)
-        #+abcl (ext:quit)
-	EOF
+$SBCL_XC_HOST < make-genesis-2.lisp
 
 echo //testing for consistency of first and second GENESIS passes
 if diff -r src/runtime/genesis output/genesis-2; then

Index: make-host-1.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/make-host-1.sh,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -d -r1.15 -r1.16
--- make-host-1.sh	16 Sep 2005 13:26:39 -0000	1.15
+++ make-host-1.sh	29 Dec 2005 16:08:31 -0000	1.16
@@ -28,33 +28,4 @@
 # header file sbcl.h which will be needed to create the C runtime
 # environment.
 echo //building cross-compiler, and doing first genesis
-$SBCL_XC_HOST <<-'EOF' || exit 1
-	;; (We want to have some limit on print length and print level
-	;; during bootstrapping because PRINT-OBJECT only gets set
-	;; up rather late, and running without PRINT-OBJECT it's easy
-	;; to fall into printing enormous (or infinitely circular)
-	;; low-level representations of things.)
-	(setf *print-level* 5 *print-length* 5)
-	(load "src/cold/shared.lisp")
-	(load "tools-for-build/ldso-stubs.lisp")
-	(in-package "SB-COLD")
-	(setf *host-obj-prefix* "obj/from-host/")
-	(load "src/cold/set-up-cold-packages.lisp")
-	(load "src/cold/defun-load-or-cload-xcompiler.lisp")
-	(load-or-cload-xcompiler #'host-cload-stem)
-        ;; Let's check that the type system is reasonably sane. (It's
-	;; easy to spend a long time wandering around confused trying
-	;; to debug cross-compilation if it isn't.)
-	(when (find :sb-test *shebang-features*)
-	  (load "tests/type.before-xc.lisp")
-	  (load "tests/info.before-xc.lisp")
-	  (load "tests/vm.before-xc.lisp"))
-        (load "tools-for-build/ucd.lisp")
-        (sb-cold::slurp-ucd)
-        (sb-cold::output)
-        (host-cload-stem "src/compiler/generic/genesis")
-	(sb!vm:genesis :c-header-dir-name "src/runtime/genesis")
-        #+cmu (ext:quit)
-        #+clisp (ext:quit)
-        #+abcl (ext:quit)
-	EOF
+$SBCL_XC_HOST < make-host-1.lisp || exit 1

Index: make-host-2.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/make-host-2.sh,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -d -r1.28 -r1.29
--- make-host-2.sh	16 Sep 2005 13:26:39 -0000	1.28
+++ make-host-2.sh	29 Dec 2005 16:08:31 -0000	1.29
@@ -45,101 +45,7 @@
 # the fasl files into the new host Lisp, and that doesn't seem to be
 # an enormously important disadvantage, either.)
 echo //running cross-compiler to create target object files
-$SBCL_XC_HOST <<-'EOF'
-
-        ;;;
-        ;;; Set up the cross-compiler.
-        ;;;
-	(setf *print-level* 5 *print-length* 5)
-	(load "src/cold/shared.lisp")
-	(in-package "SB-COLD")
-	(setf *host-obj-prefix* "obj/from-host/"
-	      *target-obj-prefix* "obj/from-xc/")
-	(load "src/cold/set-up-cold-packages.lisp")
-	(load "src/cold/defun-load-or-cload-xcompiler.lisp")
-	(load-or-cload-xcompiler #'host-load-stem)
-        (defun proclaim-target-optimization ()
-          (let ((debug (if (position :sb-show *shebang-features*) 2 1)))
-	    (sb-xc:proclaim 
-             `(optimize
-	       (compilation-speed 1)
-	       (debug ,debug)
-	       ;; CLISP's pretty-printer is fragile and tends to cause
-	       ;; stack corruption or fail internal assertions, as of
-	       ;; 2003-04-20; we therefore turn off as many notes as
-	       ;; possible.
-	       (sb!ext:inhibit-warnings #-clisp 2
-		                        #+clisp 3)
-	       ;; SAFETY = SPEED (and < 3) should provide reasonable
-	       ;; safety, but might skip some unreasonably expensive
-	       ;; stuff (e.g. %DETECT-STACK-EXHAUSTION in sbcl-0.7.2).
-	       (safety 2)
-	       (space 1)
-	       (speed 2)
-               (sb!c:insert-step-conditions 0)
-               (sb!c::stack-allocate-dynamic-extent 3)))))
-        (compile 'proclaim-target-optimization)
-	(defun in-target-cross-compilation-mode (fun)
-	  "Call FUN with everything set up appropriately for cross-compiling
-	  a target file."
-	  (let (;; In order to increase microefficiency of the target Lisp, 
-		;; enable old CMU CL defined-function-types-never-change
-		;; optimizations. (ANSI says users aren't supposed to
-		;; redefine our functions anyway; and developers can
-		;; fend for themselves.)
-		#!-sb-fluid (sb!ext:*derive-function-types* t)
-		;; Let the target know that we're the cross-compiler.
-		(*features* (cons :sb-xc *features*))
-		;; We need to tweak the readtable..
-		(*readtable* (copy-readtable)))
-            ;; ..in order to make backquotes expand into target code
-            ;; instead of host code.
-            ;; FIXME: Isn't this now taken care of automatically by
-            ;; toplevel forms in the xcompiler backq.lisp file?
-            (set-macro-character #\` #'sb!impl::backquote-macro)
-            (set-macro-character #\, #'sb!impl::comma-macro)
-	    ;; Control optimization policy.
-            (proclaim-target-optimization)
-            ;; Specify where target machinery lives.
-            (with-additional-nickname ("SB-XC" "SB!XC")
-              (funcall fun))))
-	(compile 'in-target-cross-compilation-mode)
-	(setf *target-compile-file* #'sb-xc:compile-file)
-	(setf *target-assemble-file* #'sb!c:assemble-file)
-	(setf *in-target-compilation-mode-fn*
-	      #'in-target-cross-compilation-mode)
-
-        ;;;
-        ;;; Run the cross-compiler to produce cold fasl files.
-        ;;;
-	(load "src/cold/compile-cold-sbcl.lisp")
- 
-        ;;; 
-        ;;; miscellaneous tidying up and saving results
-        ;;; 
-	(let ((filename "output/object-filenames-for-genesis.lisp-expr"))
-	  (ensure-directories-exist filename :verbose t)
-	  (with-open-file (s filename :direction :output :if-exists :supersede)
-	    (write *target-object-file-names* :stream s :readably t)))
-        ;; Let's check that the type system was reasonably sane. (It's
-	;; easy to spend a long time wandering around confused trying
-	;; to debug cold init if it wasn't.)
-	(when (position :sb-test *shebang-features*)
-	  (load "tests/type.after-xc.lisp"))
-	;; If you're experimenting with the system under a
-        ;; cross-compilation host which supports CMU-CL-style SAVE-LISP,
-        ;; this can be a good time to run it. The resulting core isn't
-	;; used in the normal build, but can be handy for experimenting
-	;; with the system. (See slam.sh for an example.)
-	(when (position :sb-after-xc-core *shebang-features*)
-          #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
-          #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core")
-          #+openmcl (ccl::save-application "output/after-xc.core")
-          #+clisp (ext:saveinitmem "output/after-xc.core"))
-        #+cmu (ext:quit)
-        #+clisp (ext:quit)
-        #+abcl (ext:quit)
-	EOF
+$SBCL_XC_HOST < make-host-2.lisp
 
 # Run GENESIS (again) in order to create cold-sbcl.core. (The first
 # time was before we ran the cross-compiler, in order to create the

Index: make-target-2.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/make-target-2.sh,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- make-target-2.sh	13 Oct 2005 00:01:36 -0000	1.26
+++ make-target-2.sh	29 Dec 2005 16:08:31 -0000	1.27
@@ -32,69 +32,4 @@
 echo //doing warm init
 ./src/runtime/sbcl \
 --core output/cold-sbcl.core \
---sysinit /dev/null --userinit /dev/null <<-'EOF'
-	;; Now that we use the compiler for macros, interpreted
-	;; /SHOW doesn't work until later in init.
-        #+sb-show (print "/hello, world!")
-
-        ;; Until PRINT-OBJECT and other machinery is set up,
-	;; we want limits on printing to avoid infinite output.
-	;; (Don't forget to undo these tweaks after the printer
-	;; is set up. It'd be cleaner to use LET to make sure 
-	;; that happens automatically, but LET is implemented
-	;; in terms of the compiler, and the compiler isn't 
-        ;; initialized yet.)
-        (setq *print-length* 10)
-	(setq *print-level* 5)
-        (setq *print-circle* t)
-
-        ;; Do warm init.
-        #+sb-show (print "/about to LOAD warm.lisp")
-	(load "src/cold/warm.lisp")
-
-        ;; Unintern no-longer-needed stuff before the possible PURIFY
-        ;; in SAVE-LISP-AND-DIE.
-        #-sb-fluid (sb-impl::!unintern-init-only-stuff)
-
-        ;; Now that the whole system is built, we don't need to 
-        ;; hobble the printer any more, so we can restore printer 
-	;; control variables to their ANSI defaults.
-        (setq *print-length* nil)
-	(setq *print-level* nil)
-        (setq *print-circle* nil)
-
-	;; FIXME: Why is it that, at least on x86 sbcl-0.6.12.46,
-	;; GC :FULL T isn't nearly as effective as PURIFY here?
-	;; (GC :FULL T gets us down to about 38 Mbytes, but PURIFY
-	;; gets us down to about 19 Mbytes.)
-	(sb-int:/show "done with warm.lisp, about to GC :FULL T")
-	(gc :full t)
-
-        ;; resetting compilation policy to neutral values in
-        ;; preparation for SAVE-LISP-AND-DIE as final SBCL core (not
-        ;; in warm.lisp because SB-C::*POLICY* has file scope)
-        (sb-int:/show "setting compilation policy to neutral values")
-        (proclaim '(optimize (compilation-speed 1)
-		             (debug 1)
-		             (inhibit-warnings 1)
-		             (safety 1)
-		             (space 1)
-		             (speed 1)))
-
-        ;; Lock internal packages
-        #+sb-package-locks
-        (dolist (p (list-all-packages))
-          (unless (member p (mapcar #'find-package '(:keyword :cl-user)))
-             (lock-package p)))
-
-        (sb-int:/show "done with warm.lisp, about to SAVE-LISP-AND-DIE")
-	;; Even if /SHOW output was wanted during build, it's probably
-	;; not wanted by default after build is complete. (And if it's
-	;; wanted, it can easily be turned back on.)
-	#+sb-show (setf sb-int:*/show* nil)
-        ;; The system is complete now, all standard functions are
-        ;; defined.
-        (sb-kernel::ctype-of-cache-clear)
-        (setq sb-c::*flame-on-necessarily-undefined-function* t)
-	(sb-ext:save-lisp-and-die "output/sbcl.core")
-	EOF
+--sysinit /dev/null --userinit /dev/null < make-target-2.lisp

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15181/src/code

Modified Files:
	numbers.lisp pred.lisp 
Log Message:
0.9.8.3:
	Make EQUAL faster (about 50% improvement for short lists on x86-64).
        As amazing as it might seem, there are actually real-world 
        applications where significant time is spent in EQUAL.
        
        * Inline EQL in EQUAL
        * Rearrange things a bit to enable the inlining
        * Rewrite EQUAL to use a local helper function


Index: numbers.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/numbers.lisp,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -d -r1.47 -r1.48
--- numbers.lisp	2 Oct 2005 00:32:00 -0000	1.47
+++ numbers.lisp	28 Dec 2005 22:37:14 -0000	1.48
@@ -969,39 +969,6 @@
     ((complex (or float rational))
      (and (= (realpart x) y)
           (zerop (imagpart x))))))
-
-(defun eql (obj1 obj2)
-  #!+sb-doc
-  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
-  (or (eq obj1 obj2)
-      (if (or (typep obj2 'fixnum)
-              (not (typep obj2 'number)))
-          nil
-          (macrolet ((foo (&rest stuff)
-                       `(typecase obj2
-                          ,@(mapcar (lambda (foo)
-                                      (let ((type (car foo))
-                                            (fn (cadr foo)))
-                                        `(,type
-                                          (and (typep obj1 ',type)
-                                               (,fn obj1 obj2)))))
-                                    stuff))))
-            (foo
-              (single-float eql)
-              (double-float eql)
-              #!+long-float
-              (long-float eql)
-              (bignum
-               (lambda (x y)
-                 (zerop (bignum-compare x y))))
-              (ratio
-               (lambda (x y)
-                 (and (eql (numerator x) (numerator y))
-                      (eql (denominator x) (denominator y)))))
-              (complex
-               (lambda (x y)
-                 (and (eql (realpart x) (realpart y))
-                      (eql (imagpart x) (imagpart y))))))))))
 
 ;;;; logicals
 

Index: pred.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/pred.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- pred.lisp	9 Sep 2005 14:16:18 -0000	1.19
+++ pred.lisp	28 Dec 2005 22:37:14 -0000	1.20
@@ -160,6 +160,43 @@
   "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
   (eq obj1 obj2))
 
+(declaim (inline %eql))
+(defun %eql (obj1 obj2)
+  #!+sb-doc
+  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
+  (or (eq obj1 obj2)
+      (if (or (typep obj2 'fixnum)
+              (not (typep obj2 'number)))
+          nil
+          (macrolet ((foo (&rest stuff)
+                       `(typecase obj2
+                          ,@(mapcar (lambda (foo)
+                                      (let ((type (car foo))
+                                            (fn (cadr foo)))
+                                        `(,type
+                                          (and (typep obj1 ',type)
+                                               (,fn obj1 obj2)))))
+                                    stuff))))
+            (foo
+             (single-float eql)
+             (double-float eql)
+             #!+long-float
+             (long-float eql)
+             (bignum
+              (lambda (x y)
+                (zerop (bignum-compare x y))))
+             (ratio
+              (lambda (x y)
+                (and (eql (numerator x) (numerator y))
+                     (eql (denominator x) (denominator y)))))
+             (complex
+              (lambda (x y)
+                (and (eql (realpart x) (realpart y))
+                     (eql (imagpart x) (imagpart y))))))))))
+
+(defun eql (x y)
+  (%eql x y))
+
 (defun bit-vector-= (x y)
   (declare (type bit-vector x y))
   (if (and (simple-bit-vector-p x)
@@ -179,19 +216,23 @@
   whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
   are the same length and have identical components. Other arrays must be
   EQ to be EQUAL."
-  (cond ((eql x y) t)
-        ((consp x)
-         (and (consp y)
-              (equal (car x) (car y))
-              (equal (cdr x) (cdr y))))
-        ((stringp x)
-         (and (stringp y) (string= x y)))
-        ((pathnamep x)
-         (and (pathnamep y) (pathname= x y)))
-        ((bit-vector-p x)
-         (and (bit-vector-p y)
-              (bit-vector-= x y)))
-        (t nil)))
+  (labels ((equal-aux (x y)
+             (cond ((%eql x y)
+                    t)
+                   ((consp x)
+                    (and (consp y)
+                         (equal-aux (car x) (car y))
+                         (equal-aux (cdr x) (cdr y))))
+                   ((stringp x)
+                    (and (stringp y) (string= x y)))
+                   ((pathnamep x)
+                    (and (pathnamep y) (pathname= x y)))
+                   ((bit-vector-p x)
+                    (and (bit-vector-p y)
+                         (bit-vector-= x y)))
+                   (t nil))))
+    (declare (maybe-inline equal-aux))
+    (equal-aux x y)))
 
 ;;; EQUALP comparison of HASH-TABLE values
 (defun hash-table-equalp (x y)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15181

Modified Files:
	NEWS package-data-list.lisp-expr version.lisp-expr 
Log Message:
0.9.8.3:
	Make EQUAL faster (about 50% improvement for short lists on x86-64).
        As amazing as it might seem, there are actually real-world 
        applications where significant time is spent in EQUAL.
        
        * Inline EQL in EQUAL
        * Rearrange things a bit to enable the inlining
        * Rewrite EQUAL to use a local helper function


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.931
retrieving revision 1.932
diff -u -d -r1.931 -r1.932
--- NEWS	19 Dec 2005 10:49:33 -0000	1.931
+++ NEWS	28 Dec 2005 22:37:14 -0000	1.932
@@ -1,4 +1,7 @@
 ;;;; -*- coding: utf-8; -*-
+changes in sbcl-0.9.9 relative to sbcl-0.9.8:
+  * optimization: faster implementation of EQUAL
+
 changes in sbcl-0.9.8 relative to sbcl-0.9.7:
   * minor incompatible change: (SETF CLASS-NAME) and (SETF
     GENERIC-FUNCTION-NAME) are generic functions once more (reverting

Index: package-data-list.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/package-data-list.lisp-expr,v
retrieving revision 1.341
retrieving revision 1.342
diff -u -d -r1.341 -r1.342
--- package-data-list.lisp-expr	16 Dec 2005 15:06:09 -0000	1.341
+++ package-data-list.lisp-expr	28 Dec 2005 22:37:14 -0000	1.342
@@ -1114,7 +1114,7 @@
                "%CHECK-BOUND" "%CHECK-VECTOR-SEQUENCE-BOUNDS"
                "%CLOSURE-FUN" "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK"
                "%COSH" "%DATA-VECTOR-AND-INDEX" "%DEPOSIT-FIELD"
-               "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1" "%FIND-POSITION"
+               "%DOUBLE-FLOAT" "%DPB" "%EQL" "%EXP" "%EXPM1" "%FIND-POSITION"
                "%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF"
                "%FIND-POSITION-IF-VECTOR-MACRO" "%FIND-POSITION-IF-NOT"
                "%FIND-POSITION-IF-NOT-VECTOR-MACRO" "%FUN-DOC"

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2613
retrieving revision 1.2614
diff -u -d -r1.2613 -r1.2614
--- version.lisp-expr	28 Dec 2005 13:56:23 -0000	1.2613
+++ version.lisp-expr	28 Dec 2005 22:37:14 -0000	1.2614
@@ -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.9.8.2"
+"0.9.8.3"

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10124/src/compiler

Modified Files:
	constraint.lisp node.lisp srctran.lisp 
Log Message:
0.9.8.2: constraint propagation
  * add (EQL LAMBDA-VAR LAMBDA-VAR) constraints on BIND and CSET
  * add cast and test constraints to all eql lambda vars
  * calculate the intersection of two lambda-var types when
    encountering (IF (EQL X Y) ...) and neither X or Y is a subtype of
    the other
  * there is now only one invocation of FIND-AND-PROPAGATE-CONSTRAINTS
  * since GEN depends on IN there is no COMPUTE-BLOCK-OUT shortcut
    anymore, a full FIND-CONSTRAINTS-IN-BLOCK is done
  * for blocks whose constraints won't be recalculated after the
    prepass (see LEADING-COMPONENT-BLOCKS) do what
    USE-RESULT-CONSTRAINTS would do is done on the prepass to save
    time
  * support test constraint propagation for blocks with with multiple
    predecessors


Index: constraint.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/constraint.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- constraint.lisp	17 Dec 2005 22:38:18 -0000	1.26
+++ constraint.lisp	28 Dec 2005 13:56:23 -0000	1.27
@@ -37,14 +37,9 @@
 ;;; In this case CP cannot even infer that I is of class INTEGER.
 ;;;
 ;;; -- In the above example if we place the check after SETQ, CP will
-;;; fail to infer (< I FIXNUM): is does not understand that this
+;;; fail to infer (< I FIXNUM): it does not understand that this
 ;;; constraint follows from (TYPEP I (INTEGER 0 0)).
 
-;;; BUGS:
-;;;
-;;; -- this code does not check whether SET appears between REF and a
-;;; test (bug 233b)
-
 (in-package "SB!C")
 
 (deftype constraint-y () '(or ctype lvar lambda-var constant))
@@ -75,6 +70,7 @@
   (not-p nil :type boolean))
 
 (defvar *constraint-number*)
+(declaim (type (integer 0) *constraint-number*))
 
 (defun find-constraint (kind x y not-p)
   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
@@ -130,31 +126,54 @@
 (defun ok-lvar-lambda-var (lvar constraints)
   (declare (type lvar lvar))
   (let ((use (lvar-uses lvar)))
-    (when (ref-p use)
-      (let ((lambda-var (ok-ref-lambda-var use)))
-        (when lambda-var
-          (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
-            (when (and constraint (sset-member constraint constraints))
-              lambda-var)))))))
+    (cond ((ref-p use)
+           (let ((lambda-var (ok-ref-lambda-var use)))
+             (when lambda-var
+               (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
+                 (when (and constraint (sset-member constraint constraints))
+                   lambda-var)))))
+          ((cast-p use)
+           (ok-lvar-lambda-var (cast-value use) constraints)))))
+
+(defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
+  (once-only ((var var))
+    `(let ((,symbol ,var))
+       (flet ((body-fun ()
+                ,@body))
+         (body-fun)
+         (do-sset-elements (con ,constraints ,result)
+           (let ((other (and (eq (constraint-kind con) 'eql)
+                             (eq (constraint-not-p con) nil)
+                             (cond ((eq ,var (constraint-x con))
+                                    (constraint-y con))
+                                   ((eq ,var (constraint-y con))
+                                    (constraint-x con))
+                                   (t
+                                    nil)))))
+             (when other
+               (setq ,symbol other)
+               (when (lambda-var-p ,symbol)
+                 (body-fun)))))))))
 
 ;;;; Searching constraints
 
-;;; Add the indicated test constraint to BLOCK, marking the block as
-;;; having a new assertion when the constriant was not already
-;;; present. We don't add the constraint if the block has multiple
-;;; predecessors, since it only holds on this particular path.
-(defun add-test-constraint (block fun x y not-p)
-  (unless (rest (block-pred block))
-    (let ((con (find-or-create-constraint fun x y not-p))
-          (old (or (block-test-constraint block)
-                   (setf (block-test-constraint block) (make-sset)))))
-      (when (sset-adjoin con old)
-        (setf (block-type-asserted block) t))))
+;;; Add the indicated test constraint to BLOCK. We don't add the
+;;; constraint if the block has multiple predecessors, since it only
+;;; holds on this particular path.
+(defun add-test-constraint (fun x y not-p constraints target)
+  (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
+         (add-eql-var-var-constraint x y constraints target))
+        (t
+         (do-eql-vars (x (x constraints))
+           (let ((con (find-or-create-constraint fun x y not-p)))
+             (sset-adjoin con target)))))
   (values))
 
 ;;; Add complementary constraints to the consequent and alternative
 ;;; blocks of IF. We do nothing if X is NIL.
-(defun add-complement-constraints (if fun x y not-p)
+(defun add-complement-constraints (if fun x y not-p constraints
+                                      consequent-constraints
+                                      alternative-constraints)
   (when (and x
              ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
              ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means
@@ -162,84 +181,68 @@
              ;; done, so we still need to avoid barfing on this case.
              (not (eq (if-consequent if)
                       (if-alternative if))))
-    (add-test-constraint (if-consequent if) fun x y not-p)
-    (add-test-constraint (if-alternative if) fun x y (not not-p)))
+    (add-test-constraint fun x y not-p constraints
+                         consequent-constraints)
+    (add-test-constraint fun x y (not not-p) constraints
+                         alternative-constraints))
   (values))
 
 ;;; Add test constraints to the consequent and alternative blocks of
 ;;; the test represented by USE.
 (defun add-test-constraints (use if constraints)
   (declare (type node use) (type cif if))
-  (typecase use
-    (ref
-     (add-complement-constraints if 'typep (ok-lvar-lambda-var (ref-lvar use)
-                                                               constraints)
-                                 (specifier-type 'null) t))
-    (combination
-     (unless (eq (combination-kind use)
-                 :error)
-       (let ((name (lvar-fun-name
-                    (basic-combination-fun use)))
-             (args (basic-combination-args use)))
-         (case name
-           ((%typep %instance-typep)
-            (let ((type (second args)))
-              (when (constant-lvar-p type)
-                (let ((val (lvar-value type)))
-                  (add-complement-constraints if 'typep
-                                              (ok-lvar-lambda-var (first args)
-                                                                  constraints)
-                                              (if (ctype-p val)
-                                                  val
-                                                  (specifier-type val))
-                                              nil)))))
-           ((eq eql)
-            (let* ((var1 (ok-lvar-lambda-var (first args) constraints))
-                   (arg2 (second args))
-                   (var2 (ok-lvar-lambda-var arg2 constraints)))
-              (cond ((not var1))
-                    (var2
-                     (add-complement-constraints if 'eql var1 var2 nil))
-                    ((constant-lvar-p arg2)
-                     (add-complement-constraints if 'eql var1
-                                                 (ref-leaf
-                                                  (principal-lvar-use arg2))
-                                                 nil)))))
-           ((< >)
-            (let* ((arg1 (first args))
-                   (var1 (ok-lvar-lambda-var arg1 constraints))
-                   (arg2 (second args))
-                   (var2 (ok-lvar-lambda-var arg2 constraints)))
-              (when var1
-                (add-complement-constraints if name var1 (lvar-type arg2)
-                                            nil))
-              (when var2
-                (add-complement-constraints if (if (eq name '<) '> '<)
-                                            var2 (lvar-type arg1)
-                                            nil))))
-           (t
-            (let ((ptype (gethash name *backend-predicate-types*)))
-              (when ptype
-                (add-complement-constraints if 'typep
-                                            (ok-lvar-lambda-var (first args)
-                                                                constraints)
-                                            ptype nil)))))))))
-  (values))
-
-;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to
-;;; the condition it tests.
-(defun find-test-constraints (block)
-  (declare (type cblock block))
-  (let ((last (block-last block)))
-    (when (if-p last)
-      (let ((use (lvar-uses (if-test last))))
-        (when (node-p use)
-          ;; BLOCK-OUT contains the (EQL LAMBDA-VAR LVAR)
-          ;; constraints valid at the end of the block. Since the
-          ;; IF node is last node in its block, it can be used to
-          ;; check LVAR LAMBDA-VAR equality.
-          (add-test-constraints use last (block-out block))))))
-  (values))
+  (let ((consequent-constraints (make-sset))
+        (alternative-constraints (make-sset)))
+    (macrolet ((add (fun x y not-p)
+                 `(add-complement-constraints if ,fun ,x ,y ,not-p
+                   constraints
+                   consequent-constraints
+                   alternative-constraints)))
+      (typecase use
+        (ref
+         (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
+              (specifier-type 'null) t))
+        (combination
+         (unless (eq (combination-kind use)
+                     :error)
+           (let ((name (lvar-fun-name
+                        (basic-combination-fun use)))
+                 (args (basic-combination-args use)))
+             (case name
+               ((%typep %instance-typep)
+                (let ((type (second args)))
+                  (when (constant-lvar-p type)
+                    (let ((val (lvar-value type)))
+                      (add 'typep (ok-lvar-lambda-var (first args) constraints)
+                           (if (ctype-p val)
+                               val
+                               (specifier-type val))
+                           nil)))))
+               ((eq eql)
+                (let* ((var1 (ok-lvar-lambda-var (first args) constraints))
+                       (arg2 (second args))
+                       (var2 (ok-lvar-lambda-var arg2 constraints)))
+                  (cond ((not var1))
+                        (var2
+                         (add 'eql var1 var2 nil))
+                        ((constant-lvar-p arg2)
+                         (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
+                              nil)))))
+               ((< >)
+                (let* ((arg1 (first args))
+                       (var1 (ok-lvar-lambda-var arg1 constraints))
+                       (arg2 (second args))
+                       (var2 (ok-lvar-lambda-var arg2 constraints)))
+                  (when var1
+                    (add name var1 (lvar-type arg2) nil))
+                  (when var2
+                    (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
+               (t
+                (let ((ptype (gethash name *backend-predicate-types*)))
+                  (when ptype
+                    (add 'typep (ok-lvar-lambda-var (first args) constraints)
+                         ptype nil))))))))))
+    (values consequent-constraints alternative-constraints)))
 
 ;;;; Applying constraints
 
@@ -367,26 +370,29 @@
                                 (member-type-p other-type))
                        (setq not-res (type-union not-res other-type)))
                      (let ((leaf-type (leaf-type leaf)))
-                       (when (or (constant-p other)
-                                 (and (leaf-refs other) ; protect from
-                                                        ; deleted vars
-                                      (csubtypep other-type leaf-type)
-                                      (not (type= other-type leaf-type))))
-                         (change-ref-leaf ref other)
-                         (when (constant-p other) (return))))))))
+                       (cond
+                         ((or (constant-p other)
+                              (and (leaf-refs other) ; protect from
+                                        ; deleted vars
+                                   (csubtypep other-type leaf-type)
+                                   (not (type= other-type leaf-type))))
+                          (change-ref-leaf ref other)
+                          (when (constant-p other) (return)))
+                         (t
+                          (setq res (type-approx-intersection2
+                                     res other-type)))))))))
             ((< >)
-             (cond ((and (integer-type-p res) (integer-type-p y))
-                    (let ((greater (eq kind '>)))
-                      (let ((greater (if not-p (not greater) greater)))
-                        (setq res
-                              (constrain-integer-type res y greater not-p)))))
-                   ((and (float-type-p res) (float-type-p y))
-                    (let ((greater (eq kind '>)))
-                      (let ((greater (if not-p (not greater) greater)))
-                        (setq res
-                              (constrain-float-type res y greater not-p)))))
-                   )))))
-
+             (cond
+               ((and (integer-type-p res) (integer-type-p y))
+                (let ((greater (eq kind '>)))
+                  (let ((greater (if not-p (not greater) greater)))
+                    (setq res
+                          (constrain-integer-type res y greater not-p)))))
+               ((and (float-type-p res) (float-type-p y))
+                (let ((greater (eq kind '>)))
+                  (let ((greater (if not-p (not greater) greater)))
+                    (setq res
+                          (constrain-float-type res y greater not-p))))))))))
       (cond ((and (if-p (node-dest ref))
                   (csubtypep (specifier-type 'null) not-res))
              (setf (node-derived-type ref) *wild-type*)
@@ -402,23 +408,64 @@
 
 ;;;; Flow analysis
 
+(defun maybe-add-eql-var-lvar-constraint (ref gen)
+  (let ((lvar (ref-lvar ref))
+        (leaf (ref-leaf ref)))
+    (when (and (lambda-var-p leaf) lvar)
+      (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
+                   gen))))
+
+;;; Copy all CONSTRAINTS involving FROM-VAR to VAR except the (EQL VAR
+;;; LVAR) ones.
+(defun inherit-constraints (var from-var constraints target)
+  (do-sset-elements (con constraints)
+    (let ((eq-x (eq from-var (constraint-x con)))
+          (eq-y (eq from-var (constraint-y con))))
+      ;; Constant substitution is controversial.
+      (unless (constant-p (constraint-y con))
+        (when (or (and eq-x (not (lvar-p (constraint-y con))))
+                  eq-y)
+          (sset-adjoin (find-or-create-constraint
+                        (constraint-kind con)
+                        (if eq-x var (constraint-x con))
+                        (if eq-y var (constraint-y con))
+                        (constraint-not-p con))
+                       target))))))
+
+;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
+;; inherit each other's constraints.
+(defun add-eql-var-var-constraint (var1 var2 constraints
+                                   &optional (target constraints))
+  (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
+    (when (sset-adjoin con target)
+      (do-eql-vars (var2 (var2 constraints))
+        (inherit-constraints var1 var2 constraints target))
+      (do-eql-vars (var1 (var1 constraints))
+        (inherit-constraints var1 var2 constraints target))
+      t)))
+
+;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
+;; LAMBDA-VAR if possible.
+(defun maybe-add-eql-var-var-constraint (var lvar constraints
+                                         &optional (target constraints))
+  (declare (type lambda-var var) (type lvar lvar))
+  (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
+    (when lambda-var
+      (add-eql-var-var-constraint var lambda-var constraints target))))
+
 ;;; Local propagation
 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
 ;;;    constraint.]
 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
 ;;;    a type constraint based on the new value type.
 (declaim (ftype (function (cblock sset
-                           &key (:ref-preprocessor function)
-                                (:set-preprocessor function))
+                           &key (:ref-preprocessor (or null function))
+                                (:set-preprocessor (or null function)))
                           sset)
                 constraint-propagate-in-block))
 (defun constraint-propagate-in-block
     (block gen &key ref-preprocessor set-preprocessor)
 
-  (let ((test (block-test-constraint block)))
-    (when test
-      (sset-union gen test)))
-
   (do-nodes (node lvar block)
     (typecase node
       (bind
@@ -427,27 +474,25 @@
            (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
                  for var in (lambda-vars fun)
                  and val in (combination-args call)
-                 when (and val
-                           (lambda-var-constraints var)
-                           ;; if VAR has no SETs, type inference is
-                           ;; fully performed by IR1 optimizer
-                           (lambda-var-sets var))
+                 when (and val (lambda-var-constraints var))
                  do (let* ((type (lvar-type val))
                            (con (find-or-create-constraint 'typep var type
                                                            nil)))
-                      (sset-adjoin con gen))))))
+                      (sset-adjoin con gen))
+                 (maybe-add-eql-var-var-constraint var val gen)))))
       (ref
        (when (ok-ref-lambda-var node)
-         (maybe-add-eql-constraint-for-lvar node gen)
+         (maybe-add-eql-var-lvar-constraint node gen)
          (when ref-preprocessor
            (funcall ref-preprocessor node gen))))
       (cast
        (let ((lvar (cast-value node)))
          (let ((var (ok-lvar-lambda-var lvar gen)))
-             (when var
-               (let* ((atype (single-value-type (cast-derived-type node))) ; FIXME
-                      (con (find-or-create-constraint 'typep var atype nil)))
-                 (sset-adjoin con gen))))))
+           (when var
+             (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
+               (do-eql-vars (var (var gen))
+                 (let ((con (find-or-create-constraint 'typep var atype nil)))
+                   (sset-adjoin con gen))))))))
       (cset
        (binding* ((var (set-var node))
                   (nil (lambda-var-p var) :exit-if-null)
@@ -457,119 +502,78 @@
          (sset-difference gen cons)
          (let* ((type (single-value-type (node-derived-type node)))
                 (con (find-or-create-constraint 'typep var type nil)))
-           (sset-adjoin con gen))))))
+           (sset-adjoin con gen))
+         (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
 
   gen)
 
-;;; BLOCK-KILL is just a list of the LAMBDA-VARs killed, so we must
-;;; compute the kill set when there are any vars killed. We bum this a
-;;; bit by special-casing when only one var is killed, and just using
-;;; that var's constraints as the kill set. This set could possibly be
-;;; precomputed, but it would have to be invalidated whenever any
-;;; constraint is added, which would be a pain.
-(defun compute-block-out (block)
-  (declare (type cblock block))
-  (let ((in (block-in block))
-        (kill (block-kill block))
-        (out (copy-sset (block-gen block))))
-    (cond ((null kill)
-           (sset-union out in))
-          ((null (rest kill))
-           (let ((con (lambda-var-constraints (first kill))))
-             (if con
-                 (sset-union-of-difference out in con)
-                 (sset-union out in))))
-          (t
-           (let ((kill-set (make-sset)))
-             (dolist (var kill)
-               (let ((con (lambda-var-constraints var)))
-                 (when con
-                   (sset-union kill-set con))))
-             (sset-union-of-difference out in kill-set))))
-    out))
+(defun constraint-propagate-if (block gen)
+  (let ((node (block-last block)))
+    (when (if-p node)
+      (let ((use (lvar-uses (if-test node))))
+        (when (node-p use)
+          (add-test-constraints use node gen))))))
 
-;; Add a (EQL LAMBDA-VAR LVAR) constraint, but only for LVAR's with a
-;; DEST that's an IF or a test for an IF.
-(defun maybe-add-eql-constraint-for-lvar (ref gen)
-  (let ((lvar (ref-lvar ref))
-        (leaf (ref-leaf ref)))
-    (when (and (lambda-var-p leaf) lvar
-               ;; This test avoids generating constraints for an LVAR
-               ;; for which EQLness to its referenced LAMBDA-VAR is
-               ;; not important because OK-LVAR-LAMBDA-VAR won't need
-               ;; it.
-               (or (cast-p (lvar-dest lvar))
-                   (if-p (lvar-dest lvar))
-                   (and (valued-node-p (lvar-dest lvar))
-                        (let ((lvar2 (node-lvar (lvar-dest lvar))))
-                          (when lvar2
-                            (if-p (lvar-dest lvar2)))))))
-      (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
-                   gen))))
+(defun constrain-node (node cons)
+  (let* ((var (ref-leaf node))
+         (con (lambda-var-constraints var)))
+    (constrain-ref-type node con cons)))
 
-;;; Compute the initial flow analysis sets for BLOCK:
-;;; -- Compute IN/OUT sets; if OUT of a predecessor is not yet
-;;;    computed, assume it to be a universal set (this is only
-;;;    possible in a loop)
-;;;
-;;; Return T if we have found a loop.
-(defun find-block-type-constraints (block)
+;;; Starting from IN compute OUT and (consequent/alternative
+;;; constraints if the block ends with and IF). Return the list of
+;;; successors that may need to be recomputed.
+(defun find-block-type-constraints (block &key final-pass-p)
   (declare (type cblock block))
-  (collect ((kill nil adjoin))
-    (let ((gen (constraint-propagate-in-block
-                block (make-sset)
-                :set-preprocessor (lambda (var)
-                                    (kill var)))))
-      (setf (block-gen block) gen)
-      (setf (block-kill block) (kill))
-      (setf (block-type-asserted block) nil)
-      (let* ((n (block-number block))
-             (pred (block-pred block))
-             (in nil)
-             (loop-p nil))
-        (dolist (b pred)
-          (cond ((> (block-number b) n)
-                 (if in
-                     (sset-intersection in (block-out b))
-                     (setq in (copy-sset (block-out b)))))
-                (t (setq loop-p t))))
-        (unless in
-          (bug "Unreachable code is found or flow graph is not ~
-                properly depth-first ordered."))
-        (setf (block-in block) in)
-        (setf (block-out block) (compute-block-out block))
-        loop-p))))
-
-;;; BLOCK-IN becomes the intersection of the OUT of the predecessors.
-;;; Our OUT is:
-;;;     gen U (in - kill)
-;;;
-;;; Return True if we have done something.
-(defun flow-propagate-constraints (block)
-  (let* ((pred (block-pred block))
-         (in (progn (aver pred)
-                    (let ((res (copy-sset (block-out (first pred)))))
-                      (dolist (b (rest pred))
-                        (sset-intersection res (block-out b)))
-                      res))))
-    (setf (block-in block) in)
-    (let ((out (compute-block-out block)))
-      (if (sset= out (block-out block))
-          nil
-          (setf (block-out block) out)))))
+  (let ((gen (constraint-propagate-in-block
+              block
+              (if final-pass-p
+                  (block-in block)
+                  (copy-sset (block-in block)))
+              :ref-preprocessor (if final-pass-p #'constrain-node nil))))
+    (setf (block-gen block) gen)
+    (multiple-value-bind (consequent-constraints alternative-constraints)
+        (constraint-propagate-if block gen)
+      (if consequent-constraints
+          (let* ((node (block-last block))
+                 (old-consequent-constraints (if-consequent-constraints node))
+                 (old-alternative-constraints (if-alternative-constraints node))
+                 (succ ()))
+            ;; Add the consequent and alternative constraints to GEN.
+            (cond ((sset-empty consequent-constraints)
+                   (setf (if-consequent-constraints node) gen)
+                   (setf (if-alternative-constraints node) gen))
+                  (t
+                   (setf (if-consequent-constraints node) (copy-sset gen))
+                   (sset-union (if-consequent-constraints node)
+                               consequent-constraints)
+                   (setf (if-alternative-constraints node) gen)
+                   (sset-union (if-alternative-constraints node)
+                               alternative-constraints)))
+            ;; Has the consequent been changed?
+            (unless (and old-consequent-constraints
+                         (sset= (if-consequent-constraints node)
+                                old-consequent-constraints))
+              (push (if-consequent node) succ))
+            ;; Has the alternative been changed?
+            (unless (and old-alternative-constraints
+                         (sset= (if-alternative-constraints node)
+                                old-alternative-constraints))
+              (push (if-alternative node) succ))
+            succ)
+          ;; There is no IF.
+          (unless (and (block-out block)
+                       (sset= gen (block-out block)))
+            (setf (block-out block) gen)
+            (block-succ block))))))
 
 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
 ;;; During this pass, we also do local constraint propagation by
-;;; adding in constraints as we seem them during the pass through the
+;;; adding in constraints as we see them during the pass through the
 ;;; block.
 (defun use-result-constraints (block)
   (declare (type cblock block))
-  (constraint-propagate-in-block
-   block (block-in block)
-   :ref-preprocessor (lambda (node cons)
-                       (let* ((var (ref-leaf node))
-                              (con (lambda-var-constraints var)))
-                         (constrain-ref-type node con cons)))))
+  (constraint-propagate-in-block block (block-in block)
+                                 :ref-preprocessor #'constrain-node))
 
 ;;; Give an empty constraints set to any var that doesn't have one and
 ;;; isn't a set closure var. Since a var that we previously rejected
@@ -588,32 +592,113 @@
       (dolist (let (lambda-lets fun))
         (frob let)))))
 
-;;; How many blocks does COMPONENT have?
-(defun component-n-blocks (component)
-  (let ((result 0))
-    (declare (type index result))
-    (do-blocks (block component :both)
-      (incf result))
-    result))
+;;; Return the constraints that flow from PRED to SUCC. This is
+;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
+;;; added.
+(defun block-out-for-successor (pred succ)
+  (declare (type cblock pred succ))
+  (let ((last (block-last pred)))
+    (or (when (if-p last)
+          (cond ((eq succ (if-consequent last))
+                 (if-consequent-constraints last))
+                ((eq succ (if-alternative last))
+                 (if-alternative-constraints last))))
+        (block-out pred))))
+
+(defun compute-block-in (block)
+  (let ((in nil))
+    (dolist (pred (block-pred block))
+      ;; If OUT has not been calculated, assume it to be the universal
+      ;; set.
+      (let ((out (block-out-for-successor pred block)))
+        (when out
+          (if in
+              (sset-intersection in out)
+              (setq in (copy-sset out))))))
+    (or in (make-sset))))
+
+(defun update-block-in (block)
+  (let ((in (compute-block-in block)))
+    (cond ((and (block-in block) (sset= in (block-in block)))
+           nil)
+          (t
+           (setf (block-in block) in)))))
+
+;;; Return two lists: one of blocks that precede all loops and
+;;; therefore require only one constraint propagation pass and the
+;;; rest. This implementation does not find all such blocks.
+;;;
+;;; A more complete implementation would be:
+;;;
+;;;     (do-blocks (block component)
+;;;       (if (every #'(lambda (pred)
+;;;                      (or (member pred leading-blocks)
+;;;                          (eq pred head)))
+;;;                  (block-pred block))
+;;;           (push block leading-blocks)
+;;;           (push block rest-of-blocks)))
+;;;
+;;; Trailing blocks that succeed all loops could be found and handled
+;;; similarly. In practice though, these more complex solutions are
+;;; slightly worse performancewise.
+(defun leading-component-blocks (component)
+  (declare (type component component))
+  (flet ((loopy-p (block)
+           (let ((n (block-number block)))
+             (dolist (pred (block-pred block))
+               (unless (< n (block-number pred))
+                 (return t))))))
+    (let ((leading-blocks ())
+          (rest-of-blocks ())
+          (seen-loop-p ()))
+      (do-blocks (block component)
+        (when (and (not seen-loop-p) (loopy-p block))
+          (setq seen-loop-p t))
+        (if seen-loop-p
+            (push block rest-of-blocks)
+            (push block leading-blocks)))
+      (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
+
+;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
+;;; a member already.
+(defun nconc-new (obj list)
+  (do ((x list (cdr x))
+       (prev nil x))
+      ((endp x) (if prev
+                    (progn
+                      (setf (cdr prev) (list obj))
+                      list)
+                    (list obj)))
+    (when (eql (car x) obj)
+      (return-from nconc-new list))))
 
 (defun find-and-propagate-constraints (component)
-  (let ((loop-p nil))
-    (do-blocks (block component)
-      (when (find-block-type-constraints block)
-        (setq loop-p t)))
-    (when loop-p
-      ;; If we have to propagate changes more than this many times,
-      ;; something is wrong.
-      (let ((max-n-changes-remaining (component-n-blocks component)))
-        (declare (type fixnum max-n-changes-remaining))
-        (loop (aver (>= max-n-changes-remaining 0))
-              (decf max-n-changes-remaining)
-              (let ((did-something nil))
-                (do-blocks (block component)
-                  (when (flow-propagate-constraints block)
-                    (setq did-something t)))
-                (unless did-something
-                  (return))))))))
+  (let ((blocks-to-process ()))
+    (flet ((enqueue (blocks)
+             (dolist (block blocks)
+               (setq blocks-to-process (nconc-new block blocks-to-process)))))
+      (multiple-value-bind (leading-blocks rest-of-blocks)
+          (leading-component-blocks component)
+        ;; Update every block once to account for changes in the
+        ;; IR1. The constraints of the lead blocks cannot be changed
+        ;; after the first pass so we might as well use them and skip
+        ;; USE-RESULT-CONSTRAINTS later.
+        (dolist (block leading-blocks)
+          (setf (block-in block) (compute-block-in block))
+          (find-block-type-constraints block :final-pass-p t))
+        (setq blocks-to-process (copy-list rest-of-blocks))
+        ;; The rest of the blocks.
+        (dolist (block rest-of-blocks)
+          (aver (eq block (pop blocks-to-process)))
+          (setf (block-in block) (compute-block-in block))
+          (enqueue (find-block-type-constraints block)))
+        ;; Propagate constraints
+        (loop for block = (pop blocks-to-process)
+              while block do
+              (unless (eq block (component-tail component))
+                (when (update-block-in block)
+                  (enqueue (find-block-type-constraints block)))))
+        rest-of-blocks))))
 
 (defun constraint-propagate (component)
   (declare (type component component))
@@ -622,16 +707,7 @@
   (unless (block-out (component-head component))
     (setf (block-out (component-head component)) (make-sset)))
 
-  (find-and-propagate-constraints component)
-
-  (do-blocks (block component)
-    (when (block-test-modified block)
-      (find-test-constraints block)
-      (setf (block-test-modified block) nil)))
-
-  (find-and-propagate-constraints component)
-
-  (do-blocks (block component)
+  (dolist (block (find-and-propagate-constraints component))
     (unless (block-delete-p block)
       (use-result-constraints block)))
 

Index: node.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -d -r1.63 -r1.64
--- node.lisp	14 Jul 2005 18:57:01 -0000	1.63
+++ node.lisp	28 Dec 2005 13:56:23 -0000	1.64
@@ -246,10 +246,7 @@
   ;; entire initial component just to clear the flags.
   (flag nil)
   ;; some kind of info used by the back end
-  (info nil)
-  ;; constraints that hold in this block and its successors by merit
-  ;; of being tested by its IF predecessors.
-  (test-constraint nil :type (or sset null)))
+  (info nil))
 (def!method print-object ((cblock cblock) stream)
   (print-unreadable-object (cblock stream :type t :identity t)
     (format stream "~W :START c~W"
@@ -1143,7 +1140,9 @@
   ;; the blocks that we execute next in true and false case,
   ;; respectively (may be the same)
   (consequent (missing-arg) :type cblock)
-  (alternative (missing-arg) :type cblock))
+  (consequent-constraints nil :type (or null sset))
+  (alternative (missing-arg) :type cblock)
+  (alternative-constraints nil :type (or null sset)))
 (defprinter (cif :conc-name if- :identity t)
   (test :prin1 (lvar-uses test))
   consequent

Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.136
retrieving revision 1.137
diff -u -d -r1.136 -r1.137
--- srctran.lisp	19 Aug 2005 21:18:47 -0000	1.136
+++ srctran.lisp	28 Dec 2005 13:56:23 -0000	1.137
@@ -301,7 +301,7 @@
            (if (and (floatp y)
                     (float-infinity-p y))
                nil
-               (set-bound (funcall f (type-bound-number x)) (consp x)))))))
+               (set-bound y (consp x)))))))
 
 ;;; Apply a binary operator OP to two bounds X and Y. The result is
 ;;; NIL if either is NIL. Otherwise bound is computed and the result

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10124

Modified Files:
	version.lisp-expr 
Log Message:
0.9.8.2: constraint propagation
  * add (EQL LAMBDA-VAR LAMBDA-VAR) constraints on BIND and CSET
  * add cast and test constraints to all eql lambda vars
  * calculate the intersection of two lambda-var types when
    encountering (IF (EQL X Y) ...) and neither X or Y is a subtype of
    the other
  * there is now only one invocation of FIND-AND-PROPAGATE-CONSTRAINTS
  * since GEN depends on IN there is no COMPUTE-BLOCK-OUT shortcut
    anymore, a full FIND-CONSTRAINTS-IN-BLOCK is done
  * for blocks whose constraints won't be recalculated after the
    prepass (see LEADING-COMPONENT-BLOCKS) do what
    USE-RESULT-CONSTRAINTS would do is done on the prepass to save
    time
  * support test constraint propagation for blocks with with multiple
    predecessors


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2612
retrieving revision 1.2613
diff -u -d -r1.2612 -r1.2613
--- version.lisp-expr	28 Dec 2005 12:39:12 -0000	1.2612
+++ version.lisp-expr	28 Dec 2005 13:56:23 -0000	1.2613
@@ -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.9.8.1"
+"0.9.8.2"

Update of /cvsroot/sbcl/sbcl-page
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8206

Modified Files:
	index-page.lisp 
Log Message:
0.9.8 release update to the web page


Index: index-page.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl-page/index-page.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- index-page.lisp	28 Nov 2005 22:47:28 -0000	1.14
+++ index-page.lisp	28 Dec 2005 13:44:09 -0000	1.15
@@ -1,6 +1,6 @@
 (define-page :index "About SBCL" "index" index-page :index-order :top)
 
-(defparameter *most-recent-release* (list "0.9.7" "November 28, 2005"))
+(defparameter *most-recent-release* (list "0.9.8" "December 27, 2005"))
 
 (defun index-page ()

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24532/src/runtime

Modified Files:
	monitor.c 
Log Message:
0.9.8.1:
        Make LDB quit on a ^D from a TTY instead of just ignoring the EOF.
        
        * More consistent with the normal REPL
        * The old behaviour would occasionally cause an infinite loop
          of printing the LDB prompt, trying to read input, finding that
          the tty was closed, printing the prompt again, etc.


Index: monitor.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/monitor.c,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -d -r1.33 -r1.34
--- monitor.c	27 Oct 2005 21:22:42 -0000	1.33
+++ monitor.c	28 Dec 2005 12:39:13 -0000	1.34
@@ -453,14 +453,7 @@
         fflush(stdout);
         line = fgets(buf, sizeof(buf), ldb_in);
         if (line == NULL) {
-            if (isatty(ldb_in_fd)) {
-                putchar('\n');
-                continue;
-            }
-            else {
-                fprintf(stderr, "\nEOF on something other than a tty.\n");
-                exit(0);
-            }
+            exit(1);
         }
         ptr = line;
         if ((token = parse_token(&ptr)) == NULL)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24532

Modified Files:
	version.lisp-expr 
Log Message:
0.9.8.1:
        Make LDB quit on a ^D from a TTY instead of just ignoring the EOF.
        
        * More consistent with the normal REPL
        * The old behaviour would occasionally cause an infinite loop
          of printing the LDB prompt, trying to read input, finding that
          the tty was closed, printing the prompt again, etc.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2611
retrieving revision 1.2612
diff -u -d -r1.2611 -r1.2612
--- version.lisp-expr	27 Dec 2005 17:18:54 -0000	1.2611
+++ version.lisp-expr	28 Dec 2005 12:39:12 -0000	1.2612
@@ -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.9.8"
+"0.9.8.1"

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29133

Modified Files:
	version.lisp-expr 
Log Message:
0.9.8: 
	release, tagged as sbcl_0_9_8


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2610
retrieving revision 1.2611
diff -u -d -r1.2610 -r1.2611
--- version.lisp-expr	22 Dec 2005 10:10:47 -0000	1.2610
+++ version.lisp-expr	27 Dec 2005 17:18:54 -0000	1.2611
@@ -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.9.7.35"
+"0.9.8"

Update of /cvsroot/sbcl/sbcl/doc/manual
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1402/doc/manual

Modified Files:
	compiler.texinfo pathnames.texinfo 
Log Message:
0.9.7.35:
	Document the "SYS" logical host, as required by ANSI.


Index: compiler.texinfo
===================================================================
RCS file: /cvsroot/sbcl/sbcl/doc/manual/compiler.texinfo,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- compiler.texinfo	17 Feb 2005 14:30:40 -0000	1.12
+++ compiler.texinfo	22 Dec 2005 10:10:47 -0000	1.13
@@ -125,7 +125,7 @@
 @comment  node-name,  next,  previous,  up
 @subsection Diagnostic Severity
 @cindex Severity of compiler messages
-@... compiler diagnostic severity
+@cindex Compiler Diagnostic Severity
 @tindex error
 @tindex warning
 @tindex style-warning
@@ -389,7 +389,7 @@
 @node The Processing Path
 @comment  node-name,  next,  previous,  up
 @subsubsection The Processing Path
-@... Processing path
+@cindex Processing Path
 @cindex Macroexpansion
 @cindex Source-to-source transformation
 
@@ -1016,8 +1016,8 @@
 @comment  node-name,  next,  previous,  up
 @section Open Coding and Inline Expansion
 @cindex Open-coding
-@... inline expansion
-@... static functions
+@cindex Inline expansion
+@cindex Static functions
 
 Since Common Lisp forbids the redefinition of standard functions, the
 compiler can have special knowledge of these standard functions

Index: pathnames.texinfo
===================================================================
RCS file: /cvsroot/sbcl/sbcl/doc/manual/pathnames.texinfo,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- pathnames.texinfo	16 Dec 2005 15:06:12 -0000	1.1
+++ pathnames.texinfo	22 Dec 2005 10:10:47 -0000	1.2
@@ -2,6 +2,8 @@
 @comment  node-name,  next,  previous,  up
 @chapter Pathnames
 
+@cindex Pathnames
+
 @menu
 * Lisp Pathnames::
 * Native Filenames::
@@ -67,10 +69,24 @@
 @c
 @c * Other symbols and integers have implementation-defined meaning.
 @c   (19.2.2.4.6)
-@...
+
+@subsection The SYS Logical Pathname Host
+
+@cindex Logical pathnames
+@cindex Pathnames, logical
+@findex logical-pathname-translations
+@findex (setf logical-pathname-translations)
+
 @c * The existence and meaning of SYS: logical pathnames is
 @c   implementation-defined.  (19.3.1.1.1)
 
+The logical pathname host named by @code{"SYS"} exists in SBCL.  Its
+@code{logical-pathname-translations} may be set by the site or the user
+applicable to point to the locations of the system's sources; in
+particular, the core system's source files match the logical pathname
+@code{"SYS:SRC;**;*.*.*"}, and the contributed modules' source files
+match @code{"SYS:CONTRIB;**;*.*.*"}.
+
 @node Native Filenames
 @comment  node-name,  next,  previous,  up
 @section Native Filenames

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1402

Modified Files:
	version.lisp-expr 
Log Message:
0.9.7.35:
	Document the "SYS" logical host, as required by ANSI.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2609
retrieving revision 1.2610
diff -u -d -r1.2609 -r1.2610
--- version.lisp-expr	21 Dec 2005 13:00:49 -0000	1.2609
+++ version.lisp-expr	22 Dec 2005 10:10:47 -0000	1.2610
@@ -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.9.7.34"
+"0.9.7.35"

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18539/src/compiler

Modified Files:
	dump.lisp 
Log Message:
0.9.7.34:
        * New bug.


Index: dump.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/dump.lisp,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -d -r1.55 -r1.56
--- dump.lisp	14 Jul 2005 18:52:38 -0000	1.55
+++ dump.lisp	21 Dec 2005 13:00:49 -0000	1.56
@@ -925,7 +925,7 @@
   (let ((code (sb!xc:char-code char)))
     (cond
       ((< code 256)
-  (dump-fop 'fop-short-character file)
+       (dump-fop 'fop-short-character file)
        (dump-byte code file))
       (t
        (dump-fop 'fop-character file)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18539

Modified Files:
	BUGS version.lisp-expr 
Log Message:
0.9.7.34:
        * New bug.


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.483
retrieving revision 1.484
diff -u -d -r1.483 -r1.484
--- BUGS	17 Dec 2005 22:38:17 -0000	1.483
+++ BUGS	21 Dec 2005 13:00:49 -0000	1.484
@@ -2100,3 +2100,15 @@
      instead errors.
 
      (reported on sbcl-help by "tichy")
+
+396: block-compilation bug
+    (let ((x 1))
+      (dotimes (y 10)
+        (let ((y y))
+          (when (funcall (eval #'(lambda (x) (eql x 2))) y)
+            (defun foo (z)
+              (incf x (incf y z))))))
+      (defun bar (z)
+        (foo z)
+        (values x)))
+  (bar 1) => 11, should be 4.

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2608
retrieving revision 1.2609
diff -u -d -r1.2608 -r1.2609
--- version.lisp-expr	19 Dec 2005 10:49:33 -0000	1.2608
+++ version.lisp-expr	21 Dec 2005 13:00:49 -0000	1.2609
@@ -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.9.7.33"
+"0.9.7.34"

Update of /cvsroot/sbcl/sbcl/doc/manual
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18539/doc/manual

Modified Files:
	ffi.texinfo 
Log Message:
0.9.7.34:
        * New bug.


Index: ffi.texinfo
===================================================================
RCS file: /cvsroot/sbcl/sbcl/doc/manual/ffi.texinfo,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- ffi.texinfo	11 Oct 2005 20:21:16 -0000	1.12
+++ ffi.texinfo	21 Dec 2005 13:00:49 -0000	1.13
@@ -359,7 +359,7 @@
 value.
 @end defun
 
-@... sb-alien:slot @var{struct-or-union} &rest @var{slot-names}
+@defun sb-alien:slot @var{struct-or-union} @var{slot-name}
 @findex slot
 
 The @code{sb-alien:slot} function extracts the value of the slot named

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18539/src/code

Modified Files:
	foreign-load.lisp 
Log Message:
0.9.7.34:
        * New bug.


Index: foreign-load.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/foreign-load.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- foreign-load.lisp	14 Jul 2005 16:30:34 -0000	1.13
+++ foreign-load.lisp	21 Dec 2005 13:00:49 -0000	1.14
@@ -88,7 +88,7 @@
 expected if user or library-code has called dlopen on FILE.
 
 References to foreign symbols in loaded shared objects do not survive
-intact through SB-EXT:SAVE-LISP-AND die on all platforms. See
+intact through SB-EXT:SAVE-LISP-AND-DIE on all platforms. See
 SB-EXT:SAVE-LISP-AND-DIE for details."
   (sb!thread:with-mutex (*foreign-lock*)
     (let* ((filename (or (unix-namestring file) file))

Update of /cvsroot/sbcl/sbcl-page
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30950

Modified Files:
	links-page.lisp 
Log Message:
I do as Xophe commands. (add manual and internals manual links to the links page)


Index: links-page.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl-page/links-page.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- links-page.lisp	29 Mar 2005 03:01:41 -0000	1.2
+++ links-page.lisp	20 Dec 2005 16:28:42 -0000	1.3
@@ -14,6 +14,8 @@
      ,(format-links
        ("http://sourceforge.net/projects/sbcl" "SBCL's SourceForge
 page" "file downloads, mailing lists, and other resources")
+       ("/manual/" "The SBCL Manual" "a fine manual")
+       ("/sbcl-internals/" "The SBCL Internals Manual" "describes SBCL's implementation details")
        ("http://sbcl-internals.cliki.net/" "The SBCL Internals CLiki" "a wiki describing SBCL's implementation")
        ("http://planet.sbcl.org/" "Planet SBCL" "a meta-blog of blogs of SBCL developers, SBCL CVS activity, and SBCL test results")
        ("http://sbcl.unmutual.info/" "SBCL Daily Tests" "SBCL daily builds and tests, used by the SBCL developers for regression testing")

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6595

Modified Files:
	NEWS version.lisp-expr 
Log Message:
0.9.7.33:
	Merge patch (Daisuke Homma sbcl-devel 2005-12-19) for stack
	exhaustion on x86/SunOS.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.930
retrieving revision 1.931
diff -u -d -r1.930 -r1.931
--- NEWS	17 Dec 2005 22:38:18 -0000	1.930
+++ NEWS	19 Dec 2005 10:49:33 -0000	1.931
@@ -5,6 +5,8 @@
     the change in the 0.9.7 release).  (SETF CLASS-NAME) is specified
     by ANSI as a generic function, and for consistency (SETF
     GENERIC-FUNCTION-NAME) is treated likewise.
+  * fixed bug #233.b: make constraint propagation notice when a variable
+    value is changed after it is referenced but before it is used
   * fixed bug #296: no more arbitrary behaviour from filenames with
     odd characters as --load arguments.  (reported by Adam Warner)
   * fixed bug #390: :CHARACTER-SET pathname components now work as
@@ -18,12 +20,12 @@
   * bug fix: the SB-SIMPLE-STREAMS contrib passes external-format
     arguments to the internal stream functions.  (thanks to David
     Lichteblau)
+  * bug fix: stack exhaustion is now handled on the x86/SunOS
+    platform.  (thanks to Daisuke Homma)
+  * bug fix: more accurate ROOM results on GENCGC platforms
   * optimization: improved type inference for arithmetic-for
     index variables in LOOP
   * optimization: faster floating-point SQRT on x86-64
-  * bug fix: more accurate ROOM results on GENCGC platforms
-  * fixed bug #233.b: make constraint propagation notice when a variable
-    value is changed after it is referenced but before it is used
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** DOCUMENTATION returns NIL instead of "" for method combinations
        that don't have a docstring

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2607
retrieving revision 1.2608
diff -u -d -r1.2607 -r1.2608
--- version.lisp-expr	17 Dec 2005 22:38:18 -0000	1.2607
+++ version.lisp-expr	19 Dec 2005 10:49:33 -0000	1.2608
@@ -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.9.7.32"
+"0.9.7.33"

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6595/src/runtime

Modified Files:
	x86-sunos-os.c 
Log Message:
0.9.7.33:
	Merge patch (Daisuke Homma sbcl-devel 2005-12-19) for stack
	exhaustion on x86/SunOS.


Index: x86-sunos-os.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/x86-sunos-os.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- x86-sunos-os.c	19 Aug 2005 12:15:16 -0000	1.1
+++ x86-sunos-os.c	19 Dec 2005 10:49:33 -0000	1.2
@@ -43,12 +43,13 @@
 os_context_register_t   *
 os_context_register_addr(os_context_t *context, int offset)
 {
+    /* Solaris x86 holds %esp value in UESP */
     switch(offset) {
     case reg_EAX: return &context->uc_mcontext.gregs[11];
     case reg_ECX: return &context->uc_mcontext.gregs[10];
     case reg_EDX: return &context->uc_mcontext.gregs[9];
     case reg_EBX: return &context->uc_mcontext.gregs[8];
-    case reg_ESP: return &context->uc_mcontext.gregs[7];
+    case reg_ESP: return &context->uc_mcontext.gregs[17]; /* REG_UESP */
     case reg_EBP: return &context->uc_mcontext.gregs[6];
     case reg_ESI: return &context->uc_mcontext.gregs[5];
     case reg_EDI: return &context->uc_mcontext.gregs[4];

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13446/src/compiler

Modified Files:
	constraint.lisp 
Log Message:
0.9.6.32:
  * added support for (EQL LAMBDA-VAR LVAR) constraints
  * fixed bug #233.b by paying attention to said constraints


Index: constraint.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/constraint.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- constraint.lisp	14 Jul 2005 18:52:37 -0000	1.25
+++ constraint.lisp	17 Dec 2005 22:38:18 -0000	1.26
@@ -47,6 +47,8 @@
 
 (in-package "SB!C")
 
+(deftype constraint-y () '(or ctype lvar lambda-var constant))
+
 (defstruct (constraint
             (:include sset-element)
             (:constructor make-constraint (number kind x y not-p))
@@ -62,48 +64,51 @@
   ;;     between X and some object of type Y.
   ;;
   ;; EQL
-  ;;     X is a LAMBDA-VAR Y is a LAMBDA-VAR or a CONSTANT. The
-  ;;     relation is asserted to hold.
+  ;;     X is a LAMBDA-VAR and Y is a LVAR, a LAMBDA-VAR or a CONSTANT.
+  ;;     The relation is asserted to hold.
   (kind nil :type (member typep < > eql))
   ;; The operands to the relation.
   (x nil :type lambda-var)
-  (y nil :type (or ctype lambda-var constant))
+  (y nil :type constraint-y)
   ;; If true, negates the sense of the constraint, so the relation
   ;; does *not* hold.
   (not-p nil :type boolean))
 
 (defvar *constraint-number*)
 
+(defun find-constraint (kind x y not-p)
+  (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
+  (etypecase y
+    (ctype
+     (do-sset-elements (con (lambda-var-constraints x) nil)
+       (when (and (eq (constraint-kind con) kind)
+                  (eq (constraint-not-p con) not-p)
+                  (type= (constraint-y con) y))
+         (return con))))
+    ((or lvar constant)
+     (do-sset-elements (con (lambda-var-constraints x) nil)
+       (when (and (eq (constraint-kind con) kind)
+                  (eq (constraint-not-p con) not-p)
+                  (eq (constraint-y con) y))
+         (return con))))
+    (lambda-var
+     (do-sset-elements (con (lambda-var-constraints x) nil)
+       (when (and (eq (constraint-kind con) kind)
+                  (eq (constraint-not-p con) not-p)
+                  (let ((cx (constraint-x con)))
+                    (eq (if (eq cx x)
+                            (constraint-y con)
+                            cx)
+                        y)))
+         (return con))))))
+
 ;;; Return a constraint for the specified arguments. We only create a
 ;;; new constraint if there isn't already an equivalent old one,
 ;;; guaranteeing that all equivalent constraints are EQ. This
 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
-(defun find-constraint (kind x y not-p)
-  (declare (type lambda-var x) (type (or constant lambda-var ctype) y)
-           (type boolean not-p))
-  (or (etypecase y
-        (ctype
-         (do-sset-elements (con (lambda-var-constraints x) nil)
-           (when (and (eq (constraint-kind con) kind)
-                      (eq (constraint-not-p con) not-p)
-                      (type= (constraint-y con) y))
-             (return con))))
-        (constant
-         (do-sset-elements (con (lambda-var-constraints x) nil)
-           (when (and (eq (constraint-kind con) kind)
-                      (eq (constraint-not-p con) not-p)
-                      (eq (constraint-y con) y))
-             (return con))))
-        (lambda-var
-         (do-sset-elements (con (lambda-var-constraints x) nil)
-           (when (and (eq (constraint-kind con) kind)
-                      (eq (constraint-not-p con) not-p)
-                      (let ((cx (constraint-x con)))
-                        (eq (if (eq cx x)
-                                (constraint-y con)
-                                cx)
-                            y)))
-             (return con)))))
+(defun find-or-create-constraint (kind x y not-p)
+  (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
+  (or (find-constraint kind x y not-p)
       (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
         (sset-adjoin new (lambda-var-constraints x))
         (when (lambda-var-p y)
@@ -120,14 +125,17 @@
                (lambda-var-constraints leaf))
       leaf)))
 
-;;; If LVAR's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE,
-;;; otherwise NIL.
-#!-sb-fluid (declaim (inline ok-lvar-lambda-var))
-(defun ok-lvar-lambda-var (lvar)
+;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
+;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
+(defun ok-lvar-lambda-var (lvar constraints)
   (declare (type lvar lvar))
   (let ((use (lvar-uses lvar)))
     (when (ref-p use)
-      (ok-ref-lambda-var use))))
+      (let ((lambda-var (ok-ref-lambda-var use)))
+        (when lambda-var
+          (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
+            (when (and constraint (sset-member constraint constraints))
+              lambda-var)))))))
 
 ;;;; Searching constraints
 
@@ -137,7 +145,7 @@
 ;;; predecessors, since it only holds on this particular path.
 (defun add-test-constraint (block fun x y not-p)
   (unless (rest (block-pred block))
-    (let ((con (find-constraint fun x y not-p))
+    (let ((con (find-or-create-constraint fun x y not-p))
           (old (or (block-test-constraint block)
                    (setf (block-test-constraint block) (make-sset)))))
       (when (sset-adjoin con old)
@@ -160,11 +168,12 @@
 
 ;;; Add test constraints to the consequent and alternative blocks of
 ;;; the test represented by USE.
-(defun add-test-constraints (use if)
+(defun add-test-constraints (use if constraints)
   (declare (type node use) (type cif if))
   (typecase use
     (ref
-     (add-complement-constraints if 'typep (ok-ref-lambda-var use)
+     (add-complement-constraints if 'typep (ok-lvar-lambda-var (ref-lvar use)
+                                                               constraints)
                                  (specifier-type 'null) t))
     (combination
      (unless (eq (combination-kind use)
@@ -178,15 +187,16 @@
               (when (constant-lvar-p type)
                 (let ((val (lvar-value type)))
                   (add-complement-constraints if 'typep
-                                              (ok-lvar-lambda-var (first args))
+                                              (ok-lvar-lambda-var (first args)
+                                                                  constraints)
                                               (if (ctype-p val)
                                                   val
                                                   (specifier-type val))
                                               nil)))))
            ((eq eql)
-            (let* ((var1 (ok-lvar-lambda-var (first args)))
+            (let* ((var1 (ok-lvar-lambda-var (first args) constraints))
                    (arg2 (second args))
-                   (var2 (ok-lvar-lambda-var arg2)))
+                   (var2 (ok-lvar-lambda-var arg2 constraints)))
               (cond ((not var1))
                     (var2
                      (add-complement-constraints if 'eql var1 var2 nil))
@@ -197,9 +207,9 @@
                                                  nil)))))
            ((< >)
             (let* ((arg1 (first args))
-                   (var1 (ok-lvar-lambda-var arg1))
+                   (var1 (ok-lvar-lambda-var arg1 constraints))
                    (arg2 (second args))
-                   (var2 (ok-lvar-lambda-var arg2)))
+                   (var2 (ok-lvar-lambda-var arg2 constraints)))
               (when var1
                 (add-complement-constraints if name var1 (lvar-type arg2)
                                             nil))
@@ -211,7 +221,8 @@
             (let ((ptype (gethash name *backend-predicate-types*)))
               (when ptype
                 (add-complement-constraints if 'typep
-                                            (ok-lvar-lambda-var (first args))
+                                            (ok-lvar-lambda-var (first args)
+                                                                constraints)
                                             ptype nil)))))))))
   (values))
 
@@ -223,9 +234,11 @@
     (when (if-p last)
       (let ((use (lvar-uses (if-test last))))
         (when (node-p use)
-          (add-test-constraints use last)))))
-
-  (setf (block-test-modified block) nil)
+          ;; BLOCK-OUT contains the (EQL LAMBDA-VAR LVAR)
+          ;; constraints valid at the end of the block. Since the
+          ;; IF node is last node in its block, it can be used to
+          ;; check LVAR LAMBDA-VAR equality.
+          (add-test-constraints use last (block-out block))))))
   (values))
 
 ;;;; Applying constraints
@@ -347,18 +360,20 @@
                  (setq not-res (type-union not-res other))
                  (setq res (type-approx-intersection2 res other))))
             (eql
-             (let ((other-type (leaf-type other)))
-               (if not-p
-                   (when (and (constant-p other)
-                              (member-type-p other-type))
-                     (setq not-res (type-union not-res other-type)))
-                   (let ((leaf-type (leaf-type leaf)))
-                     (when (or (constant-p other)
-                               (and (leaf-refs other) ; protect from deleted vars
-                                    (csubtypep other-type leaf-type)
-                                    (not (type= other-type leaf-type))))
-                       (change-ref-leaf ref other)
-                       (when (constant-p other) (return)))))))
+             (unless (lvar-p other)
+               (let ((other-type (leaf-type other)))
+                 (if not-p
+                     (when (and (constant-p other)
+                                (member-type-p other-type))
+                       (setq not-res (type-union not-res other-type)))
+                     (let ((leaf-type (leaf-type leaf)))
+                       (when (or (constant-p other)
+                                 (and (leaf-refs other) ; protect from
+                                                        ; deleted vars
+                                      (csubtypep other-type leaf-type)
+                                      (not (type= other-type leaf-type))))
+                         (change-ref-leaf ref other)
+                         (when (constant-p other) (return))))))))
             ((< >)
              (cond ((and (integer-type-p res) (integer-type-p y))
                     (let ((greater (eq kind '>)))
@@ -418,18 +433,21 @@
                            ;; fully performed by IR1 optimizer
                            (lambda-var-sets var))
                  do (let* ((type (lvar-type val))
-                           (con (find-constraint 'typep var type nil)))
+                           (con (find-or-create-constraint 'typep var type
+                                                           nil)))
                       (sset-adjoin con gen))))))
       (ref
-       (let ((var (ok-ref-lambda-var node)))
-         (when var
-           (when ref-preprocessor
-             (funcall ref-preprocessor node gen))
-           (let ((dest (and lvar (lvar-dest lvar))))
-             (when (cast-p dest)
-               (let* ((atype (single-value-type (cast-derived-type dest))) ; FIXME
-                      (con (find-constraint 'typep var atype nil)))
-                 (sset-adjoin con gen)))))))
+       (when (ok-ref-lambda-var node)
+         (maybe-add-eql-constraint-for-lvar node gen)
+         (when ref-preprocessor
+           (funcall ref-preprocessor node gen))))
+      (cast
+       (let ((lvar (cast-value node)))
+         (let ((var (ok-lvar-lambda-var lvar gen)))
+             (when var
+               (let* ((atype (single-value-type (cast-derived-type node))) ; FIXME
+                      (con (find-or-create-constraint 'typep var atype nil)))
+                 (sset-adjoin con gen))))))
       (cset
        (binding* ((var (set-var node))
                   (nil (lambda-var-p var) :exit-if-null)
@@ -438,7 +456,7 @@
            (funcall set-preprocessor var))
          (sset-difference gen cons)
          (let* ((type (single-value-type (node-derived-type node)))
-                (con (find-constraint 'typep var type nil)))
+                (con (find-or-create-constraint 'typep var type nil)))
            (sset-adjoin con gen))))))
 
   gen)
@@ -470,6 +488,25 @@
              (sset-union-of-difference out in kill-set))))
     out))
 
+;; Add a (EQL LAMBDA-VAR LVAR) constraint, but only for LVAR's with a
+;; DEST that's an IF or a test for an IF.
+(defun maybe-add-eql-constraint-for-lvar (ref gen)
+  (let ((lvar (ref-lvar ref))
+        (leaf (ref-leaf ref)))
+    (when (and (lambda-var-p leaf) lvar
+               ;; This test avoids generating constraints for an LVAR
+               ;; for which EQLness to its referenced LAMBDA-VAR is
+               ;; not important because OK-LVAR-LAMBDA-VAR won't need
+               ;; it.
+               (or (cast-p (lvar-dest lvar))
+                   (if-p (lvar-dest lvar))
+                   (and (valued-node-p (lvar-dest lvar))
+                        (let ((lvar2 (node-lvar (lvar-dest lvar))))
+                          (when lvar2
+                            (if-p (lvar-dest lvar2)))))))
+      (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
+                   gen))))
+
 ;;; Compute the initial flow analysis sets for BLOCK:
 ;;; -- Compute IN/OUT sets; if OUT of a predecessor is not yet
 ;;;    computed, assume it to be a universal set (this is only
@@ -559,34 +596,40 @@
       (incf result))
     result))
 
-(defun constraint-propagate (component &aux (loop-p nil))
+(defun find-and-propagate-constraints (component)
+  (let ((loop-p nil))
+    (do-blocks (block component)
+      (when (find-block-type-constraints block)
+        (setq loop-p t)))
+    (when loop-p
+      ;; If we have to propagate changes more than this many times,
+      ;; something is wrong.
+      (let ((max-n-changes-remaining (component-n-blocks component)))
+        (declare (type fixnum max-n-changes-remaining))
+        (loop (aver (>= max-n-changes-remaining 0))
+              (decf max-n-changes-remaining)
+              (let ((did-something nil))
+                (do-blocks (block component)
+                  (when (flow-propagate-constraints block)
+                    (setq did-something t)))
+                (unless did-something
+                  (return))))))))
+
+(defun constraint-propagate (component)
   (declare (type component component))
   (init-var-constraints component)
 
-  (do-blocks (block component)
-    (when (block-test-modified block)
-      (find-test-constraints block)))
-
   (unless (block-out (component-head component))
     (setf (block-out (component-head component)) (make-sset)))
 
+  (find-and-propagate-constraints component)
+
   (do-blocks (block component)
-    (when (find-block-type-constraints block)
-      (setq loop-p t)))
+    (when (block-test-modified block)
+      (find-test-constraints block)
+      (setf (block-test-modified block) nil)))
 
-  (when loop-p
-    (let (;; If we have to propagate changes more than this many times,
-          ;; something is wrong.
-          (max-n-changes-remaining (component-n-blocks component)))
-      (declare (type fixnum max-n-changes-remaining))
-      (loop (aver (>= max-n-changes-remaining 0))
-         (decf max-n-changes-remaining)
-         (let ((did-something nil))
-           (do-blocks (block component)
-             (when (flow-propagate-constraints block)
-               (setq did-something t)))
-           (unless did-something
-             (return))))))
+  (find-and-propagate-constraints component)
 
   (do-blocks (block component)
     (unless (block-delete-p block)