home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / guile / 1.6 / oop / goops / dispatch.scm < prev    next >
Encoding:
Text File  |  2006-06-19  |  9.1 KB  |  292 lines
  1. ;;;;     Copyright (C) 1999, 2000, 2001, 2003 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., 51 Franklin Street, Fifth Floor,
  16. ;;;; Boston, MA 02110-1301 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.  
  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 7)
  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 (cache-hashval hashset entry)
  201.   (let ((hashset-index (+ hashset-index hashset)))
  202.     (do ((sum 0)
  203.      (classes entry (cdr classes)))
  204.     ((not (struct? (car classes))) sum)
  205.       (set! sum (+ sum (struct-ref (car classes) hashset-index))))))
  206.  
  207. (define (cache-try-hash! min-misses hashset cache entries)
  208.   (let ((max-misses 0)
  209.     (mask (- (vector-length cache) 1)))
  210.     (catch 'misses
  211.        (lambda ()
  212.          (do ((ls entries (cdr ls))
  213.           (misses 0 0))
  214.          ((null? ls) max-misses)
  215.            (do ((i (logand mask (cache-hashval hashset (car ls)))
  216.                (logand mask (+ i 1))))
  217.            ((not (struct? (car (vector-ref cache i))))
  218.             (vector-set! cache i (car ls)))
  219.          (set! misses (+ 1 misses))
  220.          (if (>= misses min-misses)
  221.              (throw 'misses misses)))
  222.            (if (> misses max-misses)
  223.            (set! max-misses misses))))
  224.        (lambda (key misses)
  225.          misses))))
  226.  
  227. ;;;
  228. ;;; Memoization
  229. ;;;
  230.  
  231. ;; Backward compatibility
  232. (if (not (defined? 'lookup-create-cmethod))
  233.     (define (lookup-create-cmethod gf args)
  234.       (no-applicable-method (car args) (cadr args))))
  235.  
  236. (define (memoize-method! gf args exp)
  237.   (if (not (slot-ref gf 'used-by))
  238.       (slot-set! gf 'used-by '()))
  239.   (let ((applicable ((if (eq? gf compute-applicable-methods)
  240.              %compute-applicable-methods
  241.              compute-applicable-methods)
  242.              gf args)))
  243.     (cond (applicable
  244.        ;; *fixme* dispatch.scm needs rewriting Since the current
  245.        ;; code mutates the method cache, we have to work on a
  246.        ;; copy.  Otherwise we might disturb another thread
  247.        ;; currently dispatching on the cache.  (No need to copy
  248.        ;; the vector.)
  249.        (let* ((new (list-copy exp))
  250.           (res
  251.            (cond ((method-cache-hashed? new)
  252.               (method-cache-install! hashed-method-cache-insert!
  253.                          new args applicable))
  254.              ((passed-hash-threshold? new)
  255.               (method-cache-install! hashed-method-cache-insert!
  256.                          (method-cache->hashed! new)
  257.                          args
  258.                          applicable))
  259.              (else
  260.               (method-cache-install! method-cache-insert!
  261.                          new args applicable)))))
  262.          (set-cdr! (cdr exp) (cddr new))
  263.          res))
  264.       ((null? args)
  265.        (lookup-create-cmethod no-applicable-method (list gf '())))
  266.       (else
  267.        ;; Mutate arglist to fit no-applicable-method
  268.        (set-cdr! args (list (cons (car args) (cdr args))))
  269.        (set-car! args gf)
  270.        (lookup-create-cmethod no-applicable-method args)))))
  271.  
  272. (set-procedure-property! memoize-method! 'system-procedure #t)
  273.  
  274. (define method-cache-install!
  275.   (letrec ((first-n
  276.         (lambda (ls n)
  277.           (if (or (zero? n) (null? ls))
  278.           '()
  279.           (cons (car ls) (first-n (cdr ls) (- n 1)))))))
  280.     (lambda (insert! exp args applicable)
  281.       (let* ((specializers (method-specializers (car applicable)))
  282.          (n-specializers
  283.           (if (list? specializers)
  284.           (length specializers)
  285.           (+ 1 (slot-ref (method-cache-generic-function exp)
  286.                  'n-specialized)))))
  287.     (let* ((types (map class-of (first-n args n-specializers)))
  288.            (entry+cmethod (compute-entry-with-cmethod applicable types)))
  289.       (insert! exp (car entry+cmethod)) ; entry = types + cmethod
  290.       (cdr entry+cmethod) ; cmethod
  291.       )))))
  292.