*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)
(*compiler-note-count* 0)
(*undefined-warnings* nil)
(*in-compilation-unit* t))
- (sb!thread:with-recursive-lock (*big-compiler-lock*)
+ (with-world-lock ()
(handler-bind ((parse-unknown-type
(lambda (c)
(note-undefined-reference
(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 ir1-phases (component)
(declare (type component component))
(aver-live-component component)
- (let ((*constraint-number* 0)
+ (let ((*constraint-universe* (make-array 64 ; arbitrary, but don't
+ ;make this 0.
+ :fill-pointer 0 :adjustable t))
(loop-count 1)
(*delayed-ir1-transforms* nil))
- (declare (special *constraint-number* *delayed-ir1-transforms*))
+ (declare (special *constraint-universe* *delayed-ir1-transforms*))
(loop
(ir1-optimize-until-done component)
(when (or (component-new-functionals component)
(maybe-mumble "copy ")
(copy-propagate component))
+ (ir2-optimize component)
+
(select-representations component)
(when *check-consistency*
;;; A FILE-INFO structure holds all the source information for a
;;; given file.
-(def!struct (file-info (:copier nil))
+(def!struct (file-info
+ (:copier nil)
+ #-no-ansi-print-object
+ (:print-object (lambda (s stream)
+ (print-unreadable-object (s stream :type t)
+ (princ (file-info-name s) stream)))))
;; If a file, the truename of the corresponding source file. If from
;; a Lisp form, :LISP. If from a stream, :STREAM.
- (name (missing-arg) :type (or pathname (member :lisp :stream)))
+ (name (missing-arg) :type (or pathname (eql :lisp)))
;; the external format that we'll call OPEN with, if NAME is a file.
(external-format nil)
;; the defaulted, but not necessarily absolute file name (i.e. prior
(print-unreadable-object (s stream :type t))))
(:copier nil))
;; the UT that compilation started at
- (start-time (get-universal-time) :type unsigned-byte)
+ (start-time (get-internal-real-time) :type unsigned-byte)
;; the FILE-INFO structure for this compilation
(file-info nil :type (or file-info null))
;; the stream that we are using to read the FILE-INFO, or NIL if
;; no stream has been opened yet
- (stream nil :type (or stream null)))
+ (stream nil :type (or stream null))
+ ;; if the current compilation is recursive (e.g., due to EVAL-WHEN
+ ;; processing at compile-time), the invoking compilation's
+ ;; source-info.
+ (parent nil :type (or source-info null)))
;;; Given a pathname, return a SOURCE-INFO structure.
(defun make-file-source-info (file external-format)
- (let ((file-info (make-file-info :name (truename file)
- :untruename (merge-pathnames file)
- :external-format external-format
- :write-date (file-write-date file))))
-
- (make-source-info :file-info file-info)))
+ (make-source-info
+ :file-info (make-file-info :name (truename file)
+ :untruename (merge-pathnames file)
+ :external-format external-format
+ :write-date (file-write-date file))))
;;; Return a SOURCE-INFO to describe the incremental compilation of FORM.
-(defun make-lisp-source-info (form)
- (make-source-info :start-time (get-universal-time)
- :file-info (make-file-info :name :lisp
- :forms (vector form)
- :positions '#(0))))
-
-;;; Return a SOURCE-INFO which will read from STREAM.
-(defun make-stream-source-info (stream)
- (let ((file-info (make-file-info :name :stream)))
- (make-source-info :file-info file-info
- :stream stream)))
+(defun make-lisp-source-info (form &key parent)
+ (make-source-info
+ :file-info (make-file-info :name :lisp
+ :forms (vector form)
+ :positions '#(0))
+ :parent parent))
+
+;;; Walk up the SOURCE-INFO list until we either reach a SOURCE-INFO
+;;; with no parent (e.g., from a REPL evaluation) or until we reach a
+;;; SOURCE-INFO whose FILE-INFO denotes a file.
+(defun get-toplevelish-file-info (&optional (source-info *source-info*))
+ (if source-info
+ (do* ((sinfo source-info (source-info-parent sinfo))
+ (finfo (source-info-file-info sinfo)
+ (source-info-file-info sinfo)))
+ ((or (not (source-info-p (source-info-parent sinfo)))
+ (pathnamep (file-info-name finfo)))
+ finfo))))
;;; Return a form read from STREAM; or for EOF use the trick,
;;; popularized by Kent Pitman, of returning STREAM itself. If an
;;; error 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
(setf (source-info-stream info) nil)
(values))
+;;; Loop over FORMS retrieved from INFO. Used by COMPILE-FILE and
+;;; LOAD when loading from a FILE-STREAM associated with a source
+;;; file.
+(defmacro do-forms-from-info (((form &rest keys) info)
+ &body body)
+ (aver (symbolp form))
+ (once-only ((info info))
+ `(let ((*source-info* ,info))
+ (loop (destructuring-bind (,form &key ,@keys &allow-other-keys)
+ (let* ((file-info (source-info-file-info ,info))
+ (stream (get-source-stream ,info))
+ (pos (file-position stream))
+ (form (read-for-compile-file stream pos)))
+ (if (eq form stream) ; i.e., if EOF
+ (return)
+ (let* ((forms (file-info-forms file-info))
+ (current-idx (+ (fill-pointer forms)
+ (file-info-source-root
+ file-info))))
+ (vector-push-extend form forms)
+ (vector-push-extend pos (file-info-positions
+ file-info))
+ (list form :current-index current-idx))))
+ ,@body)))))
+
;;; Read and compile the source file.
(defun sub-sub-compile-file (info)
- (let* ((file-info (source-info-file-info info))
- (stream (get-source-stream info)))
- (loop
- (let* ((pos (file-position stream))
- (form (read-for-compile-file stream pos)))
- (if (eq form stream) ; i.e., if EOF
- (return)
- (let* ((forms (file-info-forms file-info))
- (current-idx (+ (fill-pointer forms)
- (file-info-source-root file-info))))
- (vector-push-extend form forms)
- (vector-push-extend pos (file-info-positions file-info))
- (find-source-paths form current-idx)
- (process-toplevel-form form
- `(original-source-start 0 ,current-idx)
- nil)))))))
+ (do-forms-from-info ((form current-index) info)
+ (find-source-paths form current-index)
+ (process-toplevel-form
+ form `(original-source-start 0 ,current-index) nil)))
;;; Return the INDEX'th source form read from INFO and the position
;;; where it was read.
(maybe-frob (optional-dispatch-main-entry f)))
result))))
-(defun make-functional-from-toplevel-lambda (definition
+(defun make-functional-from-toplevel-lambda (lambda-expression
&key
name
(path
(missing-arg)))
(let* ((*current-path* path)
(component (make-empty-component))
- (*current-component* component))
- (setf (component-name component)
- (debug-name 'initial-component name))
- (setf (component-kind component) :initial)
+ (*current-component* component)
+ (debug-name-tail (or name (name-lambdalike lambda-expression)))
+ (source-name (or name '.anonymous.)))
+ (setf (component-name component) (debug-name 'initial-component debug-name-tail)
+ (component-kind component) :initial)
(let* ((locall-fun (let ((*allow-instrumenting* t))
(funcall #'ir1-convert-lambdalike
- definition
- :source-name name)))
- (debug-name (debug-name 'tl-xep
- (or name
- (functional-%source-name locall-fun))))
+ lambda-expression
+ :source-name source-name)))
;; Convert the XEP using the policy of the real
;; function. Otherwise the wrong policy will be used for
;; deciding whether to type-check the parameters of the
(*lexenv* (make-lexenv :policy (lexenv-policy
(functional-lexenv locall-fun))))
(fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
- :source-name (or name '.anonymous.)
- :debug-name debug-name)))
+ :source-name source-name
+ :debug-name (debug-name 'tl-xep debug-name-tail)
+ :system-lambda t)))
(when name
(assert-global-function-definition-type name locall-fun))
(setf (functional-entry-fun fun) locall-fun
(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*))
(*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)
;; 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
((try-with-type pathname "lisp" nil))
((try-with-type pathname "lisp" t))))))
-(defun elapsed-time-to-string (tsec)
- (multiple-value-bind (tmin sec) (truncate tsec 60)
- (multiple-value-bind (thr min) (truncate tmin 60)
- (format nil "~D:~2,'0D:~2,'0D" thr min sec))))
+(defun elapsed-time-to-string (internal-time-delta)
+ (multiple-value-bind (tsec remainder)
+ (truncate internal-time-delta internal-time-units-per-second)
+ (let ((ms (truncate remainder (/ internal-time-units-per-second 1000))))
+ (multiple-value-bind (tmin sec) (truncate tsec 60)
+ (multiple-value-bind (thr min) (truncate tmin 60)
+ (format nil "~D:~2,'0D:~2,'0D.~3,'0D" thr min sec ms))))))
;;; Print some junk at the beginning and end of compilation.
(defun print-compile-start-note (source-info)
(compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&"
won
(elapsed-time-to-string
- (- (get-universal-time)
+ (- (get-internal-real-time)
(source-info-start-time source-info))))
(values))
|#
(let* ((fasl-output nil)
(output-file-name nil)
- (abort-p nil)
+ (abort-p t)
(warnings-p nil)
(failure-p t) ; T in case error keeps this from being set later
(input-pathname (verify-source-file input-file))
(defvar *constants-being-created* nil)
(defvar *constants-created-since-last-init* nil)
;;; FIXME: Shouldn't these^ variables be unbound outside LET forms?
-(defun emit-make-load-form (constant)
+(defun emit-make-load-form (constant &optional (name nil namep))
(aver (fasl-output-p *compile-object*))
(unless (or (fasl-constant-already-dumped-p constant *compile-object*)
;; KLUDGE: This special hack is because I was too lazy
(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 condition)))
+ (if namep
+ ;; If the constant is a reference to a named constant, we can
+ ;; just use SYMBOL-VALUE during LOAD.
+ (values `(symbol-value ',name) nil)
+ (handler-case
+ (sb!xc:make-load-form constant (make-null-lexenv))
+ (error (condition)
+ (compiler-error condition))))
(case creation-form
(:sb-just-dump-it-normally
(fasl-validate-structure constant *compile-object*)
projects / sbcl.git / blobdiff