[Sbcl-commits] CVS: sbcl/src/compiler dfo.lisp, 1.23, 1.24 ir1util.lisp, 1.136, 1.137 locall.lisp, 1.98, 1.99 main.lisp, 1.151, 1.152

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv5871/src/compiler

Modified Files:
	dfo.lisp ir1util.lisp locall.lisp main.lisp 
Log Message:
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.


Index: dfo.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/dfo.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- dfo.lisp	6 Feb 2007 05:06:38 -0000	1.23
+++ dfo.lisp	8 Nov 2010 12:42:01 -0000	1.24
@@ -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))

Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.136
retrieving revision 1.137
diff -u -d -r1.136 -r1.137
--- ir1util.lisp	2 Sep 2010 14:33:05 -0000	1.136
+++ ir1util.lisp	8 Nov 2010 12:42:01 -0000	1.137
@@ -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)

Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.98
retrieving revision 1.99
diff -u -d -r1.98 -r1.99
--- locall.lisp	31 Jul 2009 13:00:18 -0000	1.98
+++ locall.lisp	8 Nov 2010 12:42:02 -0000	1.99
@@ -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

Index: main.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/main.lisp,v
retrieving revision 1.151
retrieving revision 1.152
diff -u -d -r1.151 -r1.152
--- main.lisp	7 Oct 2010 16:40:47 -0000	1.151
+++ main.lisp	8 Nov 2010 12:42:02 -0000	1.152
@@ -1097,28 +1097,39 @@
          (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.