;;; 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)
+ ;; 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))
(*label-ids* (make-hash-table :test 'eq))
(*id-labels* (make-hash-table :test 'eql)))
(unwind-protect
- (with-ir1-namespace
- (let ((*warnings-p* nil)
- (*failure-p* nil))
- (values (progn ,@body)
- *warnings-p*
- *failure-p*)))
+ (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*)
;;; 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
(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
'(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)))))))
+ (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)
(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
(defun actually-compile (name definition *lexenv* source-info tlf errorp)
(let ((source-paths (when source-info *source-paths*)))
(with-compilation-values
- (sb!xc:with-compilation-unit ()
- ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
- ;; few changes. Once things are stable, the shared bindings
- ;; probably be merged back together into some shared utility
- ;; macro, or perhaps both merged into one of the existing utility
- ;; macros SB-C::WITH-COMPILATION-VALUES or
- ;; CL:WITH-COMPILATION-UNIT.
- (prog* ((tlf (or tlf 0))
- ;; If we have a source-info from LOAD, we will
- ;; also have a source-paths already set up -- so drop
- ;; the ones from WITH-COMPILATION-VALUES.
- (*source-paths* (or source-paths *source-paths*))
- ;; FIXME: Do we need the *INFO-ENVIRONMENT* 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 now that SBCL doesn't
- ;; need *BACKEND-INFO-ENVIRONMENT*.
- (*info-environment* *info-environment*)
- (form (get-lambda-to-compile definition))
- (*source-info* (or source-info
- (make-lisp-source-info
- form :parent *source-info*)))
- (*toplevel-lambdas* ())
- (*block-compile* nil)
- (*allow-instrumenting* nil)
- (*code-coverage-records* nil)
- (*code-coverage-blocks* nil)
- (*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)
- (*last-error-context* nil)
- (*gensym-counter* 0)
- ;; KLUDGE: This rebinding of policy is necessary so that
- ;; forms such as LOCALLY at the REPL actually extend the
- ;; compilation policy correctly. However, there is an
- ;; invariant that is potentially violated: future
- ;; refactoring must not allow this to be done in the file
- ;; compiler. At the moment we're clearly alright, as we
- ;; call %COMPILE with a core-object, not a fasl-stream,
- ;; but caveat future maintainers. -- CSR, 2002-10-27
- (*policy* (lexenv-policy *lexenv*))
- ;; see above
- (*handled-conditions* (lexenv-handled-conditions *lexenv*))
- ;; ditto
- (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))
- ;; FIXME: ANSI doesn't say anything about CL:COMPILE
- ;; interacting with these variables, so we shouldn't. As
- ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
- ;; binding these variables, so as a quick hack we do so
- ;; too. But a proper implementation would have verbosity
- ;; controlled by function arguments and lexical variables.
- (*compile-verbose* nil)
- (*compile-print* nil)
- (oops nil))
- (with-world-lock ()
- (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
- (unless source-paths
- (find-source-paths form tlf))
- (let ((*compiler-error-bailout*
- (lambda (e)
- (setf oops e)
- ;; Unwind the compiler frames: users want the know where
- ;; the error came from, not how the compiler got there.
- (go :error))))
- (return (%compile form (make-core-object)
- :name name
- :path `(original-source-start 0 ,tlf))))))
- :error
- ;; Either signal the error right away, or return a function that
- ;; will signal the corresponding COMPILED-PROGRAM-ERROR. This is so
- ;; that we retain our earlier behaviour when called with erronous
- ;; lambdas via %SIMPLE-EVAL. We could legally do just either one
- ;; always, but right now keeping the old behaviour seems like less
- ;; painful option: compiler.pure.lisp is full of tests that make all
- ;; sort of assumptions about when which things are signalled. FIXME,
- ;; probably.
- (if errorp
- (error oops)
- (let ((message (princ-to-string oops))
- (source (source-to-string form)))
- (return
- (lambda (&rest arguments)
- (declare (ignore arguments))
- (error 'compiled-program-error
- :message message
- :source source))))))))))
+ (sb!xc:with-compilation-unit ()
+ ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
+ ;; few changes. Once things are stable, the shared bindings
+ ;; probably be merged back together into some shared utility
+ ;; macro, or perhaps both merged into one of the existing utility
+ ;; macros SB-C::WITH-COMPILATION-VALUES or
+ ;; CL:WITH-COMPILATION-UNIT.
+ (with-source-paths
+ (prog* ((tlf (or tlf 0))
+ ;; If we have a source-info from LOAD, we will
+ ;; also have a source-paths already set up -- so drop
+ ;; the ones from WITH-COMPILATION-VALUES.
+ (*source-paths* (or source-paths *source-paths*))
+ ;; FIXME: Do we need the *INFO-ENVIRONMENT* 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 now that SBCL doesn't
+ ;; need *BACKEND-INFO-ENVIRONMENT*.
+ (*info-environment* *info-environment*)
+ (form (get-lambda-to-compile definition))
+ (*source-info* (or source-info
+ (make-lisp-source-info
+ form :parent *source-info*)))
+ (*toplevel-lambdas* ())
+ (*block-compile* nil)
+ (*allow-instrumenting* nil)
+ (*code-coverage-records* nil)
+ (*code-coverage-blocks* nil)
+ (*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)
+ (*last-error-context* nil)
+ (*gensym-counter* 0)
+ ;; KLUDGE: This rebinding of policy is necessary so that
+ ;; forms such as LOCALLY at the REPL actually extend the
+ ;; compilation policy correctly. However, there is an
+ ;; invariant that is potentially violated: future
+ ;; refactoring must not allow this to be done in the file
+ ;; compiler. At the moment we're clearly alright, as we
+ ;; call %COMPILE with a core-object, not a fasl-stream,
+ ;; but caveat future maintainers. -- CSR, 2002-10-27
+ (*policy* (lexenv-policy *lexenv*))
+ ;; see above
+ (*handled-conditions* (lexenv-handled-conditions *lexenv*))
+ ;; ditto
+ (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))
+ ;; FIXME: ANSI doesn't say anything about CL:COMPILE
+ ;; interacting with these variables, so we shouldn't. As
+ ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
+ ;; binding these variables, so as a quick hack we do so
+ ;; too. But a proper implementation would have verbosity
+ ;; controlled by function arguments and lexical variables.
+ (*compile-verbose* nil)
+ (*compile-print* nil)
+ (oops nil))
+ (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
+ (unless source-paths
+ (find-source-paths form tlf))
+ (let ((*compiler-error-bailout*
+ (lambda (e)
+ (setf oops e)
+ ;; Unwind the compiler frames: users want the know where
+ ;; the error came from, not how the compiler got there.
+ (go :error))))
+ (return
+ (with-world-lock ()
+ (%compile form (make-core-object)
+ :name name
+ :path `(original-source-start 0 ,tlf))))))
+ :error
+ ;; Either signal the error right away, or return a function that
+ ;; will signal the corresponding COMPILED-PROGRAM-ERROR. This is so
+ ;; that we retain our earlier behaviour when called with erronous
+ ;; lambdas via %SIMPLE-EVAL. We could legally do just either one
+ ;; always, but right now keeping the old behaviour seems like less
+ ;; painful option: compiler.pure.lisp is full of tests that make all
+ ;; sort of assumptions about when which things are signalled. FIXME,
+ ;; probably.
+ (if errorp
+ (error oops)
+ (let ((message (princ-to-string oops))
+ (source (source-to-string form)))
+ (return
+ (lambda (&rest arguments)
+ (declare (ignore arguments))
+ (error 'compiled-program-error
+ :message message
+ :source source)))))))))))
(defun compile-in-lexenv (name definition lexenv
&optional source-info tlf errorp)
projects / sbcl.git / commitdiff