#!+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 *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)
;;; normally causes nested uses to be no-ops).
(defvar *in-compilation-unit* nil)
-;;; This lock is siezed in the same situation: the compiler is not
-;;; presently thread-safe
-(defvar *big-compiler-lock*
- (sb!thread:make-mutex :name "big compiler lock"))
-
;;; Count of the number of compilation units dynamically enclosed by
;;; the current active WITH-COMPILATION-UNIT that were unwound out of.
(defvar *aborted-compilation-unit-count*)
(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)
(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
;;; error counts. ABORT-P should be true when the compilation unit was
(undefined-warning-count (undefined-warning-count undef)))
(dolist (*compiler-error-context* warnings)
(if #-sb-xc-host (and (eq kind :function)
- (symbolp name) ; FIXME: (SETF CL:fo)
- (eq (symbol-package name) *cl-package*)
+ (fun-name-reserved-by-ansi-p name)
*flame-on-necessarily-undefined-function*)
#+sb-xc-host nil
- (compiler-warn "undefined ~(~A~): ~S" kind name)
- (compiler-style-warn "undefined ~(~A~): ~S" kind name)))
+ (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*)
(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
(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))))))
(ir1-phases component)
+ (when *loop-analyze*
+ (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)
(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*)
;;; 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 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
(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.
;;; *TOPLEVEL-LAMBDAS* instead.
(defun convert-and-maybe-compile (form path)
(declare (list path))
- (let* ((*lexenv* (make-lexenv :policy *policy*))
+ (let* ((*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)))))
;;; We parse declarations and then recursively process the body.
(defun process-toplevel-locally (body path compile-time-too &key vars funs)
(declare (list path))
- (multiple-value-bind (forms decls) (parse-body body nil)
- (let* ((*lexenv*
- (process-decls decls vars funs (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
(setf (component-name component)
(debug-namify "~S initial component" name))
(setf (component-kind component) :initial)
- (let* ((locall-fun (ir1-convert-lambdalike
- definition
- :debug-name (debug-namify "top level local call ~S"
- name)
- ;; KLUDGE: we do this so that we get to have
- ;; nice debug returnness in functions defined
- ;; from the REPL
- :allow-debug-catch-tag t))
+ (let* ((locall-fun (let ((*allow-instrumenting* t))
+ (ir1-convert-lambdalike
+ definition
+ :debug-name (debug-namify "top level local call "
+ name))))
(fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
:source-name (or name '.anonymous.)
:debug-name (unless name
'(original-source-start 0 0)))
(when name
(legal-fun-name-or-type-error name))
- (let* ((*lexenv* (make-lexenv :policy *policy*))
+ (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)))
(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 'simple-program-error
- :format-control "execution of a form compiled with errors:~% ~S"
- :format-arguments (list ',form))
+ (make-compiler-error-form condition form)
path)
(throw 'process-toplevel-form-error-abort nil))))
((macrolet)
(funcall-in-macrolet-lexenv
magic
- (lambda (&key funs)
+ (lambda (&key funs prepend)
(declare (ignore funs))
+ (aver (null prepend))
(process-toplevel-locally body
path
- compile-time-too))))
+ compile-time-too))
+ :compile))
((symbol-macrolet)
(funcall-in-symbol-macrolet-lexenv
magic
- (lambda (&key vars)
+ (lambda (&key vars prepend)
+ (aver (null prepend))
(process-toplevel-locally body
path
compile-time-too
- :vars vars)))))))
+ :vars vars))
+ :compile)))))
((locally)
(process-toplevel-locally (rest form) path compile-time-too))
((progn)
(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* ())
- (*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)
- (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)
+ (fatal-compiler-error (condition)
+ (signal condition)
(format *error-output*
- "~@<compilation aborted because of input error: ~2I~_~A~:>"
+ "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
condition)
(values nil t t)))))
(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*)