typechecks when dependency graph had loops. (lp#1001799)
* bug fix: error forms reported with some program-errors were not escaped
properly.
+ * bug fix: functions from EVAL are now on more equal footing with functions
+ from COMPILE. (lp#1000783, lp#851170, lp#922408)
changes in sbcl-1.0.57 relative to sbcl-1.0.56:
* RANDOM enhancements and bug fixes:
(defvar *eval-tlf-index* nil)
(defvar *eval-source-info* nil)
+;;;; Turns EXPR into a lambda-form we can pass to COMPILE. Returns
+;;;; a secondary value of T if we must call the resulting function
+;;;; to evaluate EXPR -- if EXPR is already a lambda form, there's
+;;;; no need.
(defun make-eval-lambda (expr)
- `(named-lambda
- ;; This name is used to communicate the original context
- ;; for the compiler, and identifies the lambda for use of
- ;; EVAL-LAMBDA-SOURCE-LAMBDA below.
- (eval ,(sb!c::source-form-context *eval-source-context*)) ()
- (declare (muffle-conditions compiler-note))
- ;; why PROGN? So that attempts to eval free declarations
- ;; signal errors rather than return NIL. -- CSR, 2007-05-01
- (progn ,expr)))
-
-(defun eval-lambda-p (form)
- (when (and (consp form) (eq 'named-lambda (first form)))
- (let ((name (second form)))
- (when (and (consp name) (eq 'eval (first name)))
- t))))
-
-(defun eval-lambda-source-lambda (eval-lambda)
- (if (eval-lambda-p eval-lambda)
- (destructuring-bind (named-lambda name lambda-list decl (progn expr))
- eval-lambda
- (declare (ignore named-lambda name lambda-list decl progn))
- (when (and (consp expr) (member (car expr) '(lambda named-lambda)))
- expr))
- eval-lambda))
+ (if (typep expr `(cons (member lambda named-lambda lambda-with-lexenv)))
+ (values expr nil)
+ (values `(lambda ()
+ ;; why PROGN? So that attempts to eval free declarations
+ ;; signal errors rather than return NIL. -- CSR, 2007-05-01
+ (progn ,expr))
+ t)))
;;; general case of EVAL (except in that it can't handle toplevel
;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
(defun %simple-eval (expr lexenv)
- ;; FIXME: It might be nice to quieten the toplevel by muffling
- ;; warnings generated by this compilation (since we're about to
- ;; execute the results irrespective of the warnings). We might want
- ;; to be careful about not muffling warnings arising from inner
- ;; evaluations/compilations, though [e.g. the ignored variable in
- ;; (DEFUN FOO (X) 1)]. -- CSR, 2003-05-13
- ;;
- ;; As of 1.0.21.6 we muffle compiler notes lexically here, which seems
- ;; always safe. --NS
- (let* ((lambda (make-eval-lambda expr))
- (fun (sb!c:compile-in-lexenv
- nil lambda lexenv *eval-source-info* *eval-tlf-index*)))
- (funcall fun)))
+ (multiple-value-bind (lambda call) (make-eval-lambda expr)
+ (let ((fun
+ ;; This tells the compiler where the lambda comes from, in case it
+ ;; wants to report any problems.
+ (let ((sb!c::*source-form-context-alist*
+ (acons lambda *eval-source-context*
+ sb!c::*source-form-context-alist*)))
+ (handler-bind (;; Compiler notes just clutter up the REPL:
+ ;; anyone caring about performance should not
+ ;; be using EVAL.
+ (compiler-note #'muffle-warning))
+ (sb!c:compile-in-lexenv
+ nil lambda lexenv *eval-source-info* *eval-tlf-index* (not call))))))
+ (declare (function fun))
+ (if call
+ (funcall fun)
+ fun))))
;;; Handle PROGN and implicit PROGN.
(defun simple-eval-progn-body (progn-body lexenv)
(let ((condition (coerce-to-condition datum arguments
'simple-program-error 'compiler-error)))
(restart-case
- (progn
- (cerror "Replace form with call to ERROR."
- 'compiler-error
- :condition condition)
- (funcall *compiler-error-bailout* condition)
- (bug "Control returned from *COMPILER-ERROR-BAILOUT*."))
+ (cerror "Replace form with call to ERROR."
+ 'compiler-error
+ :condition condition)
(signal-error ()
- (error condition)))))
+ (error condition)))
+ (funcall *compiler-error-bailout* condition)
+ (bug "Control returned from *COMPILER-ERROR-BAILOUT*.")))
(defun compiler-warn (datum &rest arguments)
(apply #'warn datum arguments)
:form (let ((direct-file-info (source-info-file-info info)))
(when (eq :lisp (file-info-name direct-file-info))
- (let ((form (elt (file-info-forms direct-file-info) 0)))
- ;; The form COMPILE saves may include gunk
- ;; from %SIMPLE-EVAL -- this gets rid of that.
- (sb!impl::eval-lambda-source-lambda form))))
+ (elt (file-info-forms direct-file-info) 0)))
:function function)))
;;; Given an arbitrary sequence, coerce it to an unsigned vector if
(second name)
`(named-lambda ,name)))
+(defvar *source-form-context-alist* nil)
+
;;; Return the first two elements of FORM if FORM is a list. Take the
;;; CAR of the second form if appropriate.
(defun source-form-context (form)
- (cond ((atom form) nil)
- ((>= (length form) 2)
- (let* ((context-fun-default (lambda (x)
- (declare (ignore x))
- (list (first form) (second form))))
- (context-fun (gethash (first form)
- *source-context-methods*
- context-fun-default)))
- (declare (type function context-fun))
- (funcall context-fun (rest form))))
- (t
- form)))
+ (flet ((get-it (form)
+ (cond ((atom form) nil)
+ ((>= (length form) 2)
+ (let* ((context-fun-default
+ (lambda (x)
+ (declare (ignore x))
+ (list (first form) (second form))))
+ (context-fun
+ (gethash (first form)
+ *source-context-methods*
+ context-fun-default)))
+ (declare (type function context-fun))
+ (funcall context-fun (rest form))))
+ (t
+ form))))
+ (get-it (or (cdr (assoc form *source-form-context-alist* :test #'eq))
+ form))))
;;; Given a source path, return the original source form and a
;;; description of the interesting aspects of the context in which it
definition)))
;;; Handle the nontrivial case of CL:COMPILE.
-(defun actually-compile (name definition *lexenv* source-info tlf)
+;;;
+;;; If ERRORP is true signals an error immediately -- otherwise returns
+;;; a function that will signal the error.
+(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 ()
;; macro, or perhaps both merged into one of the existing utility
;; macros SB-C::WITH-COMPILATION-VALUES or
;; CL:WITH-COMPILATION-UNIT.
- (let* ((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)
- (*compiler-error-bailout*
- (lambda (&optional error)
- (declare (ignore error))
- (compiler-mumble
- "~2&fatal error, aborting compilation~%")
- (return-from actually-compile (values nil t 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))
- (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
- (clear-stuff)
- (unless source-paths
- (find-source-paths form tlf))
- (%compile form (make-core-object)
- :name name
- :path `(original-source-start 0 ,tlf))))))))
+ (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))
+ (clear-stuff)
+ (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))))))))))
(defun compile-in-lexenv (name definition lexenv
- &optional source-info tlf)
+ &optional source-info tlf errorp)
(multiple-value-bind (compiled-definition warnings-p failure-p)
(cond
#!+sb-eval
((sb!eval:interpreted-function-p definition)
(multiple-value-bind (definition lexenv)
(sb!eval:prepare-for-compile definition)
- (actually-compile name definition lexenv source-info tlf)))
+ (actually-compile name definition lexenv source-info tlf errorp)))
((compiled-function-p definition)
(values definition nil nil))
(t
- (actually-compile name definition lexenv source-info tlf)))
+ (actually-compile name definition lexenv source-info tlf errorp)))
+ (check-type compiled-definition compiled-function)
(cond (name
(if (and (symbolp name)
(macro-function name))
(defun compile (name &optional (definition (or (macro-function name)
(fdefinition name))))
#!+sb-doc
- "Coerce DEFINITION (by default, the function whose name is NAME)
- to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
- where if NAME is NIL, THING is the result of compilation, and
- otherwise THING is NAME. When NAME is not NIL, the compiled function
- is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
- (FDEFINITION NAME) otherwise."
- (multiple-value-bind (function warnings-p failure-p)
- (compile-in-lexenv name definition (make-null-lexenv))
- (values (or function
- name
- (lambda (&rest arguments)
- (error 'simple-program-error
- :format-control
- "Called function compiled with errors. Original ~
- definition:~% ~S~@[~%Arguments:~% ~{ ~S~}~]"
- :format-arguments (list definition arguments))))
- warnings-p
- failure-p)))
+ "Produce a compiled function from DEFINITION. If DEFINITION is a
+lambda-expression, it is coerced to a function. If DEFINITION is an
+interpreted function, it is compiled. If DEFINITION is already a compiled
+function, it is used as-is. (Future versions of SBCL might try to
+recompile the existing definition, but this is not currently supported.)
+
+If NAME is NIL, the compiled function is returned as the primary value.
+Otherwise the resulting compiled function replaces existing function
+definition of NAME, and NAME is returned as primary value; if NAME is a symbol
+tha names a macro, its macro function is replaced and NAME is returned as
+primary value.
+
+Also returns secondary value which is true if any conditions of type WARNING
+occur during the compilation, and NIL otherwise.
+
+Tertiary value is true if any conditions of type ERROR, or WARNING that are
+not STYLE-WARNINGs occur during compilation, and NIL otherwise.
+"
+ (compile-in-lexenv name definition (make-null-lexenv)))
'((oops ? ? ? ? ? ?)))))
(defmacro defbt (n ll &body body)
- `(progn
- ;; normal debug info
- (defun ,(intern (format nil "BT.~A.1" n)) ,ll
- ,@body)
- ;; no arguments saved
- (defun ,(intern (format nil "BT.~A.2" n)) ,ll
- (declare (optimize (debug 1) (speed 3)))
- ,@body)
- ;; no lambda-list saved
- (defun ,(intern (format nil "BT.~A.3" n)) ,ll
- (declare (optimize (debug 0)))
- ,@body)))
+ ;; WTF is this? This is a way to make these tests not depend so much on the
+ ;; details of LOAD/EVAL. Around 1.0.57 we changed %SIMPLE-EVAL to be
+ ;; slightly smarter, which meant that things which used to have xeps
+ ;; suddently had tl-xeps, etc. This takes care of that.
+ `(funcall
+ (compile nil
+ '(lambda ()
+ (progn
+ ;; normal debug info
+ (defun ,(intern (format nil "BT.~A.1" n)) ,ll
+ ,@body)
+ ;; no arguments saved
+ (defun ,(intern (format nil "BT.~A.2" n)) ,ll
+ (declare (optimize (debug 1) (speed 3)))
+ ,@body)
+ ;; no lambda-list saved
+ (defun ,(intern (format nil "BT.~A.3" n)) ,ll
+ (declare (optimize (debug 0)))
+ ,@body))))))
(defbt 1 (&key key)
(list key))
(vector-data-address (sb-sys:sap-int (sb-kernel::vector-sap memory)))
(object-base-address (logandc2 (+ vector-data-address sb-vm:lowtag-mask) sb-vm:lowtag-mask))
(object-tagged-address (+ object-base-address sb-vm:list-pointer-lowtag)))
- (multiple-value-bind
- (object valid-p)
+ (multiple-value-bind (object valid-p)
(sb-kernel:make-lisp-obj object-tagged-address nil)
+ (declare (ignore object))
(assert (not valid-p)))))
+(defun test-debugger (control form &rest targets)
+ (let ((out (make-string-output-stream))
+ (oops t))
+ (unwind-protect
+ (progn
+ (with-simple-restart (debugger-test-done! "Debugger Test Done!")
+ (let* ((*debug-io* (make-two-way-stream
+ (make-string-input-stream control)
+ (make-broadcast-stream out #+nil *standard-output*)))
+ ;; Initial announcement goes to *ERROR-OUTPUT*
+ (*error-output* *debug-io*)
+ (*invoke-debugger-hook* nil))
+ (handler-bind ((error #'invoke-debugger))
+ (eval form))))
+ (setf oops nil))
+ (when oops
+ (error "Uncontrolled unwind from debugger test.")))
+ ;; For sanity's sake this is outside the *debug-io* rebinding -- otherwise
+ ;; it could swallow our asserts!
+ (with-input-from-string (s (get-output-stream-string out))
+ (loop for line = (read-line s nil)
+ while line
+ do (assert targets)
+ #+nil
+ (format *error-output* "Got: ~A~%" line)
+ (let ((match (pop targets)))
+ (if (eq '* match)
+ ;; Whatever, till the next line matches.
+ (let ((text (pop targets)))
+ (unless (search text line)
+ (push text targets)
+ (push match targets)))
+ (unless (search match line)
+ (format *error-output* "~&Wanted: ~S~% Got: ~S~%" match line)
+ (setf oops t))))))
+ ;; Check that we saw everything we wanted
+ (when targets
+ (error "Missed: ~S" targets))
+ (assert (not oops))))
+
+(with-test (:name (:debugger :source 1))
+ (test-debugger
+ "d
+ source 0
+ debugger-test-done!"
+ `(progn
+ (defun this-will-break (x)
+ (declare (optimize debug))
+ (let* ((y (- x x))
+ (z (/ x y)))
+ (+ x z)))
+ (this-will-break 1))
+ '*
+ "debugger invoked"
+ '*
+ "DIVISION-BY-ZERO"
+ "operands (1 0)"
+ '*
+ "INTEGER-/-INTEGER"
+ "(THIS-WILL-BREAK 1)"
+ "1]"
+ "(/ X Y)"
+ "1]"))
+
+(with-test (:name (:debugger :source 2))
+ (test-debugger
+ "d
+ source 0
+ debugger-test-done!"
+ `(locally (declare (optimize (speed 0) (safety 3) (debug 3)))
+ (let ((f #'(lambda (x cont)
+ (print x (make-broadcast-stream))
+ (if (zerop x)
+ (error "foo")
+ (funcall cont (1- x) cont)))))
+ (funcall f 10 f)))
+ '*
+ "debugger"
+ '*
+ "foo"
+ '*
+ "source: (ERROR \"foo\")"
+ '*
+ "(LAMBDA (X CONT)"
+ '*
+ "(FUNCALL CONT (1- X) CONT)"
+ "1]"))
+
+(with-test (:name (disassemble :high-debug-eval))
+ (eval `(defun this-will-be-disassembled (x)
+ (declare (optimize debug))
+ (+ x x)))
+ (let* ((oopses (make-string-output-stream))
+ (disassembly
+ (let ((*error-output* oopses))
+ (with-output-to-string (*standard-output*)
+ (disassemble 'this-will-be-disassembled)))))
+ (with-input-from-string (s disassembly)
+ (assert (search "; disassembly for THIS-WILL-BE-DISASSEMBLED"
+ (read-line s))))
+ (let ((problems (get-output-stream-string oopses)))
+ (unless (zerop (length problems))
+ (error problems)))))
+
+(defun this-too-will-be-disasssembled (x)
+ (declare (optimize debug))
+ (+ x x))
+
+(with-test (:name (disassemble :high-debug-load))
+ (let* ((oopses (make-string-output-stream))
+ (disassembly
+ (let ((*error-output* oopses))
+ (with-output-to-string (*standard-output*)
+ (disassemble 'this-too-will-be-disasssembled)))))
+ (with-input-from-string (s disassembly)
+ (assert (equal "; disassembly for THIS-TOO-WILL-BE-DISASSSEMBLED"
+ (read-line s))))
+ (let ((problems (get-output-stream-string oopses)))
+ (unless (zerop (length problems))
+ (error problems)))))
+
(write-line "/debug.impure.lisp done")
(eval `(defun empty-let-is-not-toplevel-x () :fun))
(assert (eq :fun (empty-let-is-not-toplevel-fun)))))
+(with-test (:name (eval function-lambda-expression))
+ (assert (equal `(sb-int:named-lambda eval-fle-1 (x)
+ (block eval-fle-1
+ (+ x 1)))
+ (function-lambda-expression
+ (eval `(progn
+ (defun eval-fle-1 (x) (+ x 1))
+ #'eval-fle-1)))))
+ (assert (equal `(lambda (x y z) (+ x 1 y z))
+ (function-lambda-expression
+ (eval `(lambda (x y z) (+ x 1 y z)))))))
+
;;; success
projects / sbcl.git / commitdiff