mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Simplify GOOPS effective method cache format

Browse source 
* module/oop/goops.scm (single-arity-cache-dispatch)
  (compute-generic-function-dispatch-procedure)
  (memoize-effective-method!): Simplify format of effective method
  cache.
This commit is contained in:
Andy Wingo 2015-01-21 15:53:53 +01:00
parent 0d96acac33
commit d21ef26838
1 changed files with 32 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

67
module/oop/goops.scm
View file

@ -1335,12 +1335,12 @@ function."
(define (single-arity-cache-dispatch cache nargs cache-miss) (define (single-arity-cache-dispatch cache nargs cache-miss)
(match cache (match cache
(() cache-miss) (() cache-miss)
((#(len types rest? cmethod nargs*) . cache) (((typev . cmethod) . cache)
(define (type-ref n)
(and (< n len) (list-ref types n)))
(cond (cond
((eqv? nargs nargs*) ((eqv? nargs (vector-length typev))
(let ((cache-miss (single-arity-cache-dispatch cache nargs cache-miss))) (let ((cache-miss (single-arity-cache-dispatch cache nargs cache-miss)))
(define (type-ref n)
(and (< n nargs) (vector-ref typev n)))
(define-syntax args-match? (define-syntax args-match?
(syntax-rules () (syntax-rules ()
((args-match?) #t) ((args-match?) #t)
@ -1375,13 +1375,12 @@ function."
(arity-case nargs 20 dispatch (arity-case nargs 20 dispatch
(lambda args (lambda args
(define (args-match? args) (define (args-match? args)
(let lp ((args args) (types types)) (let lp ((args args) (n 0))
(match types (match args
((type . types) ((arg . args)
(let ((arg (car args)) (or (not (vector-ref typev n))
(args (cdr args))) (and (eq? (vector-ref typev n) (class-of arg))
(and (eq? type (class-of arg)) (lp args (1+ n)))))
(lp args types))))
(_ #t)))) (_ #t))))
(if (args-match? args) (if (args-match? args)
(apply cmethod args) (apply cmethod args)
@ -1394,8 +1393,9 @@ function."
(let lp ((arities 0) (cache cache)) (let lp ((arities 0) (cache cache))
(match cache (match cache
(() arities) (() arities)
((#(_ _ _ _ nargs) . cache) (((typev . cmethod) . cache)
(lp (logior arities (ash 1 nargs)) cache))))) (lp (logior arities (ash 1 (vector-length typev)))
cache)))))
(define (cache-miss . args) (define (cache-miss . args)
(memoize-generic-function-application! gf args) (memoize-generic-function-application! gf args)
(apply gf args)) (apply gf args))
@ -1411,9 +1411,9 @@ function."
cache-miss) cache-miss)
((= arities (ash 1 max-arity)) ((= arities (ash 1 max-arity))
;; Only one arity in the cache. ;; Only one arity in the cache.
(let ((nargs (match cache ((#(_ _ _ _ nargs) . _) nargs)))) (let* ((nargs max-arity)
(let ((f (single-arity-cache-dispatch cache nargs cache-miss))) (f (single-arity-cache-dispatch cache nargs cache-miss)))
(single-arity-dispatcher f nargs cache-miss)))) (single-arity-dispatcher f nargs cache-miss)))
(else (else
;; Multiple arities. ;; Multiple arities.
(let ((fv (make-vector (1+ max-arity) #f))) (let ((fv (make-vector (1+ max-arity) #f)))
@ -1429,25 +1429,22 @@ function."
(compute-generic-function-dispatch-procedure gf))) (compute-generic-function-dispatch-procedure gf)))
(define (memoize-effective-method! gf args applicable) (define (memoize-effective-method! gf args applicable)
(define (first-n ls n) (define (record-types args)
(if (or (zero? n) (null? ls)) (let ((typev (make-vector (length args) #f)))
'() (let lp ((n 0) (args args))
(cons (car ls) (first-n (cdr ls) (- n 1))))) (when (and (< n (slot-ref gf 'n-specialized))
(define (parse n ls) (pair? args))
(cond ((null? ls) (match args
(memoize n #f (map class-of args))) ((arg . args)
((= n (slot-ref gf 'n-specialized)) (vector-set! typev n (class-of arg))
(memoize n #t (map class-of (first-n args n)))) (lp (1+ n) args)))))
(else typev))
(parse (1+ n) (cdr ls))))) (let* ((typev (record-types args))
(define (memoize len rest? types) (cmethod (compute-cmethod applicable typev))
(let* ((cmethod (compute-cmethod applicable types)) (cache (acons typev cmethod (slot-ref gf 'effective-methods))))
(cache (cons (vector len types rest? cmethod (length args)) (slot-set! gf 'effective-methods cache)
(slot-ref gf 'effective-methods)))) (recompute-generic-function-dispatch-procedure! gf)
(slot-set! gf 'effective-methods cache) cmethod))
(recompute-generic-function-dispatch-procedure! gf)
cmethod))
(parse 0 args))
;;; ;;;
;;; If a method refers to `next-method' in its body, that method will be ;;; If a method refers to `next-method' in its body, that method will be