From 3b6e07c0fcb050fa86c7c42db33f49107e3097e6 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 8 Apr 2007 12:38:18 +0000 Subject: [PATCH] 1.0.4.45: workaround for bug #412 & undefined variable cleanup * When converting dead references to global variables, convert using SYMBOL-VALUE. Results in the same code, but prevents dead unbound variable references from being flushed. * Collect XREF information for constant SYMBOL-VALUE cases. * Fix one dead reference to *LEXENV* in SBCL codebase. * Fix other undefined variables in contribs. * Test-case. --- BUGS | 8 +------ NEWS | 4 ++++ contrib/sb-aclrepl/toplevel.lisp | 8 +++---- src/code/defstruct.lisp | 11 ++++++--- src/compiler/ir1tran.lisp | 49 +++++++++++++++++++++----------------- src/compiler/xref.lisp | 12 ++++++++-- tests/compiler.pure.lisp | 11 +++++++++ version.lisp-expr | 2 +- 8 files changed, 66 insertions(+), 39 deletions(-) diff --git a/BUGS b/BUGS index 74ffb2d..34cebd6 100644 --- a/BUGS +++ b/BUGS @@ -1794,10 +1794,4 @@ WORKAROUND: the problem is probably with the new FP implementation. 412: deletion of global variable references in safe code - The following returns 1 instead of signalling an error. - (funcall (compile nil - '(lambda () - (declare (optimize (safety 3))) - #:unbound - 42))) - Reported by Marco Monteiro on sbcl-devel. + fixed in 1.0.4.45. diff --git a/NEWS b/NEWS index 8ee6c2d..4881cec 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,10 @@ changes in sbcl-1.0.5 relative to sbcl-1.0.4: in multithreaded application code. * optimization: GET-INTERNAL-REAL-TIME has been optimized on POSIX platforms. (thanks to James Anderson for the optimization hint) + * enhancement: XREF information is now collected to references made + to global variables using SYMBOL-VALUE with a constant argument. + * bug fix: dead unbound variable references now signal an error. + (reported by Marco Monteiro) * bug fix: / with an unused value was being deleted in safe code. (thanks to Marco Monteiro and Kevin Reid) * bug fix: number of characters that can be written onto a single diff --git a/contrib/sb-aclrepl/toplevel.lisp b/contrib/sb-aclrepl/toplevel.lisp index 60a54bc..e80ad9b 100644 --- a/contrib/sb-aclrepl/toplevel.lisp +++ b/contrib/sb-aclrepl/toplevel.lisp @@ -1,7 +1,7 @@ (cl:defpackage :sb-aclrepl (:use "COMMON-LISP" "SB-EXT") (:shadowing-import-from "SB-IMPL" "SCRUB-CONTROL-STACK") - (:shadowing-import-from "SB-INT" "*REPL-PROMPT-FUN*" "*REPL-READ-FORM-FUN*" "*STEP*" "*STEPPING*") + (:shadowing-import-from "SB-INT" "*REPL-PROMPT-FUN*" "*REPL-READ-FORM-FUN*") (:export ;; user-level customization of UI "*PROMPT*" "*EXIT-ON-EOF*" "*MAX-HISTORY*" @@ -40,9 +40,9 @@ (loop (unwind-protect (rep-one) - ;; reset toplevel step-condition handler - (setf *step* nil - *stepping* nil)))) + ;; if we started stepping in the debugger, now is the + ;; time to stop + (sb-impl::disable-stepping)))) (declare (ignore reason-param)) (cond ((and (eq reason :inspect) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 84d8418..4559697 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -933,9 +933,14 @@ ;;; Return a LAMBDA form which can be used to set a slot. (defun slot-setter-lambda-form (dd dsd) - `(lambda (new-value instance) - ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd)) - '(dummy new-value instance)))) + ;; KLUDGE: Evaluating the results of SLOT-ACCESSOR-TRANSFORMS needs + ;; a lexenv. + (let ((sb!c:*lexenv* (if (boundp 'sb!c:*lexenv*) + sb!c:*lexenv* + (sb!c::make-null-lexenv)))) + `(lambda (new-value instance) + ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd)) + '(dummy new-value instance))))) ;;; core compile-time setup of any class with a LAYOUT, used even by ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index e633b96..23c6996 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -589,28 +589,33 @@ (defun ir1-convert-var (start next result name) (declare (type ctran start next) (type (or lvar null) result) (symbol name)) (let ((var (or (lexenv-find name vars) (find-free-var name)))) - (etypecase var - (leaf - (when (lambda-var-p var) - (let ((home (ctran-home-lambda-or-null start))) - (when home - (sset-adjoin var (lambda-calls-or-closes home)))) - (when (lambda-var-ignorep var) - ;; (ANSI's specification for the IGNORE declaration requires - ;; that this be a STYLE-WARNING, not a full WARNING.) - #-sb-xc-host - (compiler-style-warn "reading an ignored variable: ~S" name) - ;; there's no need for us to accept ANSI's lameness when - ;; processing our own code, though. - #+sb-xc-host - (warn "reading an ignored variable: ~S" name))) - (reference-leaf start next result var)) - (cons - (aver (eq (car var) 'macro)) - ;; FIXME: [Free] type declarations. -- APD, 2002-01-26 - (ir1-convert start next result (cdr var))) - (heap-alien-info - (ir1-convert start next result `(%heap-alien ',var))))) + (if (and (global-var-p var) (not result)) + ;; KLUDGE: If the reference is dead, convert using SYMBOL-VALUE + ;; which is not flushable, so that unbound dead variables signal + ;; an error (bug 412). + (ir1-convert start next result `(symbol-value ',name)) + (etypecase var + (leaf + (when (lambda-var-p var) + (let ((home (ctran-home-lambda-or-null start))) + (when home + (sset-adjoin var (lambda-calls-or-closes home)))) + (when (lambda-var-ignorep var) + ;; (ANSI's specification for the IGNORE declaration requires + ;; that this be a STYLE-WARNING, not a full WARNING.) + #-sb-xc-host + (compiler-style-warn "reading an ignored variable: ~S" name) + ;; there's no need for us to accept ANSI's lameness when + ;; processing our own code, though. + #+sb-xc-host + (warn "reading an ignored variable: ~S" name))) + (reference-leaf start next result var)) + (cons + (aver (eq (car var) 'macro)) + ;; FIXME: [Free] type declarations. -- APD, 2002-01-26 + (ir1-convert start next result (cdr var))) + (heap-alien-info + (ir1-convert start next result `(%heap-alien ',var)))))) (values)) ;;; Find a compiler-macro for a form, taking FUNCALL into account. diff --git a/src/compiler/xref.lisp b/src/compiler/xref.lisp index 40c0d37..4ea73e4 100644 --- a/src/compiler/xref.lisp +++ b/src/compiler/xref.lisp @@ -26,7 +26,8 @@ ;; Note that this code can get executed several times ;; for the same block, if the functional is referenced ;; from multiple XEPs. - (loop for node = (ctran-next this-cont) then (ctran-next (node-next node)) + (loop for node = (ctran-next this-cont) + then (ctran-next (node-next node)) until (eq node last) do (record-node-xrefs node functional)) ;; Properly record the deferred macroexpansion information @@ -80,7 +81,14 @@ (defun record-node-xrefs (node context) (declare (type node node)) (etypecase node - ((or creturn cif entry combination mv-combination cast)) + ((or creturn cif entry mv-combination cast)) + (combination + ;; Record references to globals made using SYMBOL-VALUE. + (let ((fun (principal-lvar-use (combination-fun node))) + (arg (car (combination-args node)))) + (when (and (ref-p fun) (eq 'symbol-value (leaf-%source-name (ref-leaf fun))) + (constant-lvar-p arg) (symbolp (lvar-value arg))) + (record-xref :references (lvar-value arg) context node nil)))) (ref (let ((leaf (ref-leaf node))) (typecase leaf diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index ff91c66..64acb35 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2215,3 +2215,14 @@ 0) (division-by-zero () :error))))) + +;;; Dead unbound variable (bug 412) +(with-test (:name :dead-unbound) + (assert (eq :error + (handler-case + (funcall (compile nil + '(lambda () + #:unbound + 42))) + (unbound-variable () + :error))))) diff --git a/version.lisp-expr b/version.lisp-expr index 5dec045..6355e03 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,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.4.44" +"1.0.4.45" -- 1.7.10.4