#!+sb-show *compiler-trace-output*
*last-source-context* *last-original-source*
*last-source-form* *last-format-string* *last-format-args*
- *last-message-count* *lexenv*))
+ *last-message-count* *lexenv* *fun-names-in-this-file*
+ *allow-instrumenting*))
+
+;;; Whether call of a function which cannot be defined causes a full
+;;; warning.
+(defvar *flame-on-necessarily-undefined-function* nil)
(defvar *check-consistency* nil)
(defvar *all-components*)
+;;; 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.
(defvar *compiler-trace-output* nil)
(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
"The default for the :VERBOSE argument to COMPILE-FILE.")
"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.)")
(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-output core-object null))
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."
+ One of the effects of this form is to delay undefined warnings
+ until the end of the form, instead of giving them at the end of each
+ compilation. If OVERRIDE is NIL (the default), then the outermost
+ WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
+ OVERRIDE true causes that form to grab any enclosed warnings, even if
+ it is enclosed by another WITH-COMPILATION-UNIT.
+
+ :SOURCE-PLIST Plist-Form
+ Attaches the value returned by the Plist-Form to internal debug-source
+ information of functions compiled in within the dynamic contour.
+ Primarily for use by development environments, in order to eg. associate
+ function definitions with editor-buffers. Can be accessed as
+ SB-INTROSPECT:DEFINITION-SOURCE-PLIST. If multiple, nested
+ WITH-COMPILATION-UNITs provide :SOURCE-PLISTs, they are appended
+ togather, innermost left. If Unaffected by :OVERRIDE."
`(%with-compilation-unit (lambda () ,@body) ,@options))
-(defun %with-compilation-unit (fn &key override)
- (let ((succeeded-p nil))
+(defvar *source-plist* nil)
+
+(defun %with-compilation-unit (fn &key override source-plist)
+ (declare (type function fn))
+ (let ((succeeded-p nil)
+ (*source-plist* (append source-plist *source-plist*)))
(if (and *in-compilation-unit* (not override))
;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
;; ordinarily (unless OVERRIDE) basically a no-op.
(unwind-protect
- (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
+ (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-note-count* 0)
(*undefined-warnings* nil)
(*in-compilation-unit* t))
- (handler-bind ((parse-unknown-type
- (lambda (c)
- (note-undefined-reference
- (parse-unknown-type-specifier c)
- :type))))
- (unwind-protect
- (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
- (unless succeeded-p
- (incf *aborted-compilation-unit-count*))
- (summarize-compilation-unit (not succeeded-p))))))))
+ (sb!thread:with-recursive-lock (*big-compiler-lock*)
+ (handler-bind ((parse-unknown-type
+ (lambda (c)
+ (note-undefined-reference
+ (parse-unknown-type-specifier c)
+ :type))))
+ (unwind-protect
+ (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
+ (unless succeeded-p
+ (incf *aborted-compilation-unit-count*))
+ (summarize-compilation-unit (not succeeded-p)))))))))
+
+;;; Is FUN-NAME something that no conforming program can rely on
+;;; defining as a function?
+(defun fun-name-reserved-by-ansi-p (fun-name)
+ (eq (symbol-package (fun-name-block-name fun-name))
+ *cl-package*))
;;; This is to be called at the end of a compilation unit. It signals
;;; any residual warnings about unknown stuff, then prints the total
(warnings (undefined-warning-warnings undef))
(undefined-warning-count (undefined-warning-count undef)))
(dolist (*compiler-error-context* warnings)
- (compiler-style-warn "undefined ~(~A~): ~S" kind name))
+ (if #-sb-xc-host (and (eq kind :function)
+ (fun-name-reserved-by-ansi-p name)
+ *flame-on-necessarily-undefined-function*)
+ #+sb-xc-host nil
+ (case name
+ ((declare)
+ (compiler-warn
+ "~@<There is no function named ~S. References to ~S in ~
+ some contexts (like starts of blocks) have special ~
+ meaning, but here it would have to be a function, ~
+ and that shouldn't be right.~:@>"
+ name name))
+ (t
+ (compiler-warn
+ "~@<The ~(~A~) ~S is undefined, and its name is ~
+ reserved by ANSI CL so that even if it were ~
+ defined later, the code doing so would not be ~
+ portable.~:@>"
+ kind name)))
+ (if (eq kind :variable)
+ (compiler-warn "undefined ~(~A~): ~S" kind name)
+ (compiler-style-warn "undefined ~(~A~): ~S" kind name))))
(let ((warn-count (length warnings)))
(when (and warnings (> undefined-warning-count warn-count))
(let ((more (- undefined-warning-count warn-count)))
- (compiler-style-warn
- "~W more use~:P of undefined ~(~A~) ~S"
- more kind name))))))
-
+ (if (eq kind :variable)
+ (compiler-warn
+ "~W more use~:P of undefined ~(~A~) ~S"
+ more kind name)
+ (compiler-style-warn
+ "~W more use~:P of undefined ~(~A~) ~S"
+ more kind name)))))))
+
(dolist (kind '(:variable :function :type))
(let ((summary (mapcar #'undefined-warning-name
- (remove kind undefs :test-not #'eq
+ (remove kind undefs :test #'neq
:key #'undefined-warning-kind))))
(when summary
- (compiler-style-warn
- "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
- ~% ~{~<~% ~1:;~S~>~^ ~}"
- (cdr summary) kind summary)))))))
+ (if (eq kind :variable)
+ (compiler-warn
+ "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
+ (cdr summary) kind summary)
+ (compiler-style-warn
+ "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
+ (cdr summary) kind summary))))))))
(unless (and (not abort-p)
(zerop *aborted-compilation-unit-count*)
(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 ~W fatal ERROR condition~:P~]~
- ~[~:;~:*~& caught ~W ERROR condition~:P~]~
- ~[~:;~:*~& caught ~W WARNING condition~:P~]~
- ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~
- ~[~:;~:*~& printed ~W note~:P~]"
- abort-p
- *aborted-compilation-unit-count*
- *compiler-error-count*
- *compiler-warning-count*
- *compiler-style-warning-count*
- *compiler-note-count*)))
- (format *error-output* "~&"))
+ (format *error-output* "~&compilation unit ~:[finished~;aborted~]~
+ ~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~
+ ~[~:;~:*~& caught ~W ERROR condition~:P~]~
+ ~[~:;~:*~& caught ~W WARNING condition~:P~]~
+ ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~
+ ~[~:;~:*~& printed ~W note~:P~]"
+ abort-p
+ *aborted-compilation-unit-count*
+ *compiler-error-count*
+ *compiler-warning-count*
+ *compiler-style-warning-count*
+ *compiler-note-count*))
+ (terpri *error-output*)
+ (force-output *error-output*)))
;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
;;; FAILURE-P), where BODY-VALUE is the first value of the body, and
(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))
(setf (component-reoptimize component) nil)
- (ir1-optimize component)
+ (ir1-optimize component fastp)
(cond ((component-reoptimize component)
(incf count)
- (when (= count *max-optimize-iterations*)
+ (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 "+")
(t
(maybe-mumble " ")
(return)))
- (maybe-mumble "."))
+ (setq fastp (>= count *max-optimize-iterations*))
+ (maybe-mumble (if fastp "-" ".")))
(when cleared-reanalyze
(setf (component-reanalyze component) t)))
(values))
(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
(when *compile-progress*
(compiler-mumble "") ; Sync before doing more output.
- (pre-pack-tn-stats component *error-output*))
+ (pre-pack-tn-stats component *standard-output*))
(when *check-consistency*
(maybe-mumble "check-life ")
(describe-ir2-component component *compiler-trace-output*))
(maybe-mumble "code ")
- (multiple-value-bind (code-length trace-table fixups)
+ (multiple-value-bind (code-length trace-table fixup-notes)
(generate-code component)
+ #-sb-xc-host
(when *compiler-trace-output*
(format *compiler-trace-output*
"~|~%disassembly of code for ~S~2%" component)
*code-segment*
code-length
trace-table
- fixups
+ fixup-notes
*compile-object*))
(core-object
(maybe-mumble "core")
*code-segment*
code-length
trace-table
- fixups
+ fixup-notes
*compile-object*))
(null))))))
(aver (eql (node-component (lambda-bind lambda)) component)))
(let* ((*component-being-compiled* component))
- (when sb!xc:*compile-print*
- (compiler-mumble "~&; compiling ~A: " (component-name 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 ")
(physenv-analyze component)
(%compile-component component)))
(clear-constant-info)
-
- (when sb!xc:*compile-print*
- (compiler-mumble "~&"))
-
+
(values))
\f
;;;; clearing global data structures
(setq *tn-id* 0)
(clrhash *label-ids*)
(clrhash *id-labels*)
- (setq *label-id* 0)
-
- ;; 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))))
+ (setq *label-id* 0))
;; (Note: The CMU CL code used to set CL::*GENSYM-COUNTER* to zero here.
;; Superficially, this seemed harmful -- the user could reasonably be
(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*)
(format t "~4TL~D: ~S~:[~; [closure]~]~%"
(label-id (entry-info-offset entry))
(entry-info-name entry)
- (entry-info-closure-p entry)))
+ (entry-info-closure-tn entry)))
(terpri)
(pre-pack-tn-stats component *standard-output*)
(terpri)
;;; A FILE-INFO structure holds all the source information for a
;;; given file.
-(defstruct (file-info (:copier nil))
+(def!struct (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 (missing-arg) :type (or pathname (member :lisp :stream)))
+ ;; 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
;;; 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)
;; the FILE-INFO structure for this compilation
(stream nil :type (or stream null)))
;;; Given a pathname, return a SOURCE-INFO structure.
-(defun make-file-source-info (file)
+(defun make-file-source-info (file external-format)
(let ((file-info (make-file-info :name (truename file)
:untruename file
+ :external-format external-format
:write-date (file-write-date file))))
(make-source-info :file-info file-info)))
(handler-case (read stream nil stream)
(reader-error (condition)
(error 'input-error-in-compile-file
- :error condition
+ :condition condition
;; We don't need to supply :POSITION here because
;; READER-ERRORs already know their position in the file.
))
;; file in the middle of something it's trying to read.
(end-of-file (condition)
(error 'input-error-in-compile-file
- :error condition
+ :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.
(declare (type source-info info))
(or (source-info-stream info)
(let* ((file-info (source-info-file-info info))
- (name (file-info-name file-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)))))
+ (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)
;;; *TOPLEVEL-LAMBDAS* instead.
(defun convert-and-maybe-compile (form path)
(declare (list path))
- (let* ((*lexenv* (make-lexenv :policy *policy*))
+ (let* ((*top-level-form-noted* (note-top-level-form form t))
+ (*lexenv* (make-lexenv
+ :policy *policy*
+ :handled-conditions *handled-conditions*
+ :disabled-package-locks *disabled-package-locks*))
(tll (ir1-toplevel form path nil)))
- (cond ((eq *block-compile* t) (push tll *toplevel-lambdas*))
- (t (compile-toplevel (list tll) 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
(handler-case (sb!xc:macroexpand-1 form *lexenv*)
(error (condition)
(compiler-error "(during macroexpansion of ~A)~%~A"
- (let ((*print-level* 1)
+ (let ((*print-level* 2)
(*print-length* 2))
(format nil "~S" form))
condition))))
;;; 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)
+(defun process-toplevel-locally (body path compile-time-too &key vars funs)
(declare (list path))
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (let* ((*lexenv*
- (process-decls decls nil nil (make-continuation)))
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil :toplevel t)
+ (let* ((*lexenv* (process-decls decls vars funs))
+ ;; FIXME: VALUES declaration
+ ;;
;; Binding *POLICY* is pretty much of a hack, since it
;; causes LOCALLY to "capture" enclosed proclamations. It
;; is necessary because CONVERT-AND-MAYBE-COMPILE uses the
;; 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*)))
+ (*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,
(etypecase f
(clambda (list (lambda-component f)))
(optional-dispatch (let ((result nil))
- (labels ((frob (clambda)
- (pushnew (lambda-component clambda)
- result))
- (maybe-frob (maybe-clambda)
- (when maybe-clambda
- (frob maybe-clambda))))
- (mapc #'frob (optional-dispatch-entry-points f))
+ (flet ((maybe-frob (maybe-clambda)
+ (when (and maybe-clambda
+ (promise-ready-p maybe-clambda))
+ (pushnew (lambda-component
+ (force maybe-clambda))
+ result))))
+ (map nil #'maybe-frob (optional-dispatch-entry-points f))
(maybe-frob (optional-dispatch-more-entry f))
- (maybe-frob (optional-dispatch-main-entry f)))))))
+ (maybe-frob (optional-dispatch-main-entry f)))
+ result))))
(defun make-functional-from-toplevel-lambda (definition
&key
(component (make-empty-component))
(*current-component* component))
(setf (component-name component)
- (debug-namify "~S initial component" name))
+ (debug-name 'initial-component name))
(setf (component-kind component) :initial)
- (let* ((locall-fun (ir1-convert-lambda
- definition
- :debug-name (debug-namify "top level local call ~S"
- name)))
+ (let* ((locall-fun (let ((*allow-instrumenting* t))
+ (apply #'ir1-convert-lambdalike
+ definition
+ (list :source-name name))))
(fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
:source-name (or name '.anonymous.)
- :debug-name (unless name
- "top level form"))))
+ :debug-name (debug-name 'tl-xep name))))
+ (when name
+ (assert-global-function-definition-type name locall-fun))
(setf (functional-entry-fun fun) locall-fun
(functional-kind fun) :external
(functional-has-external-references-p fun) t)
;; 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)))
- (unless (or (null name) (legal-fun-name-p name))
- (error "not a legal function name: ~S" name))
- (let* ((*lexenv* (make-lexenv :policy *policy*))
+ (when name
+ (legal-fun-name-or-type-error name))
+ (let* ((*lexenv* (make-lexenv
+ :policy *policy*
+ :handled-conditions *handled-conditions*
+ :disabled-package-locks *disabled-package-locks*))
(fun (make-functional-from-toplevel-lambda lambda-expression
:name name
:path path)))
;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
(locall-analyze-clambdas-until-done (list fun))
-
+
(multiple-value-bind (components-from-dfo top-components hairy-top)
(find-initial-dfo (list fun))
+ (declare (ignore hairy-top))
(let ((*all-components* (append components-from-dfo top-components)))
- ;; FIXME: This is more monkey see monkey do based on CMU CL
- ;; code. If anyone figures out why to only prescan HAIRY-TOP
- ;; and TOP-COMPONENTS here, instead of *ALL-COMPONENTS* or
- ;; some other combination of results from FIND-INITIAL-VALUES,
- ;; it'd be good to explain it.
- (mapc #'preallocate-physenvs-for-toplevelish-lambdas hairy-top)
- (mapc #'preallocate-physenvs-for-toplevelish-lambdas top-components)
(dolist (component-from-dfo components-from-dfo)
(compile-component component-from-dfo)
(replace-toplevel-xeps component-from-dfo)))
- (prog1
- (let ((entry-table (etypecase *compile-object*
- (fasl-output (fasl-output-entry-table
- *compile-object*))
- (core-object (core-object-entry-table
- *compile-object*)))))
- (multiple-value-bind (result found-p)
- (gethash (leaf-info fun) entry-table)
- (aver found-p)
- result))
- ;; KLUDGE: This code duplicates some other code in this
- ;; file. In the great reorganzation, the flow of program logic
- ;; changed from the original CMUCL model, and that path (as of
- ;; sbcl-0.7.5 in SUB-COMPILE-FILE) was no longer followed for
- ;; CORE-OBJECTS, leading to BUG 156. This place is
- ;; transparently not the right one for this code, but I don't
- ;; have a clear enough overview of the compiler to know how to
- ;; rearrange it all so that this operation fits in nicely, and
- ;; it was blocking reimplementation of
- ;; (DECLAIM (INLINE FOO)) (MACROLET ((..)) (DEFUN FOO ...))
- ;;
- ;; FIXME: This KLUDGE doesn't solve all the problem in an
- ;; ideal way, as (1) definitions typed in at the REPL without
- ;; an INLINE declaration will give a NULL
- ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal) and
- ;; (2) INLINE declarations will yield a
- ;; FUNCTION-LAMBDA-EXPRESSION headed by
- ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV.
- ;;
- ;; CSR, 2002-07-02
- (when (core-object-p *compile-object*)
- (fix-core-source-info *source-info* *compile-object*))
-
- (mapc #'clear-ir1-info components-from-dfo)
- (clear-stuff)))))
+ (let ((entry-table (etypecase *compile-object*
+ (fasl-output (fasl-output-entry-table
+ *compile-object*))
+ (core-object (core-object-entry-table
+ *compile-object*)))))
+ (multiple-value-bind (result found-p)
+ (gethash (leaf-info fun) entry-table)
+ (aver found-p)
+ (prog1
+ result
+ ;; KLUDGE: This code duplicates some other code in this
+ ;; file. In the great reorganzation, the flow of program
+ ;; logic changed from the original CMUCL model, and that
+ ;; path (as of sbcl-0.7.5 in SUB-COMPILE-FILE) was no
+ ;; longer followed for CORE-OBJECTS, leading to BUG
+ ;; 156. This place is transparently not the right one for
+ ;; this code, but I don't have a clear enough overview of
+ ;; the compiler to know how to rearrange it all so that
+ ;; this operation fits in nicely, and it was blocking
+ ;; reimplementation of (DECLAIM (INLINE FOO)) (MACROLET
+ ;; ((..)) (DEFUN FOO ...))
+ ;;
+ ;; FIXME: This KLUDGE doesn't solve all the problem in an
+ ;; ideal way, as (1) definitions typed in at the REPL
+ ;; without an INLINE declaration will give a NULL
+ ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal)
+ ;; and (2) INLINE declarations will yield a
+ ;; FUNCTION-LAMBDA-EXPRESSION headed by
+ ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV. -- CSR,
+ ;; 2002-07-02
+ ;;
+ ;; (2) is probably fairly easy to fix -- it is, after all,
+ ;; a matter of list manipulation (or possibly of teaching
+ ;; CL:FUNCTION about SB-C:LAMBDA-WITH-LEXENV). (1) is
+ ;; significantly harder, as the association between
+ ;; function object and source is a tricky one.
+ ;;
+ ;; FUNCTION-LAMBDA-EXPRESSION "works" (i.e. returns a
+ ;; non-NULL list) when the function in question has been
+ ;; compiled by (COMPILE <x> '(LAMBDA ...)); it does not
+ ;; work when it has been compiled as part of the top-level
+ ;; EVAL strategy of compiling everything inside (LAMBDA ()
+ ;; ...). -- CSR, 2002-11-02
+ (when (core-object-p *compile-object*)
+ (fix-core-source-info *source-info* *compile-object* result))
+
+ (mapc #'clear-ir1-info components-from-dfo)
+ (clear-stuff)))))))
(defun process-toplevel-cold-fset (name lambda-expression path)
(unless (producing-fasl-file)
(error "can't COLD-FSET except in a fasl file"))
- (unless (legal-fun-name-p name)
- (error "not a legal function name: ~S" name))
+ (legal-fun-name-or-type-error name)
(fasl-dump-cold-fset name
(%compile lambda-expression
*compile-object*
*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 "~&; ~:[compiling~;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*))))
+
;;; 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.
;;; 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-toplevel-form-error-abort
+ (catch 'process-toplevel-form-error-abort
(let* ((path (or (gethash form *source-paths*) (cons form path)))
(*compiler-error-bailout*
- (lambda ()
+ (lambda (&optional condition)
(convert-and-maybe-compile
- `(error "execution of a form compiled with errors:~% ~S"
- ',form)
+ (make-compiler-error-form condition form)
path)
(throw 'process-toplevel-form-error-abort nil))))
- (if (atom form)
- ;; (There are no EVAL-WHEN issues in the ATOM case until
- ;; SBCL gets smart enough to handle global
- ;; DEFINE-SYMBOL-MACRO.)
- (convert-and-maybe-compile form path)
- (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
- `(progn ,@body)))))))
- ((macrolet)
- (funcall-in-macrolet-lexenv
- magic
- (lambda ()
- (process-toplevel-locally body
- path
- compile-time-too))))
- ((symbol-macrolet)
- (funcall-in-symbol-macrolet-lexenv
- magic
- (lambda ()
- (process-toplevel-locally body
- path
- compile-time-too)))))))
- ((locally)
- (process-toplevel-locally (rest form) path compile-time-too))
- ((progn)
- (process-toplevel-progn (rest form) path compile-time-too))
- ;; 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
- (t
- (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
- (t
- (let ((expanded (preprocessor-macroexpand-1 form)))
- (cond ((eq expanded form)
- (when compile-time-too
- (eval form))
- (convert-and-maybe-compile form path))
- (t
- (process-toplevel-form expanded
- path
- compile-time-too))))))))))
+ (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-in-lexenv form *lexenv*))
+ (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-in-lexenv
+ `(progn ,@body)
+ *lexenv*))))))
+ ((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))
\f
\f
;;;; 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-toplevel-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 *toplevel-lambda-max* 0)
-
(defun object-call-toplevel-lambda (tll)
(declare (type functional tll))
(let ((object *compile-object*))
(etypecase object
- (fasl-output
- (fasl-dump-toplevel-lambda-call tll object))
- (core-object
- (core-call-toplevel-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
-;;; *TOPLEVEL-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-toplevel-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-toplevel-lambdas*
- (append *pending-toplevel-lambdas* lambdas))
- (let ((pending *pending-toplevel-lambdas*))
- (when (and pending
- (or (> (length pending) *toplevel-lambda-max*)
- force-p))
- (multiple-value-bind (component tll) (merge-toplevel-lambdas pending)
- (setq *pending-toplevel-lambdas* ())
- (compile-component component)
- (clear-ir1-info component)
- (object-call-toplevel-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-toplevel-lambdas (lambdas force-p)
+(defun compile-toplevel-lambdas (lambdas)
(declare (list lambdas))
(let ((len (length lambdas)))
(flet ((loser (start)
len)))
(do* ((start 0 (1+ loser))
(loser (loser start) (loser start)))
- ((>= start len)
- (when force-p
- (sub-compile-toplevel-lambdas nil t)))
- (sub-compile-toplevel-lambdas (subseq lambdas start loser)
- (or force-p (/= loser len)))
+ ((>= start len))
+ (sub-compile-toplevel-lambdas (subseq lambdas start loser))
(unless (= loser len)
(object-call-toplevel-lambda (elt lambdas loser))))))
(values))
;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201
(defun compile-toplevel (lambdas load-time-value-p)
(declare (list lambdas))
-
+
(maybe-mumble "locall ")
(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))
- (toplevel-closure nil))
+ (let ((*all-components* (append components top-components)))
(when *check-consistency*
(maybe-mumble "[check]~%")
(check-ir1-consistency *all-components*))
(dolist (component (append hairy-top top-components))
- (when (pre-physenv-analyze-toplevel component)
- (setq toplevel-closure t)))
+ (pre-physenv-analyze-toplevel component))
(dolist (component components)
(compile-component component)
- (when (replace-toplevel-xeps component)
- (setq toplevel-closure t)))
+ (replace-toplevel-xeps component))
(when *check-consistency*
(maybe-mumble "[check]~%")
(if load-time-value-p
(compile-load-time-value-lambda lambdas)
- (compile-toplevel-lambdas lambdas toplevel-closure))
+ (compile-toplevel-lambdas lambdas))
(mapc #'clear-ir1-info components)
(clear-stuff)))
;;; compilation.
(defun finish-block-compilation ()
(when *block-compile*
+ (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)
(declare (type source-info info))
- (let* ((*block-compile* *block-compile-arg*)
- (*package* (sane-package))
- (*policy* *policy*)
- (*lexenv* (make-null-lexenv))
- (*source-info* info)
- (sb!xc:*compile-file-pathname* nil)
- (sb!xc:*compile-file-truename* nil)
- (*toplevel-lambdas* ())
- (*pending-toplevel-lambdas* ())
- (*compiler-error-bailout*
- (lambda ()
- (compiler-mumble "~2&; fatal error, aborting compilation~%")
- (return-from sub-compile-file (values nil t t))))
- (*current-path* nil)
- (*last-source-context* nil)
- (*last-original-source* nil)
- (*last-source-form* nil)
- (*last-format-string* nil)
- (*last-format-args* nil)
- (*last-message-count* 0)
- ;; FIXME: Do we need this rebinding here? It's a literal
- ;; translation of the old CMU CL rebinding to
- ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*),
- ;; and it's not obvious whether the rebinding to itself is
- ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
- (*info-environment* *info-environment*)
- (*gensym-counter* 0))
+ (let ((*package* (sane-package))
+ (*readtable* *readtable*)
+ (sb!xc:*compile-file-pathname* nil) ; really bound in
+ (sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE
+ (*policy* *policy*)
+ (*handled-conditions* *handled-conditions*)
+ (*disabled-package-locks* *disabled-package-locks*)
+ (*lexenv* (make-null-lexenv))
+ (*block-compile* *block-compile-arg*)
+ (*source-info* info)
+ (*toplevel-lambdas* ())
+ (*fun-names-in-this-file* ())
+ (*allow-instrumenting* nil)
+ (*compiler-error-bailout*
+ (lambda ()
+ (compiler-mumble "~2&; fatal error, aborting compilation~%")
+ (return-from sub-compile-file (values nil t t))))
+ (*current-path* nil)
+ (*last-source-context* nil)
+ (*last-original-source* nil)
+ (*last-source-form* nil)
+ (*last-format-string* nil)
+ (*last-format-args* nil)
+ (*last-message-count* 0)
+ ;; FIXME: Do we need this rebinding here? It's a literal
+ ;; translation of the old CMU CL rebinding to
+ ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*),
+ ;; and it's not obvious whether the rebinding to itself is
+ ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
+ (*info-environment* *info-environment*)
+ (*gensym-counter* 0))
(handler-case
- (with-compilation-values
- (sb!xc:with-compilation-unit ()
- (clear-stuff)
-
- (sub-sub-compile-file info)
-
- (finish-block-compilation)
- (compile-toplevel-lambdas () t)
- (let ((object *compile-object*))
- (etypecase object
- (fasl-output (fasl-dump-source-info info object))
- (core-object (fix-core-source-info info object))
- (null)))
- nil))
+ (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
+ (with-compilation-values
+ (sb!xc:with-compilation-unit ()
+ (clear-stuff)
+
+ (sub-sub-compile-file info)
+
+ (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.
- (input-error-in-compile-file (condition)
- (format *error-output*
- "~@<compilation aborted because of input error: ~2I~_~A~:>"
- condition)
+ (fatal-compiler-error (condition)
+ (signal condition)
+ (when *compile-verbose*
+ (format *standard-output*
+ "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
+ condition))
(values nil t t)))))
;;; Return a pathname for the named file. The file must exist.
(format nil "~D:~2,'0D:~2,'0D" thr min sec))))
;;; 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))
(let ((file-info (source-info-file-info source-info)))
(compiler-mumble "~&; compiling file ~S (written ~A):~%"
: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
;; extensions
(trace-file nil)
((:block-compile *block-compile-arg*) nil))
-
#!+sb-doc
- "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.
- 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."))
+ "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)"
+;;; 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)
(output-file-name nil)
(compile-won nil)
(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))
+ (source-info (make-file-source-info input-pathname external-format))
(*compiler-trace-output* nil)) ; might be modified below
-
+
(unwind-protect
(progn
(when output-file
:direction :output))))
(when sb!xc:*compile-verbose*
- (start-error-output source-info))
+ (print-compile-start-note source-info))
(let ((*compile-object* fasl-output)
dummy)
(multiple-value-setq (dummy warnings-p failure-p)
(compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
(when sb!xc:*compile-verbose*
- (finish-error-output source-info compile-won))
+ (print-compile-end-note source-info compile-won))
(when *compiler-trace-output*
(close *compiler-trace-output*)))
#!+sb-doc
"Return a pathname describing what file COMPILE-FILE would write to given
these arguments."
- (pathname output-file))
+ (merge-pathnames output-file (merge-pathnames input-file)))
\f
;;;; MAKE-LOAD-FORM stuff
(throw 'pending-init circular-ref)))
(multiple-value-bind (creation-form init-form)
(handler-case
- (sb!xc:make-load-form constant (make-null-lexenv))
+ (sb!xc:make-load-form constant (make-null-lexenv))
(error (condition)
- (compiler-error "(while making load form for ~S)~%~A"
- constant
- condition)))
+ (compiler-error condition)))
(case creation-form
(:sb-just-dump-it-normally
(fasl-validate-structure constant *compile-object*)
(:ignore-it
nil)
(t
- (compile-toplevel-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))))
+ (let* ((name (write-to-string constant :level 1 :length 2))
(info (if init-form
(list constant name init-form)
(list constant))))
(when circular-ref
(setf (cdr circular-ref)
(append (cdr circular-ref) (cdr info))))))))))))
+
+\f
+;;;; 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-in-lexenv (form lexenv)
+ (declare (ignore lexenv))
+ (eval form))
projects / sbcl.git / blobdiff