better encapsulation support in generic functions

It's not very nice to alter the fdefinition of names which refer to
generic functions: it might not be strictly required by the spec, but
preserving the class of generic functions when encapsulated is more
friendly, so that attempts to trace or profile them doesn't break any
metaobject protocol logic which refers to particular functions by
name.  Fortunately, it's fairly straightforward to
support (un)encapsulation of generic functions through adapting the
discriminating function instead.

diff --git a/NEWS b/NEWS
index e42e100..d294148 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,5 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.1.14:
-  * improvement: support for "Mac Roman" external format.
   * new feature: the iterative spilling/coloring register allocator developed
     by Alexandra Barchunova during Google Summer of Code 2013 is now merged
     in.  By default, it only activates for functions that optimize with
@@ -20,6 +19,9 @@ changes relative to sbcl-1.1.14:
     conservative roots must be valid-looking tagged pointers or point
     within a code object, not merely point to within the allocated part
     of a page, in order to pin a page.
+  * enhancement: support for "Mac Roman" external format.
+  * enhancement: encapsulation of named generic functions now happens without
+    altering the identity of the function bound to the name.
   * bug fix: Windows applications without the console window no longer misbehave.
     (patch by Wilfredo Velazquez, lp#1256034).
   * bug fix: modular arithmetic optimizations do not stumble on dead branches

diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp
index a23c0e4..f004d2d 100644 (file)
--- a/src/code/fdefinition.lisp
+++ b/src/code/fdefinition.lisp
@@ -106,6 +106,9 @@
   (let ((fdefn (fdefinition-object name nil)))
     (unless (and fdefn (fdefn-fun fdefn))
       (error 'undefined-function :name name))
+    (when (typep (fdefn-fun fdefn) 'generic-function)
+      (return-from encapsulate
+        (encapsulate-generic-function (fdefn-fun fdefn) type body)))
     ;; We must bind and close over INFO. Consider the case where we
     ;; encapsulate (the second) an encapsulated (the first)
     ;; definition, and later someone unencapsulates the encapsulated
@@ -153,6 +156,9 @@
   (let* ((fdefn (fdefinition-object name nil))
          (encap-info (encapsulation-info (fdefn-fun fdefn))))
     (declare (type (or encapsulation-info null) encap-info))
+    (when (and fdefn (typep (fdefn-fun fdefn) 'generic-function))
+      (return-from unencapsulate
+        (unencapsulate-generic-function (fdefn-fun fdefn) type)))
     (cond ((not encap-info)
            ;; It disappeared on us, so don't worry about it.
            )
@@ -179,6 +185,9 @@
 ;;; Does NAME have an encapsulation of the given TYPE?
 (defun encapsulated-p (name type)
   (let ((fdefn (fdefinition-object name nil)))
+    (when (and fdefn (typep (fdefn-fun fdefn) 'generic-function))
+      (return-from encapsulated-p
+        (encapsulated-generic-function-p (fdefn-fun fdefn) type)))
     (do ((encap-info (encapsulation-info (fdefn-fun fdefn))
                      (encapsulation-info
                       (encapsulation-info-definition encap-info))))

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index 597a1b2..6ac72de 100644 (file)
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -307,9 +307,7 @@
                             definition-source-mixin
                             metaobject
                             funcallable-standard-object)
-  ((%documentation
-    :initform nil
-    :initarg :documentation)
+  ((%documentation :initform nil :initarg :documentation)
    ;; We need to make a distinction between the methods initially set
    ;; up by :METHOD options to DEFGENERIC and the ones set up later by
    ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
@@ -321,9 +319,8 @@
    ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
    ;; tends to leave the generic function in a state consistent with
    ;; the most-recently-loaded state of a.lisp and b.lisp.)
-   (initial-methods
-    :initform ()
-    :accessor generic-function-initial-methods))
+   (initial-methods :initform () :accessor generic-function-initial-methods)
+   (encapsulations :initform () :accessor generic-function-encapsulations))
   (:metaclass funcallable-standard-class))
 
 (defclass standard-generic-function (generic-function)

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index efbd482..6d37569 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -1556,74 +1556,106 @@
       (eq gf #'(setf slot-value-using-class))
       (eq gf #'slot-boundp-using-class)))
 
+;;; this is the normal function for computing the discriminating
+;;; function of a standard-generic-function
 (let (initial-print-object-cache)
-  (defmethod compute-discriminating-function ((gf standard-generic-function))
+  (defun standard-compute-discriminating-function (gf)
     (let ((dfun-state (slot-value gf 'dfun-state)))
-      (when (special-case-for-compute-discriminating-function-p gf)
-        ;; if we have a special case for
-        ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
-        ;; special cases implemented as of 2006-05-09) any information
-        ;; in the cache is misplaced.
-        (aver (null dfun-state)))
-      (typecase dfun-state
-        (null
-         (when (eq gf #'compute-applicable-methods)
-           (update-all-c-a-m-gf-info gf))
-         (cond
-           ((eq gf #'slot-value-using-class)
-            (update-slot-value-gf-info gf 'reader)
-            #'slot-value-using-class-dfun)
-           ((eq gf #'(setf slot-value-using-class))
-            (update-slot-value-gf-info gf 'writer)
-            #'setf-slot-value-using-class-dfun)
-           ((eq gf #'slot-boundp-using-class)
-            (update-slot-value-gf-info gf 'boundp)
-            #'slot-boundp-using-class-dfun)
-           ;; KLUDGE: PRINT-OBJECT is not a special-case in the sense
-           ;; of having a desperately special discriminating function.
-           ;; However, it is important that the machinery for printing
-           ;; conditions for stack and heap exhaustion, and the
-           ;; restarts offered by the debugger, work without consuming
-           ;; many extra resources.  This way (testing by name of GF
-           ;; rather than by identity) was the only way I found to get
-           ;; this to bootstrap, given that the PRINT-OBJECT generic
-           ;; function is only set up later, in
-           ;; SRC;PCL;PRINT-OBJECT.LISP.  -- CSR, 2008-06-09
-           ((eq (slot-value gf 'name) 'print-object)
-            (let ((nkeys (nth-value 3 (get-generic-fun-info gf))))
-              (cond ((/= nkeys 1)
-                     ;; KLUDGE: someone has defined a method
-                     ;; specialized on the second argument: punt.
-                     (setf initial-print-object-cache nil)
-                     (make-initial-dfun gf))
-                    (initial-print-object-cache
-                     (multiple-value-bind (dfun cache info)
-                         (make-caching-dfun gf (copy-cache initial-print-object-cache))
-                       (set-dfun gf dfun cache info)))
-                    ;; the relevant PRINT-OBJECT methods get defined
-                    ;; late, by delayed DEF!METHOD.  We mustn't cache
-                    ;; the effective method for our classes earlier
-                    ;; than the relevant PRINT-OBJECT methods are
-                    ;; defined...
-                    ((boundp 'sb-impl::*delayed-def!method-args*)
-                     (make-initial-dfun gf))
-                    (t (multiple-value-bind (dfun cache info)
-                           (make-final-dfun-internal
-                            gf
-                            (mapcar (lambda (x) (list (find-class x)))
-                                    '(sb-kernel::control-stack-exhausted
-                                      sb-kernel::binding-stack-exhausted
-                                      sb-kernel::alien-stack-exhausted
-                                      sb-kernel::heap-exhausted-error
-                                      restart)))
-                         (setq initial-print-object-cache cache)
-                         (set-dfun gf dfun (copy-cache cache) info))))))
-           ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info))
-            (make-final-dfun gf))
-           (t
-            (make-initial-dfun gf))))
-        (function dfun-state)
-        (cons (car dfun-state))))))
+          (when (special-case-for-compute-discriminating-function-p gf)
+            ;; if we have a special case for
+            ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
+            ;; special cases implemented as of 2006-05-09) any information
+            ;; in the cache is misplaced.
+            (aver (null dfun-state)))
+          (typecase dfun-state
+            (null
+             (when (eq gf #'compute-applicable-methods)
+               (update-all-c-a-m-gf-info gf))
+             (cond
+               ((eq gf #'slot-value-using-class)
+                (update-slot-value-gf-info gf 'reader)
+                #'slot-value-using-class-dfun)
+               ((eq gf #'(setf slot-value-using-class))
+                (update-slot-value-gf-info gf 'writer)
+                #'setf-slot-value-using-class-dfun)
+               ((eq gf #'slot-boundp-using-class)
+                (update-slot-value-gf-info gf 'boundp)
+                #'slot-boundp-using-class-dfun)
+               ;; KLUDGE: PRINT-OBJECT is not a special-case in the sense
+               ;; of having a desperately special discriminating function.
+               ;; However, it is important that the machinery for printing
+               ;; conditions for stack and heap exhaustion, and the
+               ;; restarts offered by the debugger, work without consuming
+               ;; many extra resources.  This way (testing by name of GF
+               ;; rather than by identity) was the only way I found to get
+               ;; this to bootstrap, given that the PRINT-OBJECT generic
+               ;; function is only set up later, in
+               ;; SRC;PCL;PRINT-OBJECT.LISP.  -- CSR, 2008-06-09
+               ((eq (slot-value gf 'name) 'print-object)
+                (let ((nkeys (nth-value 3 (get-generic-fun-info gf))))
+                  (cond ((/= nkeys 1)
+                         ;; KLUDGE: someone has defined a method
+                         ;; specialized on the second argument: punt.
+                         (setf initial-print-object-cache nil)
+                         (make-initial-dfun gf))
+                        (initial-print-object-cache
+                         (multiple-value-bind (dfun cache info)
+                             (make-caching-dfun gf (copy-cache initial-print-object-cache))
+                           (set-dfun gf dfun cache info)))
+                        ;; the relevant PRINT-OBJECT methods get defined
+                        ;; late, by delayed DEF!METHOD.  We mustn't cache
+                        ;; the effective method for our classes earlier
+                        ;; than the relevant PRINT-OBJECT methods are
+                        ;; defined...
+                        ((boundp 'sb-impl::*delayed-def!method-args*)
+                         (make-initial-dfun gf))
+                        (t (multiple-value-bind (dfun cache info)
+                               (make-final-dfun-internal
+                                gf
+                                (mapcar (lambda (x) (list (find-class x)))
+                                        '(sb-kernel::control-stack-exhausted
+                                          sb-kernel::binding-stack-exhausted
+                                          sb-kernel::alien-stack-exhausted
+                                          sb-kernel::heap-exhausted-error
+                                          restart)))
+                             (setq initial-print-object-cache cache)
+                             (set-dfun gf dfun (copy-cache cache) info))))))
+               ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info))
+                (make-final-dfun gf))
+               (t
+                (make-initial-dfun gf))))
+            (function dfun-state)
+            (cons (car dfun-state))))))
+
+;;; in general we need to support SBCL's encapsulation for generic
+;;; functions: the default implementation of encapsulation changes the
+;;; identity of the function bound to a name, which breaks anything
+;;; class-based, so we implement the encapsulation ourselves in the
+;;; discriminating function.
+(defun sb-impl::encapsulate-generic-function (gf type body)
+  (push (cons type body) (generic-function-encapsulations gf))
+  (reinitialize-instance gf))
+(defun sb-impl::unencapsulate-generic-function (gf type)
+  (setf (generic-function-encapsulations gf)
+        (remove type (generic-function-encapsulations gf)
+                :key #'car :count 1))
+  (reinitialize-instance gf))
+(defun sb-impl::encapsulated-generic-function-p (gf type)
+  (position type (generic-function-encapsulations gf) :key #'car))
+(defun standard-compute-discriminating-function-with-encapsulations (gf encs)
+  (if (null encs)
+      (standard-compute-discriminating-function gf)
+      (let ((inner (standard-compute-discriminating-function-with-encapsulations
+                    gf (cdr encs)))
+            (body (cdar encs)))
+        (lambda (&rest args)
+          (let ((sb-int:arg-list args)
+                (sb-int:basic-definition inner))
+            (declare (special sb-int:arg-list sb-int:basic-definition))
+            (eval body))))))
+(defmethod compute-discriminating-function ((gf standard-generic-function))
+  (standard-compute-discriminating-function-with-encapsulations
+   gf (generic-function-encapsulations gf)))
 \f
 (defmethod (setf class-name) (new-value class)
   (let ((classoid (wrapper-classoid (class-wrapper class))))

diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp
index da179ed..63e7c7a 100644 (file)
--- a/tests/interface.impure.lisp
+++ b/tests/interface.impure.lisp
@@ -328,5 +328,18 @@
        (declare (ignore x))
        nil))))
 
+(with-test (:name (trace generic-function))
+  (defgeneric traced-gf (x))
+  (defmethod traced-gf (x) (1+ x))
+  (assert (= (traced-gf 3) 4))
+  (trace traced-gf)
+  (let ((output (with-output-to-string (*trace-output*)
+                  (assert (= (traced-gf 3) 4)))))
+    (assert (> (length output) 0)))
+  (assert (typep #'traced-gf 'standard-generic-function))
+  (untrace traced-gf)
+  (let ((output (with-output-to-string (*trace-output*)
+                  (assert (= (traced-gf 3) 4)))))
+    (assert (= (length output) 0))))
 \f
 ;;;; success