*last-source-form* *last-format-string* *last-format-args*
*last-message-count* *lexenv*))
+;;; 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*)
;;; 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*)
`(%with-compilation-unit (lambda () ,@body) ,@options))
(defun %with-compilation-unit (fn &key override)
+ (declare (type function fn))
(let ((succeeded-p nil))
(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
(*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)))))))))
;;; 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)
+ (symbolp name) ; FIXME: (SETF CL:fo)
+ (eq (symbol-package name) *cl-package*)
+ *flame-on-necessarily-undefined-function*)
+ #+sb-xc-host nil
+ (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))))))
-
+
(dolist (kind '(:variable :function :type))
(let ((summary (mapcar #'undefined-warning-name
(remove kind undefs :test-not #'eq
;;; 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) (parse-body body nil)
(let* ((*lexenv*
- (process-decls decls nil nil (make-continuation)))
+ (process-decls decls vars funs (make-continuation)))
;; 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
(setf (component-name component)
(debug-namify "~S 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 (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))
(fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
:source-name (or name '.anonymous.)
:debug-name (unless name
"top level form"))))
+ (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)
(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)
compile-time-too))))))
(if (atom form)
#+sb-xc-host
- ;; (There are no EVAL-WHEN issues in the ATOM case until
- ;; SBCL gets smart enough to handle global
- ;; DEFINE-SYMBOL-MACRO or SYMBOL-MACROLET.)
+ ;; (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)
((macrolet)
(funcall-in-macrolet-lexenv
magic
- (lambda ()
+ (lambda (&key funs)
+ (declare (ignore funs))
(process-toplevel-locally body
path
compile-time-too))))
((symbol-macrolet)
(funcall-in-symbol-macrolet-lexenv
magic
- (lambda ()
+ (lambda (&key vars)
(process-toplevel-locally body
path
- compile-time-too)))))))
+ compile-time-too
+ :vars vars)))))))
((locally)
(process-toplevel-locally (rest form) path compile-time-too))
((progn)
\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))
(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)))
(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~%")
(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))
(input-pathname (verify-source-file input-file))
(source-info (make-file-source-info input-pathname))
(*compiler-trace-output* nil)) ; might be modified below
-
+
(unwind-protect
(progn
(when output-file
(: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))
projects / sbcl.git / blobdiff