;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
(declaim (special *constants* *free-vars* *component-being-compiled*
- *code-vector* *next-location* *result-fixups*
*free-funs* *source-paths*
- *seen-blocks* *seen-funs* *list-conflicts-table*
*continuation-number* *continuation-numbers*
*number-continuations* *tn-id* *tn-ids* *id-tns*
*label-ids* *label-id* *id-labels*
(defmacro sb!xc:with-compilation-unit (options &body body)
#!+sb-doc
- "WITH-COMPILATION-UNIT ({Key Value}*) Form*
- 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.
-
- :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."
+ "Affects compilations that take place within its dynamic extent. It is
+intended to be eg. wrapped around the compilation of all files in the same system.
+
+Following options 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.
+
+ :POLICY Optimize-Declaration-Form
+ Provides dynamic scoping for global compiler optimization qualities and
+ restrictions, limiting effects of subsequent OPTIMIZE proclamations and
+ calls to SB-EXT:RESTRICT-COMPILER-POLICY to the dynamic scope of BODY.
+
+ If OVERRIDE is false, specified POLICY is merged with current global
+ policy. If OVERRIDE is true, current global policy, including any
+ restrictions, is discarded in favor of the specified POLICY.
+
+ Supplying POLICY NIL is equivalent to the option not being supplied at
+ all, ie. dynamic scoping of policy does not take place.
+
+ This option is an SBCL-specific experimental extension: Interface
+ subject to change.
+
+ :SOURCE-NAMESTRING Namestring-Form
+ Attaches the value returned by the Namestring-Form to the internal
+ debug-source information as the namestring of the source file. Normally
+ the namestring of the input-file for COMPILE-FILE is used: this option
+ can be used to provide source-file information for functions compiled
+ using COMPILE, or to override the input-file of COMPILE-FILE.
+
+ If both an outer and an inner WITH-COMPILATION-UNIT provide a
+ SOURCE-NAMESTRING, the inner one takes precedence. Unaffected
+ by :OVERRIDE.
+
+ This is an SBCL-specific extension.
+
+ :SOURCE-PLIST Plist-Form
+ Attaches the value returned by the Plist-Form to internal debug-source
+ information of functions compiled in within the dynamic extent of BODY.
+
+ Primarily for use by development environments, in order to eg. associate
+ function definitions with editor-buffers. Can be accessed using
+ SB-INTROSPECT:DEFINITION-SOURCE-PLIST.
+
+ If an outer WITH-COMPILATION-UNIT form also provide a SOURCE-PLIST, it
+ is appended to the end of the provided SOURCE-PLIST. Unaffected
+ by :OVERRIDE.
+
+ This is an SBCL-specific extension.
+
+Examples:
+
+ ;; Prevent proclamations from the file leaking, and restrict
+ ;; SAFETY to 3 -- otherwise uses the current global policy.
+ (with-compilation-unit (:policy '(optimize))
+ (restrict-compiler-policy 'safety 3)
+ (load \"foo.lisp\"))
+
+ ;; Using default policy instead of the current global one,
+ ;; except for DEBUG 3.
+ (with-compilation-unit (:policy '(optimize debug)
+ :override t)
+ (load \"foo.lisp\"))
+
+ ;; Same as if :POLICY had not been specified at all: SAFETY 3
+ ;; proclamation leaks out from WITH-COMPILATION-UNIT.
+ (with-compilation-unit (:policy nil)
+ (declaim (optimize safety))
+ (load \"foo.lisp\"))
+"
`(%with-compilation-unit (lambda () ,@body) ,@options))
(defvar *source-plist* nil)
+(defvar *source-namestring* nil)
-(defun %with-compilation-unit (fn &key override source-plist)
+(defun %with-compilation-unit (fn &key override policy source-plist source-namestring)
(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))
- (unless succeeded-p
- (incf *aborted-compilation-unit-count*)))
- (let ((*aborted-compilation-unit-count* 0)
- (*compiler-error-count* 0)
- (*compiler-warning-count* 0)
- (*compiler-style-warning-count* 0)
- (*compiler-note-count* 0)
- (*undefined-warnings* nil)
- (*in-compilation-unit* t))
- (with-world-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)))))))))
+ (flet ((with-it ()
+ (let ((succeeded-p nil)
+ (*source-plist* (append source-plist *source-plist*))
+ (*source-namestring* (or source-namestring *source-namestring*)))
+ (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))
+ (unless succeeded-p
+ (incf *aborted-compilation-unit-count*)))
+ (let ((*aborted-compilation-unit-count* 0)
+ (*compiler-error-count* 0)
+ (*compiler-warning-count* 0)
+ (*compiler-style-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)))))))))
+ (if policy
+ (let ((*policy* (process-optimize-decl policy (unless override *policy*)))
+ (*policy-restrictions* (unless override *policy-restrictions*)))
+ (with-it))
+ (with-it))))
;;; Is NAME something that no conforming program can rely on
;;; defining?
;;; WARNINGS-P and FAILURE-P are as in CL:COMPILE or CL:COMPILE-FILE.
;;; This also wraps up WITH-IR1-NAMESPACE functionality.
(defmacro with-compilation-values (&body body)
- `(with-ir1-namespace
- (let ((*warnings-p* nil)
- (*failure-p* nil))
- (values (progn ,@body)
- *warnings-p*
- *failure-p*))))
+ ;; These bindings could just as well be in WITH-IR1-NAMESPACE, but
+ ;; since they're primarily debugging tools, it's nicer to have
+ ;; a wider unique scope by ID.
+ `(let ((*continuation-number* 0)
+ (*continuation-numbers* (make-hash-table :test 'eq))
+ (*number-continuations* (make-hash-table :test 'eql))
+ (*tn-id* 0)
+ (*tn-ids* (make-hash-table :test 'eq))
+ (*id-tns* (make-hash-table :test 'eql))
+ (*label-id* 0)
+ (*label-ids* (make-hash-table :test 'eq))
+ (*id-labels* (make-hash-table :test 'eql)))
+ (unwind-protect
+ (let ((*warnings-p* nil)
+ (*failure-p* nil))
+ (handler-bind ((compiler-error #'compiler-error-handler)
+ (style-warning #'compiler-style-warning-handler)
+ (warning #'compiler-warning-handler))
+ (values (progn ,@body)
+ *warnings-p*
+ *failure-p*)))
+ (clrhash *tn-ids*)
+ (clrhash *id-tns*)
+ (clrhash *continuation-numbers*)
+ (clrhash *number-continuations*)
+ (clrhash *label-ids*)
+ (clrhash *id-labels*))))
\f
;;;; component compilation
(defparameter *max-optimize-iterations* 3 ; ARB
#!+sb-doc
"The upper limit on the number of times that we will consecutively do IR1
- optimization that doesn't introduce any new code. A finite limit is
- necessary, since type inference may take arbitrarily long to converge.")
+optimization that doesn't introduce any new code. A finite limit is
+necessary, since type inference may take arbitrarily long to converge.")
(defevent ir1-optimize-until-done "IR1-OPTIMIZE-UNTIL-DONE called")
(defevent ir1-optimize-maxed-out "hit *MAX-OPTIMIZE-ITERATIONS* limit")
(return))
(incf loop-count)))
+ (when *check-consistency*
+ (do-blocks-backwards (block component)
+ (awhen (flush-dead-code block)
+ (let ((*compiler-error-context* it))
+ (compiler-warn "dead code detected at the end of ~S"
+ 'ir1-phases)))))
+
(ir1-finalize component)
(values))
(check-life-consistency component))
(maybe-mumble "pack ")
- (pack component)
+ (sb!regalloc:pack component)
(when *check-consistency*
(maybe-mumble "check-pack ")
(defun clear-constant-info ()
(maphash (lambda (k v)
(declare (ignore k))
- (setf (leaf-info v) nil))
+ (setf (leaf-info v) nil)
+ (setf (constant-boxed-tn v) nil))
*constants*)
(maphash (lambda (k v)
(declare (ignore k))
(when (constant-p v)
- (setf (leaf-info v) nil)))
+ (setf (leaf-info v) nil)
+ (setf (constant-boxed-tn v) nil)))
*free-vars*)
(values))
(blast *free-funs*)
(blast *constants*))
(values))
-
-;;; Clear global variables used by the compiler.
-;;;
-;;; FIXME: It seems kinda nasty and unmaintainable to have to do this,
-;;; and it adds overhead even when people aren't using the compiler.
-;;; Perhaps we could make these global vars unbound except when
-;;; actually in use, so that this function could go away.
-(defun clear-stuff (&optional (debug-too t))
-
- ;; Clear global tables.
- (when (boundp '*free-funs*)
- (clrhash *free-funs*)
- (clrhash *free-vars*)
- (clrhash *constants*))
-
- ;; Clear debug counters and tables.
- (clrhash *seen-blocks*)
- (clrhash *seen-funs*)
- (clrhash *list-conflicts-table*)
-
- (when debug-too
- (clrhash *continuation-numbers*)
- (clrhash *number-continuations*)
- (setq *continuation-number* 0)
- (clrhash *tn-ids*)
- (clrhash *id-tns*)
- (setq *tn-id* 0)
- (clrhash *label-ids*)
- (clrhash *id-labels*)
- (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
- ;; surprised if *GENSYM-COUNTER* turned back to zero when something was
- ;; compiled. A closer inspection showed that this actually turned out to be
- ;; harmless in practice, because CLEAR-STUFF was only called from within
- ;; forms which bound CL::*GENSYM-COUNTER* to zero. However, this means that
- ;; even though zeroing CL::*GENSYM-COUNTER* here turned out to be harmless in
- ;; practice, it was also useless in practice. So we don't do it any more.)
-
- (values))
\f
;;;; trace output
(handler-case
(read-preserving-whitespace stream nil stream)
(reader-error (condition)
- (error 'input-error-in-compile-file
- :condition condition
- ;; We don't need to supply :POSITION here because
- ;; READER-ERRORs already know their position in the file.
- ))
+ (compiler-error 'input-error-in-compile-file
+ ;; We don't need to supply :POSITION here because
+ ;; READER-ERRORs already know their position in the file.
+ :condition condition
+ :stream stream))
;; ANSI, in its wisdom, says that READ should return END-OF-FILE
;; (and that this is not a READER-ERROR) when it encounters end of
;; file in the middle of something it's trying to read.
(end-of-file (condition)
- (error 'input-error-in-compile-file
- :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.
- :position position))))
+ (compiler-error 'input-error-in-compile-file
+ :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.
+ :position position
+ :stream stream))
+ (error (condition)
+ (compiler-error 'input-error-in-compile-file
+ :condition condition
+ :position position
+ :stream stream))))
;;; If STREAM is present, return it, otherwise open a stream to the
;;; current file. There must be a current file.
;;; Read and compile the source file.
(defun sub-sub-compile-file (info)
(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)))
+ (with-source-paths
+ (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.
(if (fopcompilable-p form)
(let ((*fopcompile-label-counter* 0))
(fopcompile form path nil))
- (let ((*lexenv* (make-lexenv
- :policy *policy*
- :handled-conditions *handled-conditions*
- :disabled-package-locks *disabled-package-locks*))
- (tll (ir1-toplevel form path nil)))
- (if (eq *block-compile* t)
- (push tll *toplevel-lambdas*)
- (compile-toplevel (list tll) nil))
- nil)))))
+ (with-ir1-namespace
+ (let ((*lexenv* (make-lexenv
+ :policy *policy*
+ :handled-conditions *handled-conditions*
+ :disabled-package-locks *disabled-package-locks*))
+ (tll (ir1-toplevel form path 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
;;; forms in the source path.
(defun preprocessor-macroexpand-1 (form)
- (handler-case (sb!xc:macroexpand-1 form *lexenv*)
+ (handler-case (%macroexpand-1 form *lexenv*)
(error (condition)
(compiler-error "(during macroexpansion of ~A)~%~A"
(let ((*print-level* 2)
(declare (list path))
(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
- ;; value of *POLICY* as the policy. The need for this hack
- ;; is due to the quirk that there is no way to represent in
- ;; a POLICY that an optimize quality came from the default.
- ;;
- ;; 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*))
- ;; 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))))
+ (with-ir1-namespace
+ (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
+ ;; value of *POLICY* as the policy. The need for this hack
+ ;; is due to the quirk that there is no way to represent in
+ ;; a POLICY that an optimize quality came from the default.
+ ;;
+ ;; 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*))
+ ;; 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,
;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
(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
- 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
- ;; real function (via CONVERT-CALL / PROPAGATE-TO-ARGS).
- ;; -- JES, 2007-02-27
- (*lexenv* (make-lexenv :policy (lexenv-policy
- (functional-lexenv locall-fun))))
- (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
+ (let* ((fun (let ((*allow-instrumenting* t))
+ (funcall #'ir1-convert-lambdalike
+ 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 real function (via CONVERT-CALL /
+ ;; PROPAGATE-TO-ARGS). -- JES, 2007-02-27
+ (*lexenv* (make-lexenv :policy (lexenv-policy (functional-lexenv fun))))
+ (xep (ir1-convert-lambda (make-xep-lambda-expression fun)
: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
- (functional-kind fun) :external
- (functional-has-external-references-p locall-fun) t
- (functional-has-external-references-p fun) t)
- fun)))
+ (assert-global-function-definition-type name fun))
+ (setf (functional-kind xep) :external
+ (functional-entry-fun xep) fun
+ (functional-entry-fun fun) xep
+ (component-reanalyze component) t
+ (functional-has-external-references-p xep) t)
+ (reoptimize-component component :maybe)
+ (locall-analyze-xep-entry-point fun)
+ ;; Any leftover REFs to FUN outside local calls get replaced with the
+ ;; XEP.
+ (substitute-leaf-if (lambda (ref)
+ (let* ((lvar (ref-lvar ref))
+ (dest (when lvar (lvar-dest lvar)))
+ (kind (when (basic-combination-p dest)
+ (basic-combination-kind dest))))
+ (neq :local kind)))
+ xep
+ fun)
+ xep)))
;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a
;;; description of the result.
'(original-source-start 0 0)))
(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*))
- (*compiler-sset-counter* 0)
- (fun (make-functional-from-toplevel-lambda lambda-expression
- :name name
- :path path)))
-
- ;; FIXME: The compile-it code from here on is sort of a
- ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
- ;; better to find a way to share the code there; or
- ;; alternatively, to use this code to replace the code there.
- ;; (The second alternative might be pretty easy if we used
- ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
- ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
-
- (locall-analyze-clambdas-until-done (list fun))
-
- (let ((components-from-dfo (find-initial-dfo (list fun))))
- (dolist (component-from-dfo components-from-dfo)
- (compile-component component-from-dfo)
- (replace-toplevel-xeps component-from-dfo))
-
- (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)))))))
+ (with-ir1-namespace
+ (let* ((*lexenv* (make-lexenv
+ :policy *policy*
+ :handled-conditions *handled-conditions*
+ :disabled-package-locks *disabled-package-locks*))
+ (*compiler-sset-counter* 0)
+ (fun (make-functional-from-toplevel-lambda lambda-expression
+ :name name
+ :path path)))
+
+ ;; FIXME: The compile-it code from here on is sort of a
+ ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
+ ;; better to find a way to share the code there; or
+ ;; alternatively, to use this code to replace the code there.
+ ;; (The second alternative might be pretty easy if we used
+ ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
+ ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
+
+ (locall-analyze-clambdas-until-done (list fun))
+
+ (let ((components-from-dfo (find-initial-dfo (list fun))))
+ (dolist (component-from-dfo components-from-dfo)
+ (compile-component component-from-dfo)
+ (replace-toplevel-xeps component-from-dfo))
+
+ (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))))))))
(defun process-toplevel-cold-fset (name lambda-expression path)
(unless (producing-fasl-file)
(*print-level* 2)
(*print-pretty* nil))
(with-compiler-io-syntax
- (compiler-mumble "~&; ~:[compiling~;converting~] ~S"
- *block-compile* form)))
+ (compiler-mumble
+ #-sb-xc-host "~&; ~:[compiling~;converting~] ~S"
+ #+sb-xc-host "~&; ~:[x-compiling~;x-converting~] ~S"
+ *block-compile* form)))
form)
((and finalp
(eq :top-level-forms *compile-print*)
;;; compilation. Normally just evaluate in the appropriate
;;; environment, but also compile if outputting a CFASL.
(defun eval-compile-toplevel (body path)
- (handler-case (eval-in-lexenv `(progn ,@body) *lexenv*)
- (error (condition)
- (compiler-error "(during compile-time-too processing)~%~A"
- condition)))
+ (eval-tlf `(progn ,@body) (source-path-tlf-number path) *lexenv*)
(when *compile-toplevel-object*
(let ((*compile-object* *compile-toplevel-object*))
(convert-and-maybe-compile `(progn ,@body) path))))
(compile-load-time-value-lambda lambdas)
(compile-toplevel-lambdas lambdas))
- (mapc #'clear-ir1-info components)
- (clear-stuff)))
+ (mapc #'clear-ir1-info components)))
(values))
;;; Actually compile any stuff that has been queued up for block
(*fun-names-in-this-file* ())
(*allow-instrumenting* nil)
(*compiler-error-bailout*
- (lambda ()
- (compiler-mumble "~2&; fatal error, aborting compilation~%")
+ (lambda (&optional error)
+ (declare (ignore error))
(return-from sub-compile-file (values t t t))))
(*current-path* nil)
(*last-source-context* nil)
(handler-case
(handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
(with-compilation-values
- (sb!xc:with-compilation-unit ()
- (clear-stuff)
-
+ (sb!xc:with-compilation-unit ()
+ (with-world-lock ()
(sub-sub-compile-file info)
-
(unless (zerop (hash-table-count *code-coverage-records*))
;; Dump the code coverage records into the fasl.
- (fopcompile `(record-code-coverage
- ',(namestring *compile-file-pathname*)
- ',(let (list)
- (maphash (lambda (k v)
- (declare (ignore k))
- (push v list))
- *code-coverage-records*)
- list))
- nil
- nil))
-
+ (with-source-paths
+ (fopcompile `(record-code-coverage
+ ',(namestring *compile-file-pathname*)
+ ',(let (list)
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (push v list))
+ *code-coverage-records*)
+ list))
+ nil
+ nil)))
(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)))
+ nil))))
;; Some errors are sufficiently bewildering that we just fail
;; immediately, without trying to recover and compile more of
;; the input file.
(fatal-compiler-error (condition)
(signal condition)
+ (fresh-line *error-output*)
(pprint-logical-block (*error-output* nil :per-line-prefix "; ")
(format *error-output*
- "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
- condition))
+ "~@<~@:_compilation aborted because of fatal error: ~2I~_~A~@:_~:>"
+ (encapsulated-condition condition)))
(finish-output *error-output*)
(values t t t)))))
(compile name lambda))
#+sb-xc-host
-(defun eval-in-lexenv (form lexenv)
- (declare (ignore lexenv))
+(defun eval-tlf (form index &optional lexenv)
+ (declare (ignore index lexenv))
(eval form))
projects / sbcl.git / blobdiff