summaryrefslogtreecommitdiff
path: root/module/oop/goops
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-11-20 13:11:52 +0100
committerAndy Wingo <wingo@pobox.com>2009-11-26 00:25:07 +0100
commit2f652c6884d2ae58b4177fef2f306f0312e7b347 (patch)
tree247b6bf1278ea7f3bafbf549d41d1cda8bd1b0d3 /module/oop/goops
parent9f63ce021c567056c02b81d96742ff91416b886f (diff)
downloadguile-2f652c6884d2ae58b4177fef2f306f0312e7b347.tar.gz
generics now dispatch as applicable structs
* libguile/eval.i.c (CEVAL, SCM_APPLY): Dispatch applicable structs before pure generics. In practice what this means is that we never hit the mcache case, because all pure generics are applicable structs. We're moving over to having generics dispatch themselves. Also, they don't prepend the struct as an arg; in order to have that effect, the user has closures. * libguile/goops.c (scm_apply_generic, scm_call_generic_0): (scm_call_generic_1, scm_call_generic_2, scm_call_generic_3): Dispatch directly to the struct procedures. (scm_var_make_extended_generic): Remove a duplicate definition for scm_var_make_extended_generic. (create_standard_classes): Mark all instances of <applicable-struct-class> (themselves classes) as applicable classes. Meaning: generics are now applicable structs. * libguile/goops.h (SCM_CLASS_CLASS_LAYOUT): The hashsets are actually uw slots -- or at least, making subclasses maps the int slots to be uw slots * libguile/vm-i-system.c (call, goto/args, mv-call): Dispatch applicable structs in the VM. * module/oop/goops/dispatch.scm (emit-linear-dispatch): Fix bug in the non-rest cache miss case. (delayed-compile): Rework to avoid fluids. (cache-dispatch): Don't call `equal?', it causes bootstrapping problems with the primitive-generic equal?. Using our own version is faster anyway.
Diffstat (limited to 'module/oop/goops')
-rw-r--r--module/oop/goops/dispatch.scm49
1 files changed, 27 insertions, 22 deletions
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index ec03f599a..e08e642d4 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -72,7 +72,9 @@
(let lp ((methods methods)
(free free)
(exp `(cache-miss ,gf-sym
- ,(if rest? `(cons* ,@args rest) args))))
+ ,(if rest?
+ `(cons* ,@args rest)
+ `(list ,@args)))))
(cond
((null? methods)
(values `(,(if rest? `(,@args . rest) args)
@@ -189,38 +191,41 @@
;; get out before it blows o/~
;;
(define timer-init 10)
-(define *in-progress* (make-fluid))
-(fluid-set! *in-progress* '())
-
(define (delayed-compile gf)
(let ((timer timer-init))
(lambda args
+ (set! timer (1- timer))
(cond
- ((> timer 0)
- (set! timer (1- timer))
- (cache-dispatch gf args))
+ ((zero? timer)
+ (let ((dispatch (compute-dispatch-procedure
+ gf (slot-ref gf 'effective-methods))))
+ (slot-set! gf 'procedure dispatch)
+ (apply dispatch args)))
(else
- (let ((in-progress (fluid-ref *in-progress*)))
- (if (memq gf in-progress)
- (cache-dispatch gf args)
- (with-fluids ((*in-progress* (cons gf in-progress)))
- (let ((dispatch (compute-dispatch-procedure
- gf (slot-ref gf 'effective-methods))))
- (slot-set! gf 'procedure dispatch)
- (apply dispatch args))))))))))
+ ;; interestingly, this catches recursive compilation attempts as
+ ;; well; in that case, timer is negative
+ (cache-dispatch gf args))))))
(define (cache-dispatch gf args)
(define (map-until n f ls)
(if (or (zero? n) (null? ls))
'()
(cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
- (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
- (let lp ((cache (slot-ref gf 'effective-methods)))
- (cond ((null? cache)
- (cache-miss gf args))
- ((equal? (vector-ref (car cache) 1) types)
- (apply (vector-ref (car cache) 3) args))
- (else (lp (cdr cache)))))))
+ (define (equal? x y) ; can't use the stock equal? because it's a generic...
+ (cond ((pair? x) (and (pair? y)
+ (eq? (car x) (car y))
+ (equal? (cdr x) (cdr y))))
+ ((null? x) (null? y))
+ (else #f)))
+ (if (slot-ref gf 'n-specialized)
+ (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
+ (let lp ((cache (slot-ref gf 'effective-methods)))
+ (cond ((null? cache)
+ (cache-miss gf args))
+ ((equal? (vector-ref (car cache) 1) types)
+ (apply (vector-ref (car cache) 3) args))
+ (else (lp (cdr cache))))))
+ (cache-miss gf args)))
(define (cache-miss gf args)
(apply (memoize-method! gf args (slot-ref gf '%cache)) args))