X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=7ca4376ca3b3e29dac0bbdc6da3f2659aeb512bd;hb=590df13be510876c71757f4a14a2424e8c57ad61;hp=1c42b5840b45c2bbd519fd114479de03815d717a;hpb=5cf3c4259d529e180d75d4d140f344e600d2b06b;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 1c42b58..7ca4376 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -15,9 +15,7 @@ ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp? (declaim (special *constants* *free-vars* *component-being-compiled* - *code-vector* *next-location* *result-fixups* *free-funs* *source-paths* - *seen-blocks* *seen-funs* *list-conflicts-table* *continuation-number* *continuation-numbers* *number-continuations* *tn-id* *tn-ids* *id-tns* *label-ids* *label-id* *id-labels* @@ -32,9 +30,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) @@ -114,6 +112,9 @@ (defvar *compile-object* nil) (declaim (type object *compile-object*)) +(defvar *compile-toplevel-object* nil) + +(defvar *emit-cfasl* nil) (defvar *fopcompile-label-counter*) @@ -133,66 +134,135 @@ (defmacro sb!xc:with-compilation-unit (options &body body) #!+sb-doc - "WITH-COMPILATION-UNIT ({Key Value}*) Form* - This form affects compilations that take place within its dynamic extent. It - is intended to be wrapped around the compilation of all files in the same - system. These keywords are defined: - - :OVERRIDE Boolean-Form - One of the effects of this form is to delay undefined warnings - until the end of the form, instead of giving them at the end of each - compilation. If OVERRIDE is NIL (the default), then the outermost - WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying - OVERRIDE true causes that form to grab any enclosed warnings, even if - it is enclosed by another WITH-COMPILATION-UNIT. - - :SOURCE-PLIST Plist-Form - Attaches the value returned by the Plist-Form to internal debug-source - information of functions compiled in within the dynamic contour. - Primarily for use by development environments, in order to eg. associate - function definitions with editor-buffers. Can be accessed as - SB-INTROSPECT:DEFINITION-SOURCE-PLIST. If multiple, nested - WITH-COMPILATION-UNITs provide :SOURCE-PLISTs, they are appended - togather, innermost left. If Unaffected by :OVERRIDE." + "Affects compilations that take place within its dynamic extent. It is +intended to be eg. wrapped around the compilation of all files in the same system. + +Following options are defined: + + :OVERRIDE Boolean-Form + One of the effects of this form is to delay undefined warnings until the + end of the form, instead of giving them at the end of each compilation. + If OVERRIDE is NIL (the default), then the outermost + WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying + OVERRIDE true causes that form to grab any enclosed warnings, even if it + is enclosed by another WITH-COMPILATION-UNIT. + + :POLICY Optimize-Declaration-Form + Provides dynamic scoping for global compiler optimization qualities and + restrictions, limiting effects of subsequent OPTIMIZE proclamations and + calls to SB-EXT:RESTRICT-COMPILER-POLICY to the dynamic scope of BODY. + + If OVERRIDE is false, specified POLICY is merged with current global + policy. If OVERRIDE is true, current global policy, including any + restrictions, is discarded in favor of the specified POLICY. + + Supplying POLICY NIL is equivalent to the option not being supplied at + all, ie. dynamic scoping of policy does not take place. + + This option is an SBCL-specific experimental extension: Interface + subject to change. + + :SOURCE-NAMESTRING Namestring-Form + Attaches the value returned by the Namestring-Form to the internal + debug-source information as the namestring of the source file. Normally + the namestring of the input-file for COMPILE-FILE is used: this option + can be used to provide source-file information for functions compiled + using COMPILE, or to override the input-file of COMPILE-FILE. + + If both an outer and an inner WITH-COMPILATION-UNIT provide a + SOURCE-NAMESTRING, the inner one takes precedence. Unaffected + by :OVERRIDE. + + This is an SBCL-specific extension. + + :SOURCE-PLIST Plist-Form + Attaches the value returned by the Plist-Form to internal debug-source + information of functions compiled in within the dynamic extent of BODY. + + Primarily for use by development environments, in order to eg. associate + function definitions with editor-buffers. Can be accessed using + SB-INTROSPECT:DEFINITION-SOURCE-PLIST. + + If an outer WITH-COMPILATION-UNIT form also provide a SOURCE-PLIST, it + is appended to the end of the provided SOURCE-PLIST. Unaffected + by :OVERRIDE. + + This is an SBCL-specific extension. + +Examples: + + ;; Prevent proclamations from the file leaking, and restrict + ;; SAFETY to 3 -- otherwise uses the current global policy. + (with-compilation-unit (:policy '(optimize)) + (restrict-compiler-policy 'safety 3) + (load \"foo.lisp\")) + + ;; Using default policy instead of the current global one, + ;; except for DEBUG 3. + (with-compilation-unit (:policy '(optimize debug) + :override t) + (load \"foo.lisp\")) + + ;; Same as if :POLICY had not been specified at all: SAFETY 3 + ;; proclamation leaks out from WITH-COMPILATION-UNIT. + (with-compilation-unit (:policy nil) + (declaim (optimize safety)) + (load \"foo.lisp\")) +" `(%with-compilation-unit (lambda () ,@body) ,@options)) (defvar *source-plist* nil) +(defvar *source-namestring* nil) -(defun %with-compilation-unit (fn &key override source-plist) +(defun %with-compilation-unit (fn &key override policy source-plist source-namestring) (declare (type function fn)) - (let ((succeeded-p nil) - (*source-plist* (append source-plist *source-plist*))) - (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)) - (unless succeeded-p - (incf *aborted-compilation-unit-count*))) - (let ((*aborted-compilation-unit-count* 0) - (*compiler-error-count* 0) - (*compiler-warning-count* 0) - (*compiler-style-warning-count* 0) - (*compiler-note-count* 0) - (*undefined-warnings* nil) - (*in-compilation-unit* t)) - (with-world-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*)) + (flet ((with-it () + (let ((succeeded-p nil) + (*source-plist* (append source-plist *source-plist*)) + (*source-namestring* (or source-namestring *source-namestring*))) + (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)) + (unless succeeded-p + (incf *aborted-compilation-unit-count*))) + (let ((*aborted-compilation-unit-count* 0) + (*compiler-error-count* 0) + (*compiler-warning-count* 0) + (*compiler-style-warning-count* 0) + (*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))))))))) + (if policy + (let ((*policy* (process-optimize-decl policy (unless override *policy*))) + (*policy-restrictions* (unless override *policy-restrictions*))) + (with-it)) + (with-it)))) + +;;; 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,111 +270,142 @@ ;;; 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 ;;; WARNINGS-P and FAILURE-P are as in CL:COMPILE or CL:COMPILE-FILE. ;;; This also wraps up WITH-IR1-NAMESPACE functionality. (defmacro with-compilation-values (&body body) - `(with-ir1-namespace - (let ((*warnings-p* nil) - (*failure-p* nil)) - (values (progn ,@body) - *warnings-p* - *failure-p*)))) + ;; These bindings could just as well be in WITH-IR1-NAMESPACE, but + ;; since they're primarily debugging tools, it's nicer to have + ;; a wider unique scope by ID. + `(let ((*continuation-number* 0) + (*continuation-numbers* (make-hash-table :test 'eq)) + (*number-continuations* (make-hash-table :test 'eql)) + (*tn-id* 0) + (*tn-ids* (make-hash-table :test 'eq)) + (*id-tns* (make-hash-table :test 'eql)) + (*label-id* 0) + (*label-ids* (make-hash-table :test 'eq)) + (*id-labels* (make-hash-table :test 'eql))) + (unwind-protect + (let ((*warnings-p* nil) + (*failure-p* nil)) + (handler-bind ((compiler-error #'compiler-error-handler) + (style-warning #'compiler-style-warning-handler) + (warning #'compiler-warning-handler)) + (values (progn ,@body) + *warnings-p* + *failure-p*))) + (clrhash *tn-ids*) + (clrhash *id-tns*) + (clrhash *continuation-numbers*) + (clrhash *number-continuations*) + (clrhash *label-ids*) + (clrhash *id-labels*)))) ;;;; component compilation (defparameter *max-optimize-iterations* 3 ; ARB #!+sb-doc "The upper limit on the number of times that we will consecutively do IR1 - optimization that doesn't introduce any new code. A finite limit is - necessary, since type inference may take arbitrarily long to converge.") +optimization that doesn't introduce any new code. A finite limit is +necessary, since type inference may take arbitrarily long to converge.") (defevent ir1-optimize-until-done "IR1-OPTIMIZE-UNTIL-DONE called") (defevent ir1-optimize-maxed-out "hit *MAX-OPTIMIZE-ITERATIONS* limit") @@ -425,12 +526,25 @@ (return)) (incf loop-count))) + (when *check-consistency* + (do-blocks-backwards (block component) + (awhen (flush-dead-code block) + (let ((*compiler-error-context* it)) + (compiler-warn "dead code detected at the end of ~S" + 'ir1-phases))))) + (ir1-finalize component) (values)) (defun %compile-component (component) (let ((*code-segment* nil) - (*elsewhere* nil)) + (*elsewhere* nil) + #!+inline-constants + (*constant-segment* nil) + #!+inline-constants + (*constant-table* nil) + #!+inline-constants + (*constant-vector* nil)) (maybe-mumble "GTN ") (gtn-analyze component) (maybe-mumble "LTN ") @@ -481,7 +595,7 @@ (check-life-consistency component)) (maybe-mumble "pack ") - (pack component) + (sb!regalloc:pack component) (when *check-consistency* (maybe-mumble "check-pack ") @@ -617,12 +731,14 @@ (defun clear-constant-info () (maphash (lambda (k v) (declare (ignore k)) - (setf (leaf-info v) nil)) + (setf (leaf-info v) nil) + (setf (constant-boxed-tn v) nil)) *constants*) (maphash (lambda (k v) (declare (ignore k)) (when (constant-p v) - (setf (leaf-info v) nil))) + (setf (leaf-info v) nil) + (setf (constant-boxed-tn v) nil))) *free-vars*) (values)) @@ -646,47 +762,6 @@ (blast *free-funs*) (blast *constants*)) (values)) - -;;; Clear global variables used by the compiler. -;;; -;;; FIXME: It seems kinda nasty and unmaintainable to have to do this, -;;; and it adds overhead even when people aren't using the compiler. -;;; Perhaps we could make these global vars unbound except when -;;; actually in use, so that this function could go away. -(defun clear-stuff (&optional (debug-too t)) - - ;; Clear global tables. - (when (boundp '*free-funs*) - (clrhash *free-funs*) - (clrhash *free-vars*) - (clrhash *constants*)) - - ;; Clear debug counters and tables. - (clrhash *seen-blocks*) - (clrhash *seen-funs*) - (clrhash *list-conflicts-table*) - - (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)) - - ;; (Note: The CMU CL code used to set CL::*GENSYM-COUNTER* to zero here. - ;; Superficially, this seemed harmful -- the user could reasonably be - ;; surprised if *GENSYM-COUNTER* turned back to zero when something was - ;; compiled. A closer inspection showed that this actually turned out to be - ;; harmless in practice, because CLEAR-STUFF was only called from within - ;; forms which bound CL::*GENSYM-COUNTER* to zero. However, this means that - ;; even though zeroing CL::*GENSYM-COUNTER* here turned out to be harmless in - ;; practice, it was also useless in practice. So we don't do it any more.) - - (values)) ;;;; trace output @@ -760,7 +835,9 @@ (print-unreadable-object (s stream :type t)))) (:copier nil)) ;; the UT that compilation started at - (start-time (get-internal-real-time) :type unsigned-byte) + (start-time (get-universal-time) :type unsigned-byte) + ;; the IRT that compilation started at + (start-real-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 @@ -805,23 +882,30 @@ ;;; 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 - ;; We don't need to supply :POSITION here because - ;; READER-ERRORs already know their position in the file. - )) + (compiler-error 'input-error-in-compile-file + ;; We don't need to supply :POSITION here because + ;; READER-ERRORs already know their position in the file. + :condition condition + :stream stream)) ;; ANSI, in its wisdom, says that READ should return END-OF-FILE ;; (and that this is not a READER-ERROR) when it encounters end of ;; file in the middle of something it's trying to read. (end-of-file (condition) - (error 'input-error-in-compile-file - :condition condition - ;; We need to supply :POSITION here because the END-OF-FILE - ;; condition doesn't carry the position that the user - ;; probably cares about, where the failed READ began. - :position position)))) + (compiler-error 'input-error-in-compile-file + :condition condition + ;; We need to supply :POSITION here because the END-OF-FILE + ;; condition doesn't carry the position that the user + ;; probably cares about, where the failed READ began. + :position position + :stream stream)) + (error (condition) + (compiler-error 'input-error-in-compile-file + :condition condition + :position position + :stream stream)))) ;;; If STREAM is present, return it, otherwise open a stream to the ;;; current file. There must be a current file. @@ -882,9 +966,10 @@ ;;; Read and compile the source file. (defun sub-sub-compile-file (info) (do-forms-from-info ((form current-index) info) - (find-source-paths form current-index) - (process-toplevel-form - form `(original-source-start 0 ,current-index) nil))) + (with-source-paths + (find-source-paths form current-index) + (process-toplevel-form + form `(original-source-start 0 ,current-index) nil)))) ;;; Return the INDEX'th source form read from INFO and the position ;;; where it was read. @@ -908,21 +993,22 @@ (if (fopcompilable-p form) (let ((*fopcompile-label-counter* 0)) (fopcompile form path nil)) - (let ((*lexenv* (make-lexenv - :policy *policy* - :handled-conditions *handled-conditions* - :disabled-package-locks *disabled-package-locks*)) - (tll (ir1-toplevel form path nil))) - (if (eq *block-compile* t) - (push tll *toplevel-lambdas*) - (compile-toplevel (list tll) nil)) - nil))))) + (with-ir1-namespace + (let ((*lexenv* (make-lexenv + :policy *policy* + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) + (tll (ir1-toplevel form path 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 ;;; forms in the source path. (defun preprocessor-macroexpand-1 (form) - (handler-case (sb!xc:macroexpand-1 form *lexenv*) + (handler-case (%macroexpand-1 form *lexenv*) (error (condition) (compiler-error "(during macroexpansion of ~A)~%~A" (let ((*print-level* 2) @@ -945,25 +1031,26 @@ (declare (list path)) (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 - ;; value of *POLICY* as the policy. The need for this hack - ;; is due to the quirk that there is no way to represent in - ;; a POLICY that an optimize quality came from the default. - ;; - ;; 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*)) - ;; 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)))) + (with-ir1-namespace + (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 + ;; value of *POLICY* as the policy. The need for this hack + ;; is due to the quirk that there is no way to represent in + ;; a POLICY that an optimize quality came from the default. + ;; + ;; 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*)) + ;; 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, ;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating @@ -1020,28 +1107,39 @@ (source-name (or name '.anonymous.))) (setf (component-name component) (debug-name 'initial-component debug-name-tail) (component-kind component) :initial) - (let* ((locall-fun (let ((*allow-instrumenting* t)) - (funcall #'ir1-convert-lambdalike - lambda-expression - :source-name source-name))) - ;; Convert the XEP using the policy of the real - ;; function. Otherwise the wrong policy will be used for - ;; deciding whether to type-check the parameters of the - ;; real function (via CONVERT-CALL / PROPAGATE-TO-ARGS). - ;; -- JES, 2007-02-27 - (*lexenv* (make-lexenv :policy (lexenv-policy - (functional-lexenv locall-fun)))) - (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) + (let* ((fun (let ((*allow-instrumenting* t)) + (funcall #'ir1-convert-lambdalike + lambda-expression + :source-name source-name))) + ;; Convert the XEP using the policy of the real function. Otherwise + ;; the wrong policy will be used for deciding whether to type-check + ;; the parameters of the real function (via CONVERT-CALL / + ;; PROPAGATE-TO-ARGS). -- JES, 2007-02-27 + (*lexenv* (make-lexenv :policy (lexenv-policy (functional-lexenv fun)))) + (xep (ir1-convert-lambda (make-xep-lambda-expression fun) :source-name source-name :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 - (functional-kind fun) :external - (functional-has-external-references-p locall-fun) t - (functional-has-external-references-p fun) t) - fun))) + (assert-global-function-definition-type name fun)) + (setf (functional-kind xep) :external + (functional-entry-fun xep) fun + (functional-entry-fun fun) xep + (component-reanalyze component) t + (functional-has-external-references-p xep) t) + (reoptimize-component component :maybe) + (locall-analyze-xep-entry-point fun) + ;; Any leftover REFs to FUN outside local calls get replaced with the + ;; XEP. + (substitute-leaf-if (lambda (ref) + (let* ((lvar (ref-lvar ref)) + (dest (when lvar (lvar-dest lvar))) + (kind (when (basic-combination-p dest) + (basic-combination-kind dest)))) + (neq :local kind))) + xep + fun) + xep))) ;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a ;;; description of the result. @@ -1065,78 +1163,78 @@ '(original-source-start 0 0))) (when name (legal-fun-name-or-type-error name)) - (let* ((*lexenv* (make-lexenv - :policy *policy* - :handled-conditions *handled-conditions* - :disabled-package-locks *disabled-package-locks*)) - (*compiler-sset-counter* 0) - (fun (make-functional-from-toplevel-lambda lambda-expression - :name name - :path path))) - - ;; FIXME: The compile-it code from here on is sort of a - ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be - ;; better to find a way to share the code there; or - ;; alternatively, to use this code to replace the code there. - ;; (The second alternative might be pretty easy if we used - ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the - ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..) - - (locall-analyze-clambdas-until-done (list fun)) - - (let ((components-from-dfo (find-initial-dfo (list fun)))) - (dolist (component-from-dfo components-from-dfo) - (compile-component component-from-dfo) - (replace-toplevel-xeps component-from-dfo)) - - (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))))))) + (with-ir1-namespace + (let* ((*lexenv* (make-lexenv + :policy *policy* + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) + (*compiler-sset-counter* 0) + (fun (make-functional-from-toplevel-lambda lambda-expression + :name name + :path path))) + + ;; FIXME: The compile-it code from here on is sort of a + ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be + ;; better to find a way to share the code there; or + ;; alternatively, to use this code to replace the code there. + ;; (The second alternative might be pretty easy if we used + ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the + ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..) + + (locall-analyze-clambdas-until-done (list fun)) + + (let ((components-from-dfo (find-initial-dfo (list fun)))) + (dolist (component-from-dfo components-from-dfo) + (compile-component component-from-dfo) + (replace-toplevel-xeps component-from-dfo)) + + (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)))))))) (defun process-toplevel-cold-fset (name lambda-expression path) (unless (producing-fasl-file) @@ -1157,8 +1255,10 @@ (*print-level* 2) (*print-pretty* nil)) (with-compiler-io-syntax - (compiler-mumble "~&; ~:[compiling~;converting~] ~S" - *block-compile* form))) + (compiler-mumble + #-sb-xc-host "~&; ~:[compiling~;converting~] ~S" + #+sb-xc-host "~&; ~:[x-compiling~;x-converting~] ~S" + *block-compile* form))) form) ((and finalp (eq :top-level-forms *compile-print*) @@ -1172,6 +1272,15 @@ (t *top-level-form-noted*)))) +;;; Handle the evaluation the a :COMPILE-TOPLEVEL body during +;;; compilation. Normally just evaluate in the appropriate +;;; environment, but also compile if outputting a CFASL. +(defun eval-compile-toplevel (body path) + (eval-tlf `(progn ,@body) (source-path-tlf-number path) *lexenv*) + (when *compile-toplevel-object* + (let ((*compile-object* *compile-toplevel-object*)) + (convert-and-maybe-compile `(progn ,@body) path)))) + ;;; 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. @@ -1184,6 +1293,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 @@ -1247,12 +1357,10 @@ ;; 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*)) + (eval-compile-toplevel (list form) path)) (convert-and-maybe-compile form path)) (t (process-toplevel-form expanded @@ -1298,9 +1406,8 @@ e)))) (cond (lt (process-toplevel-progn body path new-compile-time-too)) - (new-compile-time-too (eval-in-lexenv - `(progn ,@body) - *lexenv*)))))) + (new-compile-time-too + (eval-compile-toplevel body path)))))) ((macrolet) (funcall-in-macrolet-lexenv magic @@ -1459,8 +1566,7 @@ (compile-load-time-value-lambda lambdas) (compile-toplevel-lambdas lambdas)) - (mapc #'clear-ir1-info components) - (clear-stuff))) + (mapc #'clear-ir1-info components))) (values)) ;;; Actually compile any stuff that has been queued up for block @@ -1533,8 +1639,8 @@ (*fun-names-in-this-file* ()) (*allow-instrumenting* nil) (*compiler-error-bailout* - (lambda () - (compiler-mumble "~2&; fatal error, aborting compilation~%") + (lambda (&optional error) + (declare (ignore error)) (return-from sub-compile-file (values t t t)))) (*current-path* nil) (*last-source-context* nil) @@ -1550,44 +1656,43 @@ ;; 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 - (sb!xc:with-compilation-unit () - (clear-stuff) - + (sb!xc:with-compilation-unit () + (with-world-lock () (sub-sub-compile-file info) - (unless (zerop (hash-table-count *code-coverage-records*)) ;; Dump the code coverage records into the fasl. - (fopcompile `(record-code-coverage - ',(namestring *compile-file-pathname*) - ',(let (list) - (maphash (lambda (k v) - (declare (ignore k)) - (push v list)) - *code-coverage-records*) - list)) - nil - nil)) - + (with-source-paths + (fopcompile `(record-code-coverage + ',(namestring *compile-file-pathname*) + ',(let (list) + (maphash (lambda (k v) + (declare (ignore k)) + (push v list)) + *code-coverage-records*) + list)) + nil + nil))) (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))) + nil)))) ;; Some errors are sufficiently bewildering that we just fail ;; immediately, without trying to recover and compile more of ;; the input file. (fatal-compiler-error (condition) (signal condition) + (fresh-line *error-output*) (pprint-logical-block (*error-output* nil :per-line-prefix "; ") (format *error-output* - "~@" - condition)) + "~@<~@:_compilation aborted because of fatal error: ~2I~_~A~@:_~:>" + (encapsulated-condition condition))) (finish-output *error-output*) (values t t t))))) @@ -1636,7 +1741,7 @@ won (elapsed-time-to-string (- (get-internal-real-time) - (source-info-start-time source-info)))) + (source-info-start-real-time source-info)))) (values)) ;;; Open some files and call SUB-COMPILE-FILE. If something unwinds @@ -1657,7 +1762,8 @@ ;; extensions (trace-file nil) - ((:block-compile *block-compile-arg*) nil)) + ((:block-compile *block-compile-arg*) nil) + (emit-cfasl *emit-cfasl*)) #!+sb-doc "Compile INPUT-FILE, producing a corresponding fasl file and returning its filename. @@ -1683,7 +1789,11 @@ returning its filename. :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)" + derived from the input file name. (non-standard) + + :EMIT-CFASL + (Experimental). If true, outputs the toplevel compile-time effects + of this file into a separate .cfasl file." ;;; Block compilation is currently broken. #| "Also, as a workaround for vaguely-non-ANSI behavior, the @@ -1700,7 +1810,9 @@ SPEED and COMPILATION-SPEED optimization values, and the :BLOCK-COMPILE argument will probably become deprecated." |# (let* ((fasl-output nil) + (cfasl-output nil) (output-file-name nil) + (coutput-file-name nil) (abort-p t) (warnings-p nil) (failure-p t) ; T in case error keeps this from being set later @@ -1717,6 +1829,13 @@ SPEED and COMPILATION-SPEED optimization values, and the (setq fasl-output (open-fasl-output output-file-name (namestring input-pathname)))) + (when emit-cfasl + (setq coutput-file-name + (make-pathname :type "cfasl" + :defaults output-file-name)) + (setq cfasl-output + (open-fasl-output coutput-file-name + (namestring input-pathname)))) (when trace-file (let* ((default-trace-file-pathname (make-pathname :type "trace" :defaults input-pathname)) @@ -1733,7 +1852,8 @@ SPEED and COMPILATION-SPEED optimization values, and the (when sb!xc:*compile-verbose* (print-compile-start-note source-info)) - (let ((*compile-object* fasl-output)) + (let ((*compile-object* fasl-output) + (*compile-toplevel-object* cfasl-output)) (setf (values abort-p warnings-p failure-p) (sub-compile-file source-info)))) @@ -1746,6 +1866,11 @@ SPEED and COMPILATION-SPEED optimization values, and the (when (and (not abort-p) sb!xc:*compile-verbose*) (compiler-mumble "~2&; ~A written~%" (namestring output-file-name)))) + (when cfasl-output + (close-fasl-output cfasl-output abort-p) + (when (and (not abort-p) sb!xc:*compile-verbose*) + (compiler-mumble "; ~A written~%" (namestring coutput-file-name)))) + (when sb!xc:*compile-verbose* (print-compile-end-note source-info (not abort-p))) @@ -1917,6 +2042,6 @@ SPEED and COMPILATION-SPEED optimization values, and the (compile name lambda)) #+sb-xc-host -(defun eval-in-lexenv (form lexenv) - (declare (ignore lexenv)) +(defun eval-tlf (form index &optional lexenv) + (declare (ignore index lexenv)) (eval form))