0.8.19.30: less COMPILE-FILE verbosity
[sbcl.git] / src / compiler / main.lisp
index 79e0c45..3465260 100644 (file)
@@ -28,7 +28,8 @@
                  #!+sb-show *compiler-trace-output*
                  *last-source-context* *last-original-source*
                  *last-source-form* *last-format-string* *last-format-args*
                  #!+sb-show *compiler-trace-output*
                  *last-source-context* *last-original-source*
                  *last-source-form* *last-format-string* *last-format-args*
-                 *last-message-count* *lexenv* *fun-names-in-this-file*))
+                 *last-message-count* *lexenv* *fun-names-in-this-file*
+                  *allow-instrumenting*))
 
 ;;; Whether call of a function which cannot be defined causes a full
 ;;; warning.
 
 ;;; Whether call of a function which cannot be defined causes a full
 ;;; warning.
@@ -37,6 +38,9 @@
 (defvar *check-consistency* nil)
 (defvar *all-components*)
 
 (defvar *check-consistency* nil)
 (defvar *all-components*)
 
+;;; Set to NIL to disable loop analysis for register allocation. 
+(defvar *loop-analyze* t)
+
 ;;; Bind this to a stream to capture various internal debugging output.
 (defvar *compiler-trace-output* nil)
 
 ;;; Bind this to a stream to capture various internal debugging output.
 (defvar *compiler-trace-output* nil)
 
 (defvar *toplevel-lambdas*)
 (declaim (list *toplevel-lambdas*))
 
 (defvar *toplevel-lambdas*)
 (declaim (list *toplevel-lambdas*))
 
+;;; The current non-macroexpanded toplevel form as printed when
+;;; *compile-print* is true.
+(defvar *top-level-form-noted* nil)
+
 (defvar sb!xc:*compile-verbose* t
   #!+sb-doc
   "The default for the :VERBOSE argument to COMPILE-FILE.")
 (defvar sb!xc:*compile-verbose* t
   #!+sb-doc
   "The default for the :VERBOSE argument to COMPILE-FILE.")
@@ -65,7 +73,7 @@
   "The default for the :PRINT argument to COMPILE-FILE.")
 (defvar *compile-progress* nil
   #!+sb-doc
   "The default for the :PRINT argument to COMPILE-FILE.")
 (defvar *compile-progress* nil
   #!+sb-doc
-  "When this is true, the compiler prints to *ERROR-OUTPUT* progress
+  "When this is true, the compiler prints to *STANDARD-OUTPUT* progress
   information about the phases of compilation of each function. (This
   is useful mainly in large block compilations.)")
 
   information about the phases of compilation of each function. (This
   is useful mainly in large block compilations.)")
 
 ;;; normally causes nested uses to be no-ops).
 (defvar *in-compilation-unit* nil)
 
 ;;; normally causes nested uses to be no-ops).
 (defvar *in-compilation-unit* nil)
 
-;;; This lock is siezed in the same situation: the compiler is not
-;;; presently thread-safe
-(defvar *big-compiler-lock*
-  (sb!thread:make-mutex :name "big compiler lock"))
-
 ;;; Count of the number of compilation units dynamically enclosed by
 ;;; the current active WITH-COMPILATION-UNIT that were unwound out of.
 (defvar *aborted-compilation-unit-count*)
 ;;; Count of the number of compilation units dynamically enclosed by
 ;;; the current active WITH-COMPILATION-UNIT that were unwound out of.
 (defvar *aborted-compilation-unit-count*)
 (defun maybe-mumble (&rest foo)
   (when *compile-progress*
     (compiler-mumble "~&")
 (defun maybe-mumble (&rest foo)
   (when *compile-progress*
     (compiler-mumble "~&")
-    (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+    (pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
        (apply #'compiler-mumble foo))))
 
 (deftype object () '(or fasl-output core-object null))
        (apply #'compiler-mumble foo))))
 
 (deftype object () '(or fasl-output core-object null))
   is intended to be wrapped around the compilation of all files in the same
   system. These keywords are defined:
     :OVERRIDE Boolean-Form
   is intended to be wrapped around the compilation of all files in the same
   system. These keywords are defined:
     :OVERRIDE Boolean-Form
-       One of the effects of this form is to delay undefined warnings
-       until the end of the form, instead of giving them at the end of each
-       compilation. If OVERRIDE is NIL (the default), then the outermost
-       WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
-       OVERRIDE true causes that form to grab any enclosed warnings, even if
-       it is enclosed by another WITH-COMPILATION-UNIT."
+        One of the effects of this form is to delay undefined warnings
+        until the end of the form, instead of giving them at the end of each
+        compilation. If OVERRIDE is NIL (the default), then the outermost
+        WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
+        OVERRIDE true causes that form to grab any enclosed warnings, even if
+        it is enclosed by another WITH-COMPILATION-UNIT."
   `(%with-compilation-unit (lambda () ,@body) ,@options))
 
 (defun %with-compilation-unit (fn &key override)
   `(%with-compilation-unit (lambda () ,@body) ,@options))
 
 (defun %with-compilation-unit (fn &key override)
                    (t
                     (compiler-warn
                      "~@<The ~(~A~) ~S is undefined, and its name is ~
                    (t
                     (compiler-warn
                      "~@<The ~(~A~) ~S is undefined, and its name is ~
-                       reserved by ANSI CL so that even if it it were ~
+                       reserved by ANSI CL so that even if it were ~
                        defined later, the code doing so would not be ~
                        portable.~:@>"
                      kind name)))
                        defined later, the code doing so would not be ~
                        portable.~:@>"
                      kind name)))
-                  (compiler-style-warn "undefined ~(~A~): ~S" kind name)))
+                 (if (eq kind :variable)
+                     (compiler-warn "undefined ~(~A~): ~S" kind name)
+                     (compiler-style-warn "undefined ~(~A~): ~S" kind name))))
            (let ((warn-count (length warnings)))
              (when (and warnings (> undefined-warning-count warn-count))
                (let ((more (- undefined-warning-count warn-count)))
            (let ((warn-count (length warnings)))
              (when (and warnings (> undefined-warning-count warn-count))
                (let ((more (- undefined-warning-count warn-count)))
-                 (compiler-style-warn
-                  "~W more use~:P of undefined ~(~A~) ~S"
-                  more kind name))))))
+                 (if (eq kind :variable)
+                     (compiler-warn
+                      "~W more use~:P of undefined ~(~A~) ~S"
+                      more kind name)
+                     (compiler-style-warn
+                      "~W more use~:P of undefined ~(~A~) ~S"
+                      more kind name)))))))
 
        (dolist (kind '(:variable :function :type))
          (let ((summary (mapcar #'undefined-warning-name
 
        (dolist (kind '(:variable :function :type))
          (let ((summary (mapcar #'undefined-warning-name
-                                (remove kind undefs :test-not #'eq
+                                (remove kind undefs :test #'neq
                                         :key #'undefined-warning-kind))))
            (when summary
                                         :key #'undefined-warning-kind))))
            (when summary
-             (compiler-style-warn
-              "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
-               ~%  ~{~<~%  ~1:;~S~>~^ ~}"
-              (cdr summary) kind summary)))))))
+             (if (eq kind :variable)
+                 (compiler-warn
+                   "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+                    ~%  ~{~<~%  ~1:;~S~>~^ ~}"
+                  (cdr summary) kind summary)
+                 (compiler-style-warn
+                   "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+                   ~%  ~{~<~%  ~1:;~S~>~^ ~}"
+                  (cdr summary) kind summary))))))))
 
   (unless (and (not abort-p)
               (zerop *aborted-compilation-unit-count*)
 
   (unless (and (not abort-p)
               (zerop *aborted-compilation-unit-count*)
               (zerop *compiler-warning-count*)
               (zerop *compiler-style-warning-count*)
               (zerop *compiler-note-count*))
               (zerop *compiler-warning-count*)
               (zerop *compiler-style-warning-count*)
               (zerop *compiler-note-count*))
-    (format *error-output* "~&")
-    (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+    (fresh-line *standard-output*)
+    (pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
       (compiler-mumble "compilation unit ~:[finished~;aborted~]~
                        ~[~:;~:*~&  caught ~W fatal ERROR condition~:P~]~
                        ~[~:;~:*~&  caught ~W ERROR condition~:P~]~
       (compiler-mumble "compilation unit ~:[finished~;aborted~]~
                        ~[~:;~:*~&  caught ~W fatal ERROR condition~:P~]~
                        ~[~:;~:*~&  caught ~W ERROR condition~:P~]~
                       *compiler-warning-count*
                       *compiler-style-warning-count*
                       *compiler-note-count*)))
                       *compiler-warning-count*
                       *compiler-style-warning-count*
                       *compiler-note-count*)))
-  (format *error-output* "~&"))
+  (fresh-line *standard-output*))
 
 ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
 ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and
 
 ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
 ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and
   (maybe-mumble "opt")
   (event ir1-optimize-until-done)
   (let ((count 0)
   (maybe-mumble "opt")
   (event ir1-optimize-until-done)
   (let ((count 0)
-       (cleared-reanalyze nil))
+       (cleared-reanalyze nil)
+        (fastp nil))
     (loop
       (when (component-reanalyze component)
        (setq count 0)
        (setq cleared-reanalyze t)
        (setf (component-reanalyze component) nil))
       (setf (component-reoptimize component) nil)
     (loop
       (when (component-reanalyze component)
        (setq count 0)
        (setq cleared-reanalyze t)
        (setf (component-reanalyze component) nil))
       (setf (component-reoptimize component) nil)
-      (ir1-optimize component)
+      (ir1-optimize component fastp)
       (cond ((component-reoptimize component)
              (incf count)
       (cond ((component-reoptimize component)
              (incf count)
-             (when (= count *max-optimize-iterations*)
+             (when (and (>= count *max-optimize-iterations*)
+                        (not (component-reanalyze component))
+                        (eq (component-reoptimize component) :maybe))
                (maybe-mumble "*")
                (cond ((retry-delayed-ir1-transforms :optimize)
                      (maybe-mumble "+")
                (maybe-mumble "*")
                (cond ((retry-delayed-ir1-transforms :optimize)
                      (maybe-mumble "+")
            (t
              (maybe-mumble " ")
             (return)))
            (t
              (maybe-mumble " ")
             (return)))
-      (maybe-mumble "."))
+      (setq fastp (>= count *max-optimize-iterations*))
+      (maybe-mumble (if fastp "-" ".")))
     (when cleared-reanalyze
       (setf (component-reanalyze component) t)))
   (values))
     (when cleared-reanalyze
       (setf (component-reanalyze component) t)))
   (values))
     (maybe-mumble "control ")
     (control-analyze component #'make-ir2-block)
 
     (maybe-mumble "control ")
     (control-analyze component #'make-ir2-block)
 
-    (when (ir2-component-values-receivers (component-info component))
+    (when (or (ir2-component-values-receivers (component-info component))
+              (component-dx-lvars component))
       (maybe-mumble "stack ")
       (stack-analyze component)
       ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by
       (maybe-mumble "stack ")
       (stack-analyze component)
       ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by
 
          (when *compile-progress*
            (compiler-mumble "") ; Sync before doing more output.
 
          (when *compile-progress*
            (compiler-mumble "") ; Sync before doing more output.
-           (pre-pack-tn-stats component *error-output*))
+           (pre-pack-tn-stats component *standard-output*))
 
          (when *check-consistency*
            (maybe-mumble "check-life ")
 
          (when *check-consistency*
            (maybe-mumble "check-life ")
            (describe-ir2-component component *compiler-trace-output*))
 
          (maybe-mumble "code ")
            (describe-ir2-component component *compiler-trace-output*))
 
          (maybe-mumble "code ")
-         (multiple-value-bind (code-length trace-table fixups)
+         (multiple-value-bind (code-length trace-table fixup-notes)
              (generate-code component)
 
              (generate-code component)
 
+            #-sb-xc-host
            (when *compiler-trace-output*
              (format *compiler-trace-output*
                      "~|~%disassembly of code for ~S~2%" component)
            (when *compiler-trace-output*
              (format *compiler-trace-output*
                      "~|~%disassembly of code for ~S~2%" component)
                                    *code-segment*
                                    code-length
                                    trace-table
                                    *code-segment*
                                    code-length
                                    trace-table
-                                   fixups
+                                   fixup-notes
                                    *compile-object*))
              (core-object
               (maybe-mumble "core")
                                    *compile-object*))
              (core-object
               (maybe-mumble "core")
                                    *code-segment*
                                    code-length
                                    trace-table
                                    *code-segment*
                                    code-length
                                    trace-table
-                                   fixups
+                                   fixup-notes
                                    *compile-object*))
              (null))))))
 
                                    *compile-object*))
              (null))))))
 
     (aver (eql (node-component (lambda-bind lambda)) component)))
 
   (let* ((*component-being-compiled* component))
     (aver (eql (node-component (lambda-bind lambda)) component)))
 
   (let* ((*component-being-compiled* component))
-    (when sb!xc:*compile-print*
-      (compiler-mumble "~&; compiling ~A: " (component-name component)))
 
     (ir1-phases component)
 
 
     (ir1-phases component)
 
+    (when *loop-analyze*
+      (dfo-as-needed component)
+      (find-dominators component)
+      (loop-analyze component))
+
+    #|
+    (when (and *loop-analyze* *compiler-trace-output*)
+      (labels ((print-blocks (block)
+                (format *compiler-trace-output* "    ~A~%" block)
+                (when (block-loop-next block)
+                  (print-blocks (block-loop-next block))))
+              (print-loop (loop)
+                (format *compiler-trace-output* "loop=~A~%" loop)
+                (print-blocks (loop-blocks loop))
+                (dolist (l (loop-inferiors loop))
+                  (print-loop l))))
+       (print-loop (component-outer-loop component))))
+    |#
+    
     ;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more?
     (maybe-mumble "env ")
     (physenv-analyze component)
     ;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more?
     (maybe-mumble "env ")
     (physenv-analyze component)
       (%compile-component component)))
 
   (clear-constant-info)
       (%compile-component component)))
 
   (clear-constant-info)
-
-  (when sb!xc:*compile-print*
-    (compiler-mumble "~&"))
-
+  
   (values))
 \f
 ;;;; clearing global data structures
   (values))
 \f
 ;;;; clearing global data structures
     (setq *tn-id* 0)
     (clrhash *label-ids*)
     (clrhash *id-labels*)
     (setq *tn-id* 0)
     (clrhash *label-ids*)
     (clrhash *id-labels*)
-    (setq *label-id* 0)
-
-    ;; Clear some PACK data structures (for GC purposes only).
-    (aver (not *in-pack*))
-    (dolist (sb *backend-sb-list*)
-      (when (finite-sb-p sb)
-       (fill (finite-sb-live-tns sb) nil))))
+    (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
 
   ;; (Note: The CMU CL code used to set CL::*GENSYM-COUNTER* to zero here.
   ;; Superficially, this seemed harmful -- the user could reasonably be
 (defun describe-component (component *standard-output*)
   (declare (type component component))
   (format t "~|~%;;;; component: ~S~2%" (component-name component))
 (defun describe-component (component *standard-output*)
   (declare (type component component))
   (format t "~|~%;;;; component: ~S~2%" (component-name component))
-  (print-blocks component)
+  (print-all-blocks component)
   (values))
 
 (defun describe-ir2-component (component *standard-output*)
   (values))
 
 (defun describe-ir2-component (component *standard-output*)
     (format t "~4TL~D: ~S~:[~; [closure]~]~%"
            (label-id (entry-info-offset entry))
            (entry-info-name entry)
     (format t "~4TL~D: ~S~:[~; [closure]~]~%"
            (label-id (entry-info-offset entry))
            (entry-info-name entry)
-           (entry-info-closure-p entry)))
+           (entry-info-closure-tn entry)))
   (terpri)
   (pre-pack-tn-stats component *standard-output*)
   (terpri)
   (terpri)
   (pre-pack-tn-stats component *standard-output*)
   (terpri)
 
 ;;; A FILE-INFO structure holds all the source information for a
 ;;; given file.
 
 ;;; A FILE-INFO structure holds all the source information for a
 ;;; given file.
-(defstruct (file-info (:copier nil))
+(def!struct (file-info (:copier nil))
   ;; If a file, the truename of the corresponding source file. If from
   ;; a Lisp form, :LISP. If from a stream, :STREAM.
   (name (missing-arg) :type (or pathname (member :lisp :stream)))
   ;; If a file, the truename of the corresponding source file. If from
   ;; a Lisp form, :LISP. If from a stream, :STREAM.
   (name (missing-arg) :type (or pathname (member :lisp :stream)))
+  ;; the external format that we'll call OPEN with, if NAME is a file.
+  (external-format nil)
   ;; the defaulted, but not necessarily absolute file name (i.e. prior
   ;; to TRUENAME call.) Null if not a file. This is used to set
   ;; *COMPILE-FILE-PATHNAME*, and if absolute, is dumped in the
   ;; the defaulted, but not necessarily absolute file name (i.e. prior
   ;; to TRUENAME call.) Null if not a file. This is used to set
   ;; *COMPILE-FILE-PATHNAME*, and if absolute, is dumped in the
 
 ;;; The SOURCE-INFO structure provides a handle on all the source
 ;;; information for an entire compilation.
 
 ;;; The SOURCE-INFO structure provides a handle on all the source
 ;;; information for an entire compilation.
-(defstruct (source-info
-           #-no-ansi-print-object
-           (:print-object (lambda (s stream)
-                            (print-unreadable-object (s stream :type t))))
-           (:copier nil))
+(def!struct (source-info
+            #-no-ansi-print-object
+            (:print-object (lambda (s stream)
+                             (print-unreadable-object (s stream :type t))))
+            (:copier nil))
   ;; the UT that compilation started at
   (start-time (get-universal-time) :type unsigned-byte)
   ;; the FILE-INFO structure for this compilation
   ;; the UT that compilation started at
   (start-time (get-universal-time) :type unsigned-byte)
   ;; the FILE-INFO structure for this compilation
   (stream nil :type (or stream null)))
 
 ;;; Given a pathname, return a SOURCE-INFO structure.
   (stream nil :type (or stream null)))
 
 ;;; Given a pathname, return a SOURCE-INFO structure.
-(defun make-file-source-info (file)
+(defun make-file-source-info (file external-format)
   (let ((file-info (make-file-info :name (truename file)
                                   :untruename file
   (let ((file-info (make-file-info :name (truename file)
                                   :untruename file
+                                   :external-format external-format
                                   :write-date (file-write-date file))))
 
     (make-source-info :file-info file-info)))
                                   :write-date (file-write-date file))))
 
     (make-source-info :file-info file-info)))
   (handler-case (read stream nil stream)
     (reader-error (condition)
      (error 'input-error-in-compile-file
   (handler-case (read stream nil stream)
     (reader-error (condition)
      (error 'input-error-in-compile-file
-           :error condition
+           :condition condition
            ;; We don't need to supply :POSITION here because
            ;; READER-ERRORs already know their position in the file.
            ))
            ;; We don't need to supply :POSITION here because
            ;; READER-ERRORs already know their position in the file.
            ))
     ;; file in the middle of something it's trying to read.
     (end-of-file (condition)
      (error 'input-error-in-compile-file
     ;; file in the middle of something it's trying to read.
     (end-of-file (condition)
      (error 'input-error-in-compile-file
-           :error condition
+           :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.
            ;; 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.
   (declare (type source-info info))
   (or (source-info-stream info)
       (let* ((file-info (source-info-file-info info))
   (declare (type source-info info))
   (or (source-info-stream info)
       (let* ((file-info (source-info-file-info info))
-            (name (file-info-name file-info)))
+            (name (file-info-name file-info))
+             (external-format (file-info-external-format file-info)))
        (setf sb!xc:*compile-file-truename* name
              sb!xc:*compile-file-pathname* (file-info-untruename file-info)
        (setf sb!xc:*compile-file-truename* name
              sb!xc:*compile-file-pathname* (file-info-untruename file-info)
-             (source-info-stream info) (open name :direction :input)))))
+             (source-info-stream info)
+              (open name :direction :input
+                    :external-format external-format)))))
 
 ;;; Close the stream in INFO if it is open.
 (defun close-source-info (info)
 
 ;;; Close the stream in INFO if it is open.
 (defun close-source-info (info)
 ;;; *TOPLEVEL-LAMBDAS* instead.
 (defun convert-and-maybe-compile (form path)
   (declare (list path))
 ;;; *TOPLEVEL-LAMBDAS* instead.
 (defun convert-and-maybe-compile (form path)
   (declare (list path))
-  (let* ((*lexenv* (make-lexenv :policy *policy*))
+  (let* ((*top-level-form-noted* (note-top-level-form form t))
+         (*lexenv* (make-lexenv 
+                    :policy *policy*
+                    :handled-conditions *handled-conditions*
+                    :disabled-package-locks *disabled-package-locks*))
         (tll (ir1-toplevel form path nil)))
         (tll (ir1-toplevel form path nil)))
-    (cond ((eq *block-compile* t) (push tll *toplevel-lambdas*))
-         (t (compile-toplevel (list tll) 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
 
 ;;; Macroexpand FORM in the current environment with an error handler.
 ;;; We only expand one level, so that we retain all the intervening
   (handler-case (sb!xc:macroexpand-1 form *lexenv*)
     (error (condition)
       (compiler-error "(during macroexpansion of ~A)~%~A"
   (handler-case (sb!xc:macroexpand-1 form *lexenv*)
     (error (condition)
       (compiler-error "(during macroexpansion of ~A)~%~A"
-                     (let ((*print-level* 1)
+                     (let ((*print-level* 2)
                            (*print-length* 2))
                        (format nil "~S" form))
                      condition))))
                            (*print-length* 2))
                        (format nil "~S" form))
                      condition))))
 ;;; We parse declarations and then recursively process the body.
 (defun process-toplevel-locally (body path compile-time-too &key vars funs)
   (declare (list path))
 ;;; We parse declarations and then recursively process the body.
 (defun process-toplevel-locally (body path compile-time-too &key vars funs)
   (declare (list path))
-  (multiple-value-bind (forms decls) (parse-body body nil)
-    (let* ((*lexenv*
-           (process-decls decls vars funs (make-continuation)))
+  (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
           ;; 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
           ;; 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.
           ;; 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*)))
+          (*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,
       (process-toplevel-progn forms path compile-time-too))))
 
 ;;; Parse an EVAL-WHEN situations list, returning three flags,
     (setf (component-name component)
          (debug-namify "~S initial component" name))
     (setf (component-kind component) :initial)
     (setf (component-name component)
          (debug-namify "~S initial component" name))
     (setf (component-kind component) :initial)
-    (let* ((locall-fun (ir1-convert-lambdalike
-                        definition
-                        :debug-name (debug-namify "top level local call ~S"
-                                                  name)
-                       ;; KLUDGE: we do this so that we get to have
-                       ;; nice debug returnness in functions defined
-                       ;; from the REPL
-                       :allow-debug-catch-tag t))
+    (let* ((locall-fun (let ((*allow-instrumenting* t))
+                         (ir1-convert-lambdalike
+                          definition
+                          :debug-name (debug-namify "top level local call "
+                                                    name))))
            (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
                                    :source-name (or name '.anonymous.)
                                    :debug-name (unless name
            (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
                                    :source-name (or name '.anonymous.)
                                    :debug-name (unless name
                  '(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*))
+  (let* (
+         (*lexenv* (make-lexenv :policy *policy*
+                               :handled-conditions *handled-conditions*
+                               :disabled-package-locks *disabled-package-locks*))
          (fun (make-functional-from-toplevel-lambda lambda-expression
                                                    :name name
                                                    :path path)))
          (fun (make-functional-from-toplevel-lambda lambda-expression
                                                    :name name
                                                    :path path)))
     ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
 
     (locall-analyze-clambdas-until-done (list fun))
     ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
 
     (locall-analyze-clambdas-until-done (list fun))
-    
+
     (multiple-value-bind (components-from-dfo top-components hairy-top)
         (find-initial-dfo (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)))
 
       (let ((*all-components* (append components-from-dfo top-components)))
-       ;; FIXME: This is more monkey see monkey do based on CMU CL
-       ;; code. If anyone figures out why to only prescan HAIRY-TOP
-       ;; and TOP-COMPONENTS here, instead of *ALL-COMPONENTS* or
-       ;; some other combination of results from FIND-INITIAL-VALUES,
-       ;; it'd be good to explain it.
-       (mapc #'preallocate-physenvs-for-toplevelish-lambdas hairy-top)
-       (mapc #'preallocate-physenvs-for-toplevelish-lambdas top-components)
         (dolist (component-from-dfo components-from-dfo)
           (compile-component component-from-dfo)
           (replace-toplevel-xeps component-from-dfo)))
         (dolist (component-from-dfo components-from-dfo)
           (compile-component component-from-dfo)
           (replace-toplevel-xeps component-from-dfo)))
                        *compile-object*)
   (values))
 
                        *compile-object*)
   (values))
 
+(defun note-top-level-form (form &optional finalp)
+  (when *compile-print*
+    (cond ((not *top-level-form-noted*)
+           (let ((*print-length* 2)
+                 (*print-level* 2)
+                 (*print-pretty* nil))
+             (with-compiler-io-syntax
+                 (compiler-mumble "~&; ~:[compiling~;converting~] ~S" 
+                                  *block-compile* form)))
+             form)
+          ((and finalp
+                (eq :top-level-forms *compile-print*)
+                (neq form *top-level-form-noted*))
+           (let ((*print-length* 1)
+                 (*print-level* 1)
+                 (*print-pretty* nil))
+             (with-compiler-io-syntax
+                 (compiler-mumble "~&; ... top level ~S" form)))
+           form)
+          (t
+           *top-level-form-noted*))))
+
 ;;; Process a top level FORM with the specified source PATH.
 ;;;  * If this is a magic top level form, then do stuff.
 ;;;  * If this is a macro, then expand it.
 ;;; Process a top level FORM with the specified source PATH.
 ;;;  * If this is a magic top level form, then do stuff.
 ;;;  * If this is a macro, then expand it.
 ;;; COMPILE-TIME-TOO is as defined in ANSI
 ;;; "3.2.3.1 Processing of Top Level Forms".
 (defun process-toplevel-form (form path compile-time-too)
 ;;; COMPILE-TIME-TOO is as defined in ANSI
 ;;; "3.2.3.1 Processing of Top Level Forms".
 (defun process-toplevel-form (form path compile-time-too)
-
   (declare (list path))
 
   (declare (list path))
 
-  (catch 'process-toplevel-form-error-abort
+  (catch 'process-toplevel-form-error-abort    
     (let* ((path (or (gethash form *source-paths*) (cons form path)))
           (*compiler-error-bailout*
     (let* ((path (or (gethash form *source-paths*) (cons form path)))
           (*compiler-error-bailout*
-           (lambda ()
+           (lambda (&optional condition)
              (convert-and-maybe-compile
              (convert-and-maybe-compile
-              `(error 'simple-program-error
-                :format-control "execution of a form compiled with errors:~% ~S"
-                :format-arguments (list ',form))
+              (make-compiler-error-form condition form)
               path)
              (throw 'process-toplevel-form-error-abort nil))))
 
       (flet ((default-processor (form)
               path)
              (throw 'process-toplevel-form-error-abort nil))))
 
       (flet ((default-processor (form)
-               ;; When we're cross-compiling, consider: what should we
-               ;; do when we hit e.g.
-               ;;   (EVAL-WHEN (:COMPILE-TOPLEVEL)
-               ;;     (DEFUN FOO (X) (+ 7 X)))?
-               ;; DEFUN has a macro definition in the cross-compiler,
-               ;; and a different macro definition in the target
-               ;; compiler. The only sensible thing is to use the
-               ;; target compiler's macro definition, since the
-               ;; cross-compiler's macro is in general into target
-               ;; functions which can't meaningfully be executed at
-               ;; cross-compilation time. So make sure we do the EVAL
-               ;; here, before we macroexpand.
-               ;;
-               ;; Then things get even dicier with something like
-               ;;   (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..)
-               ;; where we have to make sure that we don't uncross
-               ;; the SB!XC: prefix before we do EVAL, because otherwise
-               ;; we'd be trying to redefine the cross-compilation host's
-               ;; constants.
-               ;;
-               ;; (Isn't it fun to cross-compile Common Lisp?:-)
-               #+sb-xc-host
-               (progn
-                 (when compile-time-too
-                   (eval form)) ; letting xc host EVAL do its own macroexpansion
-                 (let* (;; (We uncross the operator name because things
-                        ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE
-                        ;; should be equivalent to their CL: counterparts
-                        ;; when being compiled as target code. We leave
-                        ;; the rest of the form uncrossed because macros
-                        ;; might yet expand into EVAL-WHEN stuff, and
-                        ;; things inside EVAL-WHEN can't be uncrossed
-                        ;; until after we've EVALed them in the
-                        ;; cross-compilation host.)
-                        (slightly-uncrossed (cons (uncross (first form))
-                                                  (rest form)))
-                        (expanded (preprocessor-macroexpand-1
-                                   slightly-uncrossed)))
-                   (if (eq expanded slightly-uncrossed)
-                       ;; (Now that we're no longer processing toplevel
-                       ;; forms, and hence no longer need to worry about
-                       ;; EVAL-WHEN, we can uncross everything.)
-                       (convert-and-maybe-compile expanded path)
-                       ;; (We have to demote COMPILE-TIME-TOO to NIL
-                       ;; here, no matter what it was before, since
-                       ;; otherwise we'd tend to EVAL subforms more than
-                       ;; once, because of WHEN COMPILE-TIME-TOO form
-                       ;; above.)
-                       (process-toplevel-form expanded path nil))))
-               ;; When we're not cross-compiling, we only need to
-               ;; macroexpand once, so we can follow the 1-thru-6
-               ;; sequence of steps in ANSI's "3.2.3.1 Processing of
-               ;; Top Level Forms".
-               #-sb-xc-host
-               (let ((expanded (preprocessor-macroexpand-1 form)))
-                (cond ((eq expanded form)
-                       (when compile-time-too
-                         (eval-in-lexenv form *lexenv*))
-                       (convert-and-maybe-compile form path))
-                      (t
-                       (process-toplevel-form expanded
-                                              path
-                                              compile-time-too))))))
+               (let ((*top-level-form-noted* (note-top-level-form form)))
+                 ;; When we're cross-compiling, consider: what should we
+                 ;; do when we hit e.g.
+                 ;;   (EVAL-WHEN (:COMPILE-TOPLEVEL)
+                 ;;     (DEFUN FOO (X) (+ 7 X)))?
+                 ;; DEFUN has a macro definition in the cross-compiler,
+                 ;; and a different macro definition in the target
+                 ;; compiler. The only sensible thing is to use the
+                 ;; target compiler's macro definition, since the
+                 ;; cross-compiler's macro is in general into target
+                 ;; functions which can't meaningfully be executed at
+                 ;; cross-compilation time. So make sure we do the EVAL
+                 ;; here, before we macroexpand.
+                 ;;
+                 ;; Then things get even dicier with something like
+                 ;;   (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..)
+                 ;; where we have to make sure that we don't uncross
+                 ;; the SB!XC: prefix before we do EVAL, because otherwise
+                 ;; we'd be trying to redefine the cross-compilation host's
+                 ;; constants.
+                 ;;
+                 ;; (Isn't it fun to cross-compile Common Lisp?:-)
+                 #+sb-xc-host
+                 (progn
+                   (when compile-time-too
+                     (eval form)) ; letting xc host EVAL do its own macroexpansion
+                   (let* (;; (We uncross the operator name because things
+                          ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE
+                          ;; should be equivalent to their CL: counterparts
+                          ;; when being compiled as target code. We leave
+                          ;; the rest of the form uncrossed because macros
+                          ;; might yet expand into EVAL-WHEN stuff, and
+                          ;; things inside EVAL-WHEN can't be uncrossed
+                          ;; until after we've EVALed them in the
+                          ;; cross-compilation host.)
+                          (slightly-uncrossed (cons (uncross (first form))
+                                                    (rest form)))
+                          (expanded (preprocessor-macroexpand-1
+                                     slightly-uncrossed)))
+                     (if (eq expanded slightly-uncrossed)
+                         ;; (Now that we're no longer processing toplevel
+                         ;; forms, and hence no longer need to worry about
+                         ;; EVAL-WHEN, we can uncross everything.)
+                         (convert-and-maybe-compile expanded path)
+                         ;; (We have to demote COMPILE-TIME-TOO to NIL
+                         ;; here, no matter what it was before, since
+                         ;; otherwise we'd tend to EVAL subforms more than
+                         ;; once, because of WHEN COMPILE-TIME-TOO form
+                         ;; above.)
+                         (process-toplevel-form expanded path nil))))
+                 ;; When we're not cross-compiling, we only need to
+                 ;; macroexpand once, so we can follow the 1-thru-6
+                 ;; sequence of steps in ANSI's "3.2.3.1 Processing of
+                 ;; Top Level Forms".
+                 #-sb-xc-host
+                 (let ((expanded (preprocessor-macroexpand-1 form)))
+                   (cond ((eq expanded form)
+                          (when compile-time-too
+                            (eval-in-lexenv form *lexenv*))
+                          (convert-and-maybe-compile form path))
+                         (t
+                          (process-toplevel-form expanded
+                                                 path
+                                                 compile-time-too)))))))
         (if (atom form)
             #+sb-xc-host
             ;; (There are no xc EVAL-WHEN issues in the ATOM case until
         (if (atom form)
             #+sb-xc-host
             ;; (There are no xc EVAL-WHEN issues in the ATOM case until
                      ((macrolet)
                       (funcall-in-macrolet-lexenv
                        magic
                      ((macrolet)
                       (funcall-in-macrolet-lexenv
                        magic
-                       (lambda (&key funs)
+                       (lambda (&key funs prepend)
                          (declare (ignore funs))
                          (declare (ignore funs))
+                        (aver (null prepend))
                          (process-toplevel-locally body
                                                    path
                                                    compile-time-too))
                          (process-toplevel-locally body
                                                    path
                                                    compile-time-too))
                      ((symbol-macrolet)
                       (funcall-in-symbol-macrolet-lexenv
                        magic
                      ((symbol-macrolet)
                       (funcall-in-symbol-macrolet-lexenv
                        magic
-                       (lambda (&key vars)
+                       (lambda (&key vars prepend)
+                        (aver (null prepend))
                          (process-toplevel-locally body
                                                    path
                                                    compile-time-too
                          (process-toplevel-locally body
                                                    path
                                                    compile-time-too
 ;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201
 (defun compile-toplevel (lambdas load-time-value-p)
   (declare (list lambdas))
 ;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201
 (defun compile-toplevel (lambdas load-time-value-p)
   (declare (list lambdas))
-
+  
   (maybe-mumble "locall ")
   (locall-analyze-clambdas-until-done lambdas)
 
   (maybe-mumble "locall ")
   (locall-analyze-clambdas-until-done lambdas)
 
 ;;; compilation.
 (defun finish-block-compilation ()
   (when *block-compile*
 ;;; compilation.
 (defun finish-block-compilation ()
   (when *block-compile*
+    (when *compile-print*
+      (compiler-mumble "~&; block compiling converted top level forms..."))
     (when *toplevel-lambdas*
       (compile-toplevel (nreverse *toplevel-lambdas*) nil)
       (setq *toplevel-lambdas* ()))
     (setq *block-compile* nil)
     (setq *entry-points* nil)))
 
     (when *toplevel-lambdas*
       (compile-toplevel (nreverse *toplevel-lambdas*) nil)
       (setq *toplevel-lambdas* ()))
     (setq *block-compile* nil)
     (setq *entry-points* nil)))
 
+(defun handle-condition-p (condition)
+  (let ((lexenv
+        (etypecase *compiler-error-context*
+          (node
+           (node-lexenv *compiler-error-context*))
+          (compiler-error-context
+           (let ((lexenv (compiler-error-context-lexenv
+                          *compiler-error-context*)))
+             (aver lexenv)
+             lexenv))
+          (null *lexenv*))))
+    (let ((muffles (lexenv-handled-conditions lexenv)))
+      (if (null muffles) ; common case
+         nil
+         (dolist (muffle muffles nil)
+           (destructuring-bind (typespec . restart-name) muffle
+             (when (and (typep condition typespec)
+                        (find-restart restart-name condition))
+               (return t))))))))
+
+(defun handle-condition-handler (condition)
+  (let ((lexenv
+        (etypecase *compiler-error-context*
+          (node
+           (node-lexenv *compiler-error-context*))
+          (compiler-error-context
+           (let ((lexenv (compiler-error-context-lexenv
+                          *compiler-error-context*)))
+             (aver lexenv)
+             lexenv))
+          (null *lexenv*))))
+    (let ((muffles (lexenv-handled-conditions lexenv)))
+      (aver muffles)
+      (dolist (muffle muffles (bug "fell through"))
+       (destructuring-bind (typespec . restart-name) muffle
+         (when (typep condition typespec)
+           (awhen (find-restart restart-name condition)
+             (invoke-restart it))))))))
+
 ;;; Read all forms from INFO and compile them, with output to OBJECT.
 ;;; Return (VALUES NIL WARNINGS-P FAILURE-P).
 (defun sub-compile-file (info)
   (declare (type source-info info))
 ;;; Read all forms from INFO and compile them, with output to OBJECT.
 ;;; Return (VALUES NIL WARNINGS-P FAILURE-P).
 (defun sub-compile-file (info)
   (declare (type source-info info))
-  (let* ((*block-compile* *block-compile-arg*)
-        (*package* (sane-package))
-        (*policy* *policy*)
-        (*lexenv* (make-null-lexenv))
-        (*source-info* info)
-        (sb!xc:*compile-file-pathname* nil)
-        (sb!xc:*compile-file-truename* nil)
-        (*toplevel-lambdas* ())
-        (*fun-names-in-this-file* ())
-        (*compiler-error-bailout*
-         (lambda ()
-           (compiler-mumble "~2&; fatal error, aborting compilation~%")
-           (return-from sub-compile-file (values nil t t))))
-        (*current-path* nil)
-        (*last-source-context* nil)
-        (*last-original-source* nil)
-        (*last-source-form* nil)
-        (*last-format-string* nil)
-        (*last-format-args* nil)
-        (*last-message-count* 0)
-        ;; FIXME: Do we need this rebinding here? It's a literal
-        ;; translation of the old CMU CL rebinding to
-        ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*),
-        ;; and it's not obvious whether the rebinding to itself is
-        ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
-        (*info-environment* *info-environment*)
-        (*gensym-counter* 0))
+  (let ((*package* (sane-package))
+        (*readtable* *readtable*)
+        (sb!xc:*compile-file-pathname* nil) ; really bound in
+        (sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE
+        (*policy* *policy*)
+       (*handled-conditions* *handled-conditions*)
+       (*disabled-package-locks* *disabled-package-locks*)
+        (*lexenv* (make-null-lexenv))
+        (*block-compile* *block-compile-arg*)
+        (*source-info* info)
+        (*toplevel-lambdas* ())
+        (*fun-names-in-this-file* ())
+        (*allow-instrumenting* nil)
+        (*compiler-error-bailout*
+         (lambda ()
+           (compiler-mumble "~2&; fatal error, aborting compilation~%")
+           (return-from sub-compile-file (values nil t t))))
+        (*current-path* nil)
+        (*last-source-context* nil)
+        (*last-original-source* nil)
+        (*last-source-form* nil)
+        (*last-format-string* nil)
+        (*last-format-args* nil)
+        (*last-message-count* 0)
+        ;; FIXME: Do we need this rebinding here? It's a literal
+        ;; translation of the old CMU CL rebinding to
+        ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*),
+        ;; and it's not obvious whether the rebinding to itself is
+        ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
+        (*info-environment* *info-environment*)
+        (*gensym-counter* 0))
     (handler-case
     (handler-case
-       (with-compilation-values
-        (sb!xc:with-compilation-unit ()
-          (clear-stuff)
-
-          (sub-sub-compile-file info)
-
-          (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))
+       (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
+         (with-compilation-values
+             (sb!xc:with-compilation-unit ()
+               (clear-stuff)
+               
+               (sub-sub-compile-file info)
+               
+               (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)))
       ;; 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.
-      (input-error-in-compile-file (condition)
-       (format *error-output*
-              "~@<compilation aborted because of input error: ~2I~_~A~:>"
-              condition)
+      (fatal-compiler-error (condition)
+       (signal condition)
+       (when *compile-verbose*
+         (format *standard-output*
+                 "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
+                 condition))
        (values nil t t)))))
 
 ;;; Return a pathname for the named file. The file must exist.
        (values nil t t)))))
 
 ;;; Return a pathname for the named file. The file must exist.
       (format nil "~D:~2,'0D:~2,'0D" thr min sec))))
 
 ;;; Print some junk at the beginning and end of compilation.
       (format nil "~D:~2,'0D:~2,'0D" thr min sec))))
 
 ;;; Print some junk at the beginning and end of compilation.
-(defun start-error-output (source-info)
+(defun print-compile-start-note (source-info)
   (declare (type source-info source-info))
   (let ((file-info (source-info-file-info source-info)))
     (compiler-mumble "~&; compiling file ~S (written ~A):~%"
   (declare (type source-info source-info))
   (let ((file-info (source-info-file-info source-info)))
     (compiler-mumble "~&; compiling file ~S (written ~A):~%"
                                                   :print-weekday nil
                                                   :print-timezone nil)))
   (values))
                                                   :print-weekday nil
                                                   :print-timezone nil)))
   (values))
-(defun finish-error-output (source-info won)
+
+(defun print-compile-end-note (source-info won)
   (declare (type source-info source-info))
   (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&"
                   won
   (declare (type source-info source-info))
   (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&"
                   won
      ;; extensions
      (trace-file nil) 
      ((:block-compile *block-compile-arg*) nil))
      ;; extensions
      (trace-file nil) 
      ((:block-compile *block-compile-arg*) nil))
-
   #!+sb-doc
   #!+sb-doc
-  "Compile INPUT-FILE, producing a corresponding fasl file and returning
-   its filename. Besides the ANSI &KEY arguments :OUTPUT-FILE, :VERBOSE,
-   :PRINT, and :EXTERNAL-FORMAT,the following extensions are supported:
-     :TRACE-FILE
-        If given, internal data structures are dumped to the specified
-        file, or if a value of T is given, to a file of *.trace type
-        derived from the input file name.
-   Also, as a workaround for vaguely-non-ANSI behavior, the :BLOCK-COMPILE
-   argument is quasi-supported, to determine whether multiple
-   functions are compiled together as a unit, resolving function
-   references at compile time. NIL means that global function names
-   are never resolved at compilation time. Currently NIL is the
-   default behavior, because although section 3.2.2.3, \"Semantic
-   Constraints\", of the ANSI spec allows this behavior under all
-   circumstances, the compiler's runtime scales badly when it
-   tries to do this for large files. If/when this performance
-   problem is fixed, the block compilation default behavior will
-   probably be made dependent on the SPEED and COMPILATION-SPEED
-   optimization values, and the :BLOCK-COMPILE argument will probably
-   become deprecated."
-
-  (unless (eq external-format :default)
-    (error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported."))
+  "Compile INPUT-FILE, producing a corresponding fasl file and
+returning its filename.
+
+  :PRINT
+     If true, a message per non-macroexpanded top level form is printed 
+     to *STANDARD-OUTPUT*. Top level forms that whose subforms are
+     processed as top level forms (eg. EVAL-WHEN, MACROLET, PROGN) receive
+     no such message, but their subforms do.
+
+     As an extension to ANSI, if :PRINT is :top-level-forms, a message 
+     per top level form after macroexpansion is printed to *STANDARD-OUTPUT*. 
+     For example, compiling an IN-PACKAGE form will result in a message about
+     a top level SETQ in addition to the message about the IN-PACKAGE form'
+     itself.
+
+     Both forms of reporting obey the SB-EXT:*COMPILER-PRINT-VARIABLE-ALIST*.
+
+  :BLOCK-COMPILE
+     Though COMPILE-FILE accepts an additional :BLOCK-COMPILE
+     argument, it is not currently supported. (non-standard)
+
+  :TRACE-FILE
+     If given, internal data structures are dumped to the specified
+     file, or if a value of T is given, to a file of *.trace type
+     derived from the input file name. (non-standard)"
+;;; Block compilation is currently broken.
+#|
+  "Also, as a workaround for vaguely-non-ANSI behavior, the
+:BLOCK-COMPILE argument is quasi-supported, to determine whether
+multiple functions are compiled together as a unit, resolving function
+references at compile time. NIL means that global function names are
+never resolved at compilation time. Currently NIL is the default
+behavior, because although section 3.2.2.3, \"Semantic Constraints\",
+of the ANSI spec allows this behavior under all circumstances, the
+compiler's runtime scales badly when it tries to do this for large
+files. If/when this performance problem is fixed, the block
+compilation default behavior will probably be made dependent on the
+SPEED and COMPILATION-SPEED optimization values, and the
+:BLOCK-COMPILE argument will probably become deprecated."
+|#
   (let* ((fasl-output nil)
         (output-file-name nil)
         (compile-won nil)
         (warnings-p nil)
         (failure-p t) ; T in case error keeps this from being set later
         (input-pathname (verify-source-file input-file))
   (let* ((fasl-output nil)
         (output-file-name nil)
         (compile-won nil)
         (warnings-p nil)
         (failure-p t) ; T in case error keeps this from being set later
         (input-pathname (verify-source-file input-file))
-        (source-info (make-file-source-info input-pathname))
+        (source-info (make-file-source-info input-pathname external-format))
         (*compiler-trace-output* nil)) ; might be modified below
 
     (unwind-protect
         (*compiler-trace-output* nil)) ; might be modified below
 
     (unwind-protect
                          :direction :output))))
 
          (when sb!xc:*compile-verbose*
                          :direction :output))))
 
          (when sb!xc:*compile-verbose*
-           (start-error-output source-info))
+           (print-compile-start-note source-info))
          (let ((*compile-object* fasl-output)
                dummy)
            (multiple-value-setq (dummy warnings-p failure-p)
          (let ((*compile-object* fasl-output)
                dummy)
            (multiple-value-setq (dummy warnings-p failure-p)
          (compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
 
       (when sb!xc:*compile-verbose*
          (compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
 
       (when sb!xc:*compile-verbose*
-       (finish-error-output source-info compile-won))
+       (print-compile-end-note source-info compile-won))
 
       (when *compiler-trace-output*
        (close *compiler-trace-output*)))
 
       (when *compiler-trace-output*
        (close *compiler-trace-output*)))
        (throw 'pending-init circular-ref)))
     (multiple-value-bind (creation-form init-form)
        (handler-case
        (throw 'pending-init circular-ref)))
     (multiple-value-bind (creation-form init-form)
        (handler-case
-           (sb!xc:make-load-form constant (make-null-lexenv))
+            (sb!xc:make-load-form constant (make-null-lexenv))
          (error (condition)
          (error (condition)
-                (compiler-error "(while making load form for ~S)~%~A"
-                                constant
-                                condition)))
+           (compiler-error condition)))
       (case creation-form
        (:sb-just-dump-it-normally
         (fasl-validate-structure constant *compile-object*)
       (case creation-form
        (:sb-just-dump-it-normally
         (fasl-validate-structure constant *compile-object*)
        (t
         (when (fasl-constant-already-dumped-p constant *compile-object*)
           (return-from emit-make-load-form nil))
        (t
         (when (fasl-constant-already-dumped-p constant *compile-object*)
           (return-from emit-make-load-form nil))
-        (let* ((name (let ((*print-level* 1) (*print-length* 2))
-                       (with-output-to-string (stream)
-                         (write constant :stream stream))))
+        (let* ((name (write-to-string constant :level 1 :length 2))
                (info (if init-form
                          (list constant name init-form)
                          (list constant))))
                (info (if init-form
                          (list constant name init-form)
                          (list constant))))