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? `(cons* ,@args rest) args))))
  76       (cond
  77        ((null? methods)
  78         (values `(,(if rest? `(,@args . rest) args)
  79                   (let ,(map (lambda (t a)
  80                                `(,t (class-of ,a)))
  81                              types args)
  82                     ,exp))
  83                 free))
  84        (else
  85         ;; jeez
  86         (let preddy ((free free)
  87                      (types types)
  88                      (specs (vector-ref (car methods) 1))
  89                      (checks '()))
  90           (if (null? types)
  91               (let ((m-sym (gensym "p")))
  92                 (lp (cdr methods)
  93                     (acons (vector-ref (car methods) 3)
  94                            m-sym
  95                            free)
  96                     `(if (and . ,checks)
  97                          ,(if rest?
  98                               `(apply ,m-sym ,@args rest)
  99                               `(,m-sym . ,args))
 100                          ,exp)))
 101               (let ((var (assq-ref free (car specs))))
 102                 (if var
 103                     (preddy free
 104                             (cdr types)
 105                             (cdr specs)
 106                             (cons `(eq? ,(car types) ,var)
 107                                   checks))
 108                     (let ((var (gensym "c")))
 109                       (preddy (acons (car specs) var free)
 110                               (cdr types)
 111                               (cdr specs)
 112                               (cons `(eq? ,(car types) ,var)
 113                                     checks))))))))))))
 114
 115 (define (compute-dispatch-procedure gf cache)
 116   (define (scan)
 117     (let lp ((ls cache) (nreq -1) (nrest -1))
 118       (cond
 119        ((null? ls)
 120         (collate (make-vector (1+ nreq) '())
 121                  (make-vector (1+ nrest) '())))
 122        ((vector-ref (car ls) 2)         ; rest
 123         (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
 124        (else                            ; req
 125         (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
 126   (define (collate req rest)
 127     (let lp ((ls cache))
 128       (cond
 129        ((null? ls)
 130         (emit req rest))
 131        ((vector-ref (car ls) 2)         ; rest
 132         (let ((n (vector-ref (car ls) 0)))
 133           (vector-set! rest n (cons (car ls) (vector-ref rest n)))
 134           (lp (cdr ls))))
 135        (else                            ; req
 136         (let ((n (vector-ref (car ls) 0)))
 137           (vector-set! req n (cons (car ls) (vector-ref req n)))
 138           (lp (cdr ls)))))))
 139   (define (emit req rest)
 140     (let ((gf-sym (gensym "g")))
 141       (define (emit-rest n clauses free)
 142         (if (< n (vector-length rest))
 143             (let ((methods (vector-ref rest n)))
 144               (cond
 145                ((null? methods)
 146                 (emit-rest (1+ n) clauses free))
 147                ;; FIXME: hash dispatch
 148                (else
 149                 (call-with-values
 150                     (lambda ()
 151                       (emit-linear-dispatch gf-sym n methods free #t))
 152                   (lambda (clause free)
 153                     (emit-rest (1+ n) (cons clause clauses) free))))))
 154             (emit-req (1- (vector-length req)) clauses free)))
 155       (define (emit-req n clauses free)
 156         (if (< n 0)
 157             (comp `(lambda ,(map cdr free)
 158                      (case-lambda ,@clauses))
 159                   (map car free))
 160             (let ((methods (vector-ref req n)))
 161               (cond
 162                ((null? methods)
 163                 (emit-req (1- n) clauses free))
 164                ;; FIXME: hash dispatch
 165                (else
 166                 (call-with-values
 167                     (lambda ()
 168                       (emit-linear-dispatch gf-sym n methods free #f))
 169                   (lambda (clause free)
 170                     (emit-req (1- n) (cons clause clauses) free))))))))
 171
 172       (emit-rest 0
 173                  (if (or (zero? (vector-length rest))
 174                          (null? (vector-ref rest 0)))
 175                      (list `(args (cache-miss ,gf-sym args)))
 176                      '())
 177                  (acons gf gf-sym '()))))
 178   (define (comp exp vals)
 179     (let ((p ((@ (system base compile) compile) exp #:env *dispatch-module*)))
 180       (apply p vals)))
 181
 182   ;; kick it.
 183   (scan))
 184
 185 ;; o/~  ten, nine, eight
 186 ;;        sometimes that's just how it goes
 187 ;;          three, two, one
 188 ;;
 189 ;;            get out before it blows    o/~
 190 ;;
 191 (define timer-init 10)
 192 (define *in-progress* (make-fluid))
 193 (fluid-set! *in-progress* '())
 194
 195 (define (delayed-compile gf)
 196   (let ((timer timer-init))
 197     (lambda args
 198       (cond
 199        ((> timer 0)
 200         (set! timer (1- timer))
 201         (cache-dispatch gf args))
 202        (else
 203         (let ((in-progress (fluid-ref *in-progress*)))
 204           (if (memq gf in-progress)
 205               (cache-dispatch gf args)
 206               (with-fluids ((*in-progress* (cons gf in-progress)))
 207                 (let ((dispatch (compute-dispatch-procedure
 208                                  gf (slot-ref gf 'effective-methods))))
 209                   (slot-set! gf 'dispatch-procedure dispatch)
 210                   (apply dispatch args))))))))))
 211
 212 (define (cache-dispatch gf args)
 213   (define (map-until n f ls)
 214     (if (or (zero? n) (null? ls))
 215         '()
 216         (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
 217   (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
 218     (let lp ((cache (slot-ref gf 'effective-methods)))
 219       (cond ((null? cache)
 220              (cache-miss gf args))
 221             ((equal? (vector-ref (car cache) 1) types)
 222              (apply (vector-ref (car cache) 3) args))
 223             (else (lp (cdr cache)))))))
 224
 225 (define (cache-miss gf args)
 226   (apply (memoize-method! gf args (slot-ref gf '%cache)) args))
 227
 228 (define (memoize-effective-method! gf args applicable)
 229   (define (first-n ls n)
 230     (if (or (zero? n) (null? ls))
 231         '()
 232         (cons (car ls) (first-n (cdr ls) (- n 1)))))
 233   (define (parse n ls)
 234     (cond ((null? ls)
 235            (memoize n #f (map class-of args)))
 236           ((= n (slot-ref gf 'n-specialized))
 237            (memoize n #t (map class-of (first-n args n))))
 238           (else
 239            (parse (1+ n) (cdr ls)))))
 240   (define (memoize len rest? types)
 241     (let* ((cmethod (compute-cmethod applicable types))
 242            (cache (cons (vector len types rest? cmethod)
 243                         (slot-ref gf 'effective-methods))))
 244       (slot-set! gf 'effective-methods cache)
 245       (slot-set! gf 'dispatch-procedure (delayed-compile gf))
 246       cmethod))
 247   (parse 0 args))
 248
 249
 250 ;;;
 251 ;;; This file implements method memoization.  It will finally be
 252 ;;; implemented on C level in order to obtain fast generic function
 253 ;;; application also during the first pass through the code.
 254 ;;;
 255
 256 ;;;
 257 ;;; Constants
 258 ;;;
 259
 260 (define hashsets 8)
 261 (define hashset-index 9)
 262
 263 (define hash-threshold 3)
 264 (define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
 265
 266 (define initial-hash-size-1 (- initial-hash-size 1))
 267
 268 (define the-list-of-no-method '(no-method))
 269
 270 ;;;
 271 ;;; Method cache
 272 ;;;
 273
 274 ;; (#@dispatch args N-SPECIALIZED #((TYPE1 ... . CMETHOD) ...) GF)
 275 ;; (#@dispatch args N-SPECIALIZED HASHSET MASK
 276 ;;             #((TYPE1 ... . CMETHOD) ...)
 277 ;;             GF)
 278
 279 ;;; Representation
 280
 281 ;; non-hashed form
 282
 283 (define method-cache-entries cadddr)
 284
 285 (define (set-method-cache-entries! mcache entries)
 286   (set-car! (cdddr mcache) entries))
 287
 288 (define (method-cache-n-methods exp)
 289   (n-cache-methods (method-cache-entries exp)))
 290
 291 (define (method-cache-methods exp)
 292   (cache-methods (method-cache-entries exp)))
 293
 294 ;; hashed form
 295
 296 (define (set-hashed-method-cache-hashset! exp hashset)
 297   (set-car! (cdddr exp) hashset))
 298
 299 (define (set-hashed-method-cache-mask! exp mask)
 300   (set-car! (cddddr exp) mask))
 301
 302 (define (hashed-method-cache-entries exp)
 303   (list-ref exp 5))
 304
 305 (define (set-hashed-method-cache-entries! exp entries)
 306   (set-car! (list-cdr-ref exp 5) entries))
 307
 308 ;; either form
 309
 310 (define (method-cache-generic-function exp)
 311   (list-ref exp (if (method-cache-hashed? exp) 6 4)))
 312
 313 ;;; Predicates
 314
 315 (define (method-cache-hashed? x)
 316   (integer? (cadddr x)))
 317
 318 (define max-non-hashed-index (- hash-threshold 2))
 319
 320 (define (passed-hash-threshold? exp)
 321   (and (> (vector-length (method-cache-entries exp)) max-non-hashed-index)
 322        (struct? (car (vector-ref (method-cache-entries exp)
 323                                  max-non-hashed-index)))))
 324
 325 ;;; Converting a method cache to hashed form
 326
 327 (define (method-cache->hashed! exp)
 328   (set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp))))
 329   exp)
 330
 331 ;;;
 332 ;;; Cache entries
 333 ;;;
 334
 335 (define (n-cache-methods entries)
 336   (do ((i (- (vector-length entries) 1) (- i 1)))
 337       ((or (< i 0) (struct? (car (vector-ref entries i))))
 338        (+ i 1))))
 339
 340 (define (cache-methods entries)
 341   (do ((i (- (vector-length entries) 1) (- i 1))
 342        (methods '() (let ((entry (vector-ref entries i)))
 343                       (if (or (not (pair? entry)) (struct? (car entry)))
 344                           (cons entry methods)
 345                           methods))))
 346       ((< i 0) methods)))
 347
 348 ;;;
 349 ;;; Method insertion
 350 ;;;
 351
 352 (define (method-cache-insert! exp entry)
 353   (let* ((entries (method-cache-entries exp))
 354          (n (n-cache-methods entries)))
 355     (if (>= n (vector-length entries))
 356         ;; grow cache
 357         (let ((new-entries (make-vector (* 2 (vector-length entries))
 358                                         the-list-of-no-method)))
 359           (do ((i 0 (+ i 1)))
 360               ((= i n))
 361             (vector-set! new-entries i (vector-ref entries i)))
 362           (vector-set! new-entries n entry)
 363           (set-method-cache-entries! exp new-entries))
 364         (vector-set! entries n entry))))
 365
 366 (define (hashed-method-cache-insert! exp entry)
 367   (let* ((cache (hashed-method-cache-entries exp))
 368          (size (vector-length cache)))
 369     (let* ((entries (cons entry (cache-methods cache)))
 370            (size (if (<= (length entries) size)
 371                      size
 372                      ;; larger size required
 373                      (let ((new-size (* 2 size)))
 374                        (set-hashed-method-cache-mask! exp (- new-size 1))
 375                        new-size)))
 376            (min-misses size)
 377            (best #f))
 378       (do ((hashset 0 (+ 1 hashset)))
 379           ((= hashset hashsets))
 380         (let* ((test-cache (make-vector size the-list-of-no-method))
 381                (misses (cache-try-hash! min-misses hashset test-cache entries)))
 382           (cond ((zero? misses)
 383                  (set! min-misses 0)
 384                  (set! best hashset)
 385                  (set! cache test-cache)
 386                  (set! hashset (- hashsets 1)))
 387                 ((< misses min-misses)
 388                  (set! min-misses misses)
 389                  (set! best hashset)
 390                  (set! cache test-cache)))))
 391       (set-hashed-method-cache-hashset! exp best)
 392       (set-hashed-method-cache-entries! exp cache))))
 393
 394 ;;;
 395 ;;; Caching
 396 ;;;
 397
 398 (define (cache-hashval hashset entry)
 399   (let ((hashset-index (+ hashset-index hashset)))
 400     (do ((sum 0)
 401          (classes entry (cdr classes)))
 402         ((not (and (pair? classes) (struct? (car classes))))
 403          sum)
 404       (set! sum (+ sum (struct-ref (car classes) hashset-index))))))
 405
 406 (define (cache-try-hash! min-misses hashset cache entries)
 407   (let ((mask (- (vector-length cache) 1)))
 408     (let outer ((in entries) (max-misses 0))
 409       (if (null? in)
 410           max-misses
 411           (let inner ((i (logand mask (cache-hashval hashset (car in))))
 412                       (misses 0))
 413             (cond
 414              ((and (pair? (vector-ref cache i))
 415                    (eq? (car (vector-ref cache i)) 'no-method))
 416               (vector-set! cache i (car in))
 417               (outer (cdr in) (if (> misses max-misses) misses max-misses)))
 418              (else
 419               (let ((misses (+ 1 misses)))
 420                 (if (>= misses min-misses)
 421                     misses ;; this is a return, yo.
 422                     (inner (logand mask (+ i 1)) misses))))))))))
 423
 424 ;;;
 425 ;;; Memoization
 426 ;;;
 427
 428 (define (memoize-method! gf args exp)
 429   (let ((applicable ((if (eq? gf compute-applicable-methods)
 430                          %compute-applicable-methods
 431                          compute-applicable-methods)
 432                      gf args)))
 433     (cond (applicable
 434            (memoize-effective-method! gf args applicable)
 435            ;; *fixme* dispatch.scm needs rewriting Since the current
 436            ;; code mutates the method cache, we have to work on a
 437            ;; copy.  Otherwise we might disturb another thread
 438            ;; currently dispatching on the cache.  (No need to copy
 439            ;; the vector.)
 440            (let* ((new (list-copy exp))
 441                   (res
 442                    (cond ((method-cache-hashed? new)
 443                           (method-cache-install! hashed-method-cache-insert!
 444                                                  new args applicable))
 445                          ((passed-hash-threshold? new)
 446                           (method-cache-install! hashed-method-cache-insert!
 447                                                  (method-cache->hashed! new)
 448                                                  args
 449                                                  applicable))
 450                          (else
 451                           (method-cache-install! method-cache-insert!
 452                                                  new args applicable)))))
 453              (set-cdr! (cdr exp) (cddr new))
 454              res))
 455           (else
 456            (no-applicable-method gf args)))))
 457
 458 (set-procedure-property! memoize-method! 'system-procedure #t)
 459
 460 (define method-cache-install!
 461   (letrec ((first-n
 462             (lambda (ls n)
 463               (if (or (zero? n) (null? ls))
 464                   '()
 465                   (cons (car ls) (first-n (cdr ls) (- n 1)))))))
 466     (lambda (insert! exp args applicable)
 467       (let* ((specializers (method-specializers (car applicable)))
 468              (n-specializers
 469               (if (list? specializers)
 470                   (length specializers)
 471                   (+ 1 (slot-ref (method-cache-generic-function exp)
 472                                  'n-specialized)))))
 473         (let* ((types (map class-of (first-n args n-specializers)))
 474                (cmethod (compute-cmethod applicable types)))
 475           (insert! exp (append types cmethod)) ; entry = types + cmethod
 476           cmethod))))) ; cmethod