X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=d77ff04ba15ba370333acc9d7c7c47940f3c52dd;hb=7e24349c17298e2959e853ea411b5f65d9f7f332;hp=2fe6b17d110dc6975a6139227935596f46b579e0;hpb=a0c5831b3a74118cf41a848300200a1acdb48dcf;p=sbcl.git

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 2fe6b17..d77ff04 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -37,7 +37,6 @@
 (defvar *flame-on-necessarily-undefined-function* nil)
 
 (defvar *check-consistency* nil)
-(defvar *all-components*)
 
 ;;; Set to NIL to disable loop analysis for register allocation.
 (defvar *loop-analyze* t)
@@ -546,6 +545,11 @@
 
   (let* ((*component-being-compiled* component))
 
+    ;; Record xref information before optimization. This way the
+    ;; stored xref data reflects the real source as closely as
+    ;; possible.
+    (record-component-xrefs component)
+
     (ir1-phases component)
 
     (when *loop-analyze*
@@ -970,16 +974,27 @@
           (debug-name 'initial-component name))
     (setf (component-kind component) :initial)
     (let* ((locall-fun (let ((*allow-instrumenting* t))
-                         (apply #'ir1-convert-lambdalike
-                                definition
-                                (list :source-name name))))
+                         (funcall #'ir1-convert-lambdalike
+                                  definition
+                                  :source-name name)))
+           (debug-name (debug-name 'tl-xep
+                                   (or name
+                                       (functional-%source-name locall-fun))))
+           ;; 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)
                                     :source-name (or name '.anonymous.)
-                                    :debug-name (debug-name 'tl-xep  name))))
+                                    :debug-name debug-name)))
       (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)))
 
@@ -1009,6 +1024,7 @@
                     :policy *policy*
                     :handled-conditions *handled-conditions*
                     :disabled-package-locks *disabled-package-locks*))
+         (*compiler-sset-counter* 0)
          (fun (make-functional-from-toplevel-lambda lambda-expression
                                                     :name name
                                                     :path path)))
@@ -1023,14 +1039,10 @@
 
     (locall-analyze-clambdas-until-done (list fun))
 
-    (multiple-value-bind (components-from-dfo top-components hairy-top)
-        (find-initial-dfo (list fun))
-      (declare (ignore hairy-top))
-
-      (let ((*all-components* (append components-from-dfo top-components)))
-        (dolist (component-from-dfo components-from-dfo)
-          (compile-component component-from-dfo)
-          (replace-toplevel-xeps component-from-dfo)))
+    (let ((components-from-dfo (find-initial-dfo (list fun))))
+      (dolist (component-from-dfo components-from-dfo)
+        (compile-component component-from-dfo)
+        (replace-toplevel-xeps component-from-dfo))
 
       (let ((entry-table (etypecase *compile-object*
                            (fasl-output (fasl-output-entry-table
@@ -1382,10 +1394,10 @@
   (maybe-mumble "IDFO ")
   (multiple-value-bind (components top-components hairy-top)
       (find-initial-dfo lambdas)
-    (let ((*all-components* (append components top-components)))
+    (let ((all-components (append components top-components)))
       (when *check-consistency*
         (maybe-mumble "[check]~%")
-        (check-ir1-consistency *all-components*))
+        (check-ir1-consistency all-components))
 
       (dolist (component (append hairy-top top-components))
         (pre-physenv-analyze-toplevel component))
@@ -1396,7 +1408,7 @@
 
       (when *check-consistency*
         (maybe-mumble "[check]~%")
-        (check-ir1-consistency *all-components*))
+        (check-ir1-consistency all-components))
 
       (if load-time-value-p
           (compile-load-time-value-lambda lambdas)
@@ -1491,6 +1503,7 @@
         ;; and it's not obvious whether the rebinding to itself is
         ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
         (*info-environment* *info-environment*)
+        (*compiler-sset-counter* 0)
         (*gensym-counter* 0))
     (handler-case
         (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
@@ -1512,8 +1525,8 @@
       ;; the input file.
       (fatal-compiler-error (condition)
        (signal condition)
-       (when *compile-verbose*
-         (format *standard-output*
+       (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+         (format *error-output*
                  "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
                  condition))
        (values nil t t)))))