diff options
author | Andy Wingo <wingo@pobox.com> | 2015-01-19 13:06:44 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-01-23 16:16:04 +0100 |
commit | 79c2ca26aea37f035c633d011c719b91892b858d (patch) | |
tree | cea4ab87dbbc50db3efc5e5d1d3ca9c9dddffa8e /module/oop | |
parent | 2a3ef7c44bcd2ec2067da55582dabc72d5129f25 (diff) | |
download | guile-79c2ca26aea37f035c633d011c719b91892b858d.tar.gz |
Optimize %initialize-object
* module/oop/goops.scm (%initialize-object): Optimize by inlining the
slot initialization, and by avoiding multiple checks for initargs
validity.
Diffstat (limited to 'module/oop')
-rw-r--r-- | 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 142982cda..6e4cd4bea 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -2736,30 +2736,49 @@ 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) (unless (memq (slot-definition-allocation slot) '(#:class #:each-subclass)) - (slot-set! obj (%slot-definition-name slot) (init-thunk))))))) + (initialize-slot! (init-thunk))))))) (lp slots)))))) (define-method (initialize (object <object>) initargs) |