From 6a6735b1da0967fcbe59ec8634ef422121a87d75 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 10 Apr 2011 12:22:35 +0000 Subject: [PATCH] protect compile-time side-effects of DEFUN with a package-lock Ie. proclaiming as a function, possibly nuking existing inline definitions. Fixes lp#675584. Now compiling a file with (DEFUN LOCKED:FOO ...) signals a compile-time error. (WITHOUT-PACKAGE-LOCKS (DEFUN LOCKED:FOO ...)) still works, as the DEFUN stops being a toplevel form, and hence no longer has compile-time side effects except for those inherent to compiling a NAMED-LAMBDA. --- NEWS | 2 ++ src/code/defboot.lisp | 5 +++++ src/compiler/ir1tran-lambda.lisp | 37 +++++++++++++++++++++---------------- tests/package-locks.impure.lisp | 15 +++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 44 insertions(+), 17 deletions(-) diff --git a/NEWS b/NEWS index 2bee762..dabff33 100644 --- a/NEWS +++ b/NEWS @@ -20,6 +20,8 @@ changes relative to sbcl-1.0.47: * bug fix: less verbose source forms for functions from EVAL. (lp#747485) * bug fix: sense of SLOT-BOUNDP-USING-CLASS was inverted in a MAKE-INSTANCE optimization. (regression from 1.0.45.18/1.0.46.15) + * bug fix: package locks did not protects against compile-time side-effects + of DEFUN. (lp#675584) changes in sbcl-1.0.47 relative to sbcl-1.0.46: * bug fix: fix mach port rights leaks in mach exception handling code on diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index c7113c4..85f00c5 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -229,6 +229,11 @@ evaluated as a PROGN." :new-function def :new-location source-location)) (setf (sb!xc:fdefinition name) def) + ;; %COMPILER-DEFUN doesn't do this except at compile-time, when it + ;; also checks package locks. By doing this here we let (SETF + ;; FDEFINITION) do the load-time package lock checking before + ;; we frob any existing inline expansions. + (sb!c::%set-inline-expansion name nil inline-lambda) (sb!c::note-name-defined name :function) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 3374deb..0404588 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -1210,34 +1210,39 @@ (substitute-leaf fun var)) fun)) +(defun %set-inline-expansion (name defined-fun inline-lambda) + (cond (inline-lambda + (setf (info :function :inline-expansion-designator name) + inline-lambda) + (when defined-fun + (setf (defined-fun-inline-expansion defined-fun) + inline-lambda))) + (t + (clear-info :function :inline-expansion-designator name)))) + ;;; the even-at-compile-time part of DEFUN ;;; -;;; The INLINE-EXPANSION is a LAMBDA-WITH-LEXENV, or NIL if there is -;;; no inline expansion. -(defun %compiler-defun (name lambda-with-lexenv compile-toplevel) +;;; The INLINE-LAMBDA is a LAMBDA-WITH-LEXENV, or NIL if there is no +;;; inline expansion. +(defun %compiler-defun (name inline-lambda compile-toplevel) (let ((defined-fun nil)) ; will be set below if we're in the compiler (when compile-toplevel - (setf defined-fun (if lambda-with-lexenv - (get-defined-fun name (fifth lambda-with-lexenv)) - (get-defined-fun name))) + (with-single-package-locked-error + (:symbol name "defining ~S as a function") + (setf defined-fun + (if inline-lambda + (get-defined-fun name (fifth inline-lambda)) + (get-defined-fun name)))) (when (boundp '*lexenv*) (remhash name *free-funs*) (aver (fasl-output-p *compile-object*)) (if (member name *fun-names-in-this-file* :test #'equal) (warn 'duplicate-definition :name name) - (push name *fun-names-in-this-file*)))) + (push name *fun-names-in-this-file*))) + (%set-inline-expansion name defined-fun inline-lambda)) (become-defined-fun-name name) - (cond (lambda-with-lexenv - (setf (info :function :inline-expansion-designator name) - lambda-with-lexenv) - (when defined-fun - (setf (defined-fun-inline-expansion defined-fun) - lambda-with-lexenv))) - (t - (clear-info :function :inline-expansion-designator name))) - ;; old CMU CL comment: ;; If there is a type from a previous definition, blast it, ;; since it is obsolete. diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index 5a95e18..3ba97a1 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -535,4 +535,19 @@ (setf (macro-function 'to-die-for) (constantly :replacement2)))))) (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for))))) +(with-test (:name :compile-time-defun-package-locked) + ;; Make sure compile-time side-effects of DEFUN are protected against. + (let ((inline-lambda (function-lambda-expression #'fill-pointer))) + ;; Make sure it's actually inlined... + (assert inline-lambda) + (assert (eq :ok + (handler-case + (ctu:file-compile `((defun fill-pointer (x) x))) + (sb-ext:symbol-package-locked-error (e) + (when (eq 'fill-pointer + (sb-ext:package-locked-error-symbol e)) + :ok))))) + (assert (equal inline-lambda + (function-lambda-expression #'fill-pointer))))) + ;;; WOOT! Done. diff --git a/version.lisp-expr b/version.lisp-expr index 7a57d74..f75dc23 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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.47.20" +"1.0.47.21" -- 1.7.10.4