module/oop/goops/dispatch.scm

   1 ;;;;    Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 3 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 \f
  18
  19 ;; There are circularities here; you can't import (oop goops compile)
  20 ;; before (oop goops). So when compiling, make sure that things are
  21 ;; kosher.
  22 (eval-when (compile) (resolve-module '(oop goops)))
  23
  24 (define-module (oop goops dispatch)
  25   #:use-module (oop goops)
  26   #:use-module (oop goops util)
  27   #:use-module (oop goops compile)
  28   #:export (memoize-method!)
  29   #:no-backtrace)
  30
  31
  32 (define *dispatch-module* (current-module))
  33
  34 ;;;
  35 ;;; Generic functions have an applicable-methods cache associated with
  36 ;;; them. Every distinct set of types that is dispatched through a
  37 ;;; generic adds an entry to the cache. This cache gets compiled out to
  38 ;;; a dispatch procedure. In steady-state, this dispatch procedure is
  39 ;;; never recompiled; but during warm-up there is some churn, both to
  40 ;;; the cache and to the dispatch procedure.
  41 ;;;
  42 ;;; So what is the deal if warm-up happens in a multithreaded context?
  43 ;;; There is indeed a window between missing the cache for a certain set
  44 ;;; of arguments, and then updating the cache with the newly computed
  45 ;;; applicable methods. One of the updaters is liable to lose their new
  46 ;;; entry.
  47 ;;;
  48 ;;; This is actually OK though, because a subsequent cache miss for the
  49 ;;; race loser will just cause memoization to try again. The cache will
  50 ;;; eventually be consistent. We're not mutating the old part of the
  51 ;;; cache, just consing on the new entry.
  52 ;;;
  53 ;;; It doesn't even matter if the dispatch procedure and the cache are
  54 ;;; inconsistent -- most likely the type-set that lost the dispatch
  55 ;;; procedure race will simply re-trigger a memoization, but since the
  56 ;;; winner isn't in the effective-methods cache, it will likely also
  57 ;;; re-trigger a memoization, and the cache will finally be consistent.
  58 ;;; As you can see there is a possibility for ping-pong effects, but
  59 ;;; it's unlikely given the shortness of the window between slot-set!
  60 ;;; invocations. We could add a mutex, but it is strictly unnecessary,
  61 ;;; and would add runtime cost and complexity.
  62 ;;;
  63
  64 (define (emit-linear-dispatch gf-sym nargs methods free rest?)
  65   (define (gen-syms n stem)
  66     (let lp ((n (1- n)) (syms '()))
  67       (if (< n 0)
  68           syms
  69           (lp (1- n) (cons (gensym stem) syms)))))
  70   (let* ((args (gen-syms nargs "a"))
  71          (types (gen-syms nargs "t")))
  72     (let lp ((methods methods)
  73              (free free)
  74              (exp `(cache-miss ,gf-sym
  75                                ,(if rest?
  76                                     `(cons* ,@args rest)
  77                                     `(list ,@args)))))
  78       (cond
  79        ((null? methods)
  80         (values `(,(if rest? `(,@args . rest) args)
  81                   (let ,(map (lambda (t a)
  82                                `(,t (class-of ,a)))
  83                              types args)
  84                     ,exp))
  85                 free))
  86        (else
  87         ;; jeez
  88         (let preddy ((free free)
  89                      (types types)
  90                      (specs (vector-ref (car methods) 1))
  91                      (checks '()))
  92           (if (null? types)
  93               (let ((m-sym (gensym "p")))
  94                 (lp (cdr methods)
  95                     (acons (vector-ref (car methods) 3)
  96                            m-sym
  97                            free)
  98                     `(if (and . ,checks)
  99                          ,(if rest?
 100                               `(apply ,m-sym ,@args rest)
 101                               `(,m-sym . ,args))
 102                          ,exp)))
 103               (let ((var (assq-ref free (car specs))))
 104                 (if var
 105                     (preddy free
 106                             (cdr types)
 107                             (cdr specs)
 108                             (cons `(eq? ,(car types) ,var)
 109                                   checks))
 110                     (let ((var (gensym "c")))
 111                       (preddy (acons (car specs) var free)
 112                               (cdr types)
 113                               (cdr specs)
 114                               (cons `(eq? ,(car types) ,var)
 115                                     checks))))))))))))
 116
 117 (define (compute-dispatch-procedure gf cache)
 118   (define (scan)
 119     (let lp ((ls cache) (nreq -1) (nrest -1))
 120       (cond
 121        ((null? ls)
 122         (collate (make-vector (1+ nreq) '())
 123                  (make-vector (1+ nrest) '())))
 124        ((vector-ref (car ls) 2)         ; rest
 125         (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
 126        (else                            ; req
 127         (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
 128   (define (collate req rest)
 129     (let lp ((ls cache))
 130       (cond
 131        ((null? ls)
 132         (emit req rest))
 133        ((vector-ref (car ls) 2)         ; rest
 134         (let ((n (vector-ref (car ls) 0)))
 135           (vector-set! rest n (cons (car ls) (vector-ref rest n)))
 136           (lp (cdr ls))))
 137        (else                            ; req
 138         (let ((n (vector-ref (car ls) 0)))
 139           (vector-set! req n (cons (car ls) (vector-ref req n)))
 140           (lp (cdr ls)))))))
 141   (define (emit req rest)
 142     (let ((gf-sym (gensym "g")))
 143       (define (emit-rest n clauses free)
 144         (if (< n (vector-length rest))
 145             (let ((methods (vector-ref rest n)))
 146               (cond
 147                ((null? methods)
 148                 (emit-rest (1+ n) clauses free))
 149                ;; FIXME: hash dispatch
 150                (else
 151                 (call-with-values
 152                     (lambda ()
 153                       (emit-linear-dispatch gf-sym n methods free #t))
 154                   (lambda (clause free)
 155                     (emit-rest (1+ n) (cons clause clauses) free))))))
 156             (emit-req (1- (vector-length req)) clauses free)))
 157       (define (emit-req n clauses free)
 158         (if (< n 0)
 159             (comp `(lambda ,(map cdr free)
 160                      (case-lambda ,@clauses))
 161                   (map car free))
 162             (let ((methods (vector-ref req n)))
 163               (cond
 164                ((null? methods)
 165                 (emit-req (1- n) clauses free))
 166                ;; FIXME: hash dispatch
 167                (else
 168                 (call-with-values
 169                     (lambda ()
 170                       (emit-linear-dispatch gf-sym n methods free #f))
 171                   (lambda (clause free)
 172                     (emit-req (1- n) (cons clause clauses) free))))))))
 173
 174       (emit-rest 0
 175                  (if (or (zero? (vector-length rest))
 176                          (null? (vector-ref rest 0)))
 177                      (list `(args (cache-miss ,gf-sym args)))
 178                      '())
 179                  (acons gf gf-sym '()))))
 180   (define (comp exp vals)
 181     (let ((p ((@ (system base compile) compile) exp #:env *dispatch-module*)))
 182       (apply p vals)))
 183
 184   ;; kick it.
 185   (scan))
 186
 187 ;; o/~  ten, nine, eight
 188 ;;        sometimes that's just how it goes
 189 ;;          three, two, one
 190 ;;
 191 ;;            get out before it blows    o/~
 192 ;;
 193 (define timer-init 30)
 194 (define (delayed-compile gf)
 195   (let ((timer timer-init))
 196     (lambda args
 197       (set! timer (1- timer))
 198       (cond
 199        ((zero? timer)
 200         (let ((dispatch (compute-dispatch-procedure
 201                          gf (slot-ref gf 'effective-methods))))
 202           (slot-set! gf 'procedure dispatch)
 203           (apply dispatch args)))
 204        (else
 205         ;; interestingly, this catches recursive compilation attempts as
 206         ;; well; in that case, timer is negative
 207         (cache-dispatch gf args))))))
 208
 209 (define (cache-dispatch gf args)
 210   (define (map-until n f ls)
 211     (if (or (zero? n) (null? ls))
 212         '()
 213         (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
 214   (define (equal? x y) ; can't use the stock equal? because it's a generic...
 215     (cond ((pair? x) (and (pair? y)
 216                           (eq? (car x) (car y))
 217                           (equal? (cdr x) (cdr y))))
 218           ((null? x) (null? y))
 219           (else #f)))
 220   (if (slot-ref gf 'n-specialized)
 221       (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
 222         (let lp ((cache (slot-ref gf 'effective-methods)))
 223           (cond ((null? cache)
 224                  (cache-miss gf args))
 225                 ((equal? (vector-ref (car cache) 1) types)
 226                  (apply (vector-ref (car cache) 3) args))
 227                 (else (lp (cdr cache))))))
 228       (cache-miss gf args)))
 229
 230 (define (cache-miss gf args)
 231   (apply (memoize-method! gf args) args))
 232
 233 (define (memoize-effective-method! gf args applicable)
 234   (define (first-n ls n)
 235     (if (or (zero? n) (null? ls))
 236         '()
 237         (cons (car ls) (first-n (cdr ls) (- n 1)))))
 238   (define (parse n ls)
 239     (cond ((null? ls)
 240            (memoize n #f (map class-of args)))
 241           ((= n (slot-ref gf 'n-specialized))
 242            (memoize n #t (map class-of (first-n args n))))
 243           (else
 244            (parse (1+ n) (cdr ls)))))
 245   (define (memoize len rest? types)
 246     (let* ((cmethod (compute-cmethod applicable types))
 247            (cache (cons (vector len types rest? cmethod)
 248                         (slot-ref gf 'effective-methods))))
 249       (slot-set! gf 'effective-methods cache)
 250       (slot-set! gf 'procedure (delayed-compile gf))
 251       cmethod))
 252   (parse 0 args))
 253
 254
 255 ;;;
 256 ;;; Memoization
 257 ;;;
 258
 259 (define (memoize-method! gf args)
 260   (let ((applicable ((if (eq? gf compute-applicable-methods)
 261                          %compute-applicable-methods
 262                          compute-applicable-methods)
 263                      gf args)))
 264     (cond (applicable
 265            (memoize-effective-method! gf args applicable))
 266           (else
 267            (no-applicable-method gf args)))))
 268
 269 (set-procedure-property! memoize-method! 'system-procedure #t)