X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=ff1bcce79cb3ee8c64c5fa6773acbb1fc4885534;hb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;hp=77567ccbe706c4674d163bfda46eb96b3b171c29;hpb=16f848f33e91035457132f704448d2d23c34724e;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 77567cc..ff1bcce 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -28,7 +28,7 @@ #!+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*)) ;;; Whether call of a function which cannot be defined causes a full ;;; warning. @@ -91,11 +91,6 @@ ;;; normally causes nested uses to be no-ops). (defvar *in-compilation-unit* nil) -;;; This lock is siezed in the same situation: the compiler is not -;;; presently thread-safe -(defvar *big-compiler-lock* - (sb!thread:make-mutex :name "big compiler lock")) - ;;; Count of the number of compilation units dynamically enclosed by ;;; the current active WITH-COMPILATION-UNIT that were unwound out of. (defvar *aborted-compilation-unit-count*) @@ -139,9 +134,6 @@ (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) @@ -161,6 +153,12 @@ (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 ;;; error counts. ABORT-P should be true when the compilation unit was @@ -184,28 +182,52 @@ (undefined-warning-count (undefined-warning-count undef))) (dolist (*compiler-error-context* warnings) (if #-sb-xc-host (and (eq kind :function) - (symbolp name) ; FIXME: (SETF CL:fo) - (eq (symbol-package name) *cl-package*) + (fun-name-reserved-by-ansi-p name) *flame-on-necessarily-undefined-function*) #+sb-xc-host nil - (compiler-warn "undefined ~(~A~): ~S" kind name) - (compiler-style-warn "undefined ~(~A~): ~S" kind name))) + (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-warn - "~W more use~:P of undefined ~(~A~) ~S" - more kind name)))))) + (if (eq kind :variable) + (compiler-warn + "~W more use~:P of undefined ~(~A~) ~S" + more kind name) + (compiler-style-warn + "~W more use~:P of undefined ~(~A~) ~S" + more kind name))))))) (dolist (kind '(:variable :function :type)) (let ((summary (mapcar #'undefined-warning-name - (remove kind undefs :test-not #'eq + (remove kind undefs :test #'neq :key #'undefined-warning-kind)))) (when summary - (compiler-style-warn - "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ - ~% ~{~<~% ~1:;~S~>~^ ~}" - (cdr summary) kind summary))))))) + (if (eq kind :variable) + (compiler-warn + "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ + ~% ~{~<~% ~1:;~S~>~^ ~}" + (cdr summary) kind summary) + (compiler-style-warn + "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ + ~% ~{~<~% ~1:;~S~>~^ ~}" + (cdr summary) kind summary)))))))) (unless (and (not abort-p) (zerop *aborted-compilation-unit-count*) @@ -426,9 +448,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) @@ -442,7 +465,7 @@ *code-segment* code-length trace-table - fixups + fixup-notes *compile-object*)) (core-object (maybe-mumble "core") @@ -450,7 +473,7 @@ *code-segment* code-length trace-table - fixups + fixup-notes *compile-object*)) (null)))))) @@ -589,13 +612,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 @@ -614,7 +631,7 @@ (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*) @@ -788,7 +805,9 @@ ;;; *TOPLEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) - (let* ((*lexenv* (make-lexenv :policy *policy*)) + (let* ((*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))))) @@ -818,9 +837,11 @@ ;;; We parse declarations and then recursively process the body. (defun process-toplevel-locally (body path compile-time-too &key vars funs) (declare (list path)) - (multiple-value-bind (forms decls) (parse-body body nil) - (let* ((*lexenv* - (process-decls decls vars funs (make-continuation))) + (multiple-value-bind (forms decls) + (parse-body body :doc-string-allowed nil :toplevel t) + (let* ((*lexenv* (process-decls decls vars funs)) + ;; FIXME: VALUES declaration + ;; ;; Binding *POLICY* is pretty much of a hack, since it ;; causes LOCALLY to "capture" enclosed proclamations. It ;; is necessary because CONVERT-AND-MAYBE-COMPILE uses the @@ -831,7 +852,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, @@ -890,8 +915,8 @@ (setf (component-kind component) :initial) (let* ((locall-fun (ir1-convert-lambdalike definition - :debug-name (debug-namify "top level local call ~S" - name) + :debug-name (debug-namify "top level local call " + name) ;; KLUDGE: we do this so that we get to have ;; nice debug returnness in functions defined ;; from the REPL @@ -929,7 +954,9 @@ '(original-source-start 0 0))) (when name (legal-fun-name-or-type-error name)) - (let* ((*lexenv* (make-lexenv :policy *policy*)) + (let* ((*lexenv* (make-lexenv :policy *policy* + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) @@ -1152,19 +1179,23 @@ ((macrolet) (funcall-in-macrolet-lexenv magic - (lambda (&key funs) + (lambda (&key funs prepend) (declare (ignore funs)) + (aver (null prepend)) (process-toplevel-locally body path - compile-time-too)))) + compile-time-too)) + :compile)) ((symbol-macrolet) (funcall-in-symbol-macrolet-lexenv magic - (lambda (&key vars) + (lambda (&key vars prepend) + (aver (null prepend)) (process-toplevel-locally body path compile-time-too - :vars vars))))))) + :vars vars)) + :compile))))) ((locally) (process-toplevel-locally (rest form) path compile-time-too)) ((progn) @@ -1317,50 +1348,95 @@ (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-arg*) - (*package* (sane-package)) - (*policy* *policy*) - (*lexenv* (make-null-lexenv)) - (*source-info* info) - (sb!xc:*compile-file-pathname* nil) - (sb!xc:*compile-file-truename* nil) - (*toplevel-lambdas* ()) - (*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* ()) + (*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) - (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.