[Guile-commits] 88/88: Simplify and optimize slot access

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 4bde3f04ea2c573a871b5f377b5f41d970dc8ebe
Author: Andy Wingo <address@hidden>
Date:   Fri Jan 23 14:55:35 2015 +0100

    Simplify and optimize slot access
    
    * module/oop/goops.scm (fold-slot-slots): Add `slot-ref/raw' slot, which
      is what the slot-ref slot was.  Now the slot-ref slot checks that the
      slot is bound, if needed.
      (slot-definition-slot-ref/raw): Define.
      (make-slot): Adapt.  Also, effective slot definition slots have no
      initargs.
      (define-standard-accessor-method, bound-check-get, standard-get)
      (standard-set): Move definitions up.
      (allocate-slots): Adapt.  If the slot has an init thunk, we don't need
      to check that it's bound.
      (slot-ref, slot-set!, slot-bound?): Simplify.
      (class-slot-ref): Use the raw getter so that we can call
      `slot-unbound' with just the class.
      (compute-getter-method, compute-setter-method): Simplify to just use
      the slot-ref / slot-set! functions from the slot.
      (%initialize-object): Simplify.
---
 module/oop/goops.scm |  153 ++++++++++++++++++++++----------------------------
 1 files changed, 68 insertions(+), 85 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index e7df368..1c4fd7d 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -208,6 +208,7 @@
   (accessor #:init-keyword #:accessor #:init-value #f)
   ;; These last don't have #:init-keyword because they are meant to be
   ;; set by `allocate-slots', not in compute-effective-slot-definition.
+  (slot-ref/raw #:init-value #f)
   (slot-ref #:init-value #f)
   (slot-set! #:init-value #f)
   (index #:init-value #f)
@@ -476,11 +477,14 @@ followed by its associated value.  If @var{l} does not 
hold a value for
 (define-slot-accessor slot-definition-accessor
   "Return the accessor of the slot @var{obj}, or @code{#f}."
    %slot-definition-accessor slot-index-accessor)
+(define-slot-accessor slot-definition-slot-ref/raw
+  "Return the raw slot-ref procedure of the slot @var{obj}."
+   %slot-definition-slot-ref/raw slot-index-slot-ref/raw)
 (define-slot-accessor slot-definition-slot-ref
-  "Return the slot-ref procedure of the slot @var{obj}, or @code{#f}."
+  "Return the slot-ref procedure of the slot @var{obj}."
    %slot-definition-slot-ref slot-index-slot-ref)
 (define-slot-accessor slot-definition-slot-set!
-  "Return the slot-set! procedure of the slot @var{obj}, or @code{#f}."
+  "Return the slot-set! procedure of the slot @var{obj}."
    %slot-definition-slot-set! slot-index-slot-set!)
 (define-slot-accessor slot-definition-index
   "Return the allocated struct offset of the slot @var{obj}, or @code{#f}."
@@ -513,10 +517,11 @@ followed by its associated value.  If @var{l} does not 
hold a value for
     (init-slot slot-index-getter #:getter #f)
     (init-slot slot-index-setter #:setter #f)
     (init-slot slot-index-accessor #:accessor #f)
-    (init-slot slot-index-slot-ref #:slot-ref #f)
-    (init-slot slot-index-slot-set! #:slot-set! #f)
-    (init-slot slot-index-index #:index #f)
-    (init-slot slot-index-size #:size #f)
+    (struct-set! slot slot-index-slot-ref/raw #f)
+    (struct-set! slot slot-index-slot-ref #f)
+    (struct-set! slot slot-index-slot-set! #f)
+    (struct-set! slot slot-index-index #f)
+    (struct-set! slot slot-index-size #f)
     slot))
 
 ;; Boot definition.
@@ -678,6 +683,35 @@ followed by its associated value.  If @var{l} does not 
hold a value for
     (struct-set! class class-index-nfields (1+ index))
     index))
 
+;;; Pre-generate getters and setters for the first 20 slots.
+(define-syntax define-standard-accessor-method
+  (lambda (stx)
+    (define num-standard-pre-cache 20)
+    (syntax-case stx ()
+      ((_ ((proc n) arg ...) body)
+       #`(define proc
+           (let ((cache (vector #,@(map (lambda (n*)
+                                          #`(lambda (arg ...)
+                                              (let ((n #,n*))
+                                                body)))
+                                        (iota num-standard-pre-cache)))))
+             (lambda (n)
+               (if (< n #,num-standard-pre-cache)
+                   (vector-ref cache n)
+                   (lambda (arg ...) body)))))))))
+
+(define-standard-accessor-method ((bound-check-get n) o)
+  (let ((x (struct-ref o n)))
+    (if (unbound? x)
+        (slot-unbound o)
+        x)))
+
+(define-standard-accessor-method ((standard-get n) o)
+  (struct-ref o n))
+
+(define-standard-accessor-method ((standard-set n) o v)
+  (struct-set! o n v))
+
 (define (allocate-slots class slots)
   "Transform the computed list of direct slot definitions @var{slots}
 into a corresponding list of effective slot definitions, allocating
@@ -687,6 +721,7 @@ slots as we go."
     ;; allocates a field to the object.  Pretty strange, but we preserve
     ;; the behavior for backward compatibility.
     (let* ((slot (compute-effective-slot-definition class slot))
+           (name (%slot-definition-name slot))
            (index (struct-ref class class-index-nfields))
            (g-n-s (compute-get-n-set class slot))
            (size (- (struct-ref class class-index-nfields) index)))
@@ -696,14 +731,25 @@ slots as we go."
               ((? integer?)
                (unless (= size 1)
                  (error "unexpected return from compute-get-n-set"))
-               (values #f #f))
+               (values (standard-get g-n-s)
+                       (if (slot-definition-init-thunk slot)
+                           (standard-get g-n-s)
+                           (bound-check-get g-n-s))
+                       (standard-set g-n-s)))
               (((? procedure? get) (? procedure? set))
-               (values get set))))
-        (lambda (get set)
-          (struct-set! slot slot-index-index index)
-          (struct-set! slot slot-index-size size)
+               (values get
+                       (lambda (o)
+                         (let ((value (get o)))
+                           (if (unbound? value)
+                               (slot-unbound class o name)
+                               value)))
+                       set))))
+        (lambda (get/raw get set)
+          (struct-set! slot slot-index-slot-ref/raw get/raw)
           (struct-set! slot slot-index-slot-ref get)
-          (struct-set! slot slot-index-slot-set! set)))
+          (struct-set! slot slot-index-slot-set! set)
+          (struct-set! slot slot-index-index index)
+          (struct-set! slot slot-index-size size)))
       slot))
   (struct-set! class class-index-nfields 0)
   (map-in-order make-effective-slot-definition slots))
@@ -1081,17 +1127,8 @@ function."
 (define (slot-ref obj slot-name)
   "Return the value from @var{obj}'s slot with the nam var{slot_name}."
   (let ((class (class-of obj)))
-    (define (slot-value slot)
-      (cond
-       ((%slot-definition-slot-ref slot)
-        => (lambda (slot-ref) (slot-ref obj)))
-       (else
-        (struct-ref obj (%slot-definition-index slot)))))
     (define (have-slot slot)
-      (let ((val (slot-value slot)))
-        (if (unbound? val)
-            (slot-unbound class obj slot-name)
-            val)))
+      ((%slot-definition-slot-ref slot) obj))
     (define (no-slot)
       (unless (symbol? slot-name)
         (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
@@ -1106,11 +1143,7 @@ function."
   "Set the slot named @var{slot_name} of @var{obj} to @var{value}."
   (let ((class (class-of obj)))
     (define (have-slot slot)
-      (cond
-       ((%slot-definition-slot-set! slot)
-        => (lambda (slot-set!) (slot-set! obj value)))
-       (else
-        (struct-set! obj (%slot-definition-index slot) value))))
+      ((%slot-definition-slot-set! slot) obj value))
     (define (no-slot)
       (unless (symbol? slot-name)
         (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
@@ -1122,22 +1155,13 @@ function."
 (define (slot-bound? obj slot-name)
   "Return the value from @var{obj}'s slot with the nam var{slot_name}."
   (let ((class (class-of obj)))
-    (define (slot-value slot)
-      (cond
-       ((%slot-definition-slot-ref slot)
-        => (lambda (slot-ref) (slot-ref obj)))
-       (else
-        (struct-ref obj (%slot-definition-index slot)))))
     (define (have-slot slot)
-      (not (unbound? (slot-value slot))))
+      (not (unbound? ((%slot-definition-slot-ref/raw slot) obj))))
     (define (no-slot)
       (unless (symbol? slot-name)
         (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
                    (list slot-name) #f))
-      (let ((val (slot-missing class obj slot-name)))
-        (if (unbound? val)
-            (slot-unbound class obj slot-name)
-            val)))
+      (not (unbound? (slot-missing class obj slot-name))))
     (%class-slot-definition class slot-name have-slot no-slot)))
 
 (define (slot-exists? obj slot-name)
@@ -2408,7 +2432,7 @@ function."
   (let ((slot (class-slot-definition class slot-name)))
     (unless (memq (%slot-definition-allocation slot) '(#:class 
#:each-subclass))
       (slot-missing class slot-name))
-    (let ((x ((%slot-definition-slot-ref slot) #f)))
+    (let ((x ((%slot-definition-slot-ref/raw slot) #f)))
       (if (unbound? x)
           (slot-unbound class slot-name)
           x))))
@@ -2611,25 +2635,17 @@ function."
    slots))
 
 (define-method (compute-getter-method (class <class>) slot)
-  (let ((init-thunk (slot-definition-init-thunk slot))
-        (slot-ref (slot-definition-slot-ref slot))
-        (index (slot-definition-index slot)))
+  (let ((slot-ref (slot-definition-slot-ref slot)))
     (make <accessor-method>
           #:specializers (list class)
-          #:procedure (cond
-                       (slot-ref (make-generic-bound-check-getter slot-ref))
-                       (init-thunk (standard-get index))
-                       (else (bound-check-get index)))
+          #:procedure slot-ref
           #:slot-definition slot)))
 
 (define-method (compute-setter-method (class <class>) slot)
-  (let ((slot-set! (slot-definition-slot-set! slot))
-        (index (slot-definition-index slot)))
+  (let ((slot-set! (slot-definition-slot-set! slot)))
     (make <accessor-method>
       #:specializers (list class <top>)
-      #:procedure (cond
-                   (slot-set! slot-set!)
-                   (else (standard-set index)))
+      #:procedure slot-set!
       #:slot-definition slot)))
 
 (define (make-generic-bound-check-getter proc)
@@ -2639,35 +2655,6 @@ function."
           (slot-unbound o)
           val))))
 
-;;; Pre-generate getters and setters for the first 20 slots.
-(define-syntax define-standard-accessor-method
-  (lambda (stx)
-    (define num-standard-pre-cache 20)
-    (syntax-case stx ()
-      ((_ ((proc n) arg ...) body)
-       #`(define proc
-           (let ((cache (vector #,@(map (lambda (n*)
-                                          #`(lambda (arg ...)
-                                              (let ((n #,n*))
-                                                body)))
-                                        (iota num-standard-pre-cache)))))
-             (lambda (n)
-               (if (< n #,num-standard-pre-cache)
-                   (vector-ref cache n)
-                   (lambda (arg ...) body)))))))))
-
-(define-standard-accessor-method ((bound-check-get n) o)
-  (let ((x (struct-ref o n)))
-    (if (unbound? x)
-        (slot-unbound o)
-        x)))
-
-(define-standard-accessor-method ((standard-get n) o)
-  (struct-ref o n))
-
-(define-standard-accessor-method ((standard-set n) o v)
-  (struct-set! o n v))
-
 ;;; compute-cpl
 ;;;
 
@@ -2778,11 +2765,7 @@ var{initargs}."
         (() obj)
         ((slot . slots)
          (define (initialize-slot! value)
-           (cond
-            ((%slot-definition-slot-set! slot)
-             => (lambda (slot-set!) (slot-set! obj value)))
-            (else
-             (struct-set! obj (%slot-definition-index slot) value))))
+           ((%slot-definition-slot-set! slot) obj value))
          (let ((initarg (get-initarg (%slot-definition-init-keyword slot))))
            (cond
             ((not (unbound? initarg))