X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=3465260416df759a7b2247652ba9fb70190785cd;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=84e9f86ea3fdb5112c65b98aff257606652facc4;hpb=e2b33e0d99f0f93263defcd2e0dffe20c4e388f3;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 84e9f86..3465260 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -14,10 +14,10 @@ (in-package "SB!C") ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp? -(declaim (special *constants* *free-variables* *component-being-compiled* +(declaim (special *constants* *free-vars* *component-being-compiled* *code-vector* *next-location* *result-fixups* - *free-functions* *source-paths* - *seen-blocks* *seen-functions* *list-conflicts-table* + *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* @@ -28,11 +28,19 @@ #!+sb-show *compiler-trace-output* *last-source-context* *last-original-source* *last-source-form* *last-format-string* *last-format-args* - *last-message-count* *lexenv*)) + *last-message-count* *lexenv* *fun-names-in-this-file* + *allow-instrumenting*)) + +;;; Whether call of a function which cannot be defined causes a full +;;; warning. +(defvar *flame-on-necessarily-undefined-function* nil) (defvar *check-consistency* nil) (defvar *all-components*) +;;; Set to NIL to disable loop analysis for register allocation. +(defvar *loop-analyze* t) + ;;; Bind this to a stream to capture various internal debugging output. (defvar *compiler-trace-output* nil) @@ -40,13 +48,11 @@ ;;; :BLOCK-COMPILE and :ENTRY-POINTS arguments that COMPILE-FILE was ;;; called with. ;;; -;;; *BLOCK-COMPILE-ARGUMENT* holds the original value of the -;;; :BLOCK-COMPILE argument, which overrides any internal -;;; declarations. +;;; *BLOCK-COMPILE-ARG* holds the original value of the :BLOCK-COMPILE +;;; argument, which overrides any internal declarations. (defvar *block-compile*) -(defvar *block-compile-argument*) -(declaim (type (member nil t :specified) - *block-compile* *block-compile-argument*)) +(defvar *block-compile-arg*) +(declaim (type (member nil t :specified) *block-compile* *block-compile-arg*)) (defvar *entry-points*) (declaim (list *entry-points*)) @@ -55,6 +61,10 @@ (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.") @@ -63,7 +73,7 @@ "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.)") @@ -97,7 +107,7 @@ (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)) @@ -114,26 +124,24 @@ 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) + (declare (type function fn)) (let ((succeeded-p nil)) (if (and *in-compilation-unit* (not override)) ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is ;; ordinarily (unless OVERRIDE) basically a no-op. (unwind-protect - (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) + (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) (unless succeeded-p (incf *aborted-compilation-unit-count*))) - ;; FIXME: Now *COMPILER-FOO-COUNT* stuff is bound in more than - ;; one place. If we can get rid of the IR1 interpreter, this - ;; should be easier to clean up. (let ((*aborted-compilation-unit-count* 0) (*compiler-error-count* 0) (*compiler-warning-count* 0) @@ -141,16 +149,23 @@ (*compiler-note-count* 0) (*undefined-warnings* nil) (*in-compilation-unit* t)) - (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)))))))) + (sb!thread:with-recursive-lock (*big-compiler-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))))))))) + +;;; Is FUN-NAME something that no conforming program can rely on +;;; defining as a function? +(defun fun-name-reserved-by-ansi-p (fun-name) + (eq (symbol-package (fun-name-block-name fun-name)) + *cl-package*)) ;;; This is to be called at the end of a compilation unit. It signals ;;; any residual warnings about unknown stuff, then prints the total @@ -163,34 +178,64 @@ (warning #'compiler-warning-handler)) (let ((undefs (sort *undefined-warnings* #'string< - :key #'(lambda (x) - (let ((x (undefined-warning-name x))) - (if (symbolp x) - (symbol-name x) - (prin1-to-string x))))))) + :key (lambda (x) + (let ((x (undefined-warning-name x))) + (if (symbolp x) + (symbol-name x) + (prin1-to-string x))))))) (dolist (undef undefs) (let ((name (undefined-warning-name undef)) (kind (undefined-warning-kind undef)) (warnings (undefined-warning-warnings undef)) (undefined-warning-count (undefined-warning-count undef))) (dolist (*compiler-error-context* warnings) - (compiler-style-warning "undefined ~(~A~): ~S" kind name)) + (if #-sb-xc-host (and (eq kind :function) + (fun-name-reserved-by-ansi-p name) + *flame-on-necessarily-undefined-function*) + #+sb-xc-host nil + (case name + ((declare) + (compiler-warn + "~@" + name name)) + (t + (compiler-warn + "~@" + 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))) - (compiler-style-warning - "~D 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 - (remove kind undefs :test-not #'eq + (remove kind undefs :test #'neq :key #'undefined-warning-kind)))) (when summary - (compiler-style-warning - "~:[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*) @@ -198,21 +243,21 @@ (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 ~D fatal ERROR condition~:P~]~ - ~[~:;~:*~& caught ~D ERROR condition~:P~]~ - ~[~:;~:*~& caught ~D WARNING condition~:P~]~ - ~[~:;~:*~& caught ~D STYLE-WARNING condition~:P~]~ - ~[~:;~:*~& printed ~D note~:P~]" + ~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~ + ~[~:;~:*~& caught ~W ERROR condition~:P~]~ + ~[~:;~:*~& caught ~W WARNING condition~:P~]~ + ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~ + ~[~:;~:*~& printed ~W note~:P~]" abort-p *aborted-compilation-unit-count* *compiler-error-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 @@ -246,17 +291,20 @@ (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) - (ir1-optimize component) + (ir1-optimize component fastp) (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 "+") @@ -273,7 +321,8 @@ (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)) @@ -310,14 +359,15 @@ ;;; Do all the IR1 phases for a non-top-level component. (defun ir1-phases (component) (declare (type component component)) + (aver-live-component component) (let ((*constraint-number* 0) (loop-count 1) (*delayed-ir1-transforms* nil)) (declare (special *constraint-number* *delayed-ir1-transforms*)) (loop (ir1-optimize-until-done component) - (when (or (component-new-funs component) - (component-reanalyze-funs component)) + (when (or (component-new-functionals component) + (component-reanalyze-functionals component)) (maybe-mumble "locall ") (locall-analyze-component component)) (dfo-as-needed component) @@ -326,21 +376,20 @@ (constraint-propagate component)) (when (retry-delayed-ir1-transforms :constraint) (maybe-mumble "Rtran ")) - ;; Delay the generation of type checks until the type - ;; constraints have had time to propagate, else the compiler can - ;; confuse itself. - (unless (and (or (component-reoptimize component) - (component-reanalyze component) - (component-new-funs component) - (component-reanalyze-funs component)) - (< loop-count (- *reoptimize-after-type-check-max* 4))) - (maybe-mumble "type ") - (generate-type-checks component) - (unless (or (component-reoptimize component) - (component-reanalyze component) - (component-new-funs component) - (component-reanalyze-funs component)) - (return))) + (flet ((want-reoptimization-p () + (or (component-reoptimize component) + (component-reanalyze component) + (component-new-functionals component) + (component-reanalyze-functionals component)))) + (unless (and (want-reoptimization-p) + ;; We delay the generation of type checks until + ;; the type constraints have had time to + ;; propagate, else the compiler can confuse itself. + (< loop-count (- *reoptimize-after-type-check-max* 4))) + (maybe-mumble "type ") + (generate-type-checks component) + (unless (want-reoptimization-p) + (return)))) (when (>= loop-count *reoptimize-after-type-check-max*) (maybe-mumble "[reoptimize limit]") (event reoptimize-maxed-out) @@ -361,7 +410,8 @@ (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 @@ -393,7 +443,7 @@ (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 ") @@ -411,9 +461,10 @@ (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) + #-sb-xc-host (when *compiler-trace-output* (format *compiler-trace-output* "~|~%disassembly of code for ~S~2%" component) @@ -427,7 +478,7 @@ *code-segment* code-length trace-table - fixups + fixup-notes *compile-object*)) (core-object (maybe-mumble "core") @@ -435,12 +486,12 @@ *code-segment* code-length trace-table - fixups + fixup-notes *compile-object*)) (null)))))) ;; We're done, so don't bother keeping anything around. - (setf (component-info component) nil) + (setf (component-info component) :dead) (values)) @@ -456,18 +507,50 @@ (:toplevel (return)) (:external (unless (every (lambda (ref) - (eq (block-component (node-block ref)) - component)) + (eq (node-component ref) component)) (leaf-refs fun)) (return)))))) (defun compile-component (component) + + ;; miscellaneous sanity checks + ;; + ;; FIXME: These are basically pretty wimpy compared to the checks done + ;; by the old CHECK-IR1-CONSISTENCY code. It would be really nice to + ;; make those internal consistency checks work again and use them. + (aver-live-component component) + (do-blocks (block component) + (aver (eql (block-component block) component))) + (dolist (lambda (component-lambdas component)) + ;; sanity check to prevent weirdness from propagating insidiously as + ;; far from its root cause as it did in bug 138: Make sure that + ;; thing-to-COMPONENT links are consistent. + (aver (eql (lambda-component lambda) 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) + (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) @@ -480,10 +563,7 @@ (%compile-component component))) (clear-constant-info) - - (when sb!xc:*compile-print* - (compiler-mumble "~&")) - + (values)) ;;;; clearing global data structures @@ -492,22 +572,22 @@ ;;;; global data structures entirely when possible and consing up the ;;;; others from scratch instead of clearing and reusing them? -;;; Clear the INFO in constants in the *FREE-VARIABLES*, etc. In +;;; Clear the INFO in constants in the *FREE-VARS*, etc. In ;;; addition to allowing stuff to be reclaimed, this is required for ;;; correct assignment of constant offsets, since we need to assign a ;;; new offset for each component. We don't clear the FUNCTIONAL-INFO ;;; slots, since they are used to keep track of functions across ;;; component boundaries. (defun clear-constant-info () - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf (leaf-info v) nil)) + (maphash (lambda (k v) + (declare (ignore k)) + (setf (leaf-info v) nil)) *constants*) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (constant-p v) - (setf (leaf-info v) nil))) - *free-variables*) + (maphash (lambda (k v) + (declare (ignore k)) + (when (constant-p v) + (setf (leaf-info v) nil))) + *free-vars*) (values)) ;;; Blow away the REFS for all global variables, and let COMPONENT @@ -515,19 +595,19 @@ (defun clear-ir1-info (component) (declare (type component component)) (labels ((blast (x) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (leaf-p v) - (setf (leaf-refs v) - (delete-if #'here-p (leaf-refs v))) - (when (basic-var-p v) - (setf (basic-var-sets v) - (delete-if #'here-p (basic-var-sets v)))))) + (maphash (lambda (k v) + (declare (ignore k)) + (when (leaf-p v) + (setf (leaf-refs v) + (delete-if #'here-p (leaf-refs v))) + (when (basic-var-p v) + (setf (basic-var-sets v) + (delete-if #'here-p (basic-var-sets v)))))) x)) (here-p (x) - (eq (block-component (node-block x)) component))) - (blast *free-variables*) - (blast *free-functions*) + (eq (node-component x) component))) + (blast *free-vars*) + (blast *free-funs*) (blast *constants*)) (values)) @@ -540,14 +620,14 @@ (defun clear-stuff (&optional (debug-too t)) ;; Clear global tables. - (when (boundp '*free-functions*) - (clrhash *free-functions*) - (clrhash *free-variables*) + (when (boundp '*free-funs*) + (clrhash *free-funs*) + (clrhash *free-vars*) (clrhash *constants*)) ;; Clear debug counters and tables. (clrhash *seen-blocks*) - (clrhash *seen-functions*) + (clrhash *seen-funs*) (clrhash *list-conflicts-table*) (when debug-too @@ -559,13 +639,7 @@ (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 @@ -580,11 +654,11 @@ ;;;; trace output -;;; Print out some useful info about Component to Stream. +;;; Print out some useful info about COMPONENT to STREAM. (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*) @@ -594,7 +668,7 @@ (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) @@ -609,15 +683,17 @@ ;;;; the error context and for recovering from errors. ;;;; ;;;; The interface we provide to this stuff is the stream-oid -;;;; Source-Info structure. The bookkeeping is done as a side-effect +;;;; SOURCE-INFO structure. The bookkeeping is done as a side effect ;;;; of getting the next source form. ;;; 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))) + ;; 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 @@ -637,11 +713,11 @@ ;;; 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 @@ -651,9 +727,10 @@ (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 + :external-format external-format :write-date (file-write-date file)))) (make-source-info :file-info file-info))) @@ -680,7 +757,7 @@ (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. )) @@ -689,7 +766,7 @@ ;; 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. @@ -710,10 +787,13 @@ (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) - (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) @@ -758,10 +838,16 @@ ;;; *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))) - (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 @@ -770,7 +856,7 @@ (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)))) @@ -786,11 +872,13 @@ ;;; Process a top level use of LOCALLY, or anything else (e.g. ;;; MACROLET) at top level which has declarations and ordinary forms. ;;; We parse declarations and then recursively process the body. -(defun process-toplevel-locally (body path compile-time-too) +(defun process-toplevel-locally (body path compile-time-too &key vars funs) (declare (list path)) - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) - (let* ((*lexenv* - (process-decls decls nil nil (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 @@ -801,7 +889,11 @@ ;; 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, @@ -833,15 +925,16 @@ (etypecase f (clambda (list (lambda-component f))) (optional-dispatch (let ((result nil)) - (labels ((frob (clambda) - (pushnew (lambda-component clambda) - result)) - (maybe-frob (maybe-clambda) - (when maybe-clambda - (frob maybe-clambda)))) - (mapc #'frob (optional-dispatch-entry-points f)) + (flet ((maybe-frob (maybe-clambda) + (when (and maybe-clambda + (promise-ready-p maybe-clambda)) + (pushnew (lambda-component + (force maybe-clambda)) + result)))) + (map nil #'maybe-frob (optional-dispatch-entry-points f)) (maybe-frob (optional-dispatch-more-entry f)) - (maybe-frob (optional-dispatch-main-entry f))))))) + (maybe-frob (optional-dispatch-main-entry f))) + result)))) (defun make-functional-from-toplevel-lambda (definition &key @@ -857,14 +950,17 @@ (setf (component-name component) (debug-namify "~S initial component" name)) (setf (component-kind component) :initial) - (let* ((locall-fun (ir1-convert-lambda definition - :debug-name (debug-namify - "top level locall ~S" - name))) + (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 "top level form")))) + (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 fun) t) @@ -890,9 +986,12 @@ ;; nice default for things where we don't have a ;; real source path (as in e.g. inside CL:COMPILE). '(original-source-start 0 0))) - (unless (or (null name) (legal-fun-name-p name)) - (error "not a legal function name: ~S" name)) - (let* ((*lexenv* (make-lexenv :policy *policy*)) + (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*)) (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) @@ -906,40 +1005,69 @@ ;; 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)) + (declare (ignore hairy-top)) (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))) - (prog1 - (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) - result)) - (mapc #'clear-ir1-info components-from-dfo) - (clear-stuff))))) + (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 '(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))))))) (defun process-toplevel-cold-fset (name lambda-expression path) (unless (producing-fasl-file) (error "can't COLD-FSET except in a fasl file")) - (unless (legal-fun-name-p name) - (error "not a legal function name: ~S" name)) + (legal-fun-name-or-type-error name) (fasl-dump-cold-fset name (%compile lambda-expression *compile-object* @@ -948,6 +1076,28 @@ *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. @@ -956,138 +1106,150 @@ ;;; 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)) - (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* - (lambda () + (lambda (&optional condition) (convert-and-maybe-compile - `(error "execution of a form compiled with errors:~% ~S" - ',form) + (make-compiler-error-form condition form) path) (throw 'process-toplevel-form-error-abort nil)))) - (if (atom form) - ;; (There are no EVAL-WHEN issues in the ATOM case until - ;; SBCL gets smart enough to handle global - ;; DEFINE-SYMBOL-MACRO.) - (convert-and-maybe-compile form path) - (flet ((need-at-least-one-arg (form) - (unless (cdr form) - (compiler-error "~S form is too short: ~S" - (car form) - form)))) - (case (car form) - ;; In the cross-compiler, top level COLD-FSET arranges - ;; for static linking at cold init time. - #+sb-xc-host - ((cold-fset) - (aver (not compile-time-too)) - (destructuring-bind (cold-fset fun-name lambda-expression) form - (declare (ignore cold-fset)) - (process-toplevel-cold-fset fun-name - lambda-expression - path))) - ((eval-when macrolet symbol-macrolet);things w/ 1 arg before body - (need-at-least-one-arg form) - (destructuring-bind (special-operator magic &rest body) form - (ecase special-operator - ((eval-when) - ;; CT, LT, and E here are as in Figure 3-7 of ANSI - ;; "3.2.3.1 Processing of Top Level Forms". - (multiple-value-bind (ct lt e) - (parse-eval-when-situations magic) - (let ((new-compile-time-too (or ct - (and compile-time-too - e)))) - (cond (lt (process-toplevel-progn - body path new-compile-time-too)) - (new-compile-time-too (eval - `(progn ,@body))))))) - ((macrolet) - (funcall-in-macrolet-lexenv - magic - (lambda () - (process-toplevel-locally body - path - compile-time-too)))) - ((symbol-macrolet) - (funcall-in-symbol-macrolet-lexenv - magic - (lambda () - (process-toplevel-locally body - path - compile-time-too))))))) - ((locally) - (process-toplevel-locally (rest form) path compile-time-too)) - ((progn) - (process-toplevel-progn (rest form) path compile-time-too)) - ;; 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 - (t - (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 - (t - (let ((expanded (preprocessor-macroexpand-1 form))) - (cond ((eq expanded form) - (when compile-time-too - (eval form)) - (convert-and-maybe-compile form path)) - (t - (process-toplevel-form expanded - path - compile-time-too)))))))))) + (flet ((default-processor (form) + (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 + ;; (1) SBCL gets smart enough to handle global + ;; DEFINE-SYMBOL-MACRO or SYMBOL-MACROLET and (2) SBCL + ;; implementors start using symbol macros in a way which + ;; interacts with SB-XC/CL distinction.) + (convert-and-maybe-compile form path) + #-sb-xc-host + (default-processor form) + (flet ((need-at-least-one-arg (form) + (unless (cdr form) + (compiler-error "~S form is too short: ~S" + (car form) + form)))) + (case (car form) + ;; In the cross-compiler, top level COLD-FSET arranges + ;; for static linking at cold init time. + #+sb-xc-host + ((cold-fset) + (aver (not compile-time-too)) + (destructuring-bind (cold-fset fun-name lambda-expression) form + (declare (ignore cold-fset)) + (process-toplevel-cold-fset fun-name + lambda-expression + path))) + ((eval-when macrolet symbol-macrolet);things w/ 1 arg before body + (need-at-least-one-arg form) + (destructuring-bind (special-operator magic &rest body) form + (ecase special-operator + ((eval-when) + ;; CT, LT, and E here are as in Figure 3-7 of ANSI + ;; "3.2.3.1 Processing of Top Level Forms". + (multiple-value-bind (ct lt e) + (parse-eval-when-situations magic) + (let ((new-compile-time-too (or ct + (and compile-time-too + e)))) + (cond (lt (process-toplevel-progn + body path new-compile-time-too)) + (new-compile-time-too (eval-in-lexenv + `(progn ,@body) + *lexenv*)))))) + ((macrolet) + (funcall-in-macrolet-lexenv + magic + (lambda (&key funs prepend) + (declare (ignore funs)) + (aver (null prepend)) + (process-toplevel-locally body + path + compile-time-too)) + :compile)) + ((symbol-macrolet) + (funcall-in-symbol-macrolet-lexenv + magic + (lambda (&key vars prepend) + (aver (null prepend)) + (process-toplevel-locally body + path + compile-time-too + :vars vars)) + :compile))))) + ((locally) + (process-toplevel-locally (rest form) path compile-time-too)) + ((progn) + (process-toplevel-progn (rest form) path compile-time-too)) + (t (default-processor form)))))))) (values)) @@ -1102,15 +1264,8 @@ ;;; Compile FORM and arrange for it to be called at load-time. Return ;;; the dumper handle and our best guess at the type of the object. -(defun compile-load-time-value - (form &optional - (name (let ((*print-level* 2) (*print-length* 3)) - (format nil "load time value of ~S" - (if (and (listp form) - (eq (car form) 'make-value-cell)) - (second form) - form))))) - (let ((lambda (compile-load-time-stuff form name t))) +(defun compile-load-time-value (form) + (let ((lambda (compile-load-time-stuff form t))) (values (fasl-dump-load-time-value-lambda lambda *compile-object*) (let ((type (leaf-type lambda))) @@ -1120,13 +1275,13 @@ ;;; Compile the FORMS and arrange for them to be called (for effect, ;;; not value) at load time. -(defun compile-make-load-form-init-forms (forms name) - (let ((lambda (compile-load-time-stuff `(progn ,@forms) name nil))) +(defun compile-make-load-form-init-forms (forms) + (let ((lambda (compile-load-time-stuff `(progn ,@forms) nil))) (fasl-dump-toplevel-lambda-call lambda *compile-object*))) -;;; Does the actual work of COMPILE-LOAD-TIME-VALUE or -;;; COMPILE-MAKE-LOAD-FORM- INIT-FORMS. -(defun compile-load-time-stuff (form name for-value) +;;; Do the actual work of COMPILE-LOAD-TIME-VALUE or +;;; COMPILE-MAKE-LOAD-FORM-INIT-FORMS. +(defun compile-load-time-stuff (form for-value) (with-ir1-namespace (let* ((*lexenv* (make-null-lexenv)) (lambda (ir1-toplevel form *current-path* for-value))) @@ -1149,87 +1304,47 @@ ;;;; COMPILE-FILE -;;; We build a list of top level lambdas, and then periodically smash -;;; them together into a single component and compile it. -(defvar *pending-toplevel-lambdas*) - -;;; The maximum number of top level lambdas we put in a single -;;; top level component. -;;; -;;; CMU CL 18b used this nontrivially by default (setting it to 10) -;;; but consequently suffered from the inability to execute some -;;; troublesome constructs correctly, e.g. inability to load a fasl -;;; file compiled from the source file -;;; (defpackage "FOO" (:use "CL")) -;;; (print 'foo::bar) -;;; because it would dump data-setup fops (including a FOP-PACKAGE for -;;; "FOO") for the second form before dumping the the code in the -;;; first form, or the fop to execute the code in the first form. By -;;; setting this value to 0 by default, we avoid this badness. This -;;; increases the number of toplevel form functions, and so increases -;;; the size of object files. -;;; -;;; The variable is still supported because when we are compiling the -;;; SBCL system itself, which is known not contain any troublesome -;;; constructs, we can set it to a nonzero value, which reduces the -;;; number of toplevel form objects, reducing the peak memory usage in -;;; GENESIS, which is desirable, since at least for SBCL version -;;; 0.6.7, this is the high water mark for memory usage during system -;;; construction. -(defparameter *toplevel-lambda-max* 0) - (defun object-call-toplevel-lambda (tll) (declare (type functional tll)) (let ((object *compile-object*)) (etypecase object - (fasl-output - (fasl-dump-toplevel-lambda-call tll object)) - (core-object - (core-call-toplevel-lambda tll object)) + (fasl-output (fasl-dump-toplevel-lambda-call tll object)) + (core-object (core-call-toplevel-lambda tll object)) (null)))) -;;; Add LAMBDAS to the pending lambdas. If this leaves more than -;;; *TOPLEVEL-LAMBDA-MAX* lambdas in the list, or if FORCE-P is true, -;;; then smash the lambdas into a single component, compile it, and -;;; call the resulting function. -(defun sub-compile-toplevel-lambdas (lambdas force-p) +;;; Smash LAMBDAS into a single component, compile it, and arrange for +;;; the resulting function to be called. +(defun sub-compile-toplevel-lambdas (lambdas) (declare (list lambdas)) - (setq *pending-toplevel-lambdas* - (append *pending-toplevel-lambdas* lambdas)) - (let ((pending *pending-toplevel-lambdas*)) - (when (and pending - (or (> (length pending) *toplevel-lambda-max*) - force-p)) - (multiple-value-bind (component tll) (merge-toplevel-lambdas pending) - (setq *pending-toplevel-lambdas* ()) - (compile-component component) - (clear-ir1-info component) - (object-call-toplevel-lambda tll)))) + (when lambdas + (multiple-value-bind (component tll) (merge-toplevel-lambdas lambdas) + (compile-component component) + (clear-ir1-info component) + (object-call-toplevel-lambda tll))) (values)) ;;; Compile top level code and call the top level lambdas. We pick off ;;; top level lambdas in non-top-level components here, calling ;;; SUB-c-t-l-l on each subsequence of normal top level lambdas. -(defun compile-toplevel-lambdas (lambdas force-p) +(defun compile-toplevel-lambdas (lambdas) (declare (list lambdas)) (let ((len (length lambdas))) (flet ((loser (start) (or (position-if (lambda (x) (not (eq (component-kind - (block-component - (node-block - (lambda-bind x)))) + (node-component (lambda-bind x))) :toplevel))) lambdas - :start start) + ;; this used to read ":start start", but + ;; start can be greater than len, which + ;; is an error according to ANSI - CSR, + ;; 2002-04-25 + :start (min start len)) len))) (do* ((start 0 (1+ loser)) (loser (loser start) (loser start))) - ((>= start len) - (when force-p - (sub-compile-toplevel-lambdas nil t))) - (sub-compile-toplevel-lambdas (subseq lambdas start loser) - (or force-p (/= loser len))) + ((>= start len)) + (sub-compile-toplevel-lambdas (subseq lambdas start loser)) (unless (= loser len) (object-call-toplevel-lambda (elt lambdas loser)))))) (values)) @@ -1241,27 +1356,24 @@ ;;; 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 "IDFO ") (multiple-value-bind (components top-components hairy-top) (find-initial-dfo lambdas) - (let ((*all-components* (append components top-components)) - (toplevel-closure nil)) + (let ((*all-components* (append components top-components))) (when *check-consistency* (maybe-mumble "[check]~%") (check-ir1-consistency *all-components*)) (dolist (component (append hairy-top top-components)) - (when (pre-physenv-analyze-toplevel component) - (setq toplevel-closure t))) + (pre-physenv-analyze-toplevel component)) (dolist (component components) (compile-component component) - (when (replace-toplevel-xeps component) - (setq toplevel-closure t))) + (replace-toplevel-xeps component)) (when *check-consistency* (maybe-mumble "[check]~%") @@ -1269,7 +1381,7 @@ (if load-time-value-p (compile-load-time-value-lambda lambdas) - (compile-toplevel-lambdas lambdas toplevel-closure)) + (compile-toplevel-lambdas lambdas)) (mapc #'clear-ir1-info components) (clear-stuff))) @@ -1279,65 +1391,112 @@ ;;; 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))) +(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)) - (let* ((*block-compile* *block-compile-argument*) - (*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* ()) - (*pending-toplevel-lambdas* ()) - (*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 - (with-compilation-values - (sb!xc:with-compilation-unit () - (clear-stuff) - - (sub-sub-compile-file info) - - (finish-block-compilation) - (compile-toplevel-lambdas () t) - (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. - (input-error-in-compile-file (condition) - (format *error-output* - "~@" - condition) + (fatal-compiler-error (condition) + (signal condition) + (when *compile-verbose* + (format *standard-output* + "~@" + condition)) (values nil t t))))) ;;; Return a pathname for the named file. The file must exist. @@ -1363,7 +1522,7 @@ (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):~%" @@ -1375,7 +1534,8 @@ :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 @@ -1402,41 +1562,57 @@ ;; extensions (trace-file nil) - ((:block-compile *block-compile-argument*) nil)) - + ((:block-compile *block-compile-arg*) nil)) #!+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)) - (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 (progn (when output-file @@ -1460,7 +1636,7 @@ :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) @@ -1477,7 +1653,7 @@ (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*))) @@ -1519,7 +1695,7 @@ #!+sb-doc "Return a pathname describing what file COMPILE-FILE would write to given these arguments." - (pathname output-file)) + (merge-pathnames output-file (merge-pathnames input-file))) ;;;; MAKE-LOAD-FORM stuff @@ -1554,7 +1730,7 @@ ;;; If the constant doesn't show up in *CONSTANTS-BEING-CREATED*, then ;;; we have to create it. We call MAKE-LOAD-FORM and check to see ;;; whether the creation form is the magic value -;;; :JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The +;;; :SB-JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The ;;; dumper will eventually get its hands on the object and use the ;;; normal structure dumping noise on it. ;;; @@ -1571,7 +1747,7 @@ ;;; deal with it. (defvar *constants-being-created* nil) (defvar *constants-created-since-last-init* nil) -;;; FIXME: Shouldn't these^ variables be bound in LET forms? +;;; FIXME: Shouldn't these^ variables be unbound outside LET forms? (defun emit-make-load-form (constant) (aver (fasl-output-p *compile-object*)) (unless (or (fasl-constant-already-dumped-p constant *compile-object*) @@ -1589,24 +1765,19 @@ (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) - (compiler-error "(while making load form for ~S)~%~A" - constant - condition))) + (compiler-error condition))) (case creation-form - (:just-dump-it-normally + (:sb-just-dump-it-normally (fasl-validate-structure constant *compile-object*) t) (:ignore-it nil) (t - (compile-toplevel-lambdas () 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)))) @@ -1619,8 +1790,7 @@ (fasl-note-handle-for-constant constant (compile-load-time-value - creation-form - (format nil "creation form for ~A" name)) + creation-form) *compile-object*) nil) (compiler-error "circular references in creation form for ~S" @@ -1632,12 +1802,20 @@ (loop for (name form) on (cdr info) by #'cddr collect name into names collect form into forms - finally - (compile-make-load-form-init-forms - forms - (format nil "init form~:[~;s~] for ~{~A~^, ~}" - (cdr forms) names))) + finally (compile-make-load-form-init-forms forms)) nil))) (when circular-ref (setf (cdr circular-ref) (append (cdr circular-ref) (cdr info)))))))))))) + + +;;;; Host compile time definitions +#+sb-xc-host +(defun compile-in-lexenv (name lambda lexenv) + (declare (ignore lexenv)) + (compile name lambda)) + +#+sb-xc-host +(defun eval-in-lexenv (form lexenv) + (declare (ignore lexenv)) + (eval form))