Don't warn when #'(setf fun) is used in the presence of a setf-macro.

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

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 102a843..1bec50e 100644 (file)
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -15,9 +15,7 @@
 
 ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
 (declaim (special *constants* *free-vars* *component-being-compiled*
 
 ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
 (declaim (special *constants* *free-vars* *component-being-compiled*

-                  *code-vector* *next-location* *result-fixups*

                   *free-funs* *source-paths*
                   *free-funs* *source-paths*

-                  *seen-blocks* *seen-funs* *list-conflicts-table*

                   *continuation-number* *continuation-numbers*
                   *number-continuations* *tn-id* *tn-ids* *id-tns*
                   *label-ids* *label-id* *id-labels*
                   *continuation-number* *continuation-numbers*
                   *number-continuations* *tn-id* *tn-ids* *id-tns*
                   *label-ids* *label-id* *id-labels*

@@ -161,47 +159,67 @@ Following options are defined:
       Supplying POLICY NIL is equivalent to the option not being supplied at
       all, ie. dynamic scoping of policy does not take place.
 
       Supplying POLICY NIL is equivalent to the option not being supplied at
       all, ie. dynamic scoping of policy does not take place.
 

-      This option is an SBCL specific EXPERIMENTAL extension: Interface
+      This option is an SBCL-specific experimental extension: Interface

       subject to change.
 
       subject to change.
 

-      Examples:
+  :SOURCE-NAMESTRING Namestring-Form
+      Attaches the value returned by the Namestring-Form to the internal
+      debug-source information as the namestring of the source file. Normally
+      the namestring of the input-file for COMPILE-FILE is used: this option
+      can be used to provide source-file information for functions compiled
+      using COMPILE, or to override the input-file of COMPILE-FILE.

 
 

-        ;; Prevent OPTIMIZE proclamations from file leaking, and
-        ;; restrict SAFETY to 3 for the LOAD -- otherwise uses the
-        ;; current global policy.
-        (with-compilation-unit (:policy '(optimize))
-          (restrict-compiler-policy 'safety 3)
-          (load \"foo.lisp\"))
+      If both an outer and an inner WITH-COMPILATION-UNIT provide a
+      SOURCE-NAMESTRING, the inner one takes precedence. Unaffected
+      by :OVERRIDE.

 
 

-        ;; Load using default policy instead of the current global one, except
-        ;; for DEBUG 3.
-        (with-compilation-unit (:policy '(optimize debug) :override t)
-          (load \"foo.lisp\"))
-
-        ;; Same as if :POLICY had not been specified at all: SAFETY 3
-        ;; leaks outside WITH-COMPILATION-UNIT.
-        (with-compilation-unit (:policy nil)
-          (declaim (optimize safety)))
+      This is an SBCL-specific extension.

 
   :SOURCE-PLIST Plist-Form
       Attaches the value returned by the Plist-Form to internal debug-source
 
   :SOURCE-PLIST Plist-Form
       Attaches the value returned by the Plist-Form to internal debug-source

-      information of functions compiled in within the dynamic contour.
-      Primarily for use by development environments, in order to eg. associate
-      function definitions with editor-buffers. Can be accessed as
-      SB-INTROSPECT:DEFINITION-SOURCE-PLIST. If multiple, nested
-      WITH-COMPILATION-UNITs provide :SOURCE-PLISTs, they are appended
-      togather, innermost left. Unaffected by :OVERRIDE.
+      information of functions compiled in within the dynamic extent of BODY.

 
 

-      This SBCL is and specific extension."
+      Primarily for use by development environments, in order to eg. associate
+      function definitions with editor-buffers. Can be accessed using
+      SB-INTROSPECT:DEFINITION-SOURCE-PLIST.
+
+      If an outer WITH-COMPILATION-UNIT form also provide a SOURCE-PLIST, it
+      is appended to the end of the provided SOURCE-PLIST. Unaffected
+      by :OVERRIDE.
+
+      This is an SBCL-specific extension.
+
+Examples:
+
+  ;; Prevent proclamations from the file leaking, and restrict
+  ;; SAFETY to 3 -- otherwise uses the current global policy.
+  (with-compilation-unit (:policy '(optimize))
+    (restrict-compiler-policy 'safety 3)
+    (load \"foo.lisp\"))
+
+  ;; Using default policy instead of the current global one,
+  ;; except for DEBUG 3.
+  (with-compilation-unit (:policy '(optimize debug)
+                          :override t)
+    (load \"foo.lisp\"))
+
+  ;; Same as if :POLICY had not been specified at all: SAFETY 3
+  ;; proclamation leaks out from WITH-COMPILATION-UNIT.
+  (with-compilation-unit (:policy nil)
+    (declaim (optimize safety))
+    (load \"foo.lisp\"))
+"

   `(%with-compilation-unit (lambda () ,@body) ,@options))
 
 (defvar *source-plist* nil)
   `(%with-compilation-unit (lambda () ,@body) ,@options))
 
 (defvar *source-plist* nil)

+(defvar *source-namestring* nil)

 
 

-(defun %with-compilation-unit (fn &key override policy source-plist)
+(defun %with-compilation-unit (fn &key override policy source-plist source-namestring)

   (declare (type function fn))
   (flet ((with-it ()
            (let ((succeeded-p nil)
   (declare (type function fn))
   (flet ((with-it ()
            (let ((succeeded-p nil)

-                 (*source-plist* (append source-plist *source-plist*)))
+                 (*source-plist* (append source-plist *source-plist*))
+                 (*source-namestring* (or source-namestring *source-namestring*)))

              (if (and *in-compilation-unit* (not override))
                  ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
                  ;; ordinarily (unless OVERRIDE) basically a no-op.
              (if (and *in-compilation-unit* (not override))
                  ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
                  ;; ordinarily (unless OVERRIDE) basically a no-op.

@@ -216,17 +234,16 @@ Following options are defined:
                        (*compiler-note-count* 0)
                        (*undefined-warnings* nil)
                        (*in-compilation-unit* t))
                        (*compiler-note-count* 0)
                        (*undefined-warnings* nil)
                        (*in-compilation-unit* t))

-                   (with-world-lock ()
-                     (handler-bind ((parse-unknown-type
-                                     (lambda (c)
-                                       (note-undefined-reference
-                                        (parse-unknown-type-specifier c)
-                                        :type))))
-                       (unwind-protect
-                            (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
-                         (unless succeeded-p
-                           (incf *aborted-compilation-unit-count*))
-                         (summarize-compilation-unit (not succeeded-p))))))))))
+                   (handler-bind ((parse-unknown-type
+                                    (lambda (c)
+                                      (note-undefined-reference
+                                       (parse-unknown-type-specifier c)
+                                       :type))))
+                     (unwind-protect
+                          (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
+                       (unless succeeded-p
+                         (incf *aborted-compilation-unit-count*))
+                       (summarize-compilation-unit (not succeeded-p)))))))))

     (if policy
         (let ((*policy* (process-optimize-decl policy (unless override *policy*)))
               (*policy-restrictions* (unless override *policy-restrictions*)))
     (if policy
         (let ((*policy* (process-optimize-decl policy (unless override *policy*)))
               (*policy-restrictions* (unless override *policy-restrictions*)))

@@ -354,12 +371,33 @@ Following options are defined:
 ;;; WARNINGS-P and FAILURE-P are as in CL:COMPILE or CL:COMPILE-FILE.
 ;;; This also wraps up WITH-IR1-NAMESPACE functionality.
 (defmacro with-compilation-values (&body body)
 ;;; WARNINGS-P and FAILURE-P are as in CL:COMPILE or CL:COMPILE-FILE.
 ;;; This also wraps up WITH-IR1-NAMESPACE functionality.
 (defmacro with-compilation-values (&body body)

-  `(with-ir1-namespace
-    (let ((*warnings-p* nil)
-          (*failure-p* nil))
-      (values (progn ,@body)
-              *warnings-p*
-              *failure-p*))))
+  ;; These bindings could just as well be in WITH-IR1-NAMESPACE, but
+  ;; since they're primarily debugging tools, it's nicer to have
+  ;; a wider unique scope by ID.
+  `(let ((*continuation-number* 0)
+         (*continuation-numbers* (make-hash-table :test 'eq))
+         (*number-continuations* (make-hash-table :test 'eql))
+         (*tn-id* 0)
+         (*tn-ids* (make-hash-table :test 'eq))
+         (*id-tns* (make-hash-table :test 'eql))
+         (*label-id* 0)
+         (*label-ids* (make-hash-table :test 'eq))
+         (*id-labels* (make-hash-table :test 'eql)))
+       (unwind-protect
+            (let ((*warnings-p* nil)
+                  (*failure-p* nil))
+              (handler-bind ((compiler-error #'compiler-error-handler)
+                             (style-warning #'compiler-style-warning-handler)
+                             (warning #'compiler-warning-handler))
+                  (values (progn ,@body)
+                       *warnings-p*
+                       *failure-p*)))
+         (clrhash *tn-ids*)
+         (clrhash *id-tns*)
+         (clrhash *continuation-numbers*)
+         (clrhash *number-continuations*)
+         (clrhash *label-ids*)
+         (clrhash *id-labels*))))

 \f
 ;;;; component compilation
 
 \f
 ;;;; component compilation
 

@@ -488,6 +526,13 @@ Following options are defined:
         (return))
       (incf loop-count)))
 
         (return))
       (incf loop-count)))
 

+  (when *check-consistency*
+    (do-blocks-backwards (block component)
+      (awhen (flush-dead-code block)
+        (let ((*compiler-error-context* it))
+          (compiler-warn "dead code detected at the end of ~S"
+                         'ir1-phases)))))
+

   (ir1-finalize component)
   (values))
 
   (ir1-finalize component)
   (values))
 

@@ -686,12 +731,14 @@ Following options are defined:
 (defun clear-constant-info ()
   (maphash (lambda (k v)
              (declare (ignore k))
 (defun clear-constant-info ()
   (maphash (lambda (k v)
              (declare (ignore k))

-             (setf (leaf-info v) nil))
+             (setf (leaf-info v) nil)
+             (setf (constant-boxed-tn v) nil))

            *constants*)
   (maphash (lambda (k v)
              (declare (ignore k))
              (when (constant-p v)
            *constants*)
   (maphash (lambda (k v)
              (declare (ignore k))
              (when (constant-p v)

-               (setf (leaf-info v) nil)))
+               (setf (leaf-info v) nil)
+               (setf (constant-boxed-tn v) nil)))

            *free-vars*)
   (values))
 
            *free-vars*)
   (values))
 

@@ -715,47 +762,6 @@ Following options are defined:
     (blast *free-funs*)
     (blast *constants*))
   (values))
     (blast *free-funs*)
     (blast *constants*))
   (values))

-
-;;; Clear global variables used by the compiler.
-;;;
-;;; FIXME: It seems kinda nasty and unmaintainable to have to do this,
-;;; and it adds overhead even when people aren't using the compiler.
-;;; Perhaps we could make these global vars unbound except when
-;;; actually in use, so that this function could go away.
-(defun clear-stuff (&optional (debug-too t))
-
-  ;; Clear global tables.
-  (when (boundp '*free-funs*)
-    (clrhash *free-funs*)
-    (clrhash *free-vars*)
-    (clrhash *constants*))
-
-  ;; Clear debug counters and tables.
-  (clrhash *seen-blocks*)
-  (clrhash *seen-funs*)
-  (clrhash *list-conflicts-table*)
-
-  (when debug-too
-    (clrhash *continuation-numbers*)
-    (clrhash *number-continuations*)
-    (setq *continuation-number* 0)
-    (clrhash *tn-ids*)
-    (clrhash *id-tns*)
-    (setq *tn-id* 0)
-    (clrhash *label-ids*)
-    (clrhash *id-labels*)
-    (setq *label-id* 0))
-
-  ;; (Note: The CMU CL code used to set CL::*GENSYM-COUNTER* to zero here.
-  ;; Superficially, this seemed harmful -- the user could reasonably be
-  ;; surprised if *GENSYM-COUNTER* turned back to zero when something was
-  ;; compiled. A closer inspection showed that this actually turned out to be
-  ;; harmless in practice, because CLEAR-STUFF was only called from within
-  ;; forms which bound CL::*GENSYM-COUNTER* to zero. However, this means that
-  ;; even though zeroing CL::*GENSYM-COUNTER* here turned out to be harmless in
-  ;; practice, it was also useless in practice. So we don't do it any more.)
-
-  (values))

 \f
 ;;;; trace output
 
 \f
 ;;;; trace output
 

@@ -879,21 +885,27 @@ Following options are defined:
   (handler-case
       (read-preserving-whitespace stream nil stream)
     (reader-error (condition)
   (handler-case
       (read-preserving-whitespace stream nil stream)
     (reader-error (condition)

-     (error 'input-error-in-compile-file
-            :condition condition
-            ;; We don't need to supply :POSITION here because
-            ;; READER-ERRORs already know their position in the file.
-            ))
+      (compiler-error 'input-error-in-compile-file
+                      ;; We don't need to supply :POSITION here because
+                      ;; READER-ERRORs already know their position in the file.
+                      :condition condition
+                      :stream stream))

     ;; ANSI, in its wisdom, says that READ should return END-OF-FILE
     ;; (and that this is not a READER-ERROR) when it encounters end of
     ;; file in the middle of something it's trying to read.
     (end-of-file (condition)
     ;; ANSI, in its wisdom, says that READ should return END-OF-FILE
     ;; (and that this is not a READER-ERROR) when it encounters end of
     ;; file in the middle of something it's trying to read.
     (end-of-file (condition)

-     (error 'input-error-in-compile-file
-            :condition condition
-            ;; We need to supply :POSITION here because the END-OF-FILE
-            ;; condition doesn't carry the position that the user
-            ;; probably cares about, where the failed READ began.
-            :position position))))
+      (compiler-error 'input-error-in-compile-file
+                      :condition condition
+                      ;; We need to supply :POSITION here because the END-OF-FILE
+                      ;; condition doesn't carry the position that the user
+                      ;; probably cares about, where the failed READ began.
+                      :position position
+                      :stream stream))
+    (error (condition)
+      (compiler-error 'input-error-in-compile-file
+                      :condition condition
+                      :position position
+                      :stream stream))))

 
 ;;; If STREAM is present, return it, otherwise open a stream to the
 ;;; current file. There must be a current file.
 
 ;;; If STREAM is present, return it, otherwise open a stream to the
 ;;; current file. There must be a current file.

@@ -954,9 +966,10 @@ Following options are defined:
 ;;; Read and compile the source file.
 (defun sub-sub-compile-file (info)
   (do-forms-from-info ((form current-index) info)
 ;;; Read and compile the source file.
 (defun sub-sub-compile-file (info)
   (do-forms-from-info ((form current-index) info)

-    (find-source-paths form current-index)
-    (process-toplevel-form
-     form `(original-source-start 0 ,current-index) nil)))
+    (with-source-paths
+      (find-source-paths form current-index)
+      (process-toplevel-form
+       form `(original-source-start 0 ,current-index) nil))))

 
 ;;; Return the INDEX'th source form read from INFO and the position
 ;;; where it was read.
 
 ;;; Return the INDEX'th source form read from INFO and the position
 ;;; where it was read.

@@ -980,21 +993,22 @@ Following options are defined:
       (if (fopcompilable-p form)
          (let ((*fopcompile-label-counter* 0))
            (fopcompile form path nil))
       (if (fopcompilable-p form)
          (let ((*fopcompile-label-counter* 0))
            (fopcompile form path nil))

-         (let ((*lexenv* (make-lexenv
-                          :policy *policy*
-                          :handled-conditions *handled-conditions*
-                          :disabled-package-locks *disabled-package-locks*))
-               (tll (ir1-toplevel form path nil)))
-           (if (eq *block-compile* t)
-               (push tll *toplevel-lambdas*)
-               (compile-toplevel (list tll) nil))
-           nil)))))
+         (with-ir1-namespace
+           (let ((*lexenv* (make-lexenv
+                            :policy *policy*
+                            :handled-conditions *handled-conditions*
+                            :disabled-package-locks *disabled-package-locks*))
+                 (tll (ir1-toplevel form path nil)))
+             (if (eq *block-compile* t)
+                 (push tll *toplevel-lambdas*)
+                 (compile-toplevel (list tll) nil))
+             nil))))))

 
 ;;; Macroexpand FORM in the current environment with an error handler.
 ;;; We only expand one level, so that we retain all the intervening
 ;;; forms in the source path.
 (defun preprocessor-macroexpand-1 (form)
 
 ;;; Macroexpand FORM in the current environment with an error handler.
 ;;; We only expand one level, so that we retain all the intervening
 ;;; forms in the source path.
 (defun preprocessor-macroexpand-1 (form)

-  (handler-case (sb!xc:macroexpand-1 form *lexenv*)
+  (handler-case (%macroexpand-1 form *lexenv*)

     (error (condition)
       (compiler-error "(during macroexpansion of ~A)~%~A"
                       (let ((*print-level* 2)
     (error (condition)
       (compiler-error "(during macroexpansion of ~A)~%~A"
                       (let ((*print-level* 2)

@@ -1017,25 +1031,26 @@ Following options are defined:
   (declare (list path))
   (multiple-value-bind (forms decls)
       (parse-body body :doc-string-allowed nil :toplevel t)
   (declare (list path))
   (multiple-value-bind (forms decls)
       (parse-body body :doc-string-allowed nil :toplevel t)

-    (let* ((*lexenv* (process-decls decls vars funs))
-           ;; FIXME: VALUES declaration
-           ;;
-           ;; Binding *POLICY* is pretty much of a hack, since it
-           ;; causes LOCALLY to "capture" enclosed proclamations. It
-           ;; is necessary because CONVERT-AND-MAYBE-COMPILE uses the
-           ;; value of *POLICY* as the policy. The need for this hack
-           ;; is due to the quirk that there is no way to represent in
-           ;; a POLICY that an optimize quality came from the default.
-           ;;
-           ;; FIXME: Ideally, something should be done so that DECLAIM
-           ;; inside LOCALLY works OK. Failing that, at least we could
-           ;; issue a warning instead of silently screwing up.
-           (*policy* (lexenv-policy *lexenv*))
-           ;; This is probably also a hack
-           (*handled-conditions* (lexenv-handled-conditions *lexenv*))
-           ;; ditto
-           (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)))
-      (process-toplevel-progn forms path compile-time-too))))
+    (with-ir1-namespace
+      (let* ((*lexenv* (process-decls decls vars funs))
+             ;; FIXME: VALUES declaration
+             ;;
+             ;; Binding *POLICY* is pretty much of a hack, since it
+             ;; causes LOCALLY to "capture" enclosed proclamations. It
+             ;; is necessary because CONVERT-AND-MAYBE-COMPILE uses the
+             ;; value of *POLICY* as the policy. The need for this hack
+             ;; is due to the quirk that there is no way to represent in
+             ;; a POLICY that an optimize quality came from the default.
+             ;;
+             ;; FIXME: Ideally, something should be done so that DECLAIM
+             ;; inside LOCALLY works OK. Failing that, at least we could
+             ;; issue a warning instead of silently screwing up.
+             (*policy* (lexenv-policy *lexenv*))
+             ;; This is probably also a hack
+             (*handled-conditions* (lexenv-handled-conditions *lexenv*))
+             ;; ditto
+             (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)))
+        (process-toplevel-progn forms path compile-time-too)))))

 
 ;;; Parse an EVAL-WHEN situations list, returning three flags,
 ;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
 
 ;;; Parse an EVAL-WHEN situations list, returning three flags,
 ;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating

@@ -1092,28 +1107,39 @@ Following options are defined:
          (source-name (or name '.anonymous.)))
     (setf (component-name component) (debug-name 'initial-component debug-name-tail)
           (component-kind component) :initial)
          (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
                                     :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.
 
 ;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a
 ;;; description of the result.

@@ -1137,78 +1163,78 @@ Following options are defined:
                   '(original-source-start 0 0)))
   (when name
     (legal-fun-name-or-type-error name))
                   '(original-source-start 0 0)))
   (when name
     (legal-fun-name-or-type-error name))

-  (let* ((*lexenv* (make-lexenv
-                    :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)))
-
-    ;; FIXME: The compile-it code from here on is sort of a
-    ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
-    ;; better to find a way to share the code there; or
-    ;; alternatively, to use this code to replace the code there.
-    ;; (The second alternative might be pretty easy if we used
-    ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
-    ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
-
-    (locall-analyze-clambdas-until-done (list fun))
-
-    (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
-                                         *compile-object*))
-                           (core-object (core-object-entry-table
-                                         *compile-object*)))))
-        (multiple-value-bind (result found-p)
-            (gethash (leaf-info fun) entry-table)
-          (aver found-p)
-          (prog1
-              result
-            ;; KLUDGE: This code duplicates some other code in this
-            ;; file. In the great reorganzation, the flow of program
-            ;; logic changed from the original CMUCL model, and that
-            ;; path (as of sbcl-0.7.5 in SUB-COMPILE-FILE) was no
-            ;; longer followed for CORE-OBJECTS, leading to BUG
-            ;; 156. This place is transparently not the right one for
-            ;; this code, but I don't have a clear enough overview of
-            ;; the compiler to know how to rearrange it all so that
-            ;; this operation fits in nicely, and it was blocking
-            ;; reimplementation of (DECLAIM (INLINE FOO)) (MACROLET
-            ;; ((..)) (DEFUN FOO ...))
-            ;;
-            ;; FIXME: This KLUDGE doesn't solve all the problem in an
-            ;; ideal way, as (1) definitions typed in at the REPL
-            ;; without an INLINE declaration will give a NULL
-            ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal)
-            ;; and (2) INLINE declarations will yield a
-            ;; FUNCTION-LAMBDA-EXPRESSION headed by
-            ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV.  -- CSR,
-            ;; 2002-07-02
-            ;;
-            ;; (2) is probably fairly easy to fix -- it is, after all,
-            ;; a matter of list manipulation (or possibly of teaching
-            ;; CL:FUNCTION about SB-C:LAMBDA-WITH-LEXENV).  (1) is
-            ;; significantly harder, as the association between
-            ;; function object and source is a tricky one.
-            ;;
-            ;; FUNCTION-LAMBDA-EXPRESSION "works" (i.e. returns a
-            ;; non-NULL list) when the function in question has been
-            ;; compiled by (COMPILE <x> '(LAMBDA ...)); it does not
-            ;; work when it has been compiled as part of the top-level
-            ;; EVAL strategy of compiling everything inside (LAMBDA ()
-            ;; ...).  -- CSR, 2002-11-02
-            (when (core-object-p *compile-object*)
-              (fix-core-source-info *source-info* *compile-object* result))
-
-            (mapc #'clear-ir1-info components-from-dfo)
-            (clear-stuff)))))))
+  (with-ir1-namespace
+    (let* ((*lexenv* (make-lexenv
+                      :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)))
+
+      ;; FIXME: The compile-it code from here on is sort of a
+      ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
+      ;; better to find a way to share the code there; or
+      ;; alternatively, to use this code to replace the code there.
+      ;; (The second alternative might be pretty easy if we used
+      ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
+      ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
+
+      (locall-analyze-clambdas-until-done (list fun))
+
+      (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
+                                           *compile-object*))
+                             (core-object (core-object-entry-table
+                                           *compile-object*)))))
+          (multiple-value-bind (result found-p)
+              (gethash (leaf-info fun) entry-table)
+            (aver found-p)
+            (prog1
+                result
+              ;; KLUDGE: This code duplicates some other code in this
+              ;; file. In the great reorganzation, the flow of program
+              ;; logic changed from the original CMUCL model, and that
+              ;; path (as of sbcl-0.7.5 in SUB-COMPILE-FILE) was no
+              ;; longer followed for CORE-OBJECTS, leading to BUG
+              ;; 156. This place is transparently not the right one for
+              ;; this code, but I don't have a clear enough overview of
+              ;; the compiler to know how to rearrange it all so that
+              ;; this operation fits in nicely, and it was blocking
+              ;; reimplementation of (DECLAIM (INLINE FOO)) (MACROLET
+              ;; ((..)) (DEFUN FOO ...))
+              ;;
+              ;; FIXME: This KLUDGE doesn't solve all the problem in an
+              ;; ideal way, as (1) definitions typed in at the REPL
+              ;; without an INLINE declaration will give a NULL
+              ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal)
+              ;; and (2) INLINE declarations will yield a
+              ;; FUNCTION-LAMBDA-EXPRESSION headed by
+              ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV.  -- CSR,
+              ;; 2002-07-02
+              ;;
+              ;; (2) is probably fairly easy to fix -- it is, after all,
+              ;; a matter of list manipulation (or possibly of teaching
+              ;; CL:FUNCTION about SB-C:LAMBDA-WITH-LEXENV).  (1) is
+              ;; significantly harder, as the association between
+              ;; function object and source is a tricky one.
+              ;;
+              ;; FUNCTION-LAMBDA-EXPRESSION "works" (i.e. returns a
+              ;; non-NULL list) when the function in question has been
+              ;; compiled by (COMPILE <x> '(LAMBDA ...)); it does not
+              ;; work when it has been compiled as part of the top-level
+              ;; EVAL strategy of compiling everything inside (LAMBDA ()
+              ;; ...).  -- CSR, 2002-11-02
+              (when (core-object-p *compile-object*)
+                (fix-core-source-info *source-info* *compile-object* result))
+
+              (mapc #'clear-ir1-info components-from-dfo))))))))

 
 (defun process-toplevel-cold-fset (name lambda-expression path)
   (unless (producing-fasl-file)
 
 (defun process-toplevel-cold-fset (name lambda-expression path)
   (unless (producing-fasl-file)

@@ -1229,8 +1255,10 @@ Following options are defined:
                  (*print-level* 2)
                  (*print-pretty* nil))
              (with-compiler-io-syntax
                  (*print-level* 2)
                  (*print-pretty* nil))
              (with-compiler-io-syntax

-                 (compiler-mumble "~&; ~:[compiling~;converting~] ~S"
-                                  *block-compile* form)))
+                 (compiler-mumble
+                  #-sb-xc-host "~&; ~:[compiling~;converting~] ~S"
+                  #+sb-xc-host "~&; ~:[x-compiling~;x-converting~] ~S"
+                  *block-compile* form)))

              form)
           ((and finalp
                 (eq :top-level-forms *compile-print*)
              form)
           ((and finalp
                 (eq :top-level-forms *compile-print*)

@@ -1248,10 +1276,7 @@ Following options are defined:
 ;;; compilation. Normally just evaluate in the appropriate
 ;;; environment, but also compile if outputting a CFASL.
 (defun eval-compile-toplevel (body path)
 ;;; compilation. Normally just evaluate in the appropriate
 ;;; environment, but also compile if outputting a CFASL.
 (defun eval-compile-toplevel (body path)

-  (handler-case (eval-in-lexenv `(progn ,@body) *lexenv*)
-    (error (condition)
-      (compiler-error "(during compile-time-too processing)~%~A"
-                      condition)))
+  (eval-tlf `(progn ,@body) (source-path-tlf-number path) *lexenv*)

   (when *compile-toplevel-object*
     (let ((*compile-object* *compile-toplevel-object*))
       (convert-and-maybe-compile `(progn ,@body) path))))
   (when *compile-toplevel-object*
     (let ((*compile-object* *compile-toplevel-object*))
       (convert-and-maybe-compile `(progn ,@body) path))))

@@ -1541,8 +1566,7 @@ Following options are defined:
           (compile-load-time-value-lambda lambdas)
           (compile-toplevel-lambdas lambdas))
 
           (compile-load-time-value-lambda lambdas)
           (compile-toplevel-lambdas lambdas))
 

-      (mapc #'clear-ir1-info components)
-      (clear-stuff)))
+      (mapc #'clear-ir1-info components)))

   (values))
 
 ;;; Actually compile any stuff that has been queued up for block
   (values))
 
 ;;; Actually compile any stuff that has been queued up for block

@@ -1615,8 +1639,8 @@ Following options are defined:
         (*fun-names-in-this-file* ())
         (*allow-instrumenting* nil)
         (*compiler-error-bailout*
         (*fun-names-in-this-file* ())
         (*allow-instrumenting* nil)
         (*compiler-error-bailout*

-         (lambda ()
-           (compiler-mumble "~2&; fatal error, aborting compilation~%")
+         (lambda (&optional error)
+           (declare (ignore error))

            (return-from sub-compile-file (values t t t))))
         (*current-path* nil)
         (*last-source-context* nil)
            (return-from sub-compile-file (values t t t))))
         (*current-path* nil)
         (*last-source-context* nil)

@@ -1636,31 +1660,29 @@ Following options are defined:
     (handler-case
         (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
           (with-compilation-values
     (handler-case
         (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
           (with-compilation-values

-              (sb!xc:with-compilation-unit ()
-                (clear-stuff)
-
+            (sb!xc:with-compilation-unit ()
+              (with-world-lock ()

                 (sub-sub-compile-file info)
                 (sub-sub-compile-file info)

-

                 (unless (zerop (hash-table-count *code-coverage-records*))
                   ;; Dump the code coverage records into the fasl.
                 (unless (zerop (hash-table-count *code-coverage-records*))
                   ;; Dump the code coverage records into the fasl.

-                  (fopcompile `(record-code-coverage
-                                ',(namestring *compile-file-pathname*)
-                                ',(let (list)
-                                       (maphash (lambda (k v)
-                                                  (declare (ignore k))
-                                                  (push v list))
-                                                *code-coverage-records*)
-                                       list))
-                              nil
-                              nil))
-
+                  (with-source-paths
+                    (fopcompile `(record-code-coverage
+                                  ',(namestring *compile-file-pathname*)
+                                  ',(let (list)
+                                      (maphash (lambda (k v)
+                                                 (declare (ignore k))
+                                                 (push v list))
+                                               *code-coverage-records*)
+                                      list))
+                                nil
+                                nil)))

                 (finish-block-compilation)
                 (let ((object *compile-object*))
                   (etypecase object
                     (fasl-output (fasl-dump-source-info info object))
                     (core-object (fix-core-source-info info object))
                     (null)))
                 (finish-block-compilation)
                 (let ((object *compile-object*))
                   (etypecase object
                     (fasl-output (fasl-dump-source-info info object))
                     (core-object (fix-core-source-info info object))
                     (null)))

-                nil)))
+                nil))))

       ;; Some errors are sufficiently bewildering that we just fail
       ;; immediately, without trying to recover and compile more of
       ;; the input file.
       ;; Some errors are sufficiently bewildering that we just fail
       ;; immediately, without trying to recover and compile more of
       ;; the input file.

@@ -2020,6 +2042,6 @@ SPEED and COMPILATION-SPEED optimization values, and the
   (compile name lambda))
 
 #+sb-xc-host
   (compile name lambda))
 
 #+sb-xc-host

-(defun eval-in-lexenv (form lexenv)
-  (declare (ignore lexenv))
+(defun eval-tlf (form index &optional lexenv)
+  (declare (ignore index lexenv))

   (eval form))
   (eval form))