X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fmain.lisp;h=b188592a84f6e42aa2930ad05e37cec293604de6;hb=91ee7afd75d8b282829daa647d0a8f1469336a77;hp=a7e5d1cfa67e23651c4892c97acf5e79681752b1;hpb=95f17ca63742f8c164309716b35bc25545a849a6;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index a7e5d1c..b188592 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -32,9 +32,9 @@ *lexenv* *fun-names-in-this-file* *allow-instrumenting*)) -;;; Whether call of a function which cannot be defined causes a full +;;; Whether reference to a thing which cannot be defined causes a full ;;; warning. -(defvar *flame-on-necessarily-undefined-function* nil) +(defvar *flame-on-necessarily-undefined-thing* nil) (defvar *check-consistency* nil) @@ -188,11 +188,19 @@ (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*)) +;;; Is NAME something that no conforming program can rely on +;;; defining? +(defun name-reserved-by-ansi-p (name kind) + (ecase kind + (:function + (eq (symbol-package (fun-name-block-name name)) + *cl-package*)) + (:type + (let ((symbol (typecase name + (symbol name) + ((cons symbol) (car name)) + (t (return-from name-reserved-by-ansi-p nil))))) + (eq (symbol-package symbol) *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 @@ -200,91 +208,101 @@ ;;; aborted by throwing out. ABORT-COUNT is the number of dynamically ;;; enclosed nested compilation units that were aborted. (defun summarize-compilation-unit (abort-p) - (unless abort-p - (handler-bind ((style-warning #'compiler-style-warning-handler) - (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))))))) - (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) - (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))) - (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 #'neq - :key #'undefined-warning-kind)))) - (when 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*) - (zerop *compiler-error-count*) - (zerop *compiler-warning-count*) - (zerop *compiler-style-warning-count*) - (zerop *compiler-note-count*)) - (pprint-logical-block (*error-output* nil :per-line-prefix "; ") - (format *error-output* "~&compilation unit ~:[finished~;aborted~]~ - ~[~:;~:*~& 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*)) - (terpri *error-output*) - (force-output *error-output*))) + (let (summary) + (unless abort-p + (handler-bind ((style-warning #'compiler-style-warning-handler) + (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))))))) + (dolist (kind '(:variable :function :type)) + (let ((names (mapcar #'undefined-warning-name + (remove kind undefs :test #'neq + :key #'undefined-warning-kind)))) + (when names (push (cons kind names) summary)))) + (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) + (if #-sb-xc-host (and (member kind '(:function :type)) + (name-reserved-by-ansi-p name kind) + *flame-on-necessarily-undefined-thing*) + #+sb-xc-host nil + (ecase kind + (:function + (case name + ((declare) + (compiler-warn + "~@" name + name)) + (t + (compiler-warn + "~@" name)))) + (:type + (if (and (consp name) (eq 'quote (car name))) + (compiler-warn + "~@" + name 'quote) + (compiler-warn + "~@" name + 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))) + (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)))))))))) + + (unless (and (not abort-p) + (zerop *aborted-compilation-unit-count*) + (zerop *compiler-error-count*) + (zerop *compiler-warning-count*) + (zerop *compiler-style-warning-count*) + (zerop *compiler-note-count*)) + (pprint-logical-block (*error-output* nil :per-line-prefix "; ") + (format *error-output* "~&compilation unit ~:[finished~;aborted~]" + abort-p) + (dolist (cell summary) + (destructuring-bind (kind &rest names) cell + (format *error-output* + "~& Undefined ~(~A~)~p:~ + ~% ~{~<~% ~1:;~S~>~^ ~}" + kind (length names) names))) + (format *error-output* "~[~:;~:*~& 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~]" + *aborted-compilation-unit-count* + *compiler-error-count* + *compiler-warning-count* + *compiler-style-warning-count* + *compiler-note-count*)) + (terpri *error-output*) + (force-output *error-output*)))) ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and @@ -459,6 +477,8 @@ (maybe-mumble "copy ") (copy-propagate component)) + (ir2-optimize component) + (select-representations component) (when *check-consistency* @@ -758,7 +778,7 @@ (print-unreadable-object (s stream :type t)))) (:copier nil)) ;; the UT that compilation started at - (start-time (get-universal-time) :type unsigned-byte) + (start-time (get-internal-real-time) :type unsigned-byte) ;; the FILE-INFO structure for this compilation (file-info nil :type (or file-info null)) ;; the stream that we are using to read the FILE-INFO, or NIL if @@ -803,7 +823,8 @@ ;;; error condition (possibly recording some extra location ;;; information). (defun read-for-compile-file (stream position) - (handler-case (read stream nil stream) + (handler-case + (read-preserving-whitespace stream nil stream) (reader-error (condition) (error 'input-error-in-compile-file :condition condition @@ -1031,7 +1052,8 @@ (functional-lexenv locall-fun)))) (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) :source-name source-name - :debug-name (debug-name 'tl-xep debug-name-tail)))) + :debug-name (debug-name 'tl-xep debug-name-tail) + :system-lambda t))) (when name (assert-global-function-definition-type name locall-fun)) (setf (functional-entry-fun fun) locall-fun @@ -1181,6 +1203,7 @@ (catch 'process-toplevel-form-error-abort (let* ((path (or (get-source-path form) (cons form path))) + (*current-path* path) (*compiler-error-bailout* (lambda (&optional condition) (convert-and-maybe-compile @@ -1244,9 +1267,7 @@ ;; sequence of steps in ANSI's "3.2.3.1 Processing of ;; Top Level Forms". #-sb-xc-host - (let ((expanded - (let ((*current-path* path)) - (preprocessor-macroexpand-1 form)))) + (let ((expanded (preprocessor-macroexpand-1 form))) (cond ((eq expanded form) (when compile-time-too (eval-in-lexenv form *lexenv*)) @@ -1547,7 +1568,7 @@ ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. (*info-environment* *info-environment*) (*compiler-sset-counter* 0) - (*gensym-counter* 0)) + (sb!xc:*gensym-counter* 0)) (handler-case (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) (with-compilation-values @@ -1605,10 +1626,13 @@ ((try-with-type pathname "lisp" nil)) ((try-with-type pathname "lisp" t)))))) -(defun elapsed-time-to-string (tsec) - (multiple-value-bind (tmin sec) (truncate tsec 60) - (multiple-value-bind (thr min) (truncate tmin 60) - (format nil "~D:~2,'0D:~2,'0D" thr min sec)))) +(defun elapsed-time-to-string (internal-time-delta) + (multiple-value-bind (tsec remainder) + (truncate internal-time-delta internal-time-units-per-second) + (let ((ms (truncate remainder (/ internal-time-units-per-second 1000)))) + (multiple-value-bind (tmin sec) (truncate tsec 60) + (multiple-value-bind (thr min) (truncate tmin 60) + (format nil "~D:~2,'0D:~2,'0D.~3,'0D" thr min sec ms)))))) ;;; Print some junk at the beginning and end of compilation. (defun print-compile-start-note (source-info) @@ -1629,7 +1653,7 @@ (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&" won (elapsed-time-to-string - (- (get-universal-time) + (- (get-internal-real-time) (source-info-start-time source-info)))) (values))