diff options
Diffstat (limited to 'module/oop')
-rw-r--r-- | module/oop/goops/dispatch.scm | 221 |
1 files changed, 220 insertions, 1 deletions
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index 14b4a854c..21a13c80b 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -29,6 +29,224 @@ :no-backtrace ) +(define *dispatch-module* (current-module)) + +;;; +;;; Generic functions have an applicable-methods cache associated with +;;; them. Every distinct set of types that is dispatched through a +;;; generic adds an entry to the cache. This cache gets compiled out to +;;; a dispatch procedure. In steady-state, this dispatch procedure is +;;; never recompiled; but during warm-up there is some churn, both to +;;; the cache and to the dispatch procedure. +;;; +;;; So what is the deal if warm-up happens in a multithreaded context? +;;; There is indeed a window between missing the cache for a certain set +;;; of arguments, and then updating the cache with the newly computed +;;; applicable methods. One of the updaters is liable to lose their new +;;; entry. +;;; +;;; This is actually OK though, because a subsequent cache miss for the +;;; race loser will just cause memoization to try again. The cache will +;;; eventually be consistent. We're not mutating the old part of the +;;; cache, just consing on the new entry. +;;; +;;; It doesn't even matter if the dispatch procedure and the cache are +;;; inconsistent -- most likely the type-set that lost the dispatch +;;; procedure race will simply re-trigger a memoization, but since the +;;; winner isn't in the effective-methods cache, it will likely also +;;; re-trigger a memoization, and the cache will finally be consistent. +;;; As you can see there is a possibility for ping-pong effects, but +;;; it's unlikely given the shortness of the window between slot-set! +;;; invocations. We could add a mutex, but it is strictly unnecessary, +;;; and would add runtime cost and complexity. +;;; + +(define (emit-linear-dispatch gf-sym nargs methods free rest?) + (define (gen-syms n stem) + (let lp ((n (1- n)) (syms '())) + (if (< n 0) + syms + (lp (1- n) (cons (gensym stem) syms))))) + (let* ((args (gen-syms nargs "a")) + (types (gen-syms nargs "t"))) + (let lp ((methods methods) + (free free) + (exp `(cache-miss ,gf-sym + ,(if rest? `(cons* ,@args rest) args)))) + (cond + ((null? methods) + (values `(,(if rest? `(,@args . rest) args) + (let ,(map (lambda (t a) + `(,t (class-of ,a))) + types args) + ,exp)) + free)) + (else + ;; jeez + (let preddy ((free free) + (types types) + (specs (vector-ref (car methods) 1)) + (checks '())) + (if (null? types) + (let ((m-sym (gensym "p"))) + (lp (cdr methods) + (acons (vector-ref (car methods) 3) + m-sym + free) + `(if (and . ,checks) + ,(if rest? + `(apply ,m-sym ,@args rest) + `(,m-sym . ,args)) + ,exp))) + (let ((var (assq-ref free (car specs)))) + (if var + (preddy free + (cdr types) + (cdr specs) + (cons `(eq? ,(car types) ,var) + checks)) + (let ((var (gensym "c"))) + (preddy (acons (car specs) var free) + (cdr types) + (cdr specs) + (cons `(eq? ,(car types) ,var) + checks)))))))))))) + +(define (compute-dispatch-procedure gf cache) + (define (scan) + (let lp ((ls cache) (nreq -1) (nrest -1)) + (cond + ((null? ls) + (collate (make-vector (1+ nreq) '()) + (make-vector (1+ nrest) '()))) + ((vector-ref (car ls) 2) ; rest + (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0)))) + (else ; req + (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest))))) + (define (collate req rest) + (let lp ((ls cache)) + (cond + ((null? ls) + (emit req rest)) + ((vector-ref (car ls) 2) ; rest + (let ((n (vector-ref (car ls) 0))) + (vector-set! rest n (cons (car ls) (vector-ref rest n))) + (lp (cdr ls)))) + (else ; req + (let ((n (vector-ref (car ls) 0))) + (vector-set! req n (cons (car ls) (vector-ref req n))) + (lp (cdr ls))))))) + (define (emit req rest) + (let ((gf-sym (gensym "g"))) + (define (emit-rest n clauses free) + (if (< n (vector-length rest)) + (let ((methods (vector-ref rest n))) + (cond + ((null? methods) + (emit-rest (1+ n) clauses free)) + ;; FIXME: hash dispatch + (else + (call-with-values + (lambda () + (emit-linear-dispatch gf-sym n methods free #t)) + (lambda (clause free) + (emit-rest (1+ n) (cons clause clauses) free)))))) + (emit-req (1- (vector-length req)) clauses free))) + (define (emit-req n clauses free) + (if (< n 0) + (comp `(lambda ,(map cdr free) + (case-lambda ,@clauses)) + (map car free)) + (let ((methods (vector-ref req n))) + (cond + ((null? methods) + (emit-req (1- n) clauses free)) + ;; FIXME: hash dispatch + (else + (call-with-values + (lambda () + (emit-linear-dispatch gf-sym n methods free #f)) + (lambda (clause free) + (emit-req (1- n) (cons clause clauses) free)))))))) + + (emit-rest 0 + (if (or (zero? (vector-length rest)) + (null? (vector-ref rest 0))) + (list `(args (cache-miss ,gf-sym args))) + '()) + (acons gf gf-sym '())))) + (define (comp exp vals) + (let ((p ((@ (system base compile) compile) exp #:env *dispatch-module*))) + (apply p vals))) + + ;; kick it. + (scan)) + +;; o/~ ten, nine, eight +;; sometimes that's just how it goes +;; three, two, one +;; +;; 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 + (cond + ((> timer 0) + (set! timer (1- timer)) + (cache-dispatch gf 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 'dispatch-procedure dispatch) + (apply dispatch 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 (cache-miss gf args) + (apply (memoize-method! gf args (slot-ref gf '%cache)) args)) + +(define (memoize-effective-method! gf args applicable) + (define (first-n ls n) + (if (or (zero? n) (null? ls)) + '() + (cons (car ls) (first-n (cdr ls) (- n 1))))) + (define (parse n ls) + (cond ((null? ls) + (memoize n #f (map class-of args))) + ((= n (slot-ref gf 'n-specialized)) + (memoize n #t (map class-of (first-n args n)))) + (else + (parse (1+ n) (cdr ls))))) + (define (memoize len rest? types) + (let* ((cmethod (compute-cmethod applicable types)) + (cache (cons (vector len types rest? cmethod) + (slot-ref gf 'effective-methods)))) + (slot-set! gf 'effective-methods cache) + (slot-set! gf 'dispatch-procedure (delayed-compile gf)) + cmethod)) + (parse 0 args)) + + ;;; ;;; This file implements method memoization. It will finally be ;;; implemented on C level in order to obtain fast generic function @@ -213,7 +431,8 @@ compute-applicable-methods) gf args))) (cond (applicable - ;; *fixme* dispatch.scm needs rewriting Since the current + (memoize-effective-method! gf args applicable) + ;; *fixme* dispatch.scm needs rewriting Since the current ;; code mutates the method cache, we have to work on a ;; copy. Otherwise we might disturb another thread ;; currently dispatching on the cache. (No need to copy |