oop/goops/dispatch.scm

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