1.0.44.4: make MAKE-FUNCTIONAL-FROM-TOPLEVEL-LAMBDA build proper XEPs

 Bring MAKE-FUNCTIONAL-FROM-TOPLEVEL-LAMBDA into closer alignment with
 MAKE-XEP. Specifically, cross-link the underlying function and the
 TL-XEP, and mark the TL-XEP for reanalysis.

 Fixes lp#310173 and lp#384892:

 * Show &REST arguments properly in backtraces.

 * Better type-derivation of function result types when the
   lambda-list is complex.

diff --git a/NEWS b/NEWS
index 4b162ec..e8d48df 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,9 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.0.44:
+  * bug fix: backtracing function with &REST arguments now shows the full
+    argument list. (lp#310173)
+  * bug fix: return types for functions with complex lambda-lists are now
+    derived properly (lp#384892)
   * bug fix: when SPEED > SPACE compiling CONCATENATE 'STRING with constant
     long string arguments slowed the compiler down to a crawl.
 

diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp
index 0a8abaf..0ce7187 100644 (file)
--- a/contrib/sb-introspect/test-driver.lisp
+++ b/contrib/sb-introspect/test-driver.lisp
@@ -378,12 +378,10 @@
 
 (deftest function-type.2
     (values (type-equal (function-type 'sun) (function-type #'sun))
-            ;; Does not currently work due to Bug #384892. (1.0.31.26)
-            #+nil
             (type-equal (function-type #'sun)
                         '(function (fixnum fixnum &key (:k1 (member nil t)))
                           (values (member t) &optional))))
-  t #+nil t)
+  t t)
 
 ;; Local functions
 
@@ -516,7 +514,7 @@
                         '(function ((member nil t)
                                     fixnum fixnum
                                     &key (:k1 (member nil t)))
-                          *)))
+                          (values (member nil t) &optional))))
   t t)
 
 ;; Misc

diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp
index 28c53e3..8ee0621 100644 (file)
--- a/src/compiler/dfo.lisp
+++ b/src/compiler/dfo.lisp
@@ -190,7 +190,10 @@
              (home-kind (functional-kind home))
              (home-externally-visible-p
               (or (eq home-kind :toplevel)
-                  (functional-has-external-references-p home))))
+                  (functional-has-external-references-p home)
+                  (let ((entry (functional-entry-fun home)))
+                    (and entry
+                         (functional-has-external-references-p entry))))))
         (unless (or (and home-externally-visible-p
                          (eq (functional-kind fun) :external))
                     (eq home-kind :deleted))

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 2532768..78d92e3 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -1305,7 +1305,8 @@
                  (aver (null (functional-entry-fun leaf)))
                  (delete-lambda leaf))
                 (:external
-                 (delete-lambda leaf))
+                 (unless (functional-has-external-references-p leaf)
+                   (delete-lambda leaf)))
                 ((:deleted :zombie :optional))))
              (optional-dispatch
               (unless (eq (functional-kind leaf) :deleted)

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index aa84315..e820d46 100644 (file)
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -209,25 +209,29 @@
   (declare (type functional fun))
   (aver (null (functional-entry-fun fun)))
   (with-ir1-environment-from-node (lambda-bind (main-entry fun))
-    (let ((res (ir1-convert-lambda (make-xep-lambda-expression fun)
+    (let ((xep (ir1-convert-lambda (make-xep-lambda-expression fun)
                                    :debug-name (debug-name
                                                 'xep (leaf-debug-name fun))
                                    :system-lambda t)))
-      (setf (functional-kind res) :external
-            (leaf-ever-used res) t
-            (functional-entry-fun res) fun
-            (functional-entry-fun fun) res
+      (setf (functional-kind xep) :external
+            (leaf-ever-used xep) t
+            (functional-entry-fun xep) fun
+            (functional-entry-fun fun) xep
             (component-reanalyze *current-component*) t)
       (reoptimize-component *current-component* :maybe)
-      (etypecase fun
-        (clambda
-         (locall-analyze-fun-1 fun))
-        (optional-dispatch
-         (dolist (ep (optional-dispatch-entry-points fun))
-           (locall-analyze-fun-1 (force ep)))
-         (when (optional-dispatch-more-entry fun)
-           (locall-analyze-fun-1 (optional-dispatch-more-entry fun)))))
-      res)))
+      (locall-analyze-xep-entry-point fun)
+      xep)))
+
+(defun locall-analyze-xep-entry-point (fun)
+  (declare (type functional fun))
+  (etypecase fun
+    (clambda
+     (locall-analyze-fun-1 fun))
+    (optional-dispatch
+     (dolist (ep (optional-dispatch-entry-points fun))
+       (locall-analyze-fun-1 (force ep)))
+     (when (optional-dispatch-more-entry fun)
+       (locall-analyze-fun-1 (optional-dispatch-more-entry fun))))))
 
 ;;; Notice a REF that is not in a local-call context. If the REF is
 ;;; already to an XEP, then do nothing, otherwise change it to the

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 33a1967..c4cf5f5 100644 (file)
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -1097,28 +1097,39 @@ Examples:
          (source-name (or name '.anonymous.)))
     (setf (component-name component) (debug-name 'initial-component debug-name-tail)
           (component-kind component) :initial)
-    (let* ((locall-fun (let ((*allow-instrumenting* t))
-                         (funcall #'ir1-convert-lambdalike
-                                  lambda-expression
-                                  :source-name source-name)))
-           ;; Convert the XEP using the policy of the real
-           ;; function. Otherwise the wrong policy will be used for
-           ;; deciding whether to type-check the parameters of the
-           ;; real function (via CONVERT-CALL / PROPAGATE-TO-ARGS).
-           ;; -- JES, 2007-02-27
-           (*lexenv* (make-lexenv :policy (lexenv-policy
-                                           (functional-lexenv locall-fun))))
-           (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
+    (let* ((fun (let ((*allow-instrumenting* t))
+                  (funcall #'ir1-convert-lambdalike
+                           lambda-expression
+                           :source-name source-name)))
+           ;; Convert the XEP using the policy of the real function. Otherwise
+           ;; the wrong policy will be used for deciding whether to type-check
+           ;; the parameters of the real function (via CONVERT-CALL /
+           ;; PROPAGATE-TO-ARGS). -- JES, 2007-02-27
+           (*lexenv* (make-lexenv :policy (lexenv-policy (functional-lexenv fun))))
+           (xep (ir1-convert-lambda (make-xep-lambda-expression fun)
                                     :source-name source-name
                                     :debug-name (debug-name 'tl-xep debug-name-tail)
                                     :system-lambda t)))
       (when name
-        (assert-global-function-definition-type name locall-fun))
-      (setf (functional-entry-fun fun) locall-fun
-            (functional-kind fun) :external
-            (functional-has-external-references-p locall-fun) t
-            (functional-has-external-references-p fun) t)
-      fun)))
+        (assert-global-function-definition-type name fun))
+      (setf (functional-kind xep) :external
+            (functional-entry-fun xep) fun
+            (functional-entry-fun fun) xep
+            (component-reanalyze component) t
+            (functional-has-external-references-p xep) t)
+      (reoptimize-component component :maybe)
+      (locall-analyze-xep-entry-point fun)
+      ;; Any leftover REFs to FUN outside local calls get replaced with the
+      ;; XEP.
+      (substitute-leaf-if (lambda (ref)
+                            (let* ((lvar (ref-lvar ref))
+                                   (dest (when lvar (lvar-dest lvar)))
+                                   (kind (when (basic-combination-p dest)
+                                           (basic-combination-kind dest))))
+                              (neq :local kind)))
+                          xep
+                          fun)
+      xep)))
 
 ;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a
 ;;; description of the result.

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index fbadfe9..ebb61ac 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2706,9 +2706,10 @@
     (assert derivedp)))
 
 (with-test (:name :base-char-typep-elimination)
-  (assert (eq (funcall (lambda (ch)
-                         (declare (type base-char ch) (optimize (speed 3) (safety 0)))
-                         (typep ch 'base-char))
+  (assert (eq (funcall (compile nil
+                                `(lambda (ch)
+                                   (declare (type base-char ch) (optimize (speed 3) (safety 0)))
+                                   (typep ch 'base-char)))
                        t)
               t)))
 
@@ -3681,3 +3682,14 @@
            (short-avg (/ (+ d0 d1 d2) 3)))
       (assert (and f1 f2 f3))
       (assert (< d3 (* 10 short-avg))))))
+
+(with-test (:name :bug-384892)
+  (assert (equal
+           '(function (fixnum fixnum &key (:k1 (member nil t)))
+             (values (member t) &optional))
+           (sb-kernel:%simple-fun-type
+            (compile nil `(lambda (x y &key k1)
+                            (declare (fixnum x y))
+                            (declare (boolean k1))
+                            (declare (ignore x y k1))
+                            t))))))

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index b79e3f3..f33a966 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -386,6 +386,33 @@
                (clos-emf-named-test nil))))
     '(((sb-pcl::emf clos-emf-named-test) ? ? nil)))))
 
+(with-test (:name :bug-310173)
+  (flet ((make-fun (n)
+           (let* ((names '(a b))
+                  (req (loop repeat n collect (pop names))))
+             (compile nil
+                      `(lambda (,@req &rest rest)
+                         (let ((* *)) ; no tail-call
+                           (apply '/ ,@req rest)))))))
+    (assert
+     (verify-backtrace (lambda ()
+                         (funcall (make-fun 0) 10 11 0))
+                       '((sb-kernel:two-arg-/ 10/11 0)
+                         (/ 10 11 0)
+                         ((lambda (&rest rest)) 10 11 0))))
+    (assert
+     (verify-backtrace (lambda ()
+                         (funcall (make-fun 1) 10 11 0))
+                       '((sb-kernel:two-arg-/ 10/11 0)
+                         (/ 10 11 0)
+                         ((lambda (a &rest rest)) 10 11 0))))
+    (assert
+     (verify-backtrace (lambda ()
+                         (funcall (make-fun 2) 10 11 0))
+                       '((sb-kernel:two-arg-/ 10/11 0)
+                         (/ 10 11 0)
+                         ((lambda (a b &rest rest)) 10 11 0))))))
+
 ;;;; test TRACE
 
 (defun trace-this ()

diff --git a/version.lisp-expr b/version.lisp-expr
index fd205fc..ce1ff25 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".)
-"1.0.44.3"
+"1.0.44.4"