*lexenv* *fun-names-in-this-file*
*allow-instrumenting*))
-;;; Whether call of a function which cannot be defined causes a full
+;;; Whether reference to a thing which cannot be defined causes a full
;;; warning.
-(defvar *flame-on-necessarily-undefined-function* nil)
+(defvar *flame-on-necessarily-undefined-thing* nil)
(defvar *check-consistency* nil)
(defvar *compile-object* nil)
(declaim (type object *compile-object*))
+(defvar *compile-toplevel-object* nil)
+
+(defvar *emit-cfasl* nil)
(defvar *fopcompile-label-counter*)
(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*))
+;;; Is NAME something that no conforming program can rely on
+;;; defining?
+(defun name-reserved-by-ansi-p (name kind)
+ (ecase kind
+ (:function
+ (eq (symbol-package (fun-name-block-name name))
+ *cl-package*))
+ (:type
+ (let ((symbol (typecase name
+ (symbol name)
+ ((cons symbol) (car name))
+ (t (return-from name-reserved-by-ansi-p nil)))))
+ (eq (symbol-package symbol) *cl-package*)))))
;;; This is to be called at the end of a compilation unit. It signals
;;; any residual warnings about unknown stuff, then prints the total
;;; aborted by throwing out. ABORT-COUNT is the number of dynamically
;;; enclosed nested compilation units that were aborted.
(defun summarize-compilation-unit (abort-p)
- (unless abort-p
- (handler-bind ((style-warning #'compiler-style-warning-handler)
- (warning #'compiler-warning-handler))
-
- (let ((undefs (sort *undefined-warnings* #'string<
- :key (lambda (x)
- (let ((x (undefined-warning-name x)))
- (if (symbolp x)
- (symbol-name x)
- (prin1-to-string x)))))))
- (dolist (undef undefs)
- (let ((name (undefined-warning-name undef))
- (kind (undefined-warning-kind undef))
- (warnings (undefined-warning-warnings undef))
- (undefined-warning-count (undefined-warning-count undef)))
- (dolist (*compiler-error-context* warnings)
- (if #-sb-xc-host (and (eq kind :function)
- (fun-name-reserved-by-ansi-p name)
- *flame-on-necessarily-undefined-function*)
- #+sb-xc-host nil
- (case name
- ((declare)
- (compiler-warn
- "~@<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)))
- (if (eq kind :variable)
- (compiler-warn
- "~W more use~:P of undefined ~(~A~) ~S"
- more kind name)
- (compiler-style-warn
- "~W more use~:P of undefined ~(~A~) ~S"
- more kind name)))))))
-
- (dolist (kind '(:variable :function :type))
- (let ((summary (mapcar #'undefined-warning-name
- (remove kind undefs :test #'neq
- :key #'undefined-warning-kind))))
- (when summary
- (if (eq kind :variable)
- (compiler-warn
- "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
- ~% ~{~<~% ~1:;~S~>~^ ~}"
- (cdr summary) kind summary)
- (compiler-style-warn
- "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
- ~% ~{~<~% ~1:;~S~>~^ ~}"
- (cdr summary) kind summary))))))))
-
- (unless (and (not abort-p)
- (zerop *aborted-compilation-unit-count*)
- (zerop *compiler-error-count*)
- (zerop *compiler-warning-count*)
- (zerop *compiler-style-warning-count*)
- (zerop *compiler-note-count*))
- (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
- (format *error-output* "~&compilation unit ~:[finished~;aborted~]~
- ~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~
- ~[~:;~:*~& caught ~W ERROR condition~:P~]~
- ~[~:;~:*~& caught ~W WARNING condition~:P~]~
- ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~
- ~[~:;~:*~& printed ~W note~:P~]"
- abort-p
- *aborted-compilation-unit-count*
- *compiler-error-count*
- *compiler-warning-count*
- *compiler-style-warning-count*
- *compiler-note-count*))
- (terpri *error-output*)
- (force-output *error-output*)))
+ (let (summary)
+ (unless abort-p
+ (handler-bind ((style-warning #'compiler-style-warning-handler)
+ (warning #'compiler-warning-handler))
+
+ (let ((undefs (sort *undefined-warnings* #'string<
+ :key (lambda (x)
+ (let ((x (undefined-warning-name x)))
+ (if (symbolp x)
+ (symbol-name x)
+ (prin1-to-string x)))))))
+ (dolist (kind '(:variable :function :type))
+ (let ((names (mapcar #'undefined-warning-name
+ (remove kind undefs :test #'neq
+ :key #'undefined-warning-kind))))
+ (when names (push (cons kind names) summary))))
+ (dolist (undef undefs)
+ (let ((name (undefined-warning-name undef))
+ (kind (undefined-warning-kind undef))
+ (warnings (undefined-warning-warnings undef))
+ (undefined-warning-count (undefined-warning-count undef)))
+ (dolist (*compiler-error-context* warnings)
+ (if #-sb-xc-host (and (member kind '(:function :type))
+ (name-reserved-by-ansi-p name kind)
+ *flame-on-necessarily-undefined-thing*)
+ #+sb-xc-host nil
+ (ecase kind
+ (:function
+ (case name
+ ((declare)
+ (compiler-warn
+ "~@<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 function ~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.~:@>" name))))
+ (:type
+ (if (and (consp name) (eq 'quote (car name)))
+ (compiler-warn
+ "~@<Undefined type ~S. The name starts with ~S: ~
+ probably use of a quoted type name in a context ~
+ where the name is not evaluated.~:@>"
+ name 'quote)
+ (compiler-warn
+ "~@<Undefined type ~S. Note that name ~S is ~
+ reserved by ANSI CL, so code defining a type with ~
+ that name would not be portable.~:@>" name
+ name))))
+ (if (eq kind :variable)
+ (compiler-warn "undefined ~(~A~): ~S" kind name)
+ (compiler-style-warn "undefined ~(~A~): ~S" kind name))))
+ (let ((warn-count (length warnings)))
+ (when (and warnings (> undefined-warning-count warn-count))
+ (let ((more (- undefined-warning-count warn-count)))
+ (if (eq kind :variable)
+ (compiler-warn
+ "~W more use~:P of undefined ~(~A~) ~S"
+ more kind name)
+ (compiler-style-warn
+ "~W more use~:P of undefined ~(~A~) ~S"
+ more kind name))))))))))
+
+ (unless (and (not abort-p)
+ (zerop *aborted-compilation-unit-count*)
+ (zerop *compiler-error-count*)
+ (zerop *compiler-warning-count*)
+ (zerop *compiler-style-warning-count*)
+ (zerop *compiler-note-count*))
+ (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+ (format *error-output* "~&compilation unit ~:[finished~;aborted~]"
+ abort-p)
+ (dolist (cell summary)
+ (destructuring-bind (kind &rest names) cell
+ (format *error-output*
+ "~& Undefined ~(~A~)~p:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
+ kind (length names) names)))
+ (format *error-output* "~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~
+ ~[~:;~:*~& caught ~W ERROR condition~:P~]~
+ ~[~:;~:*~& caught ~W WARNING condition~:P~]~
+ ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~
+ ~[~:;~:*~& printed ~W note~:P~]"
+ *aborted-compilation-unit-count*
+ *compiler-error-count*
+ *compiler-warning-count*
+ *compiler-style-warning-count*
+ *compiler-note-count*))
+ (terpri *error-output*)
+ (force-output *error-output*))))
;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
;;; FAILURE-P), where BODY-VALUE is the first value of the body, and
(defun %compile-component (component)
(let ((*code-segment* nil)
- (*elsewhere* nil))
+ (*elsewhere* nil)
+ #!+inline-constants
+ (*constant-segment* nil)
+ #!+inline-constants
+ (*constant-table* nil)
+ #!+inline-constants
+ (*constant-vector* nil))
(maybe-mumble "GTN ")
(gtn-analyze component)
(maybe-mumble "LTN ")
(maybe-mumble "copy ")
(copy-propagate component))
+ (ir2-optimize component)
+
(select-representations component)
(when *check-consistency*
(print-unreadable-object (s stream :type t))))
(:copier nil))
;; the UT that compilation started at
- (start-time (get-internal-real-time) :type unsigned-byte)
+ (start-time (get-universal-time) :type unsigned-byte)
+ ;; the IRT that compilation started at
+ (start-real-time (get-internal-real-time) :type unsigned-byte)
;; the FILE-INFO structure for this compilation
(file-info nil :type (or file-info null))
;; the stream that we are using to read the FILE-INFO, or NIL if
;;; error condition (possibly recording some extra location
;;; information).
(defun read-for-compile-file (stream position)
- (handler-case (read stream nil stream)
+ (handler-case
+ (read-preserving-whitespace stream nil stream)
(reader-error (condition)
(error 'input-error-in-compile-file
:condition condition
(t
*top-level-form-noted*))))
+;;; Handle the evaluation the a :COMPILE-TOPLEVEL body during
+;;; compilation. Normally just evaluate in the appropriate
+;;; environment, but also compile if outputting a CFASL.
+(defun eval-compile-toplevel (body path)
+ (eval-in-lexenv `(progn ,@body) *lexenv*)
+ (when *compile-toplevel-object*
+ (let ((*compile-object* *compile-toplevel-object*))
+ (convert-and-maybe-compile `(progn ,@body) path))))
+
;;; Process a top level FORM with the specified source PATH.
;;; * If this is a magic top level form, then do stuff.
;;; * If this is a macro, then expand it.
(catch 'process-toplevel-form-error-abort
(let* ((path (or (get-source-path form) (cons form path)))
+ (*current-path* path)
(*compiler-error-bailout*
(lambda (&optional condition)
(convert-and-maybe-compile
;; sequence of steps in ANSI's "3.2.3.1 Processing of
;; Top Level Forms".
#-sb-xc-host
- (let ((expanded
- (let ((*current-path* path))
- (preprocessor-macroexpand-1 form))))
+ (let ((expanded (preprocessor-macroexpand-1 form)))
(cond ((eq expanded form)
(when compile-time-too
- (eval-in-lexenv form *lexenv*))
+ (eval-compile-toplevel (list form) path))
(convert-and-maybe-compile form path))
(t
(process-toplevel-form expanded
e))))
(cond (lt (process-toplevel-progn
body path new-compile-time-too))
- (new-compile-time-too (eval-in-lexenv
- `(progn ,@body)
- *lexenv*))))))
+ (new-compile-time-too
+ (eval-compile-toplevel body path))))))
((macrolet)
(funcall-in-macrolet-lexenv
magic
;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
(*info-environment* *info-environment*)
(*compiler-sset-counter* 0)
- (*gensym-counter* 0))
+ (sb!xc:*gensym-counter* 0))
(handler-case
(handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
(with-compilation-values
won
(elapsed-time-to-string
(- (get-internal-real-time)
- (source-info-start-time source-info))))
+ (source-info-start-real-time source-info))))
(values))
;;; Open some files and call SUB-COMPILE-FILE. If something unwinds
;; extensions
(trace-file nil)
- ((:block-compile *block-compile-arg*) nil))
+ ((:block-compile *block-compile-arg*) nil)
+ (emit-cfasl *emit-cfasl*))
#!+sb-doc
"Compile INPUT-FILE, producing a corresponding fasl file and
returning its filename.
:TRACE-FILE
If given, internal data structures are dumped to the specified
file, or if a value of T is given, to a file of *.trace type
- derived from the input file name. (non-standard)"
+ derived from the input file name. (non-standard)
+
+ :EMIT-CFASL
+ (Experimental). If true, outputs the toplevel compile-time effects
+ of this file into a separate .cfasl file."
;;; Block compilation is currently broken.
#|
"Also, as a workaround for vaguely-non-ANSI behavior, the
:BLOCK-COMPILE argument will probably become deprecated."
|#
(let* ((fasl-output nil)
+ (cfasl-output nil)
(output-file-name nil)
+ (coutput-file-name nil)
(abort-p t)
(warnings-p nil)
(failure-p t) ; T in case error keeps this from being set later
(setq fasl-output
(open-fasl-output output-file-name
(namestring input-pathname))))
+ (when emit-cfasl
+ (setq coutput-file-name
+ (make-pathname :type "cfasl"
+ :defaults output-file-name))
+ (setq cfasl-output
+ (open-fasl-output coutput-file-name
+ (namestring input-pathname))))
(when trace-file
(let* ((default-trace-file-pathname
(make-pathname :type "trace" :defaults input-pathname))
(when sb!xc:*compile-verbose*
(print-compile-start-note source-info))
- (let ((*compile-object* fasl-output))
+ (let ((*compile-object* fasl-output)
+ (*compile-toplevel-object* cfasl-output))
(setf (values abort-p warnings-p failure-p)
(sub-compile-file source-info))))
(when (and (not abort-p) sb!xc:*compile-verbose*)
(compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
+ (when cfasl-output
+ (close-fasl-output cfasl-output abort-p)
+ (when (and (not abort-p) sb!xc:*compile-verbose*)
+ (compiler-mumble "; ~A written~%" (namestring coutput-file-name))))
+
(when sb!xc:*compile-verbose*
(print-compile-end-note source-info (not abort-p)))
projects / sbcl.git / blobdiff