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

Fast generic function dispatch without calling `compile' at runtime

Browse source 
* module/oop/goops.scm: Rewrite generic function dispatch to use chained
  closures instead of compiling specific dispatch procedures.  The big
  speed win before was not allocating rest arguments, which we gain by
  simply pre-generating dispatchers for arities of up to 20 arguments.
  Also now a tail call without reshuffling arguments -- which is what
  dispatch now is -- is just a (mov 0 new-procedure) and (tail-call),
  which is pretty cheap.

  (%invalidate-method-cache!): Use the new
  recompute-generic-function-dispatch-procedure!.
  (arity-case, multiple-arity-dispatcher, single-arity-dispatcher)
  (single-arity-cache-dispatch)
  (compute-generic-function-dispatch-procedure)
  (recompute-generic-function-dispatch-procedure!): New internal
  interfaces.
  (memoize-effective-method!): Update for new interfaces.
  (memoize-generic-function-application!): Rename from `memoize-method!'.
This commit is contained in:
Andy Wingo 2015-01-21 15:16:56 +01:00
parent 3f4829e082
commit 0d96acac33
1 changed files with 219 additions and 208 deletions
Download patch file Download diff file Expand all files Collapse all files

427
module/oop/goops.scm
View file

@ -27,7 +27,6 @@
(define-module (oop goops) (define-module (oop goops)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (system base target)
#:use-module ((language tree-il primitives) #:use-module ((language tree-il primitives)
:select (add-interesting-primitive!)) :select (add-interesting-primitive!))
#:export-syntax (define-class class standard-define-class #:export-syntax (define-class class standard-define-class
@ -928,6 +927,8 @@ slots as we go."
(define-standard-class <boolean> (<top>)) (define-standard-class <boolean> (<top>))
(define-standard-class <char> (<top>)) (define-standard-class <char> (<top>))
(define-standard-class <list> (<top>)) (define-standard-class <list> (<top>))
;; Not all pairs are lists, but there is code out there that relies on
;; (is-a? '(1 2 3) <list>) to work. Terrible. How to fix?
(define-standard-class <pair> (<list>)) (define-standard-class <pair> (<list>))
(define-standard-class <null> (<list>)) (define-standard-class <null> (<list>))
(define-standard-class <string> (<top>)) (define-standard-class <string> (<top>))
@ -998,8 +999,8 @@ function."
;;; later. ;;; later.
;;; ;;;
(define (%invalidate-method-cache! gf) (define (%invalidate-method-cache! gf)
(slot-set! gf 'procedure (delayed-compile gf)) (slot-set! gf 'effective-methods '())
(slot-set! gf 'effective-methods '())) (recompute-generic-function-dispatch-procedure! gf))
;; Boot definition. ;; Boot definition.
(define (invalidate-method-cache! gf) (define (invalidate-method-cache! gf)
@ -1213,16 +1214,15 @@ function."
;;; ;;;
;;; Generic functions! ;;; Generic functions!
;;;
(define *dispatch-module* (current-module))
;;; ;;;
;;; Generic functions have an applicable-methods cache associated with ;;; Generic functions have an applicable-methods cache associated with
;;; them. Every distinct set of types that is dispatched through a ;;; them. Every distinct set of types that is dispatched through a
;;; generic adds an entry to the cache. This cache gets compiled out to ;;; generic adds an entry to the cache. A composite dispatch procedure
;;; a dispatch procedure. In steady-state, this dispatch procedure is ;;; is recomputed every time an entry gets added to the cache, or when
;;; never recompiled; but during warm-up there is some churn, both to ;;; the cache is invalidated.
;;; the cache and to the dispatch procedure. ;;;
;;; In steady-state, this dispatch procedure is never regenerated; but
;;; during warm-up there is some churn.
;;; ;;;
;;; So what is the deal if warm-up happens in a multithreaded context? ;;; 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 ;;; There is indeed a window between missing the cache for a certain set
@ -1232,7 +1232,7 @@ function."
;;; ;;;
;;; This is actually OK though, because a subsequent cache miss for the ;;; This is actually OK though, because a subsequent cache miss for the
;;; race loser will just cause memoization to try again. The cache will ;;; race loser will just cause memoization to try again. The cache will
;;; eventually be consistent. We're not mutating the old part of the ;;; eventually be consistent. We're not mutating the old part of the
;;; cache, just consing on the new entry. ;;; cache, just consing on the new entry.
;;; ;;;
;;; It doesn't even matter if the dispatch procedure and the cache are ;;; It doesn't even matter if the dispatch procedure and the cache are
@ -1242,178 +1242,191 @@ function."
;;; re-trigger a memoization, and the cache will finally be consistent. ;;; re-trigger a memoization, and the cache will finally be consistent.
;;; As you can see there is a possibility for ping-pong effects, but ;;; 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! ;;; it's unlikely given the shortness of the window between slot-set!
;;; invocations. We could add a mutex, but it is strictly unnecessary, ;;; invocations.
;;; and would add runtime cost and complexity. ;;;
;;; We probably do need to use atomic access primitives to correctly
;;; handle concurrency, but that's a more general Guile concern.
;;; ;;;
(define (emit-linear-dispatch gf-sym nargs methods free rest?) (define-syntax arity-case
(define (gen-syms n stem) (lambda (x)
(let lp ((n (1- n)) (syms '())) (syntax-case x ()
(if (< n 0) ;; (arity-case n 2 foo bar)
syms ;; => (case n
(lp (1- n) (cons (gensym stem) syms))))) ;; ((0) (foo))
(let* ((args (gen-syms nargs "a")) ;; ((1) (foo a))
(types (gen-syms nargs "t"))) ;; ((2) (foo a b))
(let lp ((methods methods) ;; (else bar))
(free free) ((arity-case n max form alternate)
(exp `(cache-miss ,gf-sym (let ((max (syntax->datum #'max)))
,(if rest? #`(case n
`(cons* ,@args rest) #,@(let lp ((n 0))
`(list ,@args))))) (let ((ids (map (lambda (n)
(match methods (let* ((n (+ (char->integer #\a) n))
(() (c (integer->char n)))
(values `(,(if rest? `(,@args . rest) args) (datum->syntax #'here (symbol c))))
(let ,(map (lambda (t a) (iota n))))
`(,t (class-of ,a))) #`(((#,n) (form #,@ids))
types args) . #,(if (< n max)
,exp)) (lp (1+ n))
free)) #'()))))
((#(_ specs _ cmethod) . methods) (else alternate)))))))
(let build-dispatch ((free free)
(types types)
(specs specs)
(checks '()))
(match types
(()
(let ((m-sym (gensym "p")))
(lp methods
(acons cmethod m-sym free)
`(if (and . ,checks)
,(if rest?
`(apply ,m-sym ,@args rest)
`(,m-sym . ,args))
,exp))))
((type . types)
(match specs
((spec . specs)
(let ((var (assq-ref free spec)))
(if var
(build-dispatch free
types
specs
(cons `(eq? ,type ,var)
checks))
(let ((var (gensym "c")))
(build-dispatch (acons spec var free)
types
specs
(cons `(eq? ,type ,var)
checks)))))))))))))))
(define (compute-dispatch-procedure gf cache) ;;;
(define (scan) ;;; These dispatchers are set as the "procedure" field of <generic>
(let lp ((ls cache) (nreq -1) (nrest -1)) ;;; instances. Unlike CLOS, in GOOPS a generic function can have
(match ls ;;; multiple arities.
(() ;;;
(collate (make-vector (1+ nreq) '()) ;;; We pre-generate fast dispatchers for applications of up to 20
(make-vector (1+ nrest) '()))) ;;; arguments. More arguments than that will go through slower generic
((#(len specs rest? cmethod) . ls) ;;; routines that cons arguments into a rest list.
(if rest? ;;;
(lp ls nreq (max nrest len)) (define (multiple-arity-dispatcher fv miss)
(lp ls (max nreq len) nrest)))))) (define-syntax dispatch
(define (collate req rest) (lambda (x)
(let lp ((ls cache)) (define (build-clauses args)
(match ls (let ((len (length (syntax->datum args))))
(() (emit req rest)) #`((#,args ((vector-ref fv #,len) . #,args))
(((and entry #(len specs rest? cmethod)) . ls) . #,(syntax-case args ()
(if rest? (() #'())
(vector-set! rest len (cons entry (vector-ref rest len))) ((arg ... _) (build-clauses #'(arg ...)))))))
(vector-set! req len (cons entry (vector-ref req len)))) (syntax-case x ()
(lp ls))))) ((dispatch arg ...)
(define (emit req rest) #`(case-lambda
(let ((gf-sym (gensym "g"))) #,@(build-clauses #'(arg ...))
(define (emit-rest n clauses free) (args (apply miss args)))))))
(if (< n (vector-length rest)) (arity-case (vector-length fv) 20 dispatch
(match (vector-ref rest n) (lambda args
(() (emit-rest (1+ n) clauses free)) (let ((nargs (length args)))
;; FIXME: hash dispatch (if (< nargs (vector-length fv))
(methods (apply (vector-ref fv nargs) args)
(call-with-values (apply miss args))))))
;;;
;;; The above multiple-arity-dispatcher is entirely sufficient, and
;;; should be fast enough. Still, for no good reason we also have an
;;; arity dispatcher for generics that are only called with one arity.
;;;
(define (single-arity-dispatcher f nargs miss)
(define-syntax-rule (dispatch arg ...)
(case-lambda
((arg ...) (f arg ...))
(args (apply miss args))))
(arity-case nargs 20 dispatch
(lambda args
(if (eqv? (length args) nargs)
(apply f args)
(apply miss args)))))
;;;
;;; The guts of generic function dispatch are here. Once we've selected
;;; an arity, we need to map from arguments to effective method. Until
;;; we have `eqv?' specializers, this map is entirely a function of the
;;; types (classes) of the arguments. So, we look in the cache to see
;;; if we have seen this set of concrete types, and if so we apply the
;;; previously computed effective method. Otherwise we miss the cache,
;;; so we'll have to compute the right answer for this set of types, add
;;; the mapping to the cache, and apply the newly computed method.
;;;
;;; The cached mapping is invalidated whenever a new method is defined
;;; on this generic, or whenever the class hierarchy of any method
;;; specializer changes.
;;;
(define (single-arity-cache-dispatch cache nargs cache-miss)
(match cache
(() cache-miss)
((#(len types rest? cmethod nargs*) . cache)
(define (type-ref n)
(and (< n len) (list-ref types n)))
(cond
((eqv? nargs nargs*)
(let ((cache-miss (single-arity-cache-dispatch cache nargs cache-miss)))
(define-syntax args-match?
(syntax-rules ()
((args-match?) #t)
((args-match? (arg type) (arg* type*) ...)
;; Check that the arg has the exact type that we saw. It
;; could be that `type' is #f, which indicates the end of
;; the specializers list. Once all specializers have been
;; examined, we don't need to look at any more arguments
;; to know that this is a cache hit.
(or (not type)
(and (eq? (class-of arg) type)
(args-match? (arg* type*) ...))))))
(define-syntax dispatch
(lambda (x)
(define (bind-types types k)
(let lp ((types types) (n 0))
(syntax-case types ()
(() (k))
((type . types)
#`(let ((type (type-ref #,n)))
#,(lp #'types (1+ n)))))))
(syntax-case x ()
((dispatch arg ...)
(with-syntax (((type ...) (generate-temporaries #'(arg ...))))
(bind-types
#'(type ...)
(lambda () (lambda ()
(emit-linear-dispatch gf-sym n methods free #t)) #'(lambda (arg ...)
(lambda (clause free) (if (args-match? (arg type) ...)
(emit-rest (1+ n) (cons clause clauses) free))))) (cmethod arg ...)
(emit-req (1- (vector-length req)) clauses free))) (cache-miss arg ...))))))))))
(define (emit-req n clauses free) (arity-case nargs 20 dispatch
(if (< n 0) (lambda args
(comp `(lambda ,(map cdr free) (define (args-match? args)
(case-lambda ,@clauses)) (let lp ((args args) (types types))
(map car free)) (match types
(match (vector-ref req n) ((type . types)
(() (emit-req (1- n) clauses free)) (let ((arg (car args))
;; FIXME: hash dispatch (args (cdr args)))
(methods (and (eq? type (class-of arg))
(call-with-values (lp args types))))
(lambda () (_ #t))))
(emit-linear-dispatch gf-sym n methods free #f)) (if (args-match? args)
(lambda (clause free) (apply cmethod args)
(emit-req (1- n) (cons clause clauses) free))))))) (apply cache-miss args))))))
(else
(single-arity-cache-dispatch cache nargs cache-miss))))))
(emit-rest 0 (define (compute-generic-function-dispatch-procedure gf)
(if (or (zero? (vector-length rest)) (define (seen-arities cache)
(null? (vector-ref rest 0))) (let lp ((arities 0) (cache cache))
(list `(args (cache-miss ,gf-sym args))) (match cache
'()) (() arities)
(acons gf gf-sym '())))) ((#(_ _ _ _ nargs) . cache)
(define (comp exp vals) (lp (logior arities (ash 1 nargs)) cache)))))
;; When cross-compiling Guile itself, the native Guile must generate (define (cache-miss . args)
;; code for the host. (memoize-generic-function-application! gf args)
(with-target %host-type (apply gf args))
(lambda () (let* ((cache (slot-ref gf 'effective-methods))
(let ((p ((@ (system base compile) compile) exp (arities (seen-arities cache))
#:env *dispatch-module* (max-arity (let lp ((max -1))
#:from 'scheme (if (< arities (ash 1 (1+ max)))
#:opts '(#:partial-eval? #f #:cse? #f)))) max
(apply p vals))))) (lp (1+ max))))))
(cond
((= max-arity -1)
;; Nothing in the cache.
cache-miss)
((= arities (ash 1 max-arity))
;; Only one arity in the cache.
(let ((nargs (match cache ((#(_ _ _ _ nargs) . _) nargs))))
(let ((f (single-arity-cache-dispatch cache nargs cache-miss)))
(single-arity-dispatcher f nargs cache-miss))))
(else
;; Multiple arities.
(let ((fv (make-vector (1+ max-arity) #f)))
(let lp ((n 0))
(when (<= n max-arity)
(let ((f (single-arity-cache-dispatch cache n cache-miss)))
(vector-set! fv n f)
(lp (1+ n)))))
(multiple-arity-dispatcher fv cache-miss))))))
;; kick it. (define (recompute-generic-function-dispatch-procedure! gf)
(scan)) (slot-set! gf 'procedure
(compute-generic-function-dispatch-procedure gf)))
;; o/~ ten, nine, eight
;; sometimes that's just how it goes
;; three, two, one
;;
;; get out before it blows o/~
;;
(define timer-init 30)
(define (delayed-compile gf)
(let ((timer timer-init))
(lambda args
(set! timer (1- timer))
(cond
((zero? timer)
(let ((dispatch (compute-dispatch-procedure
gf (slot-ref gf 'effective-methods))))
(slot-set! gf 'procedure dispatch)
(apply dispatch args)))
(else
;; 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)))))
(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) args))
(define (memoize-effective-method! gf args applicable) (define (memoize-effective-method! gf args applicable)
(define (first-n ls n) (define (first-n ls n)
@ -1429,44 +1442,43 @@ function."
(parse (1+ n) (cdr ls))))) (parse (1+ n) (cdr ls)))))
(define (memoize len rest? types) (define (memoize len rest? types)
(let* ((cmethod (compute-cmethod applicable types)) (let* ((cmethod (compute-cmethod applicable types))
(cache (cons (vector len types rest? cmethod) (cache (cons (vector len types rest? cmethod (length args))
(slot-ref gf 'effective-methods)))) (slot-ref gf 'effective-methods))))
(slot-set! gf 'effective-methods cache) (slot-set! gf 'effective-methods cache)
(slot-set! gf 'procedure (delayed-compile gf)) (recompute-generic-function-dispatch-procedure! gf)
cmethod)) cmethod))
(parse 0 args)) (parse 0 args))
;;; ;;;
;;; Compiling next methods into method bodies ;;; If a method refers to `next-method' in its body, that method will be
;;; able to dispatch to the next most specific method. The exact
;;; `next-method' implementation is only known at runtime, as it is a
;;; function of which precise argument types are being dispatched, which
;;; might be subclasses of the method's declared specializers.
;;; ;;;
;;; Guile implements `next-method' by binding it as a closure variable.
;;; So, for the reader: there basic idea is that, given that the ;;; An effective method is bound to a specific `next-method' by the
;;; semantics of `next-method' depend on the concrete types being ;;; `make-procedure' slot of a <method>, which returns the new closure.
;;; dispatched, why not compile a specific procedure to handle each type
;;; combination that we see at runtime.
;;; ;;;
;;; In theory we can do much better than a bytecode compilation, because
;;; we know the *exact* types of the arguments. It's ideal for native
;;; compilation. A task for the future.
;;;
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
(define (compute-cmethod methods types) (define (compute-cmethod methods types)
(let ((make-procedure (slot-ref (car methods) 'make-procedure))) (match methods
(if make-procedure ((method . methods)
(match (slot-ref method 'make-procedure)
(#f (method-procedure method))
(make-procedure
(make-procedure (make-procedure
(if (null? (cdr methods)) (match methods
(lambda args (()
(no-next-method (method-generic-function (car methods)) args)) (lambda args
(compute-cmethod (cdr methods) types))) (no-next-method (method-generic-function method) args)))
(method-procedure (car methods))))) (methods
(compute-cmethod methods types)))))))))
;;; ;;;
;;; Memoization ;;; Memoization
;;; ;;;
(define (memoize-method! gf args) (define (memoize-generic-function-application! gf args)
(let ((applicable ((if (eq? gf compute-applicable-methods) (let ((applicable ((if (eq? gf compute-applicable-methods)
%compute-applicable-methods %compute-applicable-methods
compute-applicable-methods) compute-applicable-methods)
@ -1476,8 +1488,6 @@ function."
(else (else
(no-applicable-method gf args))))) (no-applicable-method gf args)))))
(set-procedure-property! memoize-method! 'system-procedure #t)
(define no-applicable-method (define no-applicable-method
(make <generic> #:name 'no-applicable-method)) (make <generic> #:name 'no-applicable-method))
@ -2133,8 +2143,8 @@ function."
(generic-function-methods gf))) (generic-function-methods gf)))
(define (invalidate-method-cache! gf) (define (invalidate-method-cache! gf)
(%invalidate-method-cache! gf)
(slot-set! gf 'n-specialized (calculate-n-specialized gf)) (slot-set! gf 'n-specialized (calculate-n-specialized gf))
(%invalidate-method-cache! gf)
(for-each (lambda (gf) (invalidate-method-cache! gf)) (for-each (lambda (gf) (invalidate-method-cache! gf))
(slot-ref gf 'extended-by))) (slot-ref gf 'extended-by)))
@ -2949,11 +2959,12 @@ var{initargs}."
;;; ;;;
;;; Note that standard generic functions dispatch only on the classes of ;;; Note that standard generic functions dispatch only on the classes of
;;; the arguments, and the result of such dispatch can be memoized. The ;;; the arguments, and the result of such dispatch can be memoized. The
;;; `cache-dispatch' routine implements this. `apply-generic' isn't ;;; `dispatch-generic-function-application-from-cache' routine
;;; called currently; the generic function MOP was never fully ;;; implements this. `apply-generic' isn't called currently; the
;;; implemented in GOOPS. However now that GOOPS is implemented ;;; generic function MOP was never fully implemented in GOOPS. However
;;; entirely in Scheme (2015) it's much easier to complete this work. ;;; now that GOOPS is implemented entirely in Scheme (2015) it's much
;;; Contributions gladly accepted! Please read the AMOP first though :) ;;; easier to complete this work. Contributions gladly accepted!
;;; Please read the AMOP first though :)
;;; ;;;
;;; The protocol is: ;;; The protocol is:
;;; ;;;