home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / geneqht.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  245 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: geneqht.scm,v 1.2 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1990-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; EQ?-Hash Tables for Generic Procedures
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (make-eqht)
  27.   (let ((table (%make-eqht)))
  28.     (reset-table! table)
  29.     (record-address-hash-table! table)
  30.     table))
  31.  
  32. (define (eqht/get table key default)
  33.   (let ((entries
  34.      (vector-ref (table-buckets table) (compute-key-hash table key))))
  35.     (let loop ((entries entries))
  36.       (cond ((null? entries)
  37.          default)
  38.         ((eq? (system-pair-car (car entries)) key)
  39.          (system-pair-cdr (car entries)))
  40.         (else
  41.          (loop (cdr entries)))))))
  42.  
  43. (define (eqht/put! table key datum)
  44.   (let ((buckets (table-buckets table))
  45.     (hash (compute-key-hash table key)))
  46.     (let loop ((entries (vector-ref buckets hash)))
  47.       (cond ((null? entries)
  48.          (without-interrupts
  49.           (lambda ()
  50.         (vector-set! buckets
  51.                  hash
  52.                  (cons (weak-cons key datum)
  53.                    (vector-ref buckets hash)))
  54.         (if (> (let ((count (fix:+ (table-count table) 1)))
  55.              (set-table-count! table count)
  56.              count)
  57.                (table-grow-size table))
  58.             (grow-table! table)))))
  59.         ((eq? (system-pair-car (car entries)) key)
  60.          (system-pair-set-cdr! (car entries) datum))
  61.         (else
  62.          (loop (cdr entries)))))))
  63.  
  64. (define (eqht/for-each table procedure)
  65.   (for-each-vector-element (table-buckets table)
  66.     (lambda (entries)
  67.       (for-each (lambda (entry)
  68.           (if (system-pair-car entry)
  69.               (procedure (system-pair-car entry)
  70.                  (system-pair-cdr entry))))
  71.         entries))))
  72.  
  73. ;;;; Address Hashing
  74.  
  75. (define (compute-key-hash table key)
  76.   (let loop ()
  77.     (let ((hash (eq-hash-mod key (vector-length (table-buckets table)))))
  78.       (if (not (table-needs-rehash? table))
  79.       hash
  80.       (begin
  81.         (without-interrupts (lambda () (rehash-table! table)))
  82.         (loop))))))
  83.  
  84. (define-integrable (eq-hash-mod key modulus)
  85.   (fix:remainder (let ((n
  86.             ((ucode-primitive primitive-object-set-type)
  87.              (ucode-type positive-fixnum)
  88.              key)))
  89.            (if (fix:< n 0)
  90.                (fix:not n)
  91.                n))
  92.          modulus))
  93.  
  94. (define (record-address-hash-table! table)
  95.   (set! address-hash-tables (weak-cons table address-hash-tables))
  96.   unspecific)
  97.  
  98. (define (mark-address-hash-tables!)
  99.   (let loop ((previous #f) (tables address-hash-tables))
  100.     (cond ((null? tables)
  101.        unspecific)
  102.       ((system-pair-car tables)
  103.        (set-table-needs-rehash?! (system-pair-car tables) #t)
  104.        (loop tables (system-pair-cdr tables)))
  105.       (else
  106.        (if previous
  107.            (system-pair-set-cdr! previous (system-pair-cdr tables))
  108.            (set! address-hash-tables (system-pair-cdr tables)))
  109.        (loop previous (system-pair-cdr tables))))))
  110.  
  111. (define address-hash-tables)
  112.  
  113. (define (initialize-address-hashing!)
  114.   (set! address-hash-tables '())
  115.   (add-primitive-gc-daemon! mark-address-hash-tables!))
  116.  
  117. ;;;; Resizing
  118.  
  119. (define (grow-table! table)
  120.   (let loop ((size (table-grow-size table)))
  121.     (if (> (table-count table) size)
  122.     (loop (let ((size* (round->exact (* size 2.))))
  123.         (if (> size* size)
  124.             size*
  125.             (+ size 1))))
  126.     (new-size! table size))))
  127.  
  128. (define (shrink-table! table)
  129.   (let loop ((size (table-grow-size table)))
  130.     (cond ((<= size minimum-size)
  131.        (new-size! table minimum-size))
  132.       ((< (table-count table) (compute-shrink-size size))
  133.        (loop (decrement-size size)))
  134.       (else
  135.        (new-size! table size)))))
  136.  
  137. (define (new-size! table size)
  138.   (set-table-grow-size! table size)
  139.   (let ((old-buckets (table-buckets table)))
  140.     (reset-table! table)
  141.     (rehash-table-from-old-buckets! table old-buckets)))
  142.  
  143. (define (reset-table! table)
  144.   (set-table-shrink-size! table (compute-shrink-size (table-grow-size table)))
  145.   (let ((primes
  146.      (let ((size (round->exact (table-grow-size table))))
  147.        (let loop
  148.            ((primes
  149.          (if (< size (stream-car (table-primes table)))
  150.              prime-numbers-stream
  151.              (table-primes table))))
  152.          (if (<= size (stream-car primes))
  153.          primes
  154.          (loop (stream-cdr primes)))))))
  155.     (set-table-primes! table primes)
  156.     (set-table-buckets! table (make-vector (stream-car primes) '()))))
  157.  
  158. (define (compute-shrink-size size)
  159.   (if (<= size minimum-size)
  160.       0
  161.       (max 0 (decrement-size (decrement-size size)))))
  162.  
  163. (define (decrement-size size)
  164.   (let ((size* (round->exact (/ size 2.))))
  165.     (if (< size* size)
  166.     size*
  167.     (- size 1))))
  168.  
  169. ;;;; Rehashing
  170.  
  171. (define (rehash-table-from-old-buckets! table buckets)
  172.   (let ((n-buckets (vector-length buckets)))
  173.     (set-table-needs-rehash?! table #f)
  174.     (do ((i 0 (fix:+ i 1)))
  175.     ((fix:= i n-buckets))
  176.       (let ((entries (vector-ref buckets i)))
  177.     (if (not (null? entries))
  178.         (rehash-table-entries! table entries)))))
  179.   (maybe-shrink-table! table))
  180.  
  181. (define (rehash-table-entries! table entries)
  182.   (let ((buckets (table-buckets table)))
  183.     (let ((n-buckets (vector-length buckets)))
  184.       (let loop ((entries entries))
  185.     (if (not (null? entries))
  186.         (let ((rest (cdr entries)))
  187.           (if (system-pair-car (car entries))
  188.           (let ((hash
  189.              (eq-hash-mod (system-pair-car (car entries))
  190.                       n-buckets)))
  191.             (set-cdr! entries (vector-ref buckets hash))
  192.             (vector-set! buckets hash entries))
  193.           (set-table-count! table (fix:- (table-count table) 1)))
  194.           (loop rest)))))))
  195.  
  196. (define (maybe-shrink-table! table)
  197.   ;; Since the rehashing also deletes invalid entries, the count
  198.   ;; might have been reduced.  So check to see if it's necessary to
  199.   ;; shrink the table even further.
  200.   (if (< (table-count table) (table-shrink-size table))
  201.       (shrink-table! table)))
  202.  
  203. (define (rehash-table! table)
  204.   (let ((entries (extract-table-entries! table)))
  205.     (set-table-needs-rehash?! table #f)
  206.     (rehash-table-entries! table entries))
  207.   (maybe-shrink-table! table))
  208.  
  209. (define (extract-table-entries! table)
  210.   (let ((buckets (table-buckets table)))
  211.     (let ((n-buckets (vector-length buckets)))
  212.       (let ((entries '()))
  213.     (do ((i 0 (fix:+ i 1)))
  214.         ((fix:= i n-buckets))
  215.       (let ((bucket (vector-ref buckets i)))
  216.         (if (not (null? bucket))
  217.         (begin
  218.           (let loop ((bucket bucket))
  219.             (if (null? (cdr bucket))
  220.             (set-cdr! bucket entries)
  221.             (loop (cdr bucket))))
  222.           (set! entries bucket)
  223.           (vector-set! buckets i '())))))
  224.     entries))))
  225.  
  226. ;;;; Miscellaneous
  227.  
  228. (define-structure (eqht (constructor %make-eqht ()) (conc-name table-))
  229.   (count 0)
  230.   (grow-size minimum-size)
  231.   (shrink-size 0)
  232.   buckets
  233.   (primes prime-numbers-stream)
  234.   (needs-rehash? #f))
  235.  
  236. (define-integrable minimum-size 4)
  237.  
  238. (define-integrable (without-interrupts thunk)
  239.   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
  240.     (thunk)
  241.     (set-interrupt-enables! interrupt-mask)
  242.     unspecific))
  243.  
  244. (define-integrable (weak-cons car cdr)
  245.   (system-pair-cons (ucode-type weak-cons) car cdr))