[Sbcl-commits] 1.0.46.16: death to "in: LAMBDA NIL" in compiler messages

[Nikodemus S. <nik...@ra...>]

1.0.46.16: death to "in: LAMBDA NIL" in compiler messages

 The LAMBDA NIL was 99% of the time the lambda introduced by
 %SIMPLE-EVAL-IN-LEXENV -- in other words totally uninteresting.

 Have EVAL save original form, and use that to name the lambda
 introduced in %SIMPLE-EVAL-IN-LEXENV:

   `(NAMED-LAMBDA (EVAL ,SOURCE-CONTEXT) ...)

 Finally, DEFINE-SOURCE-CONTEXT for NAMED-LAMBDA that understands the
 source context stashed into the name by %SIMPLE-EVAL-IN-LEXENV.

 Additionally, in case there is a legitimate (LAMBDA () ...) form the
 compiler wants to complain about, make sure it is printed as LAMBDA (),
 not LAMBDA NIL.

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1885
diff -u -r1.1885 NEWS
--- NEWS	28 Feb 2011 08:57:19 -0000	1.1885
+++ NEWS	28 Feb 2011 11:27:06 -0000
@@ -4,6 +4,8 @@
   * enhancement: redefinition warnings for macros from different
files. (lp#434657)
   * enhancement: better MACHINE-VERSION on Darwin x86 and x86-64. (lp#668332)
   * enhancement: (FORMAT "foo" ...) and similar signal a compile-time
warning. (lp#327223)
+  * enhancement: no more "in: LAMBDA NIL" messages from the compiler for forms
+    processed using EVAL -- now the appropriate toplevel form is
reported instead.
   * optimization: SLOT-VALUE &co are faster in the presence of
SLOT-VALUE-USING-CLASS
     and its compatriots.
   * optimization: core startup time is reduced by 30% on x86-64. (lp#557357)
Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5200
diff -u -r1.5200 version.lisp-expr
--- version.lisp-expr	28 Feb 2011 08:57:19 -0000	1.5200
+++ version.lisp-expr	28 Feb 2011 11:27:06 -0000
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.46.15"
+"1.0.46.16"
Index: src/code/eval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/eval.lisp,v
retrieving revision 1.45
diff -u -r1.45 eval.lisp
--- src/code/eval.lisp	8 May 2009 19:08:07 -0000	1.45
+++ src/code/eval.lisp	28 Feb 2011 11:27:06 -0000
@@ -20,6 +20,8 @@
   (setf sb!eval::*eval-level* -1
         sb!eval::*eval-verbose* nil))

+(defvar *eval-source-context* nil)
+
 ;;; general case of EVAL (except in that it can't handle toplevel
 ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
 (defun %simple-eval (expr lexenv)
@@ -34,7 +36,7 @@
   ;; always safe. --NS
   (let* (;; why PROGN?  So that attempts to eval free declarations
          ;; signal errors rather than return NIL.  -- CSR, 2007-05-01
-         (lambda `(lambda ()
+         (lambda `(named-lambda (eval ,(sb!c::source-form-context
*eval-source-context*)) ()
                     (declare (muffle-conditions compiler-note))
                     (progn ,expr)))
          (fun (sb!c:compile-in-lexenv nil lambda lexenv)))
@@ -156,6 +158,10 @@
                            (not (consp (let ((sb!c:*lexenv* lexenv))
                                          (sb!c:lexenv-find name funs)))))
                       (%coerce-name-to-fun name)
+                      ;; FIXME: This is a bit wasteful: it would be
nice to call
+                      ;; COMPILE-IN-LEXENV with the lambda-form directly, but
+                      ;; getting consistent source context and
muffling compiler notes
+                      ;; is easier this way.
                       (%simple-eval original-exp lexenv))))
                ((quote)
                 (unless (= n-args 1)
@@ -270,7 +276,8 @@
   #!+sb-doc
   "Evaluate the argument in a null lexical environment, returning the
    result or results."
-  (eval-in-lexenv original-exp (make-null-lexenv)))
+  (let ((*eval-source-context* original-exp))
+    (eval-in-lexenv original-exp (make-null-lexenv))))

 
 ;;; miscellaneous full function definitions of things which are
Index: src/compiler/ir1report.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1report.lisp,v
retrieving revision 1.30
diff -u -r1.30 ir1report.lisp
--- src/compiler/ir1report.lisp	11 May 2009 19:41:49 -0000	1.30
+++ src/compiler/ir1report.lisp	28 Feb 2011 11:27:06 -0000
@@ -101,6 +101,12 @@
       `(lambda ,(second thing))
       `(function ,thing)))

+(define-source-context named-lambda (name lambda-list &body forms)
+  (declare (ignore lambda-list forms))
+  (if (and (consp name) (eq 'eval (first name)))
+      (second name)
+      `(named-lambda ,name)))
+
 ;;; 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)
@@ -296,7 +302,7 @@
                (note-message-repeats stream)
                (setq last nil)
                (pprint-logical-block (stream nil :per-line-prefix "; ")
-                 (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
+                 (format stream "in:~{~<~%    ~4:;~{ ~:S~}~>~^ =>~}" in))
                (terpri stream))

              (unless (and last
Index: tests/eval.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/eval.impure.lisp,v
retrieving revision 1.21
diff -u -r1.21 eval.impure.lisp
--- tests/eval.impure.lisp	27 Apr 2010 07:19:59 -0000	1.21
+++ tests/eval.impure.lisp	28 Feb 2011 11:27:06 -0000
@@ -256,4 +256,11 @@
     (let ((fun (eval lambda-form)))
       (assert (equal lambda-form (function-lambda-expression fun))))))

+(with-test (:name (eval :source-context-in-compiler))
+  (let ((noise (with-output-to-string (*error-output*)
+                 (let ((*evaluator-mode* :compile))
+                   (eval `(defun source-context-test (x) y))))))
+    (with-input-from-string (s noise)
+      (assert (equal "; in: DEFUN SOURCE-CONTEXT-TEST" (read-line s))))))
+
 ;;; success