X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=06067d1e0aef177d5104cc857e33d8f8e5742ffe;hb=2912f5f6c2acb2da3b9fcc0f5afd1ca89782a9f8;hp=a99e5ba0034a12b8bc0b6e98d2b5fde2b267090b;hpb=cf607a404d7518e8a18c9e362913f370eb9a5e38;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index a99e5ba..06067d1 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -28,7 +28,11 @@ #!+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. +(defvar *flame-on-necessarily-undefined-function* nil) (defvar *check-consistency* nil) (defvar *all-components*) @@ -121,17 +125,15 @@ `(%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) @@ -139,16 +141,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 @@ -172,23 +181,53 @@ (warnings (undefined-warning-warnings undef)) (undefined-warning-count (undefined-warning-count undef))) (dolist (*compiler-error-context* warnings) - (compiler-style-warn "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-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 :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*) @@ -409,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) @@ -425,7 +465,7 @@ *code-segment* code-length trace-table - fixups + fixup-notes *compile-object*)) (core-object (maybe-mumble "core") @@ -433,7 +473,7 @@ *code-segment* code-length trace-table - fixups + fixup-notes *compile-object*)) (null)))))) @@ -597,7 +637,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*) @@ -801,9 +841,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 @@ -846,15 +888,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 @@ -870,10 +913,14 @@ (setf (component-name component) (debug-namify "~S initial component" name)) (setf (component-kind component) :initial) - (let* ((locall-fun (ir1-convert-lambda + (let* ((locall-fun (ir1-convert-lambdalike definition :debug-name (debug-namify "top level local call ~S" - name))) + name) + ;; KLUDGE: we do this so that we get to have + ;; nice debug returnness in functions defined + ;; from the REPL + :allow-debug-catch-tag t)) (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) :source-name (or name '.anonymous.) :debug-name (unless name @@ -937,41 +984,54 @@ (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)) - ;; 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 - (when (core-object-p *compile-object*) - (fix-core-source-info *source-info* *compile-object*)) - - (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) @@ -1121,7 +1181,8 @@ (declare (ignore funs)) (process-toplevel-locally body path - compile-time-too)))) + compile-time-too)) + :compile)) ((symbol-macrolet) (funcall-in-symbol-macrolet-lexenv magic @@ -1129,7 +1190,8 @@ (process-toplevel-locally body path compile-time-too - :vars vars))))))) + :vars vars)) + :compile))))) ((locally) (process-toplevel-locally (rest form) path compile-time-too)) ((progn) @@ -1286,32 +1348,35 @@ ;;; 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*) + (*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 () @@ -1431,7 +1496,7 @@ (input-pathname (verify-source-file input-file)) (source-info (make-file-source-info input-pathname)) (*compiler-trace-output* nil)) ; might be modified below - + (unwind-protect (progn (when output-file