home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / oop / goops / dispatch.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  7.8 KB  |  267 lines
  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.  
  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.       )))))
  267.