[Guile-commits] 02/02: Optimize %initialize-object

[Andy Wingo]

wingo pushed a commit to branch wip-goops-refactor
in repository guile.

commit 9eac2c6cc88fe7fbb2ab1dd6c42e83e3076effdc
Author: Andy Wingo <address@hidden>
Date:   Mon Jan 19 13:06:44 2015 +0100

    Optimize %initialize-object
    
    * module/oop/goops.scm (%initialize-object): Optimize by inlining the
      slot initialization, and by avoiding multiple checks for initargs
      validity.
---
 module/oop/goops.scm |   29 ++++++++++++++++++++++++-----
 1 files changed, 24 insertions(+), 5 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 7261de6..a85a5cb 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -2723,28 +2723,47 @@ function."
 (define (%initialize-object obj initargs)
   "Initialize the object @var{obj} with the given arguments
 var{initargs}."
+  (define (valid-initargs? initargs)
+    (match initargs
+      (() #t)
+      (((? keyword?) _ . initargs) (valid-initargs? initargs))
+      (_ #f)))
   (unless (instance? obj)
     (scm-error 'wrong-type-arg #f "Not an object: ~S"
                (list obj) #f))
-  (unless (even? (length initargs))
-    (scm-error 'wrong-type-arg #f "Initargs has odd length: ~S"
+  (unless (valid-initargs? initargs)
+    (scm-error 'wrong-type-arg #f "Invalid initargs: ~S"
                (list initargs) #f))
   (let ((class (class-of obj)))
     (define (get-initarg kw)
       (if kw
-          (get-keyword kw initargs *unbound*)
+          ;; Inlined get-keyword to avoid checking initargs for validity
+          ;; each time.
+          (let lp ((initargs initargs))
+            (match initargs
+              ((kw* val . initargs)
+               (if (eq? kw* kw)
+                   val
+                   (lp initargs)))
+              (_ *unbound*)))
           *unbound*))
     (let lp ((slots (struct-ref class class-index-slots)))
       (match slots
         (() 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))))
          (let ((initarg (get-initarg (%slot-definition-init-keyword slot))))
            (cond
             ((not (unbound? initarg))
-             (slot-set! obj (%slot-definition-name slot) initarg))
+             (initialize-slot! initarg))
             ((%slot-definition-init-thunk slot)
              => (lambda (init-thunk)
-                  (slot-set! obj (%slot-definition-name slot) (init-thunk))))))
+                  (initialize-slot! (init-thunk))))))
          (lp slots))))))
 
 (define-method (initialize (object <object>) initargs)