(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
(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*))
(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.")
(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)
(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.
(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)
(entry-analyze component)
(ir2-convert component)
- (when (policy nil (>= speed compilation-speed))
+ (when (policy *lexenv* (>= speed compilation-speed))
(maybe-mumble "copy ")
(copy-propagate component))
(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*))
(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)
*compiler-trace-output*))
(etypecase *compile-object*
- (fasl-file
+ (fasl-output
(maybe-mumble "fasl")
(fasl-dump-component component
*code-segment*
*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.
(defun byte-compiling ()
(if (eq *byte-compiling* :maybe)
(or (eq *byte-compile* t)
- ;; FIXME: It's bad to share this expression between this
- ;; function and LAMBDA-IS-BYTE-COMPILABLE-P (and who knows
- ;; where else?), it should be factored out into some
- ;; common function.
- (policy nil (and (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
(leaf-refs fun))
(return))))))
-(defun lambda-is-byte-compilable-p (lambda)
- #|
- (format t "~S SPEED=~S DEBUG=~S~%" ; REMOVEME
- lambda
- (policy (lambda-bind lambda) speed)
- (policy (lambda-bind lambda) debug))
- |#
- (policy (lambda-bind lambda)
- (and (zerop speed) (<= debug 1))))
-
(defun byte-compile-this-component-p (component)
(ecase *byte-compile*
((t) t)
((nil) nil)
((:maybe)
- (every #'lambda-is-byte-compilable-p (component-lambdas component)))))
+ (every #'policy-byte-compile-p (component-lambdas component)))))
(defun compile-component (component)
(let* ((*component-being-compiled* component)
: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
: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"))))
+;;; 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
(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))
;;; 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))
;;; *TOP-LEVEL-LAMBDAS* instead.
(defun convert-and-maybe-compile (form path)
(declare (list path))
- (let* ((*lexenv* (make-lexenv :policy *policy*
- :interface-policy *interface-policy*))
+ (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)))))
(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
+ ;; 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
;; 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*)))
+ (*policy* (lexenv-policy *lexenv*)))
(process-top-level-progn forms path))))
;;; Force any pending top-level forms to be compiled and dumped so
(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)
(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.
;;;;
;;;; (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.
(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)
- (aver (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))))))))))))
\f
;;;; COMPILE-FILE
(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))
(*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)
(*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*
+ "~@<compilation aborted because of input error: ~2I~_~A~:>"
+ condition)
+ (values nil t t)))))
;;; Return a list of pathnames for the named files. All the files must
;;; exist.
:print-weekday nil
:print-timezone nil)))
(values))
-
(defun finish-error-output (source-info won)
(declare (type source-info source-info))
(compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&"
;;; 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
((: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 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."
+ "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
+ ;; 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))))
+ (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 input-file
:output-file output-file))
- (setq fasl-file
- (open-fasl-file output-file-name
- (namestring input-pathname)
- (eq *byte-compile* t))))
+ (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)))
(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))))
(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...
;;; 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*))
+ (let* ((defaults (merge-pathnames input-file *default-pathname-defaults*))
(retyped (make-pathname :type *backend-fasl-file-type*
:defaults defaults)))
retyped))
"Return a pathname describing what file COMPILE-FILE would write to given
these arguments."
(pathname output-file))
+\f
+;;;; 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))))))))))))
projects / sbcl.git / blobdiff