0.8.2.39:

        * New macro SB!INT:BINDING*, uniting LET*, M-V-BIND and AWHEN;
        * add simple inference of iteration variable type;
        * SAME-LEAF-REF-P: look through CAST chains;
        * wrap all uses of handle_rt_signal into #!+sb-thread;
        * (SB-ACLREPL): CD-CMD takes one argument, not two.

diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp
index 17c2ad0..c3377e7 100644 (file)
--- a/contrib/sb-aclrepl/repl.lisp
+++ b/contrib/sb-aclrepl/repl.lisp
@@ -488,7 +488,7 @@
 
 (defun pushd-cmd (string-arg)
   (push string-arg *dir-stack*)
-  (cd-cmd *output* string-arg)
+  (cd-cmd string-arg)
   (values))
 
 (defun popd-cmd ()

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index b958b0d..cbe4cb4 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -772,6 +772,7 @@ retained, possibly temporariliy, because it might be used internally."
              "DEFPRINTER"
              "AVER" "ENFORCE-TYPE"
              "AWHEN" "ACOND" "IT"
+             "BINDING*"
             "!DEF-BOOLEAN-ATTRIBUTE"
 
             ;; ..and CONDITIONs..

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 7435069..81b6f7b 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -1097,6 +1097,33 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
                (let ((it ,test)) (declare (ignorable it)),@body)
                (acond ,@rest))))))
 
+;;; (binding* ({(name initial-value [flag])}*) body)
+;;; FLAG may be NIL or :EXIT-IF-NULL
+;;;
+;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN.
+(defmacro binding* ((&rest bindings) &body body)
+  (let ((bindings (reverse bindings)))
+    (loop with form = `(progn ,@body)
+          for binding in bindings
+          do (destructuring-bind (names initial-value &optional flag)
+                 binding
+               (multiple-value-bind (names declarations)
+                   (etypecase names
+                     (null
+                      (let ((name (gensym)))
+                        (values (list name) `((declare (ignorable ,name))))))
+                     (symbol
+                      (values (list names) nil))
+                     (list
+                      (values names nil)))
+                 (setq form `(multiple-value-bind ,names
+                                 ,initial-value
+                               ,@declarations
+                               ,(ecase flag
+                                       ((nil) form)
+                                       ((:exit-if-null)
+                                        `(when ,(first names) ,form)))))))
+          finally (return form))))
 \f
 ;;; Delayed evaluation
 (defmacro delay (form)

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 6e868c2..f31fb9c 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1251,18 +1251,74 @@
                 (reoptimize-continuation cont))))))
       (values))))
 
+;;; Iteration variable: exactly one SETQ of the form:
+;;;
+;;; (let ((var initial))
+;;;   ...
+;;;   (setq var (+ var step))
+;;;   ...)
+(defun maybe-infer-iteration-var-type (var initial-type)
+  (binding* ((sets (lambda-var-sets var) :exit-if-null)
+             (set (first sets))
+             (() (null (rest sets)) :exit-if-null)
+             (set-use (principal-continuation-use (set-value set)))
+             (() (and (combination-p set-use)
+                      (fun-info-p (combination-kind set-use))
+                      (eq (combination-fun-source-name set-use) '+))
+               :exit-if-null)
+             (+-args (basic-combination-args set-use))
+             (() (and (proper-list-of-length-p +-args 2 2)
+                      (let ((first (principal-continuation-use
+                                    (first +-args))))
+                        (and (ref-p first)
+                             (eq (ref-leaf first) var))))
+               :exit-if-null)
+             (step-type (continuation-type (second +-args))))
+    (when (and (numeric-type-p initial-type)
+               (numeric-type-p step-type)
+               (eq (numeric-type-class initial-type)
+                   (numeric-type-class step-type))
+               (eq (numeric-type-format initial-type)
+                   (numeric-type-format step-type))
+               (eq (numeric-type-complexp initial-type)
+                   (numeric-type-complexp step-type)))
+      (multiple-value-bind (low high)
+          (cond ((csubtypep step-type (specifier-type '(real 0 *)))
+                 (values (numeric-type-low initial-type) nil))
+                ((csubtypep step-type (specifier-type '(real * 0)))
+                 (values nil (numeric-type-high initial-type)))
+                (t
+                 (values nil nil)))
+        (modified-numeric-type initial-type
+                               :low low
+                               :high high
+                               :enumerable nil)))))
+(deftransform + ((x y) * * :result result)
+  "check for iteration variable reoptimization"
+  (let ((dest (principal-continuation-end result))
+        (use (principal-continuation-use x)))
+    (when (and (ref-p use)
+               (set-p dest)
+               (eq (ref-leaf use)
+                   (set-var dest)))
+      (reoptimize-continuation (set-value dest))))
+  (give-up-ir1-transform))
+
 ;;; Figure out the type of a LET variable that has sets. We compute
-;;; the union of the initial value TYPE and the types of all the set
+;;; the union of the INITIAL-TYPE and the types of all the set
 ;;; values and to a PROPAGATE-TO-REFS with this type.
-(defun propagate-from-sets (var type)
-  (collect ((res type type-union))
+(defun propagate-from-sets (var initial-type)
+  (collect ((res initial-type type-union))
     (dolist (set (basic-var-sets var))
       (let ((type (continuation-type (set-value set))))
         (res type)
         (when (node-reoptimize set)
           (derive-node-type set (make-single-value-type type))
           (setf (node-reoptimize set) nil))))
-    (propagate-to-refs var (res)))
+    (let ((res (res)))
+      (awhen (maybe-infer-iteration-var-type var initial-type)
+        (setq res (type-intersection res it)))
+      (propagate-to-refs var res)))
   (values))
 
 ;;; If a LET variable, find the initial value's type and do
@@ -1274,9 +1330,10 @@
     (when (and (lambda-var-p var) (leaf-refs var))
       (let ((home (lambda-var-home var)))
        (when (eq (functional-kind home) :let)
-         (let ((iv (let-var-initial-value var)))
-           (setf (continuation-reoptimize iv) nil)
-           (propagate-from-sets var (continuation-type iv)))))))
+         (let* ((initial-value (let-var-initial-value var))
+                 (initial-type (continuation-type initial-value)))
+           (setf (continuation-reoptimize initial-value) nil)
+            (propagate-from-sets var initial-type))))))
 
   (derive-node-type node (make-single-value-type
                           (continuation-type (set-value node))))

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index bda707f..c59ab7c 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2886,8 +2886,8 @@
 ;;; change.
 (defun same-leaf-ref-p (x y)
   (declare (type continuation x y))
-  (let ((x-use (continuation-use x))
-       (y-use (continuation-use y)))
+  (let ((x-use (principal-continuation-use x))
+       (y-use (principal-continuation-use y)))
     (and (ref-p x-use)
         (ref-p y-use)
         (eq (ref-leaf x-use) (ref-leaf y-use))

diff --git a/src/runtime/interrupt.h b/src/runtime/interrupt.h
index 1f24a72..f725900 100644 (file)
--- a/src/runtime/interrupt.h
+++ b/src/runtime/interrupt.h
@@ -49,7 +49,9 @@ extern void interrupt_internal_error(int, siginfo_t*, os_context_t*,
                                     boolean continuable);
 extern boolean handle_control_stack_guard_triggered(os_context_t *,void *);
 extern boolean interrupt_maybe_gc(int, siginfo_t*, void*);
+#ifdef LISP_FEATURE_SB_THREAD
 extern boolean handle_rt_signal(int, siginfo_t*, void*);
+#endif
 extern void undoably_install_low_level_interrupt_handler (int signal,
                                                          void
                                                          handler(int,

diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c
index 879c0d4..aed1458 100644 (file)
--- a/src/runtime/linux-os.c
+++ b/src/runtime/linux-os.c
@@ -260,8 +260,10 @@ os_install_interrupt_handlers(void)
 {
     undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
                                                 sigsegv_handler);
+#ifdef LISP_FEATURE_SB_THREAD
     undoably_install_low_level_interrupt_handler(SIG_INTERRUPT_THREAD,
                                                 handle_rt_signal);
+#endif
     undoably_install_low_level_interrupt_handler(SIGCONT,
                                                 sigcont_handler);
 }

diff --git a/version.lisp-expr b/version.lisp-expr
index d03560a..53f84cf 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.2.38"
+"0.8.2.39"