: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
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
HCoop / bpt / guile.git / commitdiff