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