mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
269 lines
10 KiB
Scheme
269 lines
10 KiB
Scheme
;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
|
||
;;;;
|
||
;;;; This library is free software; you can redistribute it and/or
|
||
;;;; modify it under the terms of the GNU Lesser General Public
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 3 of the License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This library is distributed in the hope that it will be useful,
|
||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this library; if not, write to the Free Software
|
||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
;;;;
|
||
|
||
|
||
;; There are circularities here; you can't import (oop goops compile)
|
||
;; before (oop goops). So when compiling, make sure that things are
|
||
;; kosher.
|
||
(eval-when (compile) (resolve-module '(oop goops)))
|
||
|
||
(define-module (oop goops dispatch)
|
||
#:use-module (oop goops)
|
||
#:use-module (oop goops util)
|
||
#:use-module (oop goops compile)
|
||
#:export (memoize-method!)
|
||
#: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)
|
||
`(list ,@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 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 (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 'procedure (delayed-compile gf))
|
||
cmethod))
|
||
(parse 0 args))
|
||
|
||
|
||
;;;
|
||
;;; Memoization
|
||
;;;
|
||
|
||
(define (memoize-method! gf args)
|
||
(let ((applicable ((if (eq? gf compute-applicable-methods)
|
||
%compute-applicable-methods
|
||
compute-applicable-methods)
|
||
gf args)))
|
||
(cond (applicable
|
||
(memoize-effective-method! gf args applicable))
|
||
(else
|
||
(no-applicable-method gf args)))))
|
||
|
||
(set-procedure-property! memoize-method! 'system-procedure #t)
|