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.

diff --git a/NEWS b/NEWS
index 2bee762..dabff33 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"