guile18/oop/goops/dispatch.scm

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