e churn.
;;;
;;; 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 probably do need to use atomic access primitives to correctly
;;; handle concurrency, but that's a more general Guile concern.
;;;

(define-syntax arity-case
  (lambda (x)
    (syntax-case x ()
      ;; (arity-case n 2 foo bar)
      ;; => (case n
      ;;      ((0) (foo))
      ;;      ((1) (foo a))
      ;;      ((2) (foo a b))
      ;;      (else bar))
      ((arity-case n max form alternate)
       (let ((max (syntax->datum #'max)))
         #`(case n
             #,@(let lp ((n 0))
                  (let ((ids (map (lambda (n)
                                    (let* ((n (+ (char->integer #\a) n))
                                           (c (integer->char n)))
                                      (datum->syntax #'here (symbol c))))
                                  (iota n))))
                    #`(((#,n) (form #,@ids))
                       . #,(if (< n max)
                               (lp (1+ n))
                               #'()))))
             (else alternate)))))))

;;;
;;; These dispatchers are set as the "procedure" field of <generic>
;;; instances.  Unlike CLOS, in GOOPS a generic function can have
;;; multiple arities.
;;;
;;; We pre-generate fast dispatchers for applications of up to 20
;;; arguments.  More arguments than that will go through slower generic
;;; routines that cons arguments into a rest list.
;;;
(define (multiple-arity-dispatcher fv miss)
  (define-syntax dispatch
    (lambda (x)
      (define (build-clauses args)
        (let ((len (length (syntax->datum args))))
          #`((#,args ((vector-ref fv #,len) . #,args))
             . #,(syntax-case args ()
                   (() #'())
                   ((arg ... _) (build-clauses #'(arg ...)))))))
      (syntax-case x ()
        ((dispatch arg ...)
         #`(case-lambda
             #,@(build-clauses #'(arg ...))
             (args (apply miss args)))))))
  (arity-case (1- (vector-length fv)) 20 dispatch
              (lambda args
                (let ((nargs (length args)))
                  (if (< nargs (vector-length fv))
                      (apply (vector-ref fv nargs) args)
                      (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)
    (((typev . cmethod) . cache)
     (cond
      ((eqv? nargs (vector-length typev))
       (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?
           (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 (arg ...)
                         (if (args-match? (arg type) ...)
                             (cmethod arg ...)
                             (cache-miss arg ...))))))))))
         (arity-case nargs 20 dispatch
                     (lambda args
                       (define (args-match? args)
                         (let lp ((args args) (n 0))
                           (match args
                             ((arg . args)
                              (or (not (vector-ref typev n))
                                  (and (eq? (vector-ref typev n) (class-of arg))
                                       (lp args (1+ n)))))
                             (_ #t))))
                       (if (args-match? args)
                           (apply cmethod args)
                           (apply cache-miss args))))))
      (else
       (single-arity-cache-dispatch cache nargs cache-miss))))))

(define (compute-generic-function-dispatch-procedure gf)
  (define (seen-arities cache)
    (let lp ((arities 0) (cache cache))
      (match cache
        (() arities)
        (((typev . cmethod) . cache)
         (lp (logior arities (ash 1 (vector-length typev)))
             cache)))))
  (define (cache-miss . args)
    (memoize-generic-function-application! gf args)
    (apply gf args))
  (let* ((cache (slot-ref gf 'effective-methods))
         (arities (seen-arities cache))
         (max-arity (let lp ((max -1))
                      (if (< arities (ash 1 (1+ max)))
                          max
                          (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 max-arity)
             (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))))))

(define (recompute-generic-function-dispatch-procedure! gf)
  (slot-set! gf 'procedure
             (compute-generic-function-dispatch-procedure gf)))

(define (memoize-effective-method! gf args applicable)
  (define (record-types args)
    (let ((typev (make-vector (length args) #f)))
      (let lp ((n 0) (args args))
        (when (and (< n (slot-ref gf 'n-specialized))
                   (pair? args))
          (match args
            ((arg . args)
             (vector-set! typev n (class-of arg))
             (lp (1+ n) args)))))
      typev))
  (let* ((typev (record-types args))
         (compute-effective-method (if (eq? (class-of gf) <generic>)
                                       %compute-effective-method
                                       compute-effective-method))
         (cmethod (compute-effective-method gf applicable typev))
         (cache (acons typev cmethod (slot-ref gf 'effective-methods))))
    (slot-set! gf 'effective-methods cache)
    (recompute-generic-function-dispatch-procedure! gf)
    cmethod))

;;;
;;; 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.
;;; An effective method is bound to a specific `next-method' by the
;;; `make-procedure' slot of a <method>, which returns the new closure.
;;;
(define (%compute-specialized-effective-method gf method types next-method)
  (match (slot-ref method 'make-procedure)
    (#f (method-procedure method))
    (make-procedure (make-procedure next-method))))

(define (compute-specialized-effective-method gf method types next-method)
  (%compute-specialized-effective-method gf method types next-method))

(define (%compute-effective-method gf methods types)
  (match methods
    ((method . methods)
     (let ((compute-specialized-effective-method
            (if (and (eq? (class-of gf) <generic>)
                     (eq? (class-of method) <method>))
                %compute-specialized-effective-method
                compute-specialized-effective-method)))
       (compute-specialized-effective-method
        gf method types
        (match methods
          (()
           (lambda args
             (no-next-method gf args)))
          (methods
           (let ((compute-effective-method (if (eq? (class-of gf) <generic>)
                                               %compute-effective-method
                                               compute-effective-method)))
             (compute-effective-method gf methods types)))))))))

;; Boot definition; overrided with a generic later.
(define (compute-effective-method gf methods types)
  (%compute-effective-method gf methods types))

;;;
;;; Memoization
;;;

(define (memoize-generic-function-application! gf args)
  (let ((applicable ((if (eq? (class-of gf) <generic>)
                         %compute-applicable-methods
                         compute-applicable-methods)
                     gf args)))
    (cond (applicable
           (memoize-effective-method! gf args applicable))
          (else
           (no-applicable-method gf args)))))

(define no-applicable-method
  (make <generic> #:name 'no-applicable-method))

(%goops-early-init)

;; Then load the rest of GOOPS

