mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Optimize %initialize-object

Browse source 
* module/oop/goops.scm (%initialize-object): Optimize by inlining the
  slot initialization, and by avoiding multiple checks for initargs
  validity.
This commit is contained in:
Andy Wingo 2015-01-19 13:06:44 +01:00
parent 2a3ef7c44b
commit 79c2ca26ae
1 changed files with 24 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

29
module/oop/goops.scm
View file

@ -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)