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 ;;;
  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 (define (cache-try-hash! min-misses hashset cache entries)
 189   (let ((mask (- (vector-length cache) 1)))
 190     (let outer ((in entries) (max-misses 0))
 191       (if (null? in)
 192           max-misses
 193           (let inner ((i (logand mask (cache-hashval hashset (car in))))
 194                       (misses 0))
 195             (cond
 196              ((and (pair? (vector-ref cache i))
 197                    (eq? (car (vector-ref cache i)) 'no-method))
 198               (vector-set! cache i (car in))
 199               (outer (cdr in) (if (> misses max-misses) misses max-misses)))
 200              (else
 201               (let ((misses (+ 1 misses)))
 202                 (if (>= misses min-misses)
 203                     misses ;; this is a return, yo.
 204                     (inner (logand mask (+ i 1)) misses))))))))))
 205
 206 ;;;
 207 ;;; Memoization
 208 ;;;
 209
 210 ;; Backward compatibility
 211 (define (lookup-create-cmethod gf args)
 212   (no-applicable-method (car args) (cadr args)))
 213
 214 (define (memoize-method! gf args exp)
 215   (if (not (slot-ref gf 'used-by))
 216       (slot-set! gf 'used-by '()))
 217   (let ((applicable ((if (eq? gf compute-applicable-methods)
 218                          %compute-applicable-methods
 219                          compute-applicable-methods)
 220                      gf args)))
 221     (cond (applicable
 222            ;; *fixme* dispatch.scm needs rewriting Since the current
 223            ;; code mutates the method cache, we have to work on a
 224            ;; copy.  Otherwise we might disturb another thread
 225            ;; currently dispatching on the cache.  (No need to copy
 226            ;; the vector.)
 227            (let* ((new (list-copy exp))
 228                   (res
 229                    (cond ((method-cache-hashed? new)
 230                           (method-cache-install! hashed-method-cache-insert!
 231                                                  new args applicable))
 232                          ((passed-hash-threshold? new)
 233                           (method-cache-install! hashed-method-cache-insert!
 234                                                  (method-cache->hashed! new)
 235                                                  args
 236                                                  applicable))
 237                          (else
 238                           (method-cache-install! method-cache-insert!
 239                                                  new args applicable)))))
 240              (set-cdr! (cdr exp) (cddr new))
 241              res))
 242           ((null? args)
 243            (lookup-create-cmethod no-applicable-method (list gf '())))
 244           (else
 245            ;; Mutate arglist to fit no-applicable-method
 246            (set-cdr! args (list (cons (car args) (cdr args))))
 247            (set-car! args gf)
 248            (lookup-create-cmethod no-applicable-method args)))))
 249
 250 (set-procedure-property! memoize-method! 'system-procedure #t)
 251
 252 (define method-cache-install!
 253   (letrec ((first-n
 254             (lambda (ls n)
 255               (if (or (zero? n) (null? ls))
 256                   '()
 257                   (cons (car ls) (first-n (cdr ls) (- n 1)))))))
 258     (lambda (insert! exp args applicable)
 259       (let* ((specializers (method-specializers (car applicable)))
 260              (n-specializers
 261               (if (list? specializers)
 262                   (length specializers)
 263                   (+ 1 (slot-ref (method-cache-generic-function exp)
 264                                  'n-specialized)))))
 265         (let* ((types (map class-of (first-n args n-specializers)))
 266                (cmethod (compute-cmethod applicable types)))
 267           (insert! exp (append types cmethod)) ; entry = types + cmethod
 268           cmethod))))) ; cmethod