X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=d5ce1d971073b01af453c448389135d60dfc6a58;hb=b33fd6859bbe71667bf9d8a6dbcaf62464bfbee5;hp=a28f61ffc4e8666dc560a258b2c92da612689bdb;hpb=e02c32bd4d07a7d30c9a9d78be54f1f9f84f9877;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index a28f61f..d5ce1d9 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. @@ -11,6 +13,20 @@ (in-package "SB!C") +(defconstant sb!xc:call-arguments-limit most-positive-fixnum + #!+sb-doc + "The exclusive upper bound on the number of arguments which may be passed + to a function, including &REST args.") +(defconstant sb!xc:lambda-parameters-limit most-positive-fixnum + #!+sb-doc + "The exclusive upper bound on the number of parameters which may be specifed + in a given lambda list. This is actually the limit on required and &OPTIONAL + parameters. With &KEY and &AUX you can get more.") +(defconstant sb!xc:multiple-values-limit most-positive-fixnum + #!+sb-doc + "The exclusive upper bound on the number of multiple VALUES that you can + return.") + ;;; 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* @@ -40,7 +56,8 @@ 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 +;;; the value of the :BYTE-COMPILE argument which was passed to the +;;; compiler (defvar *byte-compile* :maybe) ;;; Bound by COMPILE-COMPONENT to T when byte-compiling, and NIL when @@ -54,7 +71,6 @@ (defvar *all-components*) ;;; 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 @@ -101,18 +117,13 @@ sb!xc:*compile-file-pathname* sb!xc:*compile-file-truename*)) -;;; the values of *PACKAGE* and policy when compilation started -(defvar *initial-package*) -(defvar *initial-cookie*) -(defvar *initial-interface-cookie*) - -;;; The source-info structure for the current compilation. This is null -;;; globally to indicate that we aren't currently in any identifiable -;;; compilation. +;;; the SOURCE-INFO structure for the current compilation. This is +;;; null globally to indicate that we aren't currently in any +;;; identifiable compilation. (defvar *source-info* nil) -;;; True if we are within a WITH-COMPILATION-UNIT form (which normally -;;; causes nested uses to be no-ops). +;;; This is true if we are within a WITH-COMPILATION-UNIT form (which +;;; normally causes nested uses to be no-ops). (defvar *in-compilation-unit* nil) ;;; Count of the number of compilation units dynamically enclosed by @@ -122,9 +133,11 @@ ;;; Mumble conditional on *COMPILE-PROGRESS*. (defun maybe-mumble (&rest foo) (when *compile-progress* - (apply #'compiler-mumble foo))) + (compiler-mumble "~&") + (pprint-logical-block (*error-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*)) @@ -225,19 +238,21 @@ (zerop *compiler-warning-count*) (zerop *compiler-style-warning-count*) (zerop *compiler-note-count*))) - (compiler-mumble - "~2&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~]~2%" - abort-p - *aborted-compilation-unit-count* - *compiler-error-count* - *compiler-warning-count* - *compiler-style-warning-count* - *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* "~&")) ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and @@ -279,24 +294,42 @@ (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)) + (cond ((component-reoptimize component) + (incf count) + (when (= count *max-optimize-iterations*) + (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))) (maybe-mumble ".")) (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.") @@ -318,8 +351,9 @@ (defun ir1-phases (component) (declare (type component component)) (let ((*constraint-number* 0) - (loop-count 1)) - (declare (special *constraint-number*)) + (loop-count 1) + (*delayed-ir1-transforms* nil)) + (declare (special *constraint-number* *delayed-ir1-transforms*)) (loop (ir1-optimize-until-done component) (when (or (component-new-functions component) @@ -330,7 +364,8 @@ (when *constraint-propagate* (maybe-mumble "constraint ") (constraint-propagate component)) - (maybe-mumble "type ") + (when (retry-delayed-ir1-transforms :constraint) + (maybe-mumble "Rtran ")) ;; Delay the generation of type checks until the type ;; constraints have had time to propagate, else the compiler can ;; confuse itself. @@ -338,7 +373,8 @@ (component-reanalyze component) (component-new-functions component) (component-reanalyze-functions component)) - (< loop-count (- *reoptimize-after-type-check-max* 2))) + (< loop-count (- *reoptimize-after-type-check-max* 4))) + (maybe-mumble "type ") (generate-type-checks component) (unless (or (component-reoptimize component) (component-reanalyze component) @@ -380,7 +416,7 @@ (entry-analyze component) (ir2-convert component) - (when (policy nil (>= speed cspeed)) + (when (policy *lexenv* (>= speed compilation-speed)) (maybe-mumble "copy ") (copy-propagate component)) @@ -410,7 +446,6 @@ (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*)) @@ -419,7 +454,6 @@ (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) @@ -427,7 +461,7 @@ *compiler-trace-output*)) (etypecase *compile-object* - (fasl-file + (fasl-output (maybe-mumble "fasl") (fasl-dump-component component *code-segment* @@ -445,11 +479,16 @@ *compile-object*)) (null)))))) - ;; We are done, so don't bother keeping anything around. + ;; We're done, so don't bother keeping anything around. (setf (component-info component) nil) (values)) +(defun policy-byte-compile-p (thing) + (policy thing + (and (zerop speed) + (<= debug 1)))) + ;;; 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. @@ -459,39 +498,40 @@ (defun byte-compiling () (if (eq *byte-compiling* :maybe) (or (eq *byte-compile* t) - (policy nil (zerop speed) (<= debug 1))) + (policy-byte-compile-p *lexenv*)) (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... +;;; 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. +;;; +;;; FIXME: The original CMU CL comment said "This doesn't really cover +;;; all cases..." That's a little scary. (defun delete-if-no-entries (component) (dolist (fun (component-lambdas component) (delete-component component)) (case (functional-kind fun) (:top-level (return)) (:external - (unless (every #'(lambda (ref) - (eq (block-component (node-block ref)) - component)) + (unless (every (lambda (ref) + (eq (block-component (node-block ref)) + component)) (leaf-refs fun)) (return)))))) +(defun byte-compile-this-component-p (component) + (ecase *byte-compile* + ((t) t) + ((nil) nil) + ((:maybe) + (every #'policy-byte-compile-p (component-lambdas component))))) + (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) - (zerop speed) (<= debug 1)) - (return nil))))))) - + (*byte-compiling* (byte-compile-this-component-p component))) (when sb!xc:*compile-print* - (compiler-mumble "~&~:[~;byte ~]compiling ~A: " + (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: " *byte-compiling* (component-name component))) @@ -592,8 +632,8 @@ (clrhash *id-labels*) (setq *label-id* 0) - ;; Clear some Pack data structures (for GC purposes only). - (assert (not *in-pack*)) + ;; Clear some PACK data structures (for GC purposes only). + (aver (not *in-pack*)) (dolist (sb *backend-sb-list*) (when (finite-sb-p sb) (fill (finite-sb-live-tns sb) nil)))) @@ -643,26 +683,26 @@ ;;;; Source-Info structure. The bookkeeping is done as a side-effect ;;;; of getting the next source form. -;;; The File-Info structure holds all the source information for a +;;; A FILE-INFO structure holds all the source information for a ;;; given file. -(defstruct file-info - ;; If a file, the truename of the corresponding source file. If from a Lisp - ;; form, :LISP, if from a stream, :STREAM. +(defstruct (file-info (:copier nil)) + ;; 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))) - ;; 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 debug-info. + ;; 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 + ;; debug-info. (untruename nil :type (or pathname null)) - ;; The file's write date (if relevant.) + ;; the file's write date (if relevant) (write-date nil :type (or unsigned-byte null)) - ;; This file's FILE-COMMENT, or NIL if none. - (comment nil :type (or simple-string null)) - ;; The source path root number of the first form in this file (i.e. the - ;; total number of forms converted previously in this compilation.) + ;; the source path root number of the first form in this file (i.e. + ;; the total number of forms converted previously in this + ;; compilation) (source-root 0 :type unsigned-byte) - ;; Parallel vectors containing the forms read out of the file and the file - ;; positions that reading of each form started at (i.e. the end of the - ;; previous form.) + ;; parallel vectors containing the forms read out of the file and + ;; the file positions that reading of each form started at (i.e. the + ;; end of the previous form) (forms (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t)) (positions (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))) @@ -671,7 +711,8 @@ (defstruct (source-info #-no-ansi-print-object (:print-object (lambda (s stream) - (print-unreadable-object (s stream :type t))))) + (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 @@ -704,7 +745,7 @@ :forms (vector form) :positions '#(0))))) -;;; Return a SOURCE-INFO which will read from Stream. +;;; 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 @@ -712,105 +753,42 @@ :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)) - -;;; 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) - (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")))) - -;;; If Stream is present, return it, otherwise open a stream to the +;;; Read a form 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 stream nil stream) + (reader-error (condition) + (error 'input-error-in-compile-file + :error condition + ;; We don't need to supply :POSITION here because + ;; READER-ERRORs already know their position in the file. + )) + ;; ANSI, in its wisdom, says that READ should return END-OF-FILE + ;; (and that this is not a READER-ERROR) when it encounters end of + ;; file in the middle of something it's trying to read. + (end-of-file (condition) + (error 'input-error-in-compile-file + :error 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)))) + +;;; 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. ;;; ;;; FIXME: Since we now do the standard ANSI thing of only one file -;;; per compile (unlike the CMU CL extended COMPILE-FILE) can't this -;;; complexity (including ADVANCE-SOURCE-FILE) go away? +;;; 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. (defun get-source-stream (info) (declare (type source-info info)) (cond ((source-info-stream info)) (t - (setq *package* *initial-package*) - (setq *default-cookie* (copy-cookie *initial-cookie*)) - (setq *default-interface-cookie* - (copy-cookie *initial-interface-cookie*)) (let* ((finfo (first (source-info-current-file info))) (name (file-info-name finfo))) (setq sb!xc:*compile-file-truename* name) @@ -846,23 +824,26 @@ (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)))))) + (form (read-for-compile-file stream pos))) + (if (eq form stream) ; i.e., if 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. +;;; +;;; FIXME: This is unnecessarily general cruft now that we only read +;;; a single file in COMPILE-FILE. (defun find-file-info (index info) (declare (type index index) (type source-info info)) (dolist (file (source-info-files info)) @@ -873,6 +854,9 @@ ;;; Return the INDEX'th source form read from INFO and the position ;;; where it was read. +;;; +;;; FIXME: This is unnecessarily general cruft now that we only read +;;; a single file in COMPILE-FILE. (defun find-source-root (index info) (declare (type source-info info) (type index index)) (let* ((file (find-file-info index info)) @@ -888,8 +872,7 @@ ;;; *TOP-LEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) - (let* ((*lexenv* (make-lexenv :cookie *default-cookie* - :interface-cookie *default-interface-cookie*)) + (let* ((*lexenv* (make-lexenv :policy *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))))) @@ -911,43 +894,31 @@ ;;; Process a top-level use of LOCALLY. We parse declarations and then ;;; recursively process the body. -;;; -;;; Binding *DEFAULT-xxx-COOKIE* 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 -;;; *DEFAULT-COOKIE* as the policy. The need for this hack is due to -;;; the quirk that there is no way to represent in a cookie that an -;;; optimize quality came from the default. (defun process-top-level-locally (form path) (declare (list path)) (multiple-value-bind (forms decls) (sb!sys:parse-body (cdr form) nil) (let* ((*lexenv* (process-decls decls nil nil (make-continuation))) - (*default-cookie* (lexenv-cookie *lexenv*)) - (*default-interface-cookie* (lexenv-interface-cookie *lexenv*))) + ;; 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*))) (process-top-level-progn forms path)))) -;;; Stash file comment in the FILE-INFO structure. -(defun process-file-comment (form) - (unless (and (proper-list-of-length-p form 2) - (stringp (second form))) - (compiler-error "bad FILE-COMMENT form: ~S" form)) - (let ((file (first (source-info-current-file *source-info*)))) - (cond ((file-info-comment file) - (compiler-warning "ignoring extra file comment:~% ~S" form)) - (t - (let ((comment (coerce (second form) 'simple-string))) - (setf (file-info-comment file) comment) - (when sb!xc:*compile-verbose* - (compiler-mumble "~&FILE-COMMENT: ~A~2&" comment))))))) - -;;; 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. +;;; 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 + (fasl-output (compile-top-level-lambdas () t) (fasl-dump-cold-load-form form object)) ((or null core-object) @@ -955,8 +926,6 @@ (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. ;;; * If this is a macro, then expand it. @@ -1010,7 +979,6 @@ (process-top-level-progn (cddr form) path)))) (locally (process-top-level-locally form path)) (progn (process-top-level-progn (cdr form) path)) - (file-comment (process-file-comment form)) (t (let* ((uform (uncross form)) (exp (preprocessor-macroexpand uform))) @@ -1024,11 +992,11 @@ ;;;; ;;;; (See EMIT-MAKE-LOAD-FORM.) -;;; Returns T iff we are currently producing a fasl-file and hence +;;; Returns T iff 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. @@ -1070,132 +1038,13 @@ ;;; the name. If not in a :TOP-LEVEL 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)) (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 @@ -1232,7 +1081,7 @@ (declare (type functional tll)) (let ((object *compile-object*)) (etypecase object - (fasl-file + (fasl-output (fasl-dump-top-level-lambda-call tll object)) (core-object (core-call-top-level-lambda tll object)) @@ -1362,13 +1211,8 @@ #+nil (*compiler-style-warning-count* 0) #+nil (*compiler-note-count* 0) (*block-compile* *block-compile-argument*) - (*package* *package*) - (*initial-package* *package*) - (*initial-cookie* *default-cookie*) - (*initial-interface-cookie* *default-interface-cookie*) - (*default-cookie* (copy-cookie *initial-cookie*)) - (*default-interface-cookie* - (copy-cookie *initial-interface-cookie*)) + (*package* (sane-package)) + (*policy* *policy*) (*lexenv* (make-null-lexenv)) (*converting-for-interpreter* nil) (*source-info* info) @@ -1377,10 +1221,9 @@ (*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)))) + (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) @@ -1391,20 +1234,29 @@ (*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)))) + (handler-case + (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-output (fasl-dump-source-info info object)) + (core-object (fix-core-source-info info object d-s-info)) + (null))) + nil)) + ;; Some errors are sufficiently bewildering that we just fail + ;; immediately, without trying to recover and compile more of + ;; the input file. + (input-error-in-compile-file (condition) + (format *error-output* + "~@" + condition) + (values nil t t))))) ;;; Return a list of pathnames for the named files. All the files must ;;; exist. @@ -1439,18 +1291,17 @@ (defun start-error-output (source-info) (declare (type source-info source-info)) (dolist (x (source-info-files source-info)) - (compiler-mumble "compiling file ~S (written ~A):~%" + (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))) - (compiler-mumble "~%") (values)) (defun finish-error-output (source-info won) (declare (type source-info source-info)) - (compiler-mumble "~&compilation ~:[aborted after~;finished in~] ~A~&" + (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&" won (elapsed-time-to-string (- (get-universal-time) @@ -1459,71 +1310,99 @@ ;;; 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 - (source + (input-file &key - (output-file t) ; FIXME: ANSI says this should be a pathname designator. + + ;; 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 ;; function.. ((:verbose sb!xc:*compile-verbose*) sb!xc:*compile-verbose*) ((:print sb!xc:*compile-print*) sb!xc:*compile-print*) (external-format :default) + + ;; extensions + (trace-file nil) ((:block-compile *block-compile-argument*) nil) - ((:entry-points *entry-points*) nil) ((:byte-compile *byte-compile*) *byte-compile-default*)) + #!+sb-doc - "Compile SOURCE, producing a corresponding FASL file. - :Output-File - The name of the fasl to output, NIL for none, T for the default. - :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." + "Compile INPUT-FILE, producing a corresponding fasl file and returning + its filename. Besides the ANSI &KEY arguments :OUTPUT-FILE, :VERBOSE, + :PRINT, and :EXTERNAL-FORMAT,the following extensions are supported: + :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. + :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. (This option will probably become + formally deprecated starting around sbcl-0.7.0, when various + cleanups related to the byte interpreter are planned.) + 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." + (unless (eq external-format :default) (error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported.")) - (let* ((fasl-file nil) + (let* ((fasl-output 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 - (source (first (verify-source-files (list source)))) - (source-info (make-file-source-info (list source)))) + ;; KLUDGE: The listifying and unlistifying in the stuff + ;; related to VERIFY-SOURCE-FILES below 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 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))) + (*compiler-trace-output* nil)) ; might be modified below + (unwind-protect (progn (when output-file (setq output-file-name - (sb!xc:compile-file-pathname source - :output-file output-file - :byte-compile *byte-compile*)) - (setq fasl-file - (open-fasl-file output-file-name - (namestring source) - (eq *byte-compile* t)))) + (sb!xc:compile-file-pathname input-file + :output-file output-file)) + (setq fasl-output + (open-fasl-output output-file-name + (namestring input-pathname) + (eq *byte-compile* t)))) + (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* (start-error-output source-info)) - (let ((*compile-object* fasl-file) + (let ((*compile-object* fasl-output) dummy) (multiple-value-setq (dummy warnings-p failure-p) (sub-compile-file source-info))) @@ -1531,14 +1410,18 @@ (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 fasl-output + (close-fasl-output fasl-output (not compile-won)) + (setq output-file-name + (pathname (fasl-output-stream fasl-output))) (when (and compile-won sb!xc:*compile-verbose*) - (compiler-mumble "~2&~A written~%" (namestring output-file-name)))) + (compiler-mumble "~2&; ~A written~%" (namestring output-file-name)))) (when sb!xc:*compile-verbose* - (finish-error-output source-info compile-won))) + (finish-error-output source-info compile-won)) + + (when *compiler-trace-output* + (close *compiler-trace-output*))) (values (if output-file ;; Hack around filesystem race condition... @@ -1547,22 +1430,156 @@ warnings-p failure-p))) -(defun sb!xc:compile-file-pathname (file-path - &key (output-file t) byte-compile +;;; a helper function for COMPILE-FILE-PATHNAME: the default for +;;; the OUTPUT-FILE argument +;;; +;;; ANSI: The defaults for the OUTPUT-FILE are taken from the pathname +;;; that results from merging the INPUT-FILE with the value of +;;; *DEFAULT-PATHNAME-DEFAULTS*, except that the type component should +;;; 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))) + 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 +;;; pathname, it is translated into a physical pathname as if by +;;; calling TRANSLATE-LOGICAL-PATHNAME. +;;; So I haven't really tried to make this precisely ANSI-compatible +;;; at the level of e.g. whether it returns logical pathname or a +;;; 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) #!+sb-doc "Return a pathname describing what file COMPILE-FILE would write to given these arguments." - (declare (values (or null pathname))) - (let ((pathname (pathname file-path))) - (cond ((not (eq output-file t)) - (when output-file - (translate-logical-pathname (pathname output-file)))) - ((and (typep pathname 'logical-pathname) (not (eq byte-compile t))) - (make-pathname :type "FASL" :defaults pathname - :case :common)) - (t - (make-pathname :defaults (translate-logical-pathname pathname) - :type (if (eq byte-compile t) - (backend-byte-fasl-file-type) - *backend-fasl-file-type*)))))) + (pathname output-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 +;;; :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) + (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) + (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-p 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))))))))))))