X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=41c49a175416c3358c9a402ae8dd5426df6a2b99;hb=HEAD;hp=e70a997b58c0595d398af6d3f777acc2d7a48c3e;hpb=0b5610d8a220a4b20cbeac958953ca4d67c00038;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index e70a997..7ca4376 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1,4 +1,6 @@ -;;;; the top-level interfaces to the compiler +;;;; the top level interfaces to the compiler, plus some other +;;;; compiler-related stuff (e.g. CL:CALL-ARGUMENTS-LIMIT) which +;;;; doesn't obviously belong anywhere else ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -12,69 +14,54 @@ (in-package "SB!C") ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp? -(declaim (special *constants* *free-variables* *component-being-compiled* - *code-vector* *next-location* *result-fixups* - *free-functions* *source-paths* - *seen-blocks* *seen-functions* *list-conflicts-table* - *continuation-number* *continuation-numbers* - *number-continuations* *tn-id* *tn-ids* *id-tns* - *label-ids* *label-id* *id-labels* - *undefined-warnings* *compiler-error-count* - *compiler-warning-count* *compiler-style-warning-count* - *compiler-note-count* - *compiler-error-bailout* - #!+sb-show *compiler-trace-output* - *last-source-context* *last-original-source* - *last-source-form* *last-format-string* *last-format-args* - *last-message-count* *lexenv*)) - -(defvar *byte-compile-default* :maybe - #!+sb-doc - "the default value for the :BYTE-COMPILE argument to COMPILE-FILE") - -(defvar *byte-compile-top-level* - #-sb-xc-host t - #+sb-xc-host nil ; since the byte compiler isn't supported in cross-compiler - #!+sb-doc - "Similar to *BYTE-COMPILE-DEFAULT*, but controls the compilation of top-level - forms (evaluated at load-time) when the :BYTE-COMPILE argument is :MAYBE - (the default.) When true, we decide to byte-compile.") - -;;; default value of the :BYTE-COMPILE argument to the compiler -(defvar *byte-compile* :maybe) - -;;; Bound by COMPILE-COMPONENT to T when byte-compiling, and NIL when -;;; native compiling. During IR1 conversion this can also be :MAYBE, -;;; in which case we must look at the policy, see (byte-compiling). -(defvar *byte-compiling* :maybe) -(declaim (type (member t nil :maybe) *byte-compile* *byte-compiling* - *byte-compile-default*)) +(declaim (special *constants* *free-vars* *component-being-compiled* + *free-funs* *source-paths* + *continuation-number* *continuation-numbers* + *number-continuations* *tn-id* *tn-ids* *id-tns* + *label-ids* *label-id* *id-labels* + *undefined-warnings* *compiler-error-count* + *compiler-warning-count* *compiler-style-warning-count* + *compiler-note-count* + *compiler-error-bailout* + #!+sb-show *compiler-trace-output* + *last-source-context* *last-original-source* + *last-source-form* *last-format-string* *last-format-args* + *last-message-count* *last-error-context* + *lexenv* *fun-names-in-this-file* + *allow-instrumenting*)) + +;;; Whether reference to a thing which cannot be defined causes a full +;;; warning. +(defvar *flame-on-necessarily-undefined-thing* nil) (defvar *check-consistency* nil) -(defvar *all-components*) + +;;; Set to NIL to disable loop analysis for register allocation. +(defvar *loop-analyze* t) ;;; Bind this to a stream to capture various internal debugging output. -#!+sb-show (defvar *compiler-trace-output* nil) ;;; The current block compilation state. These are initialized to the ;;; :BLOCK-COMPILE and :ENTRY-POINTS arguments that COMPILE-FILE was ;;; called with. ;;; -;;; *BLOCK-COMPILE-ARGUMENT* holds the original value of the -;;; :BLOCK-COMPILE argument, which overrides any internal -;;; declarations. +;;; *BLOCK-COMPILE-ARG* holds the original value of the :BLOCK-COMPILE +;;; argument, which overrides any internal declarations. (defvar *block-compile*) -(defvar *block-compile-argument*) -(declaim (type (member nil t :specified) - *block-compile* *block-compile-argument*)) +(defvar *block-compile-arg*) +(declaim (type (member nil t :specified) *block-compile* *block-compile-arg*)) (defvar *entry-points*) (declaim (list *entry-points*)) -;;; When block compiling, used by PROCESS-FORM to accumulate top-level +;;; When block compiling, used by PROCESS-FORM to accumulate top level ;;; lambdas resulting from compiling subforms. (In reverse order.) -(defvar *top-level-lambdas*) -(declaim (list *top-level-lambdas*)) +(defvar *toplevel-lambdas*) +(declaim (list *toplevel-lambdas*)) + +;;; The current non-macroexpanded toplevel form as printed when +;;; *compile-print* is true. +(defvar *top-level-form-noted* nil) (defvar sb!xc:*compile-verbose* t #!+sb-doc @@ -84,7 +71,7 @@ "The default for the :PRINT argument to COMPILE-FILE.") (defvar *compile-progress* nil #!+sb-doc - "When this is true, the compiler prints to *ERROR-OUTPUT* progress + "When this is true, the compiler prints to *STANDARD-OUTPUT* progress information about the phases of compilation of each function. (This is useful mainly in large block compilations.)") @@ -98,8 +85,8 @@ compiling.") (declaim (type (or pathname null) - sb!xc:*compile-file-pathname* - sb!xc:*compile-file-truename*)) + sb!xc:*compile-file-pathname* + sb!xc:*compile-file-truename*)) ;;; the SOURCE-INFO structure for the current compilation. This is ;;; null globally to indicate that we aren't currently in any @@ -118,60 +105,164 @@ (defun maybe-mumble (&rest foo) (when *compile-progress* (compiler-mumble "~&") - (pprint-logical-block (*error-output* nil :per-line-prefix "; ") + (pprint-logical-block (*standard-output* nil :per-line-prefix "; ") (apply #'compiler-mumble foo)))) -(deftype object () '(or fasl-file core-object null)) +(deftype object () '(or fasl-output core-object null)) (defvar *compile-object* nil) (declaim (type object *compile-object*)) +(defvar *compile-toplevel-object* nil) + +(defvar *emit-cfasl* nil) + +(defvar *fopcompile-label-counter*) + +;; Used during compilation to map code paths to the matching +;; instrumentation conses. +(defvar *code-coverage-records* nil) +;; Used during compilation to keep track of with source paths have been +;; instrumented in which blocks. +(defvar *code-coverage-blocks* nil) +;; Stores the code coverage instrumentation results. Keys are namestrings, +;; the value is a list of (CONS PATH STATE), where STATE is NIL for +;; a path that has not been visited, and T for one that has. +(defvar *code-coverage-info* (make-hash-table :test 'equal)) + ;;;; WITH-COMPILATION-UNIT and WITH-COMPILATION-VALUES (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." + "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)) -(defun %with-compilation-unit (fn &key override) - (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)) - (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) - (*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)))))))) +(defvar *source-plist* nil) +(defvar *source-namestring* nil) + +(defun %with-compilation-unit (fn &key override policy source-plist source-namestring) + (declare (type function fn)) + (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 @@ -179,84 +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))))))) - (unless *converting-for-interpreter* - (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) - (compiler-style-warning "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-warning - "~D 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-warning - "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ - ~% ~{~<~% ~1:;~S~>~^ ~}" - (cdr summary) kind summary))))))) - - (unless (or *converting-for-interpreter* - (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*))) - (format *error-output* "~&") - (pprint-logical-block (*error-output* nil :per-line-prefix "; ") - (compiler-mumble "compilation unit ~:[finished~;aborted~]~ - ~[~:;~:*~& caught ~D fatal ERROR condition~:P~]~ - ~[~:;~:*~& caught ~D ERROR condition~:P~]~ - ~[~:;~:*~& caught ~D WARNING condition~:P~]~ - ~[~:;~:*~& caught ~D STYLE-WARNING condition~:P~]~ - ~[~:;~:*~& printed ~D note~:P~]" - abort-p - *aborted-compilation-unit-count* - *compiler-error-count* - *compiler-warning-count* - *compiler-style-warning-count* - *compiler-note-count*))) - (format *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") @@ -270,32 +419,54 @@ (maybe-mumble "opt") (event ir1-optimize-until-done) (let ((count 0) - (cleared-reanalyze nil)) + (cleared-reanalyze nil) + (fastp nil)) (loop (when (component-reanalyze component) - (setq count 0) - (setq cleared-reanalyze t) - (setf (component-reanalyze component) nil)) + (setq count 0) + (setq cleared-reanalyze t) + (setf (component-reanalyze component) nil)) (setf (component-reoptimize component) nil) - (ir1-optimize component) - (unless (component-reoptimize component) - (maybe-mumble " ") - (return)) - (incf count) - (when (= count *max-optimize-iterations*) - (event ir1-optimize-maxed-out) - (maybe-mumble "* ") - (setf (component-reoptimize component) nil) - (do-blocks (block component) - (setf (block-reoptimize block) nil)) - (return)) - (maybe-mumble ".")) + (ir1-optimize component fastp) + (cond ((component-reoptimize component) + (incf count) + (when (and (>= count *max-optimize-iterations*) + (not (component-reanalyze component)) + (eq (component-reoptimize component) :maybe)) + (maybe-mumble "*") + (cond ((retry-delayed-ir1-transforms :optimize) + (maybe-mumble "+") + (setq count 0)) + (t + (event ir1-optimize-maxed-out) + (setf (component-reoptimize component) nil) + (do-blocks (block component) + (setf (block-reoptimize block) nil)) + (return))))) + ((retry-delayed-ir1-transforms :optimize) + (setf count 0) + (maybe-mumble "+")) + (t + (maybe-mumble " ") + (return))) + (setq fastp (>= count *max-optimize-iterations*)) + (maybe-mumble (if fastp "-" "."))) (when cleared-reanalyze (setf (component-reanalyze component) t))) (values)) (defparameter *constraint-propagate* t) -(defparameter *reoptimize-after-type-check-max* 5) + +;;; KLUDGE: This was bumped from 5 to 10 in a DTC patch ported by MNA +;;; from CMU CL into sbcl-0.6.11.44, the same one which allowed IR1 +;;; transforms to be delayed. Either DTC or MNA or both didn't explain +;;; why, and I don't know what the rationale was. -- WHN 2001-04-28 +;;; +;;; FIXME: It would be good to document why it's important to have a +;;; large value here, and what the drawbacks of an excessively large +;;; value are; and it might also be good to make it depend on +;;; optimization policy. +(defparameter *reoptimize-after-type-check-max* 10) (defevent reoptimize-maxed-out "*REOPTIMIZE-AFTER-TYPE-CHECK-MAX* exceeded.") @@ -308,54 +479,72 @@ (loop (find-dfo component) (unless (component-reanalyze component) - (maybe-mumble " ") - (return)) + (maybe-mumble " ") + (return)) (maybe-mumble "."))) (values)) ;;; Do all the IR1 phases for a non-top-level component. (defun ir1-phases (component) (declare (type component component)) - (let ((*constraint-number* 0) - (loop-count 1)) - (declare (special *constraint-number*)) + (aver-live-component component) + (let ((*constraint-universe* (make-array 64 ; arbitrary, but don't + ;make this 0. + :fill-pointer 0 :adjustable t)) + (loop-count 1) + (*delayed-ir1-transforms* nil)) + (declare (special *constraint-universe* *delayed-ir1-transforms*)) (loop (ir1-optimize-until-done component) - (when (or (component-new-functions component) - (component-reanalyze-functions component)) - (maybe-mumble "locall ") - (local-call-analyze component)) + (when (or (component-new-functionals component) + (component-reanalyze-functionals component)) + (maybe-mumble "locall ") + (locall-analyze-component component)) (dfo-as-needed component) (when *constraint-propagate* - (maybe-mumble "constraint ") - (constraint-propagate component)) - (maybe-mumble "type ") - ;; Delay the generation of type checks until the type - ;; constraints have had time to propagate, else the compiler can - ;; confuse itself. - (unless (and (or (component-reoptimize component) - (component-reanalyze component) - (component-new-functions component) - (component-reanalyze-functions component)) - (< loop-count (- *reoptimize-after-type-check-max* 2))) - (generate-type-checks component) - (unless (or (component-reoptimize component) - (component-reanalyze component) - (component-new-functions component) - (component-reanalyze-functions component)) - (return))) + (maybe-mumble "constraint ") + (constraint-propagate component)) + (when (retry-delayed-ir1-transforms :constraint) + (maybe-mumble "Rtran ")) + (flet ((want-reoptimization-p () + (or (component-reoptimize component) + (component-reanalyze component) + (component-new-functionals component) + (component-reanalyze-functionals component)))) + (unless (and (want-reoptimization-p) + ;; We delay the generation of type checks until + ;; the type constraints have had time to + ;; propagate, else the compiler can confuse itself. + (< loop-count (- *reoptimize-after-type-check-max* 4))) + (maybe-mumble "type ") + (generate-type-checks component) + (unless (want-reoptimization-p) + (return)))) (when (>= loop-count *reoptimize-after-type-check-max*) - (maybe-mumble "[reoptimize limit]") - (event reoptimize-maxed-out) - (return)) + (maybe-mumble "[reoptimize limit]") + (event reoptimize-maxed-out) + (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 native-compile-component (component) +(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 ") @@ -364,7 +553,8 @@ (maybe-mumble "control ") (control-analyze component #'make-ir2-block) - (when (ir2-component-values-receivers (component-info component)) + (when (or (ir2-component-values-receivers (component-info component)) + (component-dx-lvars component)) (maybe-mumble "stack ") (stack-analyze component) ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by @@ -373,148 +563,157 @@ (dfo-as-needed component)) (unwind-protect - (progn - (maybe-mumble "IR2tran ") - (init-assembler) - (entry-analyze component) - (ir2-convert component) - - (when (policy nil (>= speed compilation-speed)) - (maybe-mumble "copy ") - (copy-propagate component)) - - (select-representations component) - - (when *check-consistency* - (maybe-mumble "check2 ") - (check-ir2-consistency component)) - - (delete-unreferenced-tns component) - - (maybe-mumble "life ") - (lifetime-analyze component) - - (when *compile-progress* - (compiler-mumble "") ; Sync before doing more output. - (pre-pack-tn-stats component *error-output*)) - - (when *check-consistency* - (maybe-mumble "check-life ") - (check-life-consistency component)) - - (maybe-mumble "pack ") - (pack component) - - (when *check-consistency* - (maybe-mumble "check-pack ") - (check-pack-consistency component)) - - #!+sb-show - (when *compiler-trace-output* - (describe-component component *compiler-trace-output*) - (describe-ir2-component component *compiler-trace-output*)) - - (maybe-mumble "code ") - (multiple-value-bind (code-length trace-table fixups) - (generate-code component) - - #!+sb-show - (when *compiler-trace-output* - (format *compiler-trace-output* - "~|~%disassembly of code for ~S~2%" component) - (sb!disassem:disassemble-assem-segment *code-segment* - *compiler-trace-output*)) - - (etypecase *compile-object* - (fasl-file - (maybe-mumble "fasl") - (fasl-dump-component component - *code-segment* - code-length - trace-table - fixups - *compile-object*)) - (core-object - (maybe-mumble "core") - (make-core-component component - *code-segment* - code-length - trace-table - fixups - *compile-object*)) - (null)))))) - - ;; We are done, so don't bother keeping anything around. - (setf (component-info component) nil) + (progn + (maybe-mumble "IR2tran ") + (init-assembler) + (entry-analyze component) + (ir2-convert component) + + (when (policy *lexenv* (>= speed compilation-speed)) + (maybe-mumble "copy ") + (copy-propagate component)) + + (ir2-optimize component) + + (select-representations component) + + (when *check-consistency* + (maybe-mumble "check2 ") + (check-ir2-consistency component)) + + (delete-unreferenced-tns component) + + (maybe-mumble "life ") + (lifetime-analyze component) + + (when *compile-progress* + (compiler-mumble "") ; Sync before doing more output. + (pre-pack-tn-stats component *standard-output*)) + + (when *check-consistency* + (maybe-mumble "check-life ") + (check-life-consistency component)) + + (maybe-mumble "pack ") + (sb!regalloc:pack component) + + (when *check-consistency* + (maybe-mumble "check-pack ") + (check-pack-consistency component)) + + (when *compiler-trace-output* + (describe-component component *compiler-trace-output*) + (describe-ir2-component component *compiler-trace-output*)) + + (maybe-mumble "code ") + (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) + (sb!disassem:disassemble-assem-segment *code-segment* + *compiler-trace-output*)) + + (etypecase *compile-object* + (fasl-output + (maybe-mumble "fasl") + (fasl-dump-component component + *code-segment* + code-length + trace-table + fixup-notes + *compile-object*)) + (core-object + (maybe-mumble "core") + (make-core-component component + *code-segment* + code-length + trace-table + fixup-notes + *compile-object*)) + (null)))))) + + ;; We're done, so don't bother keeping anything around. + (setf (component-info component) :dead) (values)) -;;; Return our best guess for whether we will byte compile code -;;; currently being IR1 converted. This is only a guess because the -;;; decision is made on a per-component basis. -;;; -;;; FIXME: This should be called something more mnemonic, e.g. -;;; PROBABLY-BYTE-COMPILING -(defun byte-compiling () - (if (eq *byte-compiling* :maybe) - (or (eq *byte-compile* t) - (policy nil (and (zerop speed) (<= debug 1)))) - (and *byte-compile* *byte-compiling*))) - ;;; Delete components with no external entry points before we try to ;;; generate code. Unreachable closures can cause IR2 conversion to ;;; puke on itself, since it is the reference to the closure which -;;; normally causes the components to be combined. This doesn't really -;;; cover all cases... +;;; normally causes the components to be combined. (defun delete-if-no-entries (component) - (dolist (fun (component-lambdas component) - (delete-component component)) + (dolist (fun (component-lambdas component) (delete-component component)) + (when (functional-has-external-references-p fun) + (return)) (case (functional-kind fun) - (:top-level (return)) + (:toplevel (return)) (:external - (unless (every #'(lambda (ref) - (eq (block-component (node-block ref)) - component)) - (leaf-refs fun)) - (return)))))) + (unless (every (lambda (ref) + (eq (node-component ref) component)) + (leaf-refs fun)) + (return)))))) (defun compile-component (component) - (let* ((*component-being-compiled* component) - (*byte-compiling* - (ecase *byte-compile* - ((t) t) - ((nil) nil) - (:maybe - (dolist (fun (component-lambdas component) t) - (unless (policy (lambda-bind fun) - (and (zerop speed) (<= debug 1))) - (return nil))))))) - - (when sb!xc:*compile-print* - (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: " - *byte-compiling* - (component-name component))) + + ;; miscellaneous sanity checks + ;; + ;; FIXME: These are basically pretty wimpy compared to the checks done + ;; by the old CHECK-IR1-CONSISTENCY code. It would be really nice to + ;; make those internal consistency checks work again and use them. + (aver-live-component component) + (do-blocks (block component) + (aver (eql (block-component block) component))) + (dolist (lambda (component-lambdas component)) + ;; sanity check to prevent weirdness from propagating insidiously as + ;; far from its root cause as it did in bug 138: Make sure that + ;; thing-to-COMPONENT links are consistent. + (aver (eql (lambda-component lambda) component)) + (aver (eql (node-component (lambda-bind lambda)) component))) + + (let* ((*component-being-compiled* component)) + + ;; Record xref information before optimization. This way the + ;; stored xref data reflects the real source as closely as + ;; possible. + (record-component-xrefs component) (ir1-phases component) + (when *loop-analyze* + (dfo-as-needed component) + (find-dominators component) + (loop-analyze component)) + + #| + (when (and *loop-analyze* *compiler-trace-output*) + (labels ((print-blocks (block) + (format *compiler-trace-output* " ~A~%" block) + (when (block-loop-next block) + (print-blocks (block-loop-next block)))) + (print-loop (loop) + (format *compiler-trace-output* "loop=~A~%" loop) + (print-blocks (loop-blocks loop)) + (dolist (l (loop-inferiors loop)) + (print-loop l)))) + (print-loop (component-outer-loop component)))) + |# + ;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more? (maybe-mumble "env ") - (environment-analyze component) + (physenv-analyze component) (dfo-as-needed component) (delete-if-no-entries component) (unless (eq (block-next (component-head component)) - (component-tail component)) - (if *byte-compiling* - (byte-compile-component component) - (native-compile-component component)))) + (component-tail component)) + (%compile-component component))) (clear-constant-info) - (when sb!xc:*compile-print* - (compiler-mumble "~&")) - (values)) ;;;; clearing global data structures @@ -523,22 +722,24 @@ ;;;; global data structures entirely when possible and consing up the ;;;; others from scratch instead of clearing and reusing them? -;;; Clear the INFO in constants in the *FREE-VARIABLES*, etc. In +;;; Clear the INFO in constants in the *FREE-VARS*, etc. In ;;; addition to allowing stuff to be reclaimed, this is required for ;;; correct assignment of constant offsets, since we need to assign a ;;; new offset for each component. We don't clear the FUNCTIONAL-INFO ;;; slots, since they are used to keep track of functions across ;;; component boundaries. (defun clear-constant-info () - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf (leaf-info v) nil)) - *constants*) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (constant-p v) - (setf (leaf-info v) nil))) - *free-variables*) + (maphash (lambda (k v) + (declare (ignore k)) + (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 (constant-boxed-tn v) nil))) + *free-vars*) (values)) ;;; Blow away the REFS for all global variables, and let COMPONENT @@ -546,76 +747,29 @@ (defun clear-ir1-info (component) (declare (type component component)) (labels ((blast (x) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (leaf-p v) - (setf (leaf-refs v) - (delete-if #'here-p (leaf-refs v))) - (when (basic-var-p v) - (setf (basic-var-sets v) - (delete-if #'here-p (basic-var-sets v)))))) - x)) - (here-p (x) - (eq (block-component (node-block x)) component))) - (blast *free-variables*) - (blast *free-functions*) + (maphash (lambda (k v) + (declare (ignore k)) + (when (leaf-p v) + (setf (leaf-refs v) + (delete-if #'here-p (leaf-refs v))) + (when (basic-var-p v) + (setf (basic-var-sets v) + (delete-if #'here-p (basic-var-sets v)))))) + x)) + (here-p (x) + (eq (node-component x) component))) + (blast *free-vars*) + (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-functions*) - (clrhash *free-functions*) - (clrhash *free-variables*) - (clrhash *constants*)) - - ;; Clear debug counters and tables. - (clrhash *seen-blocks*) - (clrhash *seen-functions*) - (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) - - ;; Clear some Pack data structures (for GC purposes only). - (assert (not *in-pack*)) - (dolist (sb *backend-sb-list*) - (when (finite-sb-p sb) - (fill (finite-sb-live-tns sb) nil)))) - - ;; (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 -;;; Print out some useful info about Component to Stream. +;;; Print out some useful info about COMPONENT to STREAM. (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*) @@ -623,9 +777,9 @@ (format t "entries:~%") (dolist (entry (ir2-component-entries (component-info component))) (format t "~4TL~D: ~S~:[~; [closure]~]~%" - (label-id (entry-info-offset entry)) - (entry-info-name entry) - (entry-info-closure-p entry))) + (label-id (entry-info-offset entry)) + (entry-info-name entry) + (entry-info-closure-tn entry))) (terpri) (pre-pack-tn-stats component *standard-output*) (terpri) @@ -640,15 +794,22 @@ ;;;; the error context and for recovering from errors. ;;;; ;;;; The interface we provide to this stuff is the stream-oid -;;;; Source-Info structure. The bookkeeping is done as a side-effect +;;;; SOURCE-INFO structure. The bookkeeping is done as a side effect ;;;; of getting the next source form. ;;; A FILE-INFO structure holds all the source information for a ;;; given file. -(defstruct (file-info (:copier nil)) +(def!struct (file-info + (:copier nil) + #-no-ansi-print-object + (:print-object (lambda (s stream) + (print-unreadable-object (s stream :type t) + (princ (file-info-name s) stream))))) ;; If a file, the truename of the corresponding source file. If from ;; a Lisp form, :LISP. If from a stream, :STREAM. - (name (required-argument) :type (or pathname (member :lisp :stream))) + (name (missing-arg) :type (or pathname (eql :lisp))) + ;; the external format that we'll call OPEN with, if NAME is a file. + (external-format nil) ;; the defaulted, but not necessarily absolute file name (i.e. prior ;; to TRUENAME call.) Null if not a file. This is used to set ;; *COMPILE-FILE-PATHNAME*, and if absolute, is dumped in the @@ -668,153 +829,106 @@ ;;; The SOURCE-INFO structure provides a handle on all the source ;;; information for an entire compilation. -(defstruct (source-info - #-no-ansi-print-object - (:print-object (lambda (s stream) - (print-unreadable-object (s stream :type t)))) - (:copier nil)) +(def!struct (source-info + #-no-ansi-print-object + (:print-object (lambda (s stream) + (print-unreadable-object (s stream :type t)))) + (:copier nil)) ;; the UT that compilation started at (start-time (get-universal-time) :type unsigned-byte) - ;; a list of the FILE-INFO structures for this compilation - (files nil :type list) - ;; the tail of the FILES for the file we are currently reading - (current-file nil :type list) - ;; the stream that we are using to read the CURRENT-FILE, or NIL if + ;; 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 ;; no stream has been opened yet - (stream nil :type (or stream null))) - -;;; Given a list of pathnames, return a SOURCE-INFO structure. -(defun make-file-source-info (files) - (declare (list files)) - (let ((file-info - (mapcar (lambda (x) - (make-file-info :name (truename x) - :untruename x - :write-date (file-write-date x))) - files))) - - (make-source-info :files file-info - :current-file file-info))) - -;;; Return a SOURCE-INFO to describe the incremental compilation of -;;; FORM. Also used by SB!EVAL:INTERNAL-EVAL. -(defun make-lisp-source-info (form) + (stream nil :type (or stream null)) + ;; if the current compilation is recursive (e.g., due to EVAL-WHEN + ;; processing at compile-time), the invoking compilation's + ;; source-info. + (parent nil :type (or source-info null))) + +;;; Given a pathname, return a SOURCE-INFO structure. +(defun make-file-source-info (file external-format) (make-source-info - :start-time (get-universal-time) - :files (list (make-file-info :name :lisp - :forms (vector form) - :positions '#(0))))) - -;;; Return a SOURCE-INFO which will read from Stream. -(defun make-stream-source-info (stream) - (let ((files (list (make-file-info :name :stream)))) - (make-source-info - :files files - :current-file files - :stream stream))) - -;;; Print an error message for a non-EOF error on STREAM. OLD-POS is a -;;; preceding file position that hopefully comes before the beginning -;;; of the line. Of course, this only works on streams that support -;;; the file-position operation. -(defun normal-read-error (stream old-pos condition) - (declare (type stream stream) (type unsigned-byte old-pos)) - (let ((pos (file-position stream))) - (file-position stream old-pos) - (let ((start old-pos)) - (loop - (let ((line (read-line stream nil)) - (end (file-position stream))) - (when (>= end pos) - ;; FIXME: READER-ERROR also prints the file position. Do we really - ;; need to try to give position information here? - (compiler-abort "read error at ~D:~% \"~A/\\~A\"~%~A" - pos - (string-left-trim " " - (subseq line 0 (- pos start))) - (subseq line (- pos start)) - condition) - (return)) - (setq start end))))) - (values)) + :file-info (make-file-info :name (truename file) + :untruename (merge-pathnames file) + :external-format external-format + :write-date (file-write-date file)))) -;;; Back STREAM up to the position Pos, then read a form with -;;; *READ-SUPPRESS* on, discarding the result. If an error happens -;;; during this read, then bail out using COMPILER-ERROR (fatal in -;;; this context). -(defun ignore-error-form (stream pos) - (declare (type stream stream) (type unsigned-byte pos)) - (file-position stream pos) - (handler-case (let ((*read-suppress* t)) - (read stream)) - (error (condition) - (declare (ignore condition)) - (compiler-error "unable to recover from read error")))) - -;;; Print an error message giving some context for an EOF error. We -;;; print the first line after POS that contains #\" or #\(, or -;;; lacking that, the first non-empty line. -(defun unexpected-eof-error (stream pos condition) - (declare (type stream stream) (type unsigned-byte pos)) - (let ((res nil)) - (file-position stream pos) - (loop - (let ((line (read-line stream nil nil))) - (unless line (return)) - (when (or (find #\" line) (find #\( line)) - (setq res line) - (return)) - (unless (or res (zerop (length line))) - (setq res line)))) - (compiler-abort "read error in form starting at ~D:~%~@[ \"~A\"~%~]~A" - pos - res - condition)) - (file-position stream (file-length stream)) - (values)) - -;;; Read a form from STREAM, returning EOF at EOF. If a read error -;;; happens, then attempt to recover if possible, returning a proxy -;;; error form. -;;; -;;; FIXME: This seems like quite a lot of complexity, and it seems -;;; impossible to get it quite right. (E.g. the `(CERROR ..) form -;;; returned here won't do the right thing if it's not in a position -;;; for an executable form.) I think it might be better to just stop -;;; trying to recover from read errors, punting all this noise -;;; (including UNEXPECTED-EOF-ERROR and IGNORE-ERROR-FORM) and doing a -;;; COMPILER-ABORT instead. -(defun careful-read (stream eof pos) - (handler-case (read stream nil eof) +;;; Return a SOURCE-INFO to describe the incremental compilation of FORM. +(defun make-lisp-source-info (form &key parent) + (make-source-info + :file-info (make-file-info :name :lisp + :forms (vector form) + :positions '#(0)) + :parent parent)) + +;;; Walk up the SOURCE-INFO list until we either reach a SOURCE-INFO +;;; with no parent (e.g., from a REPL evaluation) or until we reach a +;;; SOURCE-INFO whose FILE-INFO denotes a file. +(defun get-toplevelish-file-info (&optional (source-info *source-info*)) + (if source-info + (do* ((sinfo source-info (source-info-parent sinfo)) + (finfo (source-info-file-info sinfo) + (source-info-file-info sinfo))) + ((or (not (source-info-p (source-info-parent sinfo))) + (pathnamep (file-info-name finfo))) + finfo)))) + +;;; Return a form read from STREAM; or for EOF use the trick, +;;; popularized by Kent Pitman, of returning STREAM itself. If an +;;; error happens, then convert it to standard abort-the-compilation +;;; error condition (possibly recording some extra location +;;; information). +(defun read-for-compile-file (stream position) + (handler-case + (read-preserving-whitespace stream nil stream) + (reader-error (condition) + (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) + (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) - (let ((new-pos (file-position stream))) - (cond ((= new-pos (file-length stream)) - (unexpected-eof-error stream pos condition)) - (t - (normal-read-error stream pos condition) - (ignore-error-form stream pos)))) - '(cerror "Skip this form." - "compile-time read error")))) + (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. When we open a new -;;; file, we also reset *PACKAGE* and policy. This gives the effect of -;;; rebinding around each file. +;;; current file. There must be a current file. ;;; -;;; FIXME: Since we now do the standard ANSI thing of only one file -;;; per compile (unlike the CMU CL extended COMPILE-FILE) this code is -;;; becoming stale, and the remaining bits of it (and the related code -;;; in ADVANCE-SOURCE-FILE) can go away. +;;; FIXME: This is probably an unnecessarily roundabout way to do +;;; things now that we process a single file in COMPILE-FILE (unlike +;;; the old CMU CL code, which accepted multiple files). Also, the old +;;; comment said +;;; When we open a new file, we also reset *PACKAGE* and policy. +;;; This gives the effect of rebinding around each file. +;;; which doesn't seem to be true now. Check to make sure that if +;;; such rebinding is necessary, it's still done somewhere. (defun get-source-stream (info) (declare (type source-info info)) - (cond ((source-info-stream info)) - (t - (let* ((finfo (first (source-info-current-file info))) - (name (file-info-name finfo))) - (setq sb!xc:*compile-file-truename* name) - (setq sb!xc:*compile-file-pathname* (file-info-untruename finfo)) - (setf (source-info-stream info) - (open name :direction :input)))))) + (or (source-info-stream info) + (let* ((file-info (source-info-file-info info)) + (name (file-info-name file-info)) + (external-format (file-info-external-format file-info))) + (setf sb!xc:*compile-file-truename* name + sb!xc:*compile-file-pathname* (file-info-untruename file-info) + (source-info-stream info) + (open name :direction :input + :external-format external-format))))) ;;; Close the stream in INFO if it is open. (defun close-source-info (info) @@ -824,185 +938,501 @@ (setf (source-info-stream info) nil) (values)) -;;; Advance INFO to the next source file. If there is no next source -;;; file, return NIL, otherwise T. -(defun advance-source-file (info) - (declare (type source-info info)) - (close-source-info info) - (let ((prev (pop (source-info-current-file info)))) - (if (source-info-current-file info) - (let ((current (first (source-info-current-file info)))) - (setf (file-info-source-root current) - (+ (file-info-source-root prev) - (length (file-info-forms prev)))) - t) - nil))) - -;;; Read the sources from the source files and process them. -(defun process-sources (info) - (let* ((file (first (source-info-current-file info))) - (stream (get-source-stream info))) - (loop - (let* ((pos (file-position stream)) - (eof '(*eof*)) - (form (careful-read stream eof pos))) - (if (eq form eof) - (return) - (let* ((forms (file-info-forms file)) - (current-idx (+ (fill-pointer forms) - (file-info-source-root file)))) - (vector-push-extend form forms) - (vector-push-extend pos (file-info-positions file)) - (clrhash *source-paths*) - (find-source-paths form current-idx) - (process-top-level-form form - `(original-source-start 0 ,current-idx)))))) - (when (advance-source-file info) - (process-sources info)))) - -;;; Return the FILE-INFO describing the INDEX'th form. -(defun find-file-info (index info) - (declare (type index index) (type source-info info)) - (dolist (file (source-info-files info)) - (when (> (+ (length (file-info-forms file)) - (file-info-source-root file)) - index) - (return file)))) +;;; Loop over FORMS retrieved from INFO. Used by COMPILE-FILE and +;;; LOAD when loading from a FILE-STREAM associated with a source +;;; file. +(defmacro do-forms-from-info (((form &rest keys) info) + &body body) + (aver (symbolp form)) + (once-only ((info info)) + `(let ((*source-info* ,info)) + (loop (destructuring-bind (,form &key ,@keys &allow-other-keys) + (let* ((file-info (source-info-file-info ,info)) + (stream (get-source-stream ,info)) + (pos (file-position stream)) + (form (read-for-compile-file stream pos))) + (if (eq form stream) ; i.e., if EOF + (return) + (let* ((forms (file-info-forms file-info)) + (current-idx (+ (fill-pointer forms) + (file-info-source-root + file-info)))) + (vector-push-extend form forms) + (vector-push-extend pos (file-info-positions + file-info)) + (list form :current-index current-idx)))) + ,@body))))) + +;;; Read and compile the source file. +(defun sub-sub-compile-file (info) + (do-forms-from-info ((form current-index) info) + (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. (defun find-source-root (index info) - (declare (type source-info info) (type index index)) - (let* ((file (find-file-info index info)) - (idx (- index (file-info-source-root file)))) - (values (aref (file-info-forms file) idx) - (aref (file-info-positions file) idx)))) + (declare (type index index) (type source-info info)) + (let ((file-info (source-info-file-info info))) + (values (aref (file-info-forms file-info) index) + (aref (file-info-positions file-info) index)))) -;;;; top-level form processing +;;;; processing of top level forms -;;; This is called by top-level form processing when we are ready to +;;; This is called by top level form processing when we are ready to ;;; actually compile something. If *BLOCK-COMPILE* is T, then we still ;;; convert the form, but delay compilation, pushing the result on -;;; *TOP-LEVEL-LAMBDAS* instead. +;;; *TOPLEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) - (let* ((*lexenv* (make-lexenv :policy *policy* - :interface-policy *interface-policy*)) - (tll (ir1-top-level form path nil))) - (cond ((eq *block-compile* t) (push tll *top-level-lambdas*)) - (t (compile-top-level (list tll) nil))))) - -;;; Process a PROGN-like portion of a top-level form. Forms is a list of -;;; the forms, and Path is source path of the form they came out of. -(defun process-top-level-progn (forms path) - (declare (list forms) (list path)) - (dolist (form forms) - (process-top-level-form form path))) - -;;; Macroexpand form in the current environment with an error handler. + (let ((*top-level-form-noted* (note-top-level-form form t))) + ;; Don't bother to compile simple objects that just sit there. + (when (and form (or (symbolp form) (consp form))) + (if (fopcompilable-p form) + (let ((*fopcompile-label-counter* 0)) + (fopcompile form path 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 (form) - (handler-case (sb!xc:macroexpand-1 form *lexenv*) +(defun preprocessor-macroexpand-1 (form) + (handler-case (%macroexpand-1 form *lexenv*) (error (condition) - (compiler-error "(during macroexpansion)~%~A" condition)))) + (compiler-error "(during macroexpansion of ~A)~%~A" + (let ((*print-level* 2) + (*print-length* 2)) + (format nil "~S" form)) + condition)))) + +;;; Process a PROGN-like portion of a top level form. FORMS is a list of +;;; the forms, and PATH is the source path of the FORM they came out of. +;;; COMPILE-TIME-TOO is as in ANSI "3.2.3.1 Processing of Top Level Forms". +(defun process-toplevel-progn (forms path compile-time-too) + (declare (list forms) (list path)) + (dolist (form forms) + (process-toplevel-form form path compile-time-too))) -;;; Process a top-level use of LOCALLY. We parse declarations and then -;;; recursively process the body. -(defun process-top-level-locally (form path) +;;; Process a top level use of LOCALLY, or anything else (e.g. +;;; MACROLET) at top level which has declarations and ordinary forms. +;;; 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) (sb!sys:parse-body (cdr form) nil) - (let* ((*lexenv* - (process-decls decls nil nil (make-continuation))) - ;; Binding *xxx-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*)) - (*interface-policy* (lexenv-interface-policy *lexenv*))) - (process-top-level-progn forms path)))) - -;;; Force any pending top-level forms to be compiled and dumped so -;;; that they will be evaluated in the correct package environment. -;;; Dump the form to be evaled at (cold) load time, and if EVAL is -;;; true, eval the form immediately. -(defun process-cold-load-form (form path eval) - (let ((object *compile-object*)) - (etypecase object - (fasl-file - (compile-top-level-lambdas () t) - (fasl-dump-cold-load-form form object)) - ((or null core-object) - (convert-and-maybe-compile form path))) - (when eval - (eval form)))) - -(declaim (special *compiler-error-bailout*)) - -;;; Process a top-level FORM with the specified source PATH. -;;; * If this is a magic top-level form, then do stuff. + (multiple-value-bind (forms decls) + (parse-body body :doc-string-allowed nil :toplevel t) + (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 +;;; the types of situations present in the list. +(defun parse-eval-when-situations (situations) + (when (or (not (listp situations)) + (set-difference situations + '(:compile-toplevel + compile + :load-toplevel + load + :execute + eval))) + (compiler-error "bad EVAL-WHEN situation list: ~S" situations)) + (let ((deprecated-names (intersection situations '(compile load eval)))) + (when deprecated-names + (style-warn "using deprecated EVAL-WHEN situation names~{ ~S~}" + deprecated-names))) + (values (intersection '(:compile-toplevel compile) + situations) + (intersection '(:load-toplevel load) situations) + (intersection '(:execute eval) situations))) + + +;;; utilities for extracting COMPONENTs of FUNCTIONALs +(defun functional-components (f) + (declare (type functional f)) + (etypecase f + (clambda (list (lambda-component f))) + (optional-dispatch (let ((result nil)) + (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))) + result)))) + +(defun make-functional-from-toplevel-lambda (lambda-expression + &key + name + (path + ;; I'd thought NIL should + ;; work, but it doesn't. + ;; -- WHN 2001-09-20 + (missing-arg))) + (let* ((*current-path* path) + (component (make-empty-component)) + (*current-component* component) + (debug-name-tail (or name (name-lambdalike lambda-expression))) + (source-name (or name '.anonymous.))) + (setf (component-name component) (debug-name 'initial-component debug-name-tail) + (component-kind component) :initial) + (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 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. +;;; * If *COMPILE-OBJECT* is a CORE-OBJECT, then write the function +;;; into core and return the compiled FUNCTION value. +;;; * If *COMPILE-OBJECT* is a fasl file, then write the function +;;; into the fasl file and return a dump handle. +;;; +;;; If NAME is provided, then we try to use it as the name of the +;;; function for debugging/diagnostic information. +(defun %compile (lambda-expression + *compile-object* + &key + name + (path + ;; This magical idiom seems to be the appropriate + ;; path for compiling standalone LAMBDAs, judging + ;; from the CMU CL code and experiment, so it's a + ;; nice default for things where we don't have a + ;; real source path (as in e.g. inside CL:COMPILE). + '(original-source-start 0 0))) + (when name + (legal-fun-name-or-type-error name)) + (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) + (error "can't COLD-FSET except in a fasl file")) + (legal-fun-name-or-type-error name) + (fasl-dump-cold-fset name + (%compile lambda-expression + *compile-object* + :name name + :path path) + *compile-object*) + (values)) + +(defun note-top-level-form (form &optional finalp) + (when *compile-print* + (cond ((not *top-level-form-noted*) + (let ((*print-length* 2) + (*print-level* 2) + (*print-pretty* nil)) + (with-compiler-io-syntax + (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*) + (neq form *top-level-form-noted*)) + (let ((*print-length* 1) + (*print-level* 1) + (*print-pretty* nil)) + (with-compiler-io-syntax + (compiler-mumble "~&; ... top level ~S" form))) + form) + (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. ;;; * Otherwise, just compile it. -(defun process-top-level-form (form path) - +;;; +;;; COMPILE-TIME-TOO is as defined in ANSI +;;; "3.2.3.1 Processing of Top Level Forms". +(defun process-toplevel-form (form path compile-time-too) (declare (list path)) - (catch 'process-top-level-form-error-abort - (let* ((path (or (gethash form *source-paths*) (cons form path))) - (*compiler-error-bailout* - #'(lambda () - (convert-and-maybe-compile - `(error "execution of a form compiled with errors:~% ~S" - ',form) - path) - (throw 'process-top-level-form-error-abort nil)))) - (if (atom form) - (convert-and-maybe-compile form path) - (case (car form) - ;; FIXME: It's not clear to me why we would want this - ;; special case; it might have been needed for some - ;; variation of the old GENESIS system, but it certainly - ;; doesn't seem to be needed for ours. Sometime after the - ;; system is running I'd like to remove it tentatively and - ;; see whether anything breaks, and if nothing does break, - ;; remove it permanently. (And if we *do* want special - ;; treatment of all these, we probably want to treat WARN - ;; the same way..) - ((error cerror break signal) - (process-cold-load-form form path nil)) - ;; FIXME: ANSI seems to encourage things like DEFSTRUCT to - ;; be done with EVAL-WHEN, without this kind of one-off - ;; compiler magic. - (sb!kernel:%compiler-defstruct - (convert-and-maybe-compile form path) - (compile-top-level-lambdas () t)) - ((eval-when) - (unless (>= (length form) 2) - (compiler-error "EVAL-WHEN form is too short: ~S" form)) - (do-eval-when-stuff - (cadr form) (cddr form) - #'(lambda (forms) - (process-top-level-progn forms path)))) - ((macrolet) - (unless (>= (length form) 2) - (compiler-error "MACROLET form is too short: ~S" form)) - (do-macrolet-stuff - (cadr form) - #'(lambda () - (process-top-level-progn (cddr form) path)))) - (locally (process-top-level-locally form path)) - (progn (process-top-level-progn (cdr form) path)) - (t - (let* ((uform (uncross form)) - (exp (preprocessor-macroexpand uform))) - (if (eq exp uform) - (convert-and-maybe-compile uform path) - (process-top-level-form exp path)))))))) + (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 + (make-compiler-error-form condition form) + path) + (throw 'process-toplevel-form-error-abort nil)))) + + (flet ((default-processor (form) + (let ((*top-level-form-noted* (note-top-level-form form))) + ;; When we're cross-compiling, consider: what should we + ;; do when we hit e.g. + ;; (EVAL-WHEN (:COMPILE-TOPLEVEL) + ;; (DEFUN FOO (X) (+ 7 X)))? + ;; DEFUN has a macro definition in the cross-compiler, + ;; and a different macro definition in the target + ;; compiler. The only sensible thing is to use the + ;; target compiler's macro definition, since the + ;; cross-compiler's macro is in general into target + ;; functions which can't meaningfully be executed at + ;; cross-compilation time. So make sure we do the EVAL + ;; here, before we macroexpand. + ;; + ;; Then things get even dicier with something like + ;; (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..) + ;; where we have to make sure that we don't uncross + ;; the SB!XC: prefix before we do EVAL, because otherwise + ;; we'd be trying to redefine the cross-compilation host's + ;; constants. + ;; + ;; (Isn't it fun to cross-compile Common Lisp?:-) + #+sb-xc-host + (progn + (when compile-time-too + (eval form)) ; letting xc host EVAL do its own macroexpansion + (let* (;; (We uncross the operator name because things + ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE + ;; should be equivalent to their CL: counterparts + ;; when being compiled as target code. We leave + ;; the rest of the form uncrossed because macros + ;; might yet expand into EVAL-WHEN stuff, and + ;; things inside EVAL-WHEN can't be uncrossed + ;; until after we've EVALed them in the + ;; cross-compilation host.) + (slightly-uncrossed (cons (uncross (first form)) + (rest form))) + (expanded (preprocessor-macroexpand-1 + slightly-uncrossed))) + (if (eq expanded slightly-uncrossed) + ;; (Now that we're no longer processing toplevel + ;; forms, and hence no longer need to worry about + ;; EVAL-WHEN, we can uncross everything.) + (convert-and-maybe-compile expanded path) + ;; (We have to demote COMPILE-TIME-TOO to NIL + ;; here, no matter what it was before, since + ;; otherwise we'd tend to EVAL subforms more than + ;; once, because of WHEN COMPILE-TIME-TOO form + ;; above.) + (process-toplevel-form expanded path nil)))) + ;; When we're not cross-compiling, we only need to + ;; macroexpand once, so we can follow the 1-thru-6 + ;; sequence of steps in ANSI's "3.2.3.1 Processing of + ;; Top Level Forms". + #-sb-xc-host + (let ((expanded (preprocessor-macroexpand-1 form))) + (cond ((eq expanded form) + (when compile-time-too + (eval-compile-toplevel (list form) path)) + (convert-and-maybe-compile form path)) + (t + (process-toplevel-form expanded + path + compile-time-too))))))) + (if (atom form) + #+sb-xc-host + ;; (There are no xc EVAL-WHEN issues in the ATOM case until + ;; (1) SBCL gets smart enough to handle global + ;; DEFINE-SYMBOL-MACRO or SYMBOL-MACROLET and (2) SBCL + ;; implementors start using symbol macros in a way which + ;; interacts with SB-XC/CL distinction.) + (convert-and-maybe-compile form path) + #-sb-xc-host + (default-processor form) + (flet ((need-at-least-one-arg (form) + (unless (cdr form) + (compiler-error "~S form is too short: ~S" + (car form) + form)))) + (case (car form) + ;; In the cross-compiler, top level COLD-FSET arranges + ;; for static linking at cold init time. + #+sb-xc-host + ((cold-fset) + (aver (not compile-time-too)) + (destructuring-bind (cold-fset fun-name lambda-expression) form + (declare (ignore cold-fset)) + (process-toplevel-cold-fset fun-name + lambda-expression + path))) + ((eval-when macrolet symbol-macrolet);things w/ 1 arg before body + (need-at-least-one-arg form) + (destructuring-bind (special-operator magic &rest body) form + (ecase special-operator + ((eval-when) + ;; CT, LT, and E here are as in Figure 3-7 of ANSI + ;; "3.2.3.1 Processing of Top Level Forms". + (multiple-value-bind (ct lt e) + (parse-eval-when-situations magic) + (let ((new-compile-time-too (or ct + (and compile-time-too + e)))) + (cond (lt (process-toplevel-progn + body path new-compile-time-too)) + (new-compile-time-too + (eval-compile-toplevel body path)))))) + ((macrolet) + (funcall-in-macrolet-lexenv + magic + (lambda (&key funs prepend) + (declare (ignore funs)) + (aver (null prepend)) + (process-toplevel-locally body + path + compile-time-too)) + :compile)) + ((symbol-macrolet) + (funcall-in-symbol-macrolet-lexenv + magic + (lambda (&key vars prepend) + (aver (null prepend)) + (process-toplevel-locally body + path + compile-time-too + :vars vars)) + :compile))))) + ((locally) + (process-toplevel-locally (rest form) path compile-time-too)) + ((progn) + (process-toplevel-progn (rest form) path compile-time-too)) + (t (default-processor form)))))))) (values)) @@ -1010,440 +1440,318 @@ ;;;; ;;;; (See EMIT-MAKE-LOAD-FORM.) -;;; Returns T iff we are currently producing a fasl-file and hence +;;; Return T if we are currently producing a fasl file and hence ;;; constants need to be dumped carefully. (defun producing-fasl-file () - (unless *converting-for-interpreter* - (fasl-file-p *compile-object*))) + (fasl-output-p *compile-object*)) ;;; Compile FORM and arrange for it to be called at load-time. Return ;;; the dumper handle and our best guess at the type of the object. -(defun compile-load-time-value - (form &optional - (name (let ((*print-level* 2) (*print-length* 3)) - (format nil "load time value of ~S" - (if (and (listp form) - (eq (car form) 'make-value-cell)) - (second form) - form))))) - (let ((lambda (compile-load-time-stuff form name t))) +(defun compile-load-time-value (form) + (let ((lambda (compile-load-time-stuff form t))) (values (fasl-dump-load-time-value-lambda lambda *compile-object*) (let ((type (leaf-type lambda))) - (if (function-type-p type) - (single-value-type (function-type-returns type)) - *wild-type*))))) + (if (fun-type-p type) + (single-value-type (fun-type-returns type)) + *wild-type*))))) ;;; Compile the FORMS and arrange for them to be called (for effect, ;;; not value) at load time. -(defun compile-make-load-form-init-forms (forms name) - (let ((lambda (compile-load-time-stuff `(progn ,@forms) name nil))) - (fasl-dump-top-level-lambda-call lambda *compile-object*))) +(defun compile-make-load-form-init-forms (forms) + (let ((lambda (compile-load-time-stuff `(progn ,@forms) nil))) + (fasl-dump-toplevel-lambda-call lambda *compile-object*))) -;;; Does the actual work of COMPILE-LOAD-TIME-VALUE or -;;; COMPILE-MAKE-LOAD-FORM- INIT-FORMS. -(defun compile-load-time-stuff (form name for-value) +;;; Do the actual work of COMPILE-LOAD-TIME-VALUE or +;;; COMPILE-MAKE-LOAD-FORM-INIT-FORMS. +(defun compile-load-time-stuff (form for-value) (with-ir1-namespace (let* ((*lexenv* (make-null-lexenv)) - (lambda (ir1-top-level form *current-path* for-value))) - (setf (leaf-name lambda) name) - (compile-top-level (list lambda) t) + (lambda (ir1-toplevel form *current-path* for-value nil))) + (compile-toplevel (list lambda) t) lambda))) -;;; Called by COMPILE-TOP-LEVEL when it was pased T for +;;; This is called by COMPILE-TOPLEVEL when it was passed T for ;;; LOAD-TIME-VALUE-P (which happens in COMPILE-LOAD-TIME-STUFF). We ;;; don't try to combine this component with anything else and frob -;;; the name. If not in a :TOP-LEVEL component, then don't bother +;;; the name. If not in a :TOPLEVEL component, then don't bother ;;; compiling, because it was merged with a run-time component. (defun compile-load-time-value-lambda (lambdas) - (assert (null (cdr lambdas))) + (aver (null (cdr lambdas))) (let* ((lambda (car lambdas)) - (component (block-component (node-block (lambda-bind lambda))))) - (when (eq (component-kind component) :top-level) - (setf (component-name component) (leaf-name lambda)) + (component (lambda-component lambda))) + (when (eql (component-kind component) :toplevel) + (setf (component-name component) (leaf-debug-name lambda)) (compile-component component) (clear-ir1-info component)))) - -;;; The entry point for MAKE-LOAD-FORM support. When IR1 conversion -;;; finds a constant structure, it invokes this to arrange for proper -;;; dumping. If it turns out that the constant has already been -;;; dumped, then we don't need to do anything. -;;; -;;; If the constant hasn't been dumped, then we check to see whether -;;; we are in the process of creating it. We detect this by -;;; maintaining the special *CONSTANTS-BEING-CREATED* as a list of all -;;; the constants we are in the process of creating. Actually, each -;;; entry is a list of the constant and any init forms that need to be -;;; processed on behalf of that constant. -;;; -;;; It's not necessarily an error for this to happen. If we are -;;; processing the init form for some object that showed up *after* -;;; the original reference to this constant, then we just need to -;;; defer the processing of that init form. To detect this, we -;;; maintain *CONSTANTS-CREATED-SINCE-LAST-INIT* as a list of the -;;; constants created since the last time we started processing an -;;; init form. If the constant passed to emit-make-load-form shows up -;;; in this list, then there is a circular chain through creation -;;; forms, which is an error. -;;; -;;; If there is some intervening init form, then we blow out of -;;; processing it by throwing to the tag PENDING-INIT. The value we -;;; throw is the entry from *CONSTANTS-BEING-CREATED*. This is so the -;;; offending init form can be tacked onto the init forms for the -;;; circular object. -;;; -;;; If the constant doesn't show up in *CONSTANTS-BEING-CREATED*, then -;;; we have to create it. We call MAKE-LOAD-FORM and check to see -;;; whether the creation form is the magic value -;;; :JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The -;;; dumper will eventually get its hands on the object and use the -;;; normal structure dumping noise on it. -;;; -;;; Otherwise, we bind *CONSTANTS-BEING-CREATED* and -;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* and compile the creation form -;;; much the way LOAD-TIME-VALUE does. When this finishes, we tell the -;;; dumper to use that result instead whenever it sees this constant. -;;; -;;; Now we try to compile the init form. We bind -;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* to NIL and compile the init -;;; form (and any init forms that were added because of circularity -;;; detection). If this works, great. If not, we add the init forms to -;;; the init forms for the object that caused the problems and let it -;;; deal with it. -(defvar *constants-being-created* nil) -(defvar *constants-created-since-last-init* nil) -;;; FIXME: Shouldn't these^ variables be bound in LET forms? -(defun emit-make-load-form (constant) - (assert (fasl-file-p *compile-object*)) - (unless (or (fasl-constant-already-dumped constant *compile-object*) - ;; KLUDGE: This special hack is because I was too lazy - ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM - ;; function of LAYOUT returns nontrivial forms when - ;; building the cross-compiler but :IGNORE-IT when - ;; cross-compiling or running under the target Lisp. -- - ;; WHN 19990914 - #+sb-xc-host (typep constant 'layout)) - (let ((circular-ref (assoc constant *constants-being-created* :test #'eq))) - (when circular-ref - (when (find constant *constants-created-since-last-init* :test #'eq) - (throw constant t)) - (throw 'pending-init circular-ref))) - (multiple-value-bind (creation-form init-form) - (handler-case - (sb!xc:make-load-form constant (make-null-lexenv)) - (error (condition) - (compiler-error "(while making load form for ~S)~%~A" - constant - condition))) - (case creation-form - (:just-dump-it-normally - (fasl-validate-structure constant *compile-object*) - t) - (:ignore-it - nil) - (t - (compile-top-level-lambdas () t) - (when (fasl-constant-already-dumped constant *compile-object*) - (return-from emit-make-load-form nil)) - (let* ((name (let ((*print-level* 1) (*print-length* 2)) - (with-output-to-string (stream) - (write constant :stream stream)))) - (info (if init-form - (list constant name init-form) - (list constant)))) - (let ((*constants-being-created* - (cons info *constants-being-created*)) - (*constants-created-since-last-init* - (cons constant *constants-created-since-last-init*))) - (when - (catch constant - (fasl-note-handle-for-constant - constant - (compile-load-time-value - creation-form - (format nil "creation form for ~A" name)) - *compile-object*) - nil) - (compiler-error "circular references in creation form for ~S" - constant))) - (when (cdr info) - (let* ((*constants-created-since-last-init* nil) - (circular-ref - (catch 'pending-init - (loop for (name form) on (cdr info) by #'cddr - collect name into names - collect form into forms - finally - (compile-make-load-form-init-forms - forms - (format nil "init form~:[~;s~] for ~{~A~^, ~}" - (cdr forms) names))) - nil))) - (when circular-ref - (setf (cdr circular-ref) - (append (cdr circular-ref) (cdr info)))))))))))) ;;;; COMPILE-FILE -;;; We build a list of top-level lambdas, and then periodically smash -;;; them together into a single component and compile it. -(defvar *pending-top-level-lambdas*) - -;;; The maximum number of top-level lambdas we put in a single -;;; top-level component. -;;; -;;; CMU CL 18b used this nontrivially by default (setting it to 10) -;;; but consequently suffered from the inability to execute some -;;; troublesome constructs correctly, e.g. inability to load a fasl -;;; file compiled from the source file -;;; (defpackage "FOO" (:use "CL")) -;;; (print 'foo::bar) -;;; because it would dump data-setup fops (including a FOP-PACKAGE for -;;; "FOO") for the second form before dumping the the code in the -;;; first form, or the fop to execute the code in the first form. By -;;; setting this value to 0 by default, we avoid this badness. This -;;; increases the number of toplevel form functions, and so increases -;;; the size of object files. -;;; -;;; The variable is still supported because when we are compiling the -;;; SBCL system itself, which is known not contain any troublesome -;;; constructs, we can set it to a nonzero value, which reduces the -;;; number of toplevel form objects, reducing the peak memory usage in -;;; GENESIS, which is desirable, since at least for SBCL version -;;; 0.6.7, this is the high water mark for memory usage during system -;;; construction. -(defparameter *top-level-lambda-max* 0) - -(defun object-call-top-level-lambda (tll) +(defun object-call-toplevel-lambda (tll) (declare (type functional tll)) (let ((object *compile-object*)) (etypecase object - (fasl-file - (fasl-dump-top-level-lambda-call tll object)) - (core-object - (core-call-top-level-lambda tll object)) + (fasl-output (fasl-dump-toplevel-lambda-call tll object)) + (core-object (core-call-toplevel-lambda tll object)) (null)))) -;;; Add LAMBDAS to the pending lambdas. If this leaves more than -;;; *TOP-LEVEL-LAMBDA-MAX* lambdas in the list, or if FORCE-P is true, -;;; then smash the lambdas into a single component, compile it, and -;;; call the resulting function. -(defun sub-compile-top-level-lambdas (lambdas force-p) +;;; Smash LAMBDAS into a single component, compile it, and arrange for +;;; the resulting function to be called. +(defun sub-compile-toplevel-lambdas (lambdas) (declare (list lambdas)) - (setq *pending-top-level-lambdas* - (append *pending-top-level-lambdas* lambdas)) - (let ((pending *pending-top-level-lambdas*)) - (when (and pending - (or (> (length pending) *top-level-lambda-max*) - force-p)) - (multiple-value-bind (component tll) (merge-top-level-lambdas pending) - (setq *pending-top-level-lambdas* ()) - (let ((*byte-compile* (if (eq *byte-compile* :maybe) - *byte-compile-top-level* - *byte-compile*))) - (compile-component component)) - (clear-ir1-info component) - (object-call-top-level-lambda tll)))) + (when lambdas + (multiple-value-bind (component tll) (merge-toplevel-lambdas lambdas) + (compile-component component) + (clear-ir1-info component) + (object-call-toplevel-lambda tll))) (values)) -;;; Compile top-level code and call the top-level lambdas. We pick off -;;; top-level lambdas in non-top-level components here, calling -;;; SUB-c-t-l-l on each subsequence of normal top-level lambdas. -(defun compile-top-level-lambdas (lambdas force-p) +;;; Compile top level code and call the top level lambdas. We pick off +;;; top level lambdas in non-top-level components here, calling +;;; SUB-c-t-l-l on each subsequence of normal top level lambdas. +(defun compile-toplevel-lambdas (lambdas) (declare (list lambdas)) (let ((len (length lambdas))) (flet ((loser (start) - (or (position-if #'(lambda (x) - (not (eq (component-kind - (block-component - (node-block - (lambda-bind x)))) - :top-level))) - lambdas - :start start) - len))) + (or (position-if (lambda (x) + (not (eq (component-kind + (node-component (lambda-bind x))) + :toplevel))) + lambdas + ;; this used to read ":start start", but + ;; start can be greater than len, which + ;; is an error according to ANSI - CSR, + ;; 2002-04-25 + :start (min start len)) + len))) (do* ((start 0 (1+ loser)) - (loser (loser start) (loser start))) - ((>= start len) - (when force-p - (sub-compile-top-level-lambdas nil t))) - (sub-compile-top-level-lambdas (subseq lambdas start loser) - (or force-p (/= loser len))) - (unless (= loser len) - (object-call-top-level-lambda (elt lambdas loser)))))) + (loser (loser start) (loser start))) + ((>= start len)) + (sub-compile-toplevel-lambdas (subseq lambdas start loser)) + (unless (= loser len) + (object-call-toplevel-lambda (elt lambdas loser)))))) (values)) -;;; Compile LAMBDAS (a list of the lambdas for top-level forms) into -;;; the object file. We loop doing local call analysis until it -;;; converges, since a single pass might miss something due to -;;; components being joined by LET conversion. +;;; Compile LAMBDAS (a list of CLAMBDAs for top level forms) into the +;;; object file. ;;; ;;; LOAD-TIME-VALUE-P seems to control whether it's MAKE-LOAD-FORM and ;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201 -(defun compile-top-level (lambdas load-time-value-p) +(defun compile-toplevel (lambdas load-time-value-p) (declare (list lambdas)) + (maybe-mumble "locall ") - (loop - (let ((did-something nil)) - (dolist (lambda lambdas) - (let* ((component (block-component (node-block (lambda-bind lambda)))) - (*all-components* (list component))) - (when (component-new-functions component) - (setq did-something t) - (local-call-analyze component)))) - (unless did-something (return)))) + (locall-analyze-clambdas-until-done lambdas) (maybe-mumble "IDFO ") (multiple-value-bind (components top-components hairy-top) (find-initial-dfo lambdas) - (let ((*all-components* (append components top-components)) - (top-level-closure nil)) + (let ((all-components (append components top-components))) (when *check-consistency* - (maybe-mumble "[check]~%") - (check-ir1-consistency *all-components*)) + (maybe-mumble "[check]~%") + (check-ir1-consistency all-components)) (dolist (component (append hairy-top top-components)) - (when (pre-environment-analyze-top-level component) - (setq top-level-closure t))) - - (let ((*byte-compile* - (if (and top-level-closure (eq *byte-compile* :maybe)) - nil - *byte-compile*))) - (dolist (component components) - (compile-component component) - (when (replace-top-level-xeps component) - (setq top-level-closure t))) - - (when *check-consistency* - (maybe-mumble "[check]~%") - (check-ir1-consistency *all-components*)) - - (if load-time-value-p - (compile-load-time-value-lambda lambdas) - (compile-top-level-lambdas lambdas top-level-closure))) + (pre-physenv-analyze-toplevel component)) (dolist (component components) - (clear-ir1-info component)) - (clear-stuff))) + (compile-component component) + (replace-toplevel-xeps component)) + + (when *check-consistency* + (maybe-mumble "[check]~%") + (check-ir1-consistency all-components)) + + (if load-time-value-p + (compile-load-time-value-lambda lambdas) + (compile-toplevel-lambdas lambdas)) + + (mapc #'clear-ir1-info components))) (values)) ;;; Actually compile any stuff that has been queued up for block ;;; compilation. (defun finish-block-compilation () (when *block-compile* - (when *top-level-lambdas* - (compile-top-level (nreverse *top-level-lambdas*) nil) - (setq *top-level-lambdas* ())) + (when *compile-print* + (compiler-mumble "~&; block compiling converted top level forms...")) + (when *toplevel-lambdas* + (compile-toplevel (nreverse *toplevel-lambdas*) nil) + (setq *toplevel-lambdas* ())) (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 &optional d-s-info) +;;; Return (VALUES ABORT-P WARNINGS-P FAILURE-P). +(defun sub-compile-file (info) (declare (type source-info info)) - (let* (;; These are bound in WITH-COMPILATION-UNIT now. -- WHN 20000308 - #+nil (*compiler-error-count* 0) - #+nil (*compiler-warning-count* 0) - #+nil (*compiler-style-warning-count* 0) - #+nil (*compiler-note-count* 0) - (*block-compile* *block-compile-argument*) - (*package* (sane-package)) - (*policy* *policy*) - (*interface-policy* *interface-policy*) - (*lexenv* (make-null-lexenv)) - (*converting-for-interpreter* nil) - (*source-info* info) - (sb!xc:*compile-file-pathname* nil) - (sb!xc:*compile-file-truename* nil) - (*top-level-lambdas* ()) - (*pending-top-level-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) - (*info-environment* (or *backend-info-environment* - *info-environment*)) - (*gensym-counter* 0)) - (with-compilation-values - (sb!xc:with-compilation-unit () - (clear-stuff) - - (process-sources info) - - (finish-block-compilation) - (compile-top-level-lambdas () t) - (let ((object *compile-object*)) - (etypecase object - (fasl-file (fasl-dump-source-info info object)) - (core-object (fix-core-source-info info object d-s-info)) - (null))) - nil)))) - -;;; Return a list of pathnames for the named files. All the files must -;;; exist. -(defun verify-source-files (stuff) - (let* ((stuff (if (listp stuff) stuff (list stuff))) - (default-host (make-pathname - :host (pathname-host (pathname (first stuff)))))) + (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*) + (*code-coverage-records* (make-hash-table :test 'equal)) + (*code-coverage-blocks* (make-hash-table :test 'equal)) + (*handled-conditions* *handled-conditions*) + (*disabled-package-locks* *disabled-package-locks*) + (*lexenv* (make-null-lexenv)) + (*block-compile* *block-compile-arg*) + (*toplevel-lambdas* ()) + (*fun-names-in-this-file* ()) + (*allow-instrumenting* nil) + (*compiler-error-bailout* + (lambda (&optional error) + (declare (ignore error)) + (return-from sub-compile-file (values t 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*) + (*compiler-sset-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 () + (with-world-lock () + (sub-sub-compile-file info) + (unless (zerop (hash-table-count *code-coverage-records*)) + ;; Dump the code coverage records into the fasl. + (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)))) + ;; 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* + "~@<~@:_compilation aborted because of fatal error: ~2I~_~A~@:_~:>" + (encapsulated-condition condition))) + (finish-output *error-output*) + (values t t t))))) + +;;; Return a pathname for the named file. The file must exist. +(defun verify-source-file (pathname-designator) + (let* ((pathname (pathname pathname-designator)) + (default-host (make-pathname :host (pathname-host pathname)))) (flet ((try-with-type (path type error-p) - (let ((new (merge-pathnames - path (make-pathname :type type - :defaults default-host)))) - (if (probe-file new) - new - (and error-p (truename new)))))) - (unless stuff - (error "can't compile with no source files")) - (mapcar #'(lambda (x) - (let ((x (pathname x))) - (cond ((typep x 'logical-pathname) - (try-with-type x "LISP" t)) - ((probe-file x) x) - ((try-with-type x "lisp" nil)) - ((try-with-type x "lisp" t))))) - stuff)))) - -(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)))) + (let ((new (merge-pathnames + path (make-pathname :type type + :defaults default-host)))) + (if (probe-file new) + new + (and error-p (truename new)))))) + (cond ((typep pathname 'logical-pathname) + (try-with-type pathname "LISP" t)) + ((probe-file pathname) pathname) + ((try-with-type pathname "lisp" nil)) + ((try-with-type pathname "lisp" t)))))) + +(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 start-error-output (source-info) +(defun print-compile-start-note (source-info) (declare (type source-info source-info)) - (dolist (x (source-info-files source-info)) + (let ((file-info (source-info-file-info source-info))) (compiler-mumble "~&; compiling file ~S (written ~A):~%" - (namestring (file-info-name x)) - (sb!int:format-universal-time nil - (file-info-write-date x) - :style :government - :print-weekday nil - :print-timezone nil))) + (namestring (file-info-name file-info)) + (sb!int:format-universal-time nil + (file-info-write-date + file-info) + :style :government + :print-weekday nil + :print-timezone nil))) (values)) -(defun finish-error-output (source-info won) +(defun print-compile-end-note (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)))) + won + (elapsed-time-to-string + (- (get-internal-real-time) + (source-info-start-real-time source-info)))) (values)) ;;; Open some files and call SUB-COMPILE-FILE. If something unwinds ;;; out of the compile, then abort the writing of the output file, so -;;; we don't overwrite it with known garbage. +;;; that we don't overwrite it with known garbage. (defun sb!xc:compile-file (input-file &key + + ;; ANSI options (output-file (cfp-output-file-default input-file)) ;; FIXME: ANSI doesn't seem to say anything about ;; *COMPILE-VERBOSE* and *COMPILE-PRINT* being rebound by this @@ -1451,80 +1759,134 @@ ((:verbose sb!xc:*compile-verbose*) sb!xc:*compile-verbose*) ((:print sb!xc:*compile-print*) sb!xc:*compile-print*) (external-format :default) - ((:block-compile *block-compile-argument*) nil) - ((:entry-points *entry-points*) nil) - ((:byte-compile *byte-compile*) *byte-compile-default*)) + + ;; extensions + (trace-file nil) + ((:block-compile *block-compile-arg*) nil) + (emit-cfasl *emit-cfasl*)) #!+sb-doc - "Compile INPUT-FILE, producing a corresponding fasl file. - :Output-File - The name of the fasl to output. - :Block-Compile - Determines whether multiple functions are compiled together as a unit, - resolving function references at compile time. NIL means that global - function names are never resolved at compilation time. - :Entry-Points - This specifies a list of function names for functions in the file(s) that - must be given global definitions. This only applies to block - compilation. If the value is NIL (the default) then all functions - will be globally defined. - :Byte-Compile {T | NIL | :MAYBE} - Determines whether to compile into interpreted byte code instead of - machine instructions. Byte code is several times smaller, but much - slower. If :MAYBE, then only byte-compile when SPEED is 0 and - DEBUG <= 1. The default is the value of SB-EXT:*BYTE-COMPILE-DEFAULT*, - which is initially :MAYBE." - (unless (eq external-format :default) - (error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported.")) - (let* ((fasl-file nil) - (output-file-name nil) - (compile-won nil) - (warnings-p nil) - (failure-p t) ; T in case error keeps this from being set later - ;; KLUDGE: The listifying and unlistifying in the next calls - ;; is to interface to old CMU CL code which accepted and - ;; returned lists of multiple source files. It would be - ;; cleaner to redo VERIFY-SOURCE-FILES and as - ;; VERIFY-SOURCE-FILE, accepting a single source file, and - ;; do a similar transformation on MAKE-FILE-SOURCE-INFO too. - ;; -- WHN 20000201 - (input-pathname (first (verify-source-files (list input-file)))) - (source-info (make-file-source-info (list input-pathname)))) + "Compile INPUT-FILE, producing a corresponding fasl file and +returning its filename. + + :PRINT + If true, a message per non-macroexpanded top level form is printed + to *STANDARD-OUTPUT*. Top level forms that whose subforms are + processed as top level forms (eg. EVAL-WHEN, MACROLET, PROGN) receive + no such message, but their subforms do. + + As an extension to ANSI, if :PRINT is :top-level-forms, a message + per top level form after macroexpansion is printed to *STANDARD-OUTPUT*. + For example, compiling an IN-PACKAGE form will result in a message about + a top level SETQ in addition to the message about the IN-PACKAGE form' + itself. + + Both forms of reporting obey the SB-EXT:*COMPILER-PRINT-VARIABLE-ALIST*. + + :BLOCK-COMPILE + Though COMPILE-FILE accepts an additional :BLOCK-COMPILE + argument, it is not currently supported. (non-standard) + + :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) + + :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 +:BLOCK-COMPILE argument is quasi-supported, to determine whether +multiple functions are compiled together as a unit, resolving function +references at compile time. NIL means that global function names are +never resolved at compilation time. Currently NIL is the default +behavior, because although section 3.2.2.3, \"Semantic Constraints\", +of the ANSI spec allows this behavior under all circumstances, the +compiler's runtime scales badly when it tries to do this for large +files. If/when this performance problem is fixed, the block +compilation default behavior will probably be made dependent on the +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 + (input-pathname (verify-source-file input-file)) + (source-info (make-file-source-info input-pathname external-format)) + (*compiler-trace-output* nil)) ; might be modified below + (unwind-protect - (progn - (when output-file - (setq output-file-name - (sb!xc:compile-file-pathname input-file - :output-file output-file)) - (setq fasl-file - (open-fasl-file output-file-name - (namestring input-pathname) - (eq *byte-compile* t)))) - - (when sb!xc:*compile-verbose* - (start-error-output source-info)) - (let ((*compile-object* fasl-file) - dummy) - (multiple-value-setq (dummy warnings-p failure-p) - (sub-compile-file source-info))) - (setq compile-won t)) + (progn + (when output-file + (setq output-file-name + (sb!xc:compile-file-pathname input-file + :output-file output-file)) + (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)) + (trace-file-pathname + (if (eql trace-file t) + default-trace-file-pathname + (merge-pathnames trace-file + default-trace-file-pathname)))) + (setf *compiler-trace-output* + (open trace-file-pathname + :if-exists :supersede + :direction :output)))) + + (when sb!xc:*compile-verbose* + (print-compile-start-note source-info)) + + (let ((*compile-object* fasl-output) + (*compile-toplevel-object* cfasl-output)) + (setf (values abort-p warnings-p failure-p) + (sub-compile-file source-info)))) (close-source-info source-info) - (when fasl-file - (close-fasl-file fasl-file (not compile-won)) - (setq output-file-name (pathname (fasl-file-stream fasl-file))) - (when (and compile-won sb!xc:*compile-verbose*) - (compiler-mumble "~2&; ~A written~%" (namestring output-file-name)))) + (when fasl-output + (close-fasl-output fasl-output abort-p) + (setq output-file-name + (pathname (fasl-output-stream fasl-output))) + (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* - (finish-error-output source-info compile-won))) - - (values (if output-file - ;; Hack around filesystem race condition... - (or (probe-file output-file-name) output-file-name) - nil) - warnings-p - failure-p))) + (print-compile-end-note source-info (not abort-p))) + + (when *compiler-trace-output* + (close *compiler-trace-output*))) + + ;; CLHS says that the first value is NIL if the "file could not + ;; be created". We interpret this to mean "a valid fasl could not + ;; be created" -- which can happen if the compilation is aborted + ;; before the whole file has been processed, due to eg. a reader + ;; error. + (values (when (and (not abort-p) output-file) + ;; Hack around filesystem race condition... + (or (probe-file output-file-name) output-file-name)) + warnings-p + failure-p))) ;;; a helper function for COMPILE-FILE-PATHNAME: the default for ;;; the OUTPUT-FILE argument @@ -1535,12 +1897,10 @@ ;;; default to the appropriate implementation-defined default type for ;;; compiled files. (defun cfp-output-file-default (input-file) - (let* ((defaults (merge-pathnames input-file - *default-pathname-defaults*)) - (retyped (make-pathname :type *backend-fasl-file-type* - :defaults defaults))) + (let* ((defaults (merge-pathnames input-file *default-pathname-defaults*)) + (retyped (make-pathname :type *fasl-file-type* :defaults defaults))) retyped)) - + ;;; KLUDGE: Part of the ANSI spec for this seems contradictory: ;;; If INPUT-FILE is a logical pathname and OUTPUT-FILE is unsupplied, ;;; the result is a logical pathname. If INPUT-FILE is a logical @@ -1551,11 +1911,137 @@ ;;; physical pathname. Patches to make it more correct are welcome. ;;; -- WHN 2000-12-09 (defun sb!xc:compile-file-pathname (input-file - &key - (output-file (cfp-output-file-default - input-file)) - &allow-other-keys) + &key + (output-file nil output-file-p) + &allow-other-keys) #!+sb-doc "Return a pathname describing what file COMPILE-FILE would write to given these arguments." - (pathname output-file)) + (if output-file-p + (merge-pathnames output-file (cfp-output-file-default input-file)) + (cfp-output-file-default input-file))) + +;;;; MAKE-LOAD-FORM stuff + +;;; The entry point for MAKE-LOAD-FORM support. When IR1 conversion +;;; finds a constant structure, it invokes this to arrange for proper +;;; dumping. If it turns out that the constant has already been +;;; dumped, then we don't need to do anything. +;;; +;;; If the constant hasn't been dumped, then we check to see whether +;;; we are in the process of creating it. We detect this by +;;; maintaining the special *CONSTANTS-BEING-CREATED* as a list of all +;;; the constants we are in the process of creating. Actually, each +;;; entry is a list of the constant and any init forms that need to be +;;; processed on behalf of that constant. +;;; +;;; It's not necessarily an error for this to happen. If we are +;;; processing the init form for some object that showed up *after* +;;; the original reference to this constant, then we just need to +;;; defer the processing of that init form. To detect this, we +;;; maintain *CONSTANTS-CREATED-SINCE-LAST-INIT* as a list of the +;;; constants created since the last time we started processing an +;;; init form. If the constant passed to emit-make-load-form shows up +;;; in this list, then there is a circular chain through creation +;;; forms, which is an error. +;;; +;;; If there is some intervening init form, then we blow out of +;;; processing it by throwing to the tag PENDING-INIT. The value we +;;; throw is the entry from *CONSTANTS-BEING-CREATED*. This is so the +;;; offending init form can be tacked onto the init forms for the +;;; circular object. +;;; +;;; If the constant doesn't show up in *CONSTANTS-BEING-CREATED*, then +;;; we have to create it. We call MAKE-LOAD-FORM and check to see +;;; whether the creation form is the magic value +;;; :SB-JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The +;;; dumper will eventually get its hands on the object and use the +;;; normal structure dumping noise on it. +;;; +;;; Otherwise, we bind *CONSTANTS-BEING-CREATED* and +;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* and compile the creation form +;;; much the way LOAD-TIME-VALUE does. When this finishes, we tell the +;;; dumper to use that result instead whenever it sees this constant. +;;; +;;; Now we try to compile the init form. We bind +;;; *CONSTANTS-CREATED-SINCE-LAST-INIT* to NIL and compile the init +;;; form (and any init forms that were added because of circularity +;;; detection). If this works, great. If not, we add the init forms to +;;; the init forms for the object that caused the problems and let it +;;; deal with it. +(defvar *constants-being-created* nil) +(defvar *constants-created-since-last-init* nil) +;;; FIXME: Shouldn't these^ variables be unbound outside LET forms? +(defun emit-make-load-form (constant &optional (name nil namep)) + (aver (fasl-output-p *compile-object*)) + (unless (or (fasl-constant-already-dumped-p constant *compile-object*) + ;; KLUDGE: This special hack is because I was too lazy + ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM + ;; function of LAYOUT returns nontrivial forms when + ;; building the cross-compiler but :IGNORE-IT when + ;; cross-compiling or running under the target Lisp. -- + ;; WHN 19990914 + #+sb-xc-host (typep constant 'layout)) + (let ((circular-ref (assoc constant *constants-being-created* :test #'eq))) + (when circular-ref + (when (find constant *constants-created-since-last-init* :test #'eq) + (throw constant t)) + (throw 'pending-init circular-ref))) + (multiple-value-bind (creation-form init-form) + (if namep + ;; If the constant is a reference to a named constant, we can + ;; just use SYMBOL-VALUE during LOAD. + (values `(symbol-value ',name) nil) + (handler-case + (sb!xc:make-load-form constant (make-null-lexenv)) + (error (condition) + (compiler-error condition)))) + (case creation-form + (:sb-just-dump-it-normally + (fasl-validate-structure constant *compile-object*) + t) + (:ignore-it + nil) + (t + (let* ((name (write-to-string constant :level 1 :length 2)) + (info (if init-form + (list constant name init-form) + (list constant)))) + (let ((*constants-being-created* + (cons info *constants-being-created*)) + (*constants-created-since-last-init* + (cons constant *constants-created-since-last-init*))) + (when + (catch constant + (fasl-note-handle-for-constant + constant + (compile-load-time-value + creation-form) + *compile-object*) + nil) + (compiler-error "circular references in creation form for ~S" + constant))) + (when (cdr info) + (let* ((*constants-created-since-last-init* nil) + (circular-ref + (catch 'pending-init + (loop for (name form) on (cdr info) by #'cddr + collect name into names + collect form into forms + finally (compile-make-load-form-init-forms forms)) + nil))) + (when circular-ref + (setf (cdr circular-ref) + (append (cdr circular-ref) (cdr info)))))))))))) + + +;;;; Host compile time definitions +#+sb-xc-host +(defun compile-in-lexenv (name lambda lexenv) + (declare (ignore lexenv)) + (compile name lambda)) + +#+sb-xc-host +(defun eval-tlf (form index &optional lexenv) + (declare (ignore index lexenv)) + (eval form))