From 77af6d16968262049d6dadfb5521af7a8a7c6868 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Mon, 18 Aug 2003 07:53:35 +0000 Subject: [PATCH] 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. --- contrib/sb-aclrepl/repl.lisp | 2 +- package-data-list.lisp-expr | 1 + src/code/early-extensions.lisp | 27 +++++++++++++++ src/compiler/ir1opt.lisp | 71 ++++++++++++++++++++++++++++++++++++---- src/compiler/srctran.lisp | 4 +-- src/runtime/interrupt.h | 2 ++ src/runtime/linux-os.c | 2 ++ version.lisp-expr | 2 +- 8 files changed, 100 insertions(+), 11 deletions(-) diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index 17c2ad0..c3377e7 100644 --- 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 --- 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 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1097,6 +1097,33 @@ which can be found at .~:@>" (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)))) ;;; Delayed evaluation (defmacro delay (form) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 6e868c2..f31fb9c 100644 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4