home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / oop / goops / dispatch.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  9.1 KB  |  294 lines
  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.  
  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 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.       )))))
  294.