From 9efa3ad24423b6839186bf51f509953dbbaaf2ef Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 29 May 1990 16:19:56 +0000 Subject: [PATCH] Made clearing of debug-id tables by CLEAR-STUFF optional so that we can keep the interpreter from trashing them. Added printing of a summary of undefined warning names. Added printing of header and trailer error output. Fixed COMPILE to use the new interface to FIND-INITIAL-DFO. --- compiler/main.lisp | 152 +++++++++++++++++++++++++++++++-------------- 1 file changed, 107 insertions(+), 45 deletions(-) diff --git a/compiler/main.lisp b/compiler/main.lisp index 64e406607..9ff98a76f 100644 --- a/compiler/main.lisp +++ b/compiler/main.lisp @@ -266,11 +266,11 @@ (undefined-value)) -;;; CLEAR-STUFF -- Internal +;;; CLEAR-STUFF -- Interface ;;; ;;; Clear all the global variables used by the compiler. ;;; -(defun clear-stuff () +(defun clear-stuff (&optional (debug-too t)) ;; ;; Clear global tables. (clrhash *free-functions*) @@ -282,15 +282,17 @@ (clrhash *seen-blocks*) (clrhash *seen-functions*) (clrhash *list-conflicts-table*) - (clrhash *continuation-numbers*) - (clrhash *number-continuations*) - (setq *continuation-number* 0) - (clrhash *tn-ids*) - (clrhash *id-tns*) - (setq *tn-id* 0) - (clrhash *label-ids*) - (clrhash *id-labels*) - (setq *label-id* 0) + + (when debug-too + (clrhash *continuation-numbers*) + (clrhash *number-continuations*) + (setq *continuation-number* 0) + (clrhash *tn-ids*) + (clrhash *id-tns*) + (setq *tn-id* 0) + (clrhash *label-ids*) + (clrhash *id-labels*) + (setq *label-id* 0)) ;; ;; Clear some Pack data structures (for GC purposes only.) (dolist (sb *sb-list*) @@ -298,7 +300,9 @@ (fill (finite-sb-live-tns sb) nil))) ;; ;; Reset Gensym. - (setq lisp:*gensym-counter* 0)) + (setq lisp:*gensym-counter* 0) + + (values)) ;;; PRINT-SUMMARY -- Interface @@ -311,38 +315,50 @@ ;;; (defun print-summary (abort-p abort-count) (unless abort-p - (let ((funs (sort *undefined-warnings* #'string< - :key #'(lambda (x) - (let ((x (undefined-warning-name x))) - (if (symbolp x) - (symbol-name x) - (prin1-to-string x))))))) - (dolist (fun funs) - (let ((name (undefined-warning-name fun)) - (kind (undefined-warning-kind fun)) - (warnings (undefined-warning-warnings fun)) - (count (undefined-warning-count fun))) + (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)) + (count (undefined-warning-count undef))) (dolist (*compiler-error-context* warnings) (compiler-warning "Undefined ~(~A~): ~S" kind name)) (let ((warn-count (length warnings))) - (when (> count warn-count) + (when (and warnings (> count warn-count)) (let ((more (- count warn-count))) - (compiler-warning - "~D ~:[~;more ~]use~P of undefined ~(~A~) ~S." - more warnings more kind name)))))))) - - (compiler-mumble - "~2&Compilation unit ~:[finished~;aborted~].~ - ~[~:;~:*~& ~D fatal error~:P~]~ - ~[~:;~:*~& ~D error~:P~]~ - ~[~:;~:*~& ~D warning~:P~]~ - ~[~:;~:*~& ~D note~:P~]~2%" - abort-p - abort-count - *compiler-error-count* - *compiler-warning-count* - *compiler-note-count*)) + (compiler-warning "~D more use~P of undefined ~(~A~) ~S." + more warnings more kind name)))))) + + (dolist (kind '(:variable :function :type)) + (let ((summary (mapcar #'undefined-warning-name + (remove kind undefs :test-not #'eq + :key #'undefined-warning-kind)))) + (when summary + (compiler-warning + "Undefined ~(~A~) summary:~% ~{~<~% ~1:;~S~>~^ ~}" + kind summary)))))) + + (unless (and (not abort-p) (zerop abort-count) + (zerop *compiler-error-count*) + (zerop *compiler-warning-count*) + (zerop *compiler-note-count*)) + (compiler-mumble + "~2&Compilation unit ~:[finished~;aborted~].~ + ~[~:;~:*~& ~D fatal error~:P~]~ + ~[~:;~:*~& ~D error~:P~]~ + ~[~:;~:*~& ~D warning~:P~]~ + ~[~:;~:*~& ~D note~:P~]~2%" + abort-p + abort-count + *compiler-error-count* + *compiler-warning-count* + *compiler-note-count*))) ;;; Describe-Component -- Internal @@ -972,6 +988,45 @@ (close-source-info info)))) +(defun elapsed-time-to-string (it) + (let ((tsec (truncate it internal-time-units-per-second))) + (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))))) + + +;;; START-ERROR-OUTPUT, FINISH-ERROR-OUTPUT -- Internal +;;; +;;; Print some junk at the beginning and end of compilation. +;;; +(defun start-error-output (source-info) + (declare (type source-info source-info)) + (compiler-mumble "~2&Python version ~A, VM ~A on ~A.~%" + compiler-version vm-version + (ext:format-universal-time nil (get-universal-time) + :print-weekday nil + :print-timezone nil)) + (dolist (x (source-info-files source-info)) + (compiler-mumble "Compiling: ~A ~A~%" + (namestring (file-info-name x)) + (ext:format-universal-time nil (file-info-write-date x) + :print-weekday nil + :print-timezone nil))) + (compiler-mumble "~%") + (undefined-value)) +;;; +(defun finish-error-output (source-info won) + (declare (type source-info source-info)) + (compiler-mumble "Compilation ~:[aborted after~;finished in] ~A.~&" + won + (elapsed-time-to-string + (- (get-universal-time) + (source-info-start-time source-info)))) + (undefined-value)) + + ;;; COMPILE-FILE -- Public ;;; ;;; Open some files and call SUB-COMPILE-FILE. If the compile is unwound @@ -1015,6 +1070,7 @@ (source (verify-source-files source)) (source-info (make-file-source-info source)) (default (pathname (first source)))) + (start-error-output source-info) (unwind-protect (progn #-new-compiler @@ -1058,7 +1114,12 @@ (close-source-info source-info) (when fasl-file - (close-fasl-file fasl-file (not compile-won))) + (close-fasl-file fasl-file (not compile-won)) + (when compile-won + (compiler-mumble "~&~A written.~%" + (namestring (truename output-file-name))))) + + (finish-error-output source-info compile-won) (when error-file-stream (let ((name (pathname error-file-stream))) @@ -1159,11 +1220,12 @@ (*all-components* (list component))) (local-call-analyze component)) - (let* ((components (find-initial-dfo (list lambda))) - (*all-components* components)) - (dolist (component components) - (compile-component component object) - (clear-ir2-info component))) + (multiple-value-bind (components top-components) + (find-initial-dfo (list lambda)) + (let ((*all-components* (append components top-components))) + (dolist (component *all-components*) + (compile-component component object) + (clear-ir2-info component)))) (fix-core-source-info *source-info* object) (let* ((res (core-call-top-level-lambda lambda object)) -- GitLab