1.0.5.9: experimental semi-synchronous deadlines

[sbcl.git] / src / compiler / main.lisp

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 8e4e154..d77ff04 100644 (file)
--- 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)))))
@@ -1795,8 +1808,6 @@ SPEED and COMPILATION-SPEED optimization values, and the
         (:ignore-it
          nil)
         (t
-         (when (fasl-constant-already-dumped-p constant *compile-object*)
-           (return-from emit-make-load-form nil))
          (let* ((name (write-to-string constant :level 1 :length 2))
                 (info (if init-form
                           (list constant name init-form)