X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=3465260416df759a7b2247652ba9fb70190785cd;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=cabe030d93de918efbd4141aa29902dd7d0c399a;hpb=208e7b3072e383a2b2555ee259c9691e45cac3d6;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index cabe030..3465260 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -61,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.") @@ -69,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.)") @@ -103,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)) @@ -239,8 +243,8 @@ (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~]~ @@ -253,7 +257,7 @@ *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 @@ -287,18 +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 (and (= count *max-optimize-iterations*) - (not (component-reanalyze component))) + (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 "+") @@ -315,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)) @@ -436,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 ") @@ -522,8 +529,6 @@ (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) @@ -558,10 +563,7 @@ (%compile-component component))) (clear-constant-info) - - (when sb!xc:*compile-print* - (compiler-mumble "~&")) - + (values)) ;;;; clearing global data structures @@ -666,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) @@ -690,6 +692,8 @@ ;; 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 @@ -723,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))) @@ -782,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) @@ -830,12 +838,16 @@ ;;; *TOPLEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) - (let* ((*lexenv* (make-lexenv :policy *policy* - :handled-conditions *handled-conditions* - :disabled-package-locks *disabled-package-locks*)) + (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 @@ -844,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)))) @@ -993,18 +1005,12 @@ ;; 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))) @@ -1070,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. @@ -1078,10 +1106,9 @@ ;;; 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 (&optional condition) @@ -1091,69 +1118,70 @@ (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 @@ -1328,7 +1356,7 @@ ;;; 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) @@ -1363,6 +1391,8 @@ ;;; 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* ())) @@ -1416,7 +1446,6 @@ (*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*) @@ -1464,9 +1493,10 @@ ;; the input file. (fatal-compiler-error (condition) (signal condition) - (format *error-output* - "~@" - condition) + (when *compile-verbose* + (format *standard-output* + "~@" + condition)) (values nil t t))))) ;;; Return a pathname for the named file. The file must exist. @@ -1492,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):~%" @@ -1504,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 @@ -1532,38 +1563,54 @@ ;; extensions (trace-file 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 @@ -1589,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) @@ -1606,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*))) @@ -1730,9 +1777,7 @@ (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))))