oop/goops/dispatch.scm

   1 ;;;;    Copyright (C) 1999, 2000 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This program is free software; you can redistribute it and/or modify
   4 ;;;; it under the terms of the GNU General Public License as published by
   5 ;;;; the Free Software Foundation; either version 2, or (at your option)
   6 ;;;; any later version.
   7 ;;;;
   8 ;;;; This program 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
  11 ;;;; GNU General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU General Public License
  14 ;;;; along with this software; see the file COPYING.  If not, write to
  15 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16 ;;;; Boston, MA 02111-1307 USA
  17 ;;;;
  18 \f
  19
  20 (define-module (oop goops dispatch)
  21   :use-module (oop goops)
  22   :use-module (oop goops util)
  23   :use-module (oop goops compile)
  24   :no-backtrace
  25   )
  26
  27 (export memoize-method!)
  28
  29 ;;;
  30 ;;; This file implements method memoization.  It will finally be
  31 ;;; implemented on C level in order to obtain fast generic function
  32 ;;; application also during the first pass through the code.
  33 ;;;
  34
  35 ;;;
  36 ;;; Constants
  37 ;;;
  38
  39 (define hashsets 8)
  40 (define hashset-index 7)
  41
  42 (define hash-threshold 3)
  43 (define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
  44
  45 (define initial-hash-size-1 (- initial-hash-size 1))
  46
  47 (define the-list-of-no-method '(no-method))
  48
  49 ;;;
  50 ;;; Method cache
  51 ;;;
  52
  53 ;; (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF)
  54 ;; (#@dispatch args N-SPECIALIZED HASHSET MASK
  55 ;;             #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
  56 ;;             GF)
  57
  58 ;;; Representation
  59
  60 ;; non-hashed form
  61
  62 (define method-cache-entries cadddr)
  63
  64 (define (set-method-cache-entries! mcache entries)
  65   (set-car! (cdddr mcache) entries))
  66
  67 (define (method-cache-n-methods exp)
  68   (n-cache-methods (method-cache-entries exp)))
  69
  70 (define (method-cache-methods exp)
  71   (cache-methods (method-cache-entries exp)))
  72
  73 ;; hashed form
  74
  75 (define (set-hashed-method-cache-hashset! exp hashset)
  76   (set-car! (cdddr exp) hashset))
  77
  78 (define (set-hashed-method-cache-mask! exp mask)
  79   (set-car! (cddddr exp) mask))
  80
  81 (define (hashed-method-cache-entries exp)
  82   (list-ref exp 5))
  83
  84 (define (set-hashed-method-cache-entries! exp entries)
  85   (set-car! (list-cdr-ref exp 5) entries))
  86
  87 ;; either form
  88
  89 (define (method-cache-generic-function exp)
  90   (list-ref exp (if (method-cache-hashed? exp) 6 4)))
  91
  92 ;;; Predicates
  93
  94 (define (method-cache-hashed? x)
  95   (integer? (cadddr x)))
  96
  97 (define max-non-hashed-index (- hash-threshold 2))
  98
  99 (define (passed-hash-threshold? exp)
 100   (and (> (vector-length (method-cache-entries exp)) max-non-hashed-index)
 101        (struct? (car (vector-ref (method-cache-entries exp)
 102                                  max-non-hashed-index)))))
 103
 104 ;;; Converting a method cache to hashed form
 105
 106 (define (method-cache->hashed! exp)
 107   (set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp))))
 108   exp)
 109
 110 ;;;
 111 ;;; Cache entries
 112 ;;;
 113
 114 (define (n-cache-methods entries)
 115   (do ((i (- (vector-length entries) 1) (- i 1)))
 116       ((or (< i 0) (struct? (car (vector-ref entries i))))
 117        (+ i 1))))
 118
 119 (define (cache-methods entries)
 120   (do ((i (- (vector-length entries) 1) (- i 1))
 121        (methods '() (let ((entry (vector-ref entries i)))
 122                       (if (struct? (car entry))
 123                           (cons entry methods)
 124                           methods))))
 125       ((< i 0) methods)))
 126
 127 ;;;
 128 ;;; Method insertion
 129 ;;;
 130
 131 (define (method-cache-insert! exp entry)
 132   (let* ((entries (method-cache-entries exp))
 133          (n (n-cache-methods entries)))
 134     (if (>= n (vector-length entries))
 135         ;; grow cache
 136         (let ((new-entries (make-vector (* 2 (vector-length entries))
 137                                         the-list-of-no-method)))
 138           (do ((i 0 (+ i 1)))
 139               ((= i n))
 140             (vector-set! new-entries i (vector-ref entries i)))
 141           (vector-set! new-entries n entry)
 142           (set-method-cache-entries! exp new-entries))
 143         (vector-set! entries n entry))))
 144
 145 (define (hashed-method-cache-insert! exp entry)
 146   (let* ((cache (hashed-method-cache-entries exp))
 147          (size (vector-length cache)))
 148     (let* ((entries (cons entry (cache-methods cache)))
 149            (size (if (<= (length entries) size)
 150                      size
 151                      ;; larger size required
 152                      (let ((new-size (* 2 size)))
 153                        (set-hashed-method-cache-mask! exp (- new-size 1))
 154                        new-size)))
 155            (min-misses size)
 156            (best #f))
 157       (do ((hashset 0 (+ 1 hashset)))
 158           ((= hashset hashsets))
 159         (let* ((test-cache (make-vector size the-list-of-no-method))
 160                (misses (cache-try-hash! min-misses hashset test-cache entries)))
 161           (cond ((zero? misses)
 162                  (set! min-misses 0)
 163                  (set! best hashset)
 164                  (set! cache test-cache)
 165                  (set! hashset (- hashsets 1)))
 166                 ((< misses min-misses)
 167                  (set! min-misses misses)
 168                  (set! best hashset)
 169                  (set! cache test-cache)))))
 170       (set-hashed-method-cache-hashset! exp best)
 171       (set-hashed-method-cache-entries! exp cache))))
 172
 173 ;;;
 174 ;;; Caching
 175 ;;;
 176
 177 (define environment? pair?)
 178
 179 (define (cache-hashval hashset entry)
 180   (let ((hashset-index (+ hashset-index hashset)))
 181     (do ((sum 0)
 182          (classes entry (cdr classes)))
 183         ((environment? (car classes)) sum)
 184       (set! sum (+ sum (struct-ref (car classes) hashset-index))))))
 185
 186 (define (cache-try-hash! min-misses hashset cache entries)
 187   (let ((max-misses 0)
 188         (mask (- (vector-length cache) 1)))
 189     (catch 'misses
 190            (lambda ()
 191              (do ((ls entries (cdr ls))
 192                   (misses 0 0))
 193                  ((null? ls) max-misses)
 194                (do ((i (logand mask (cache-hashval hashset (car ls)))
 195                        (logand mask (+ i 1))))
 196                    ((not (struct? (car (vector-ref cache i))))
 197                     (vector-set! cache i (car ls)))
 198                  (set! misses (+ 1 misses))
 199                  (if (>= misses min-misses)
 200                      (throw 'misses misses)))
 201                (if (> misses max-misses)
 202                    (set! max-misses misses))))
 203            (lambda (key misses)
 204              misses))))
 205
 206 ;;;
 207 ;;; Memoization
 208 ;;;
 209
 210 ;; Backward compatibility
 211 (if (not (defined? 'lookup-create-cmethod))
 212     (define (lookup-create-cmethod gf args)
 213       (no-applicable-method (car args) (cadr args))))
 214
 215 (define (memoize-method! gf args exp)
 216   (if (not (slot-ref gf 'used-by))
 217       (slot-set! gf 'used-by '()))
 218   (let ((applicable ((if (eq? gf compute-applicable-methods)
 219                          %compute-applicable-methods
 220                          compute-applicable-methods)
 221                      gf args)))
 222     (cond (applicable
 223            ;; *fixme* dispatch.scm needs rewriting Since the current
 224            ;; code mutates the method cache, we have to work on a
 225            ;; copy.  Otherwise we might disturb another thread
 226            ;; currently dispatching on the cache.  (No need to copy
 227            ;; the vector.)
 228            (let* ((new (list-copy exp))
 229                   (res
 230                    (cond ((method-cache-hashed? new)
 231                           (method-cache-install! hashed-method-cache-insert!
 232                                                  new args applicable))
 233                          ((passed-hash-threshold? new)
 234                           (method-cache-install! hashed-method-cache-insert!
 235                                                  (method-cache->hashed! new)
 236                                                  args
 237                                                  applicable))
 238                          (else
 239                           (method-cache-install! method-cache-insert!
 240                                                  new args applicable)))))
 241              (set-cdr! (cdr exp) (cddr new))
 242              res))
 243           ((null? args)
 244            (lookup-create-cmethod no-applicable-method (list gf '())))
 245           (else
 246            ;; Mutate arglist to fit no-applicable-method
 247            (set-cdr! args (list (cons (car args) (cdr args))))
 248            (set-car! args gf)
 249            (lookup-create-cmethod no-applicable-method args)))))
 250
 251 (set-procedure-property! memoize-method! 'system-procedure #t)
 252
 253 (define method-cache-install!
 254   (letrec ((first-n
 255             (lambda (ls n)
 256               (if (or (zero? n) (null? ls))
 257                   '()
 258                   (cons (car ls) (first-n (cdr ls) (- n 1)))))))
 259     (lambda (insert! exp args applicable)
 260       (let* ((specializers (method-specializers (car applicable)))
 261              (n-specializers
 262               (if (list? specializers)
 263                   (length specializers)
 264                   (+ 1 (slot-ref (method-cache-generic-function exp)
 265                                  'n-specialized)))))
 266         (let* ((types (map class-of (first-n args n-specializers)))
 267                (entry+cmethod (compute-entry-with-cmethod applicable types)))
 268           (insert! exp (car entry+cmethod)) ; entry = types + cmethod
 269           (cdr entry+cmethod) ; cmethod
 270           )))))