From: Andy Wingo <wingo@pobox.com>
Date: Sat, 24 Jan 2015 17:59:15 +0000 (+0100)
Subject: Fix accessor struct inlining in GOOPS
X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/e7097386cb28f04cfeedc11415b06623ee2ac70c

Fix accessor struct inlining in GOOPS

Fixes bug #17355.

* module/oop/goops.scm (memoize-effective-method!): Adapt to
  compute-effective-method change.
  (compute-effective-method, %compute-effective-method): Renamed from
  compute-cmethod; now a generic protocol.
  (compute-specialized-effective-method)
  (%compute-specialized-effective-method): New sub-protocol.
  (memoize-generic-function-application!): Adapt to call the hard-wired
  compute-applicable-methods based on the concrete arguments types --
  the semantics is that %compute-applicable-methods is the
  implementation for <generic> functions.  Perhaps we should do the same
  for sort-applicable-methods and method-more-specific?.
  (compute-getter-method, compute-setter-method): The standard
  #:procedure is now a generic slot-ref.  It wasn't valid to inline
  field access here, because subtypes could have different field
  layouts.
  (compute-applicable-methods): Refactor generic definition to use
  lexical scoping.
  (compute-specialized-effective-method): New method for
  <accessor-method>, which does field access inlining based on the
  concrete types being applied.

* test-suite/tests/goops.test ("accessor slots"): New test.
---

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 1c4fd7de2..01ca7825c 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1465,7 +1465,10 @@ function."
              (lp (1+ n) args)))))
       typev))
   (let* ((typev (record-types args))
-         (cmethod (compute-cmethod applicable typev))
+         (compute-effective-method (if (eq? (class-of gf) <generic>)
+                                       %compute-effective-method
+                                       compute-effective-method))
+         (cmethod (compute-effective-method gf applicable typev))
          (cache (acons typev cmethod (slot-ref gf 'effective-methods))))
     (slot-set! gf 'effective-methods cache)
     (recompute-generic-function-dispatch-procedure! gf)
@@ -1482,26 +1485,44 @@ function."
 ;;; An effective method is bound to a specific `next-method' by the
 ;;; `make-procedure' slot of a <method>, which returns the new closure.
 ;;;
-(define (compute-cmethod methods types)
+(define (%compute-specialized-effective-method gf method types next-method)
+  (match (slot-ref method 'make-procedure)
+    (#f (method-procedure method))
+    (make-procedure (make-procedure next-method))))
+
+(define (compute-specialized-effective-method gf method types next-method)
+  (%compute-specialized-effective-method gf method types next-method))
+
+(define (%compute-effective-method gf methods types)
   (match methods
     ((method . methods)
-     (match (slot-ref method 'make-procedure)
-       (#f (method-procedure method))
-       (make-procedure
-        (make-procedure
-         (match methods
-           (()
-            (lambda args
-              (no-next-method (method-generic-function method) args)))
-           (methods
-            (compute-cmethod methods types)))))))))
+     (let ((compute-specialized-effective-method
+            (if (and (eq? (class-of gf) <generic>)
+                     (eq? (class-of method) <method>))
+                %compute-specialized-effective-method
+                compute-specialized-effective-method)))
+       (compute-specialized-effective-method
+        gf method types
+        (match methods
+          (()
+           (lambda args
+             (no-next-method gf args)))
+          (methods
+           (let ((compute-effective-method (if (eq? (class-of gf) <generic>)
+                                               %compute-effective-method
+                                               compute-effective-method)))
+             (compute-effective-method gf methods types)))))))))
+
+;; Boot definition; overrided with a generic later.
+(define (compute-effective-method gf methods types)
+  (%compute-effective-method gf methods types))
 
 ;;;
 ;;; Memoization
 ;;;
 
 (define (memoize-generic-function-application! gf args)
-  (let ((applicable ((if (eq? gf compute-applicable-methods)
+  (let ((applicable ((if (eq? (class-of gf) <generic>)
                          %compute-applicable-methods
                          compute-applicable-methods)
                      gf args)))
@@ -2635,17 +2656,17 @@ function."
    slots))
 
 (define-method (compute-getter-method (class <class>) slot)
-  (let ((slot-ref (slot-definition-slot-ref slot)))
+  (let ((name (slot-definition-name slot)))
     (make <accessor-method>
           #:specializers (list class)
-          #:procedure slot-ref
+          #:procedure (lambda (o) (slot-ref o name))
           #:slot-definition slot)))
 
 (define-method (compute-setter-method (class <class>) slot)
-  (let ((slot-set! (slot-definition-slot-set! slot)))
+  (let ((name (slot-definition-name slot)))
     (make <accessor-method>
       #:specializers (list class <top>)
-      #:procedure slot-set!
+      #:procedure (lambda (o v) (slot-set! o name v))
       #:slot-definition slot)))
 
 (define (make-generic-bound-check-getter proc)
@@ -2970,14 +2991,11 @@ var{initargs}."
         (no-applicable-method gf args))))
 
 ;; compute-applicable-methods is bound to %compute-applicable-methods.
-;; *fixme* use let
-(define %%compute-applicable-methods
-  (make <generic> #:name 'compute-applicable-methods))
-
-(define-method (%%compute-applicable-methods (gf <generic>) args)
-  (%compute-applicable-methods gf args))
-
-(set! compute-applicable-methods %%compute-applicable-methods)
+(define compute-applicable-methods
+  (let ((gf (make <generic> #:name 'compute-applicable-methods)))
+    (add-method! gf (method ((gf <generic>) args)
+                      (%compute-applicable-methods gf args)))
+    gf))
 
 (define-method (sort-applicable-methods (gf <generic>) methods args)
   (%sort-applicable-methods methods (map class-of args)))
@@ -2985,6 +3003,33 @@ var{initargs}."
 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
   (%method-more-specific? m1 m2 targs))
 
+(define compute-effective-method
+  (let ((gf (make <generic> #:name 'compute-effective-method)))
+    (add-method! gf (method ((gf <generic>) methods typev)
+                      (%compute-effective-method gf methods typev)))
+    gf))
+
+(define compute-specialized-effective-method
+  (let ((gf (make <generic> #:name 'compute-specialized-effective-method)))
+    (add-method!
+     gf
+     (method ((gf <generic>) (method <method>) typev next)
+       (%compute-specialized-effective-method gf method typev next)))
+    gf))
+
+(define-method (compute-specialized-effective-method (gf <generic>)
+                                                     (m <accessor-method>)
+                                                     typev
+                                                     next)
+  (let ((name (slot-definition-name (accessor-method-slot-definition m))))
+    (match typev
+      (#(class)
+       (slot-definition-slot-ref (class-slot-definition class name)))
+      (#(class _)
+       (slot-definition-slot-set! (class-slot-definition class name)))
+      (_
+       (next-method)))))
+
 (define-method (apply-method (gf <generic>) methods build-next args)
   (apply (method-procedure (car methods))
          (build-next (cdr methods) args)
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 21b9d31a9..cb1d48331 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -621,3 +621,37 @@
   (pass-if-equal "<a>"
       (list <a> <b> <d> <c> <e> <f> <object> <top>)
     (compute-cpl <a>)))
+
+(with-test-prefix "accessor slots"
+  (let* ((a-accessor (make-accessor 'a))
+         (b-accessor (make-accessor 'b))
+         (<a> (class ()
+                (a #:init-keyword #:a #:accessor a-accessor)
+                #:name '<a>))
+         (<b> (class ()
+                (b #:init-keyword #:b #:accessor b-accessor)
+                #:name '<b>))
+         (<ab> (class (<a> <b>) #:name '<ab>))
+         (<ba> (class (<b> <a>) #:name '<ba>))
+         (<cab> (class (<ab>)
+                  (a #:init-keyword #:a)
+                  #:name '<cab>))
+         (<cba> (class (<ba>)
+                  (a #:init-keyword #:a)
+                  #:name '<cba>))
+         (a (make <a> #:a 'a))
+         (b (make <b> #:b 'b))
+         (ab (make <ab> #:a 'a #:b 'b))
+         (ba (make <ba> #:a 'a #:b 'b))
+         (cab (make <cab> #:a 'a #:b 'b))
+         (cba (make <cba> #:a 'a #:b 'b)))
+    (pass-if-equal "a accessor on a" 'a (a-accessor a))
+    (pass-if-equal "a accessor on ab" 'a (a-accessor ab))
+    (pass-if-equal "a accessor on ba" 'a (a-accessor ba))
+    (pass-if-equal "a accessor on cab" 'a (a-accessor cab))
+    (pass-if-equal "a accessor on cba" 'a (a-accessor cba))
+    (pass-if-equal "b accessor on a" 'b (b-accessor b))
+    (pass-if-equal "b accessor on ab" 'b (b-accessor ab))
+    (pass-if-equal "b accessor on ba" 'b (b-accessor ba))
+    (pass-if-equal "b accessor on cab" 'b (b-accessor cab))
+    (pass-if-equal "b accessor on cba" 'b (b-accessor cba))))