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 / hashtb.scm < prev    next >
Text File  |  1999-01-02  |  29KB  |  851 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: hashtb.scm,v 1.23 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. ;;;; Hash Tables
  23. ;;; package: (runtime hash-table)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Hash Table Structure
  28.  
  29. (define-structure (hash-table
  30.            (constructor make-hash-table
  31.                 (key-hash
  32.                  key=?
  33.                  make-entry
  34.                  entry-valid?
  35.                  entry-key
  36.                  entry-datum
  37.                  set-entry-datum!))
  38.            (conc-name table-))
  39.   ;; Procedures describing keys and entries.
  40.   (key-hash #f read-only #t)
  41.   (key=? #f read-only #t)
  42.   (make-entry #f read-only #t)
  43.   (entry-valid? #f read-only #t)
  44.   (entry-key #f read-only #t)
  45.   (entry-datum #f read-only #t)
  46.   (set-entry-datum! #f read-only #t)
  47.  
  48.   ;; Parameters of the hash table.
  49.   (rehash-threshold default-rehash-threshold)
  50.   (rehash-size default-rehash-size)
  51.  
  52.   ;; Internal state variables.
  53.   (count 0)
  54.   (grow-size minimum-size)
  55.   (shrink-size 0)
  56.   buckets
  57.   (primes prime-numbers-stream)
  58.   (flags 0))
  59.  
  60. (define-integrable (table-standard-accessors? table)
  61.   (read-flag table 1))
  62.  
  63. (define-integrable (set-table-standard-accessors?! table value)
  64.   (write-flag table 1 value))
  65.  
  66. (define-integrable (table-needs-rehash? table)
  67.   (read-flag table 2))
  68.  
  69. (define-integrable (set-table-needs-rehash?! table value)
  70.   (write-flag table 2 value))
  71.  
  72. (define-integrable (table-initial-size-in-effect? table)
  73.   (read-flag table 4))
  74.  
  75. (define-integrable (set-table-initial-size-in-effect?! table value)
  76.   (write-flag table 4 value))
  77.  
  78. (define-integrable (table-rehash-after-gc? table)
  79.   (read-flag table 8))
  80.  
  81. (define-integrable (set-table-rehash-after-gc?! table value)
  82.   (write-flag table 8 value))
  83.  
  84. (define-integrable (read-flag table flag)
  85.   (fix:= (fix:and (table-flags table) flag) flag))
  86.  
  87. (define-integrable (write-flag table flag value)
  88.   (if value
  89.       (set-table-flags! table (fix:or (table-flags table) flag))
  90.       (set-table-flags! table (fix:andc (table-flags table) flag))))
  91.  
  92. (define-integrable minimum-size 4)
  93. (define-integrable default-rehash-threshold 1)
  94. (define-integrable default-rehash-size 2.)
  95.  
  96. (define-integrable (guarantee-hash-table object procedure)
  97.   (if (not (hash-table? object))
  98.       (error:wrong-type-argument object "hash table" procedure)))
  99.  
  100. ;;;; Constructors
  101.  
  102. (define (hash-table/constructor key-hash key=? make-entry entry-valid?
  103.                 entry-key entry-datum set-entry-datum!
  104.                 #!optional rehash-after-gc?)
  105.   (let ((make-entry (if (eq? cons make-entry) strong-cons make-entry))
  106.     (entry-valid? (if (eq? #t entry-valid?) strong-valid? entry-valid?))
  107.     (entry-key (if (eq? car entry-key) strong-car entry-key))
  108.     (entry-datum (if (eq? cdr entry-datum) strong-cdr entry-datum))
  109.     (set-entry-datum!
  110.      (if (eq? set-cdr! set-entry-datum!)
  111.          strong-set-cdr!
  112.          set-entry-datum!))
  113.     (rehash-after-gc?
  114.      (and (not (default-object? rehash-after-gc?))
  115.           rehash-after-gc?)))
  116.     (lambda (#!optional initial-size)
  117.       (let ((initial-size
  118.          (if (default-object? initial-size)
  119.          #f
  120.          (check-arg initial-size
  121.                 #f
  122.                 exact-nonnegative-integer?
  123.                 "exact nonnegative integer"
  124.                 #f))))
  125.     (let ((table
  126.            (make-hash-table key-hash key=? make-entry entry-valid?
  127.                 entry-key entry-datum set-entry-datum!)))
  128.       (if (and initial-size (> initial-size minimum-size))
  129.           ;; If an initial size is given, it means that the table
  130.           ;; should be initialized with that usable size.  The
  131.           ;; table's usable size remains fixed at the initial size
  132.           ;; until the count exceeds the usable size, at which point
  133.           ;; normal table resizing takes over.
  134.           (begin
  135.         (set-table-grow-size! table initial-size)
  136.         (set-table-initial-size-in-effect?! table #t)))
  137.       (set-table-standard-accessors?!
  138.        table
  139.        (and (eq? eq? key=?)
  140.         (or (eq? car entry-key)
  141.             (eq? strong-car entry-key)
  142.             (eq? weak-car entry-key))
  143.         (or (eq? cdr entry-datum)
  144.             (eq? strong-cdr entry-datum)
  145.             (eq? weak-cdr entry-datum))
  146.         (or (eq? set-cdr! set-entry-datum!)
  147.             (eq? strong-set-cdr! set-entry-datum!)
  148.             (eq? weak-set-cdr! set-entry-datum!))))
  149.       (set-table-rehash-after-gc?! table rehash-after-gc?)
  150.       (reset-table! table)
  151.       (if rehash-after-gc?
  152.           (set! address-hash-tables (weak-cons table address-hash-tables)))
  153.       table)))))
  154.  
  155. ;;; Standard trick because known calls to these primitives compile
  156. ;;; more efficiently than unknown calls.
  157. (define (strong-cons key datum) (cons key datum))
  158. (define (strong-valid? entry) entry #t)
  159. (define (strong-car entry) (car entry))
  160. (define (strong-cdr entry) (cdr entry))
  161. (define (strong-set-cdr! entry datum) (set-cdr! entry datum))
  162.  
  163. (define (strong-hash-table/constructor key-hash key=?
  164.                        #!optional rehash-after-gc?)
  165.   (hash-table/constructor key-hash key=? cons #t car cdr set-cdr!
  166.               (and (not (default-object? rehash-after-gc?))
  167.                    rehash-after-gc?)))
  168.  
  169. (define (weak-hash-table/constructor key-hash key=?
  170.                      #!optional rehash-after-gc?)
  171.   (hash-table/constructor key-hash key=? weak-cons weak-pair/car?
  172.               weak-car weak-cdr weak-set-cdr!
  173.               (and (not (default-object? rehash-after-gc?))
  174.                    rehash-after-gc?)))
  175.  
  176. ;;;; Accessors
  177.  
  178. (define (hash-table/get table key default)
  179.   (guarantee-hash-table table 'HASH-TABLE/GET)
  180.   (let ((entries
  181.      (vector-ref (table-buckets table) (compute-key-hash table key))))
  182.     (if (and key (table-standard-accessors? table))
  183.     ;; Optimize standard case: compiler makes this fast.
  184.     (let loop ((entries entries))
  185.       (cond ((null? entries)
  186.          default)
  187.         ((eq? (system-pair-car (car entries)) key)
  188.          (system-pair-cdr (car entries)))
  189.         (else
  190.          (loop (cdr entries)))))
  191.     (let ((key=? (table-key=? table))
  192.           (entry-key (table-entry-key table)))
  193.       (let loop ((entries entries))
  194.         (cond ((null? entries)
  195.            default)
  196.           ((key=? (entry-key (car entries)) key)
  197.            ((table-entry-datum table) (car entries)))
  198.           (else
  199.            (loop (cdr entries)))))))))
  200.  
  201. ;; This is useful when interning objects using a hash-table.
  202. (define (hash-table/get-key table key default)
  203.   (guarantee-hash-table table 'HASH-TABLE/GET)
  204.   (let ((entries
  205.      (vector-ref (table-buckets table) (compute-key-hash table key))))
  206.     (if (and key (table-standard-accessors? table))
  207.     ;; Optimize standard case: compiler makes this fast.
  208.     (let loop ((entries entries))
  209.       (cond ((null? entries)
  210.          default)
  211.         ((eq? (system-pair-car (car entries)) key)
  212.          (system-pair-car (car entries)))
  213.         (else
  214.          (loop (cdr entries)))))
  215.     (let ((key=? (table-key=? table))
  216.           (entry-key (table-entry-key table)))
  217.       (let loop ((entries entries))
  218.         (cond ((null? entries)
  219.            default)
  220.           ((key=? (entry-key (car entries)) key)
  221.            (entry-key (car entries)))
  222.           (else
  223.            (loop (cdr entries)))))))))
  224.  
  225. (define hash-table/lookup
  226.   (let ((default (list #f)))
  227.     (lambda (table key if-found if-not-found)
  228.       (let ((datum (hash-table/get table key default)))
  229.     (if (eq? datum default)
  230.         (if-not-found)
  231.         (if-found datum))))))
  232.  
  233. ;;;; Modifiers
  234.  
  235. (define (hash-table/put! table key datum)
  236.   (guarantee-hash-table table 'HASH-TABLE/PUT!)
  237.   (let ((buckets (table-buckets table))
  238.     (hash (compute-key-hash table key)))
  239.     (let ((add-bucket!
  240.        (lambda ()
  241.          (without-interrupts
  242.           (lambda ()
  243.         (vector-set! buckets
  244.                  hash
  245.                  (cons ((table-make-entry table) key datum)
  246.                    (vector-ref buckets hash)))
  247.         (if (> (let ((count (fix:+ (table-count table) 1)))
  248.              (set-table-count! table count)
  249.              count)
  250.                (table-grow-size table))
  251.             (grow-table! table)))))))
  252.       (if (and key (table-standard-accessors? table))
  253.       (let loop ((entries (vector-ref buckets hash)))
  254.         (cond ((null? entries)
  255.            (add-bucket!))
  256.           ((eq? (system-pair-car (car entries)) key)
  257.            (system-pair-set-cdr! (car entries) datum))
  258.           (else
  259.            (loop (cdr entries)))))
  260.       (let ((key=? (table-key=? table))
  261.         (entry-key (table-entry-key table)))
  262.         (let loop ((entries (vector-ref buckets hash)))
  263.           (cond ((null? entries)
  264.              (add-bucket!))
  265.             ((key=? (entry-key (car entries)) key)
  266.              ((table-set-entry-datum! table) (car entries) datum))
  267.             (else
  268.              (loop (cdr entries))))))))))
  269.  
  270. (define (hash-table/remove! table key)
  271.   (guarantee-hash-table table 'HASH-TABLE/REMOVE!)
  272.   (let ((key=? (table-key=? table))
  273.     (entry-key (table-entry-key table))
  274.     (decrement-count
  275.      (lambda ()
  276.        (if (< (let ((count (fix:- (table-count table) 1)))
  277.             (set-table-count! table count)
  278.             count)
  279.           (table-shrink-size table))
  280.            (shrink-table! table)))))
  281.     (let ((buckets (table-buckets table))
  282.       (hash (compute-key-hash table key)))
  283.       (let ((entries (vector-ref buckets hash)))
  284.     (if (not (null? entries))
  285.         (let ((next (cdr entries)))
  286.           (if (key=? (entry-key (car entries)) key)
  287.           (without-interrupts
  288.            (lambda ()
  289.              (vector-set! buckets hash next)
  290.              (decrement-count)))
  291.           (let loop ((previous entries) (entries next))
  292.             (if (not (null? entries))
  293.             (let ((next (cdr entries)))
  294.               (if (key=? (entry-key (car entries)) key)
  295.                   (without-interrupts
  296.                    (lambda ()
  297.                  (set-cdr! previous next)
  298.                  (decrement-count)))
  299.                   (loop entries next))))))))))))
  300.  
  301. ;;;; Enumerators
  302.  
  303. (define (hash-table/for-each table procedure)
  304.   ;; It's difficult to make this more efficient because PROCEDURE is
  305.   ;; allowed to delete the entry from the table, and if the table is
  306.   ;; resized while being examined we'll lose our place.
  307.   (guarantee-hash-table table 'HASH-TABLE/FOR-EACH)
  308.   (let ((entry-key (table-entry-key table))
  309.     (entry-datum (table-entry-datum table)))
  310.     (for-each (lambda (entry)
  311.         (procedure (entry-key entry) (entry-datum entry)))
  312.           (hash-table/entries-list table))))
  313.  
  314. (define (hash-table/entries-vector table)
  315.   (guarantee-hash-table table 'HASH-TABLE/ENTRIES-VECTOR)
  316.   (let ((result (make-vector (table-count table))))
  317.     (let* ((buckets (table-buckets table))
  318.        (n-buckets (vector-length buckets)))
  319.       (let per-bucket ((n 0) (i 0))
  320.     (if (fix:< n n-buckets)
  321.         (let per-entry ((entries (vector-ref buckets n)) (i i))
  322.           (if (null? entries)
  323.           (per-bucket (fix:+ n 1) i)
  324.           (begin
  325.             (vector-set! result i (car entries))
  326.             (per-entry (cdr entries) (fix:+ i 1))))))))
  327.     result))
  328.  
  329. (define (hash-table/entries-list table)
  330.   (guarantee-hash-table table 'HASH-TABLE/ENTRIES-LIST)
  331.   (table->list table (lambda (entry) entry)))
  332.  
  333. (define (hash-table->alist table)
  334.   (guarantee-hash-table table 'HASH-TABLE->ALIST)
  335.   (table->list table
  336.            (let ((entry-key (table-entry-key table))
  337.              (entry-datum (table-entry-datum table)))
  338.          (lambda (entry)
  339.            (cons (entry-key entry) (entry-datum entry))))))
  340.  
  341. (define (hash-table/key-list table)
  342.   (guarantee-hash-table table 'HASH-TABLE/KEY-LIST)
  343.   (table->list table (table-entry-key table)))
  344.  
  345. (define (hash-table/datum-list table)
  346.   (guarantee-hash-table table 'HASH-TABLE/DATUM-LIST)
  347.   (table->list table (table-entry-datum table)))
  348.  
  349. (define (table->list table entry->element)
  350.   (let ((buckets (table-buckets table))
  351.     (cons-element
  352.      (let ((entry-valid? (table-entry-valid? table)))
  353.        (if (eq? strong-valid? entry-valid?)
  354.            (lambda (entry result)
  355.          (cons (entry->element entry) result))
  356.            (lambda (entry result)
  357.          (let ((element (entry->element entry)))
  358.            (if (entry-valid? entry)
  359.                (cons element result)
  360.                result)))))))
  361.     (let ((n-buckets (vector-length buckets)))
  362.       (let loop ((n 0) (result '()))
  363.     (if (fix:< n n-buckets)
  364.         (loop (fix:+ n 1)
  365.           (let loop ((entries (vector-ref buckets n)) (result result))
  366.             (if (null? entries)
  367.             result
  368.             (loop (cdr entries)
  369.                   (cons-element (car entries) result)))))
  370.         result)))))
  371.  
  372. ;;;; Parameters
  373.  
  374. (define hash-table/key-hash
  375.   (record-accessor hash-table 'KEY-HASH))
  376.  
  377. (define hash-table/key=?
  378.   (record-accessor hash-table 'KEY=?))
  379.  
  380. (define hash-table/make-entry
  381.   (record-accessor hash-table 'MAKE-ENTRY))
  382.  
  383. (define hash-table/entry-key
  384.   (record-accessor hash-table 'ENTRY-KEY))
  385.  
  386. (define hash-table/entry-datum
  387.   (record-accessor hash-table 'ENTRY-DATUM))
  388.  
  389. (define hash-table/set-entry-datum!
  390.   (record-accessor hash-table 'SET-ENTRY-DATUM!))
  391.  
  392. (define hash-table/rehash-threshold
  393.   (record-accessor hash-table 'REHASH-THRESHOLD))
  394.  
  395. (define hash-table/rehash-size
  396.   (record-accessor hash-table 'REHASH-SIZE))
  397.  
  398. (define hash-table/count
  399.   (record-accessor hash-table 'COUNT))
  400.  
  401. (define hash-table/size
  402.   (record-accessor hash-table 'GROW-SIZE))
  403.  
  404. (define (set-hash-table/rehash-threshold! table threshold)
  405.   (guarantee-hash-table table 'SET-HASH-TABLE/REHASH-THRESHOLD!)
  406.   (let ((threshold
  407.      (check-arg threshold
  408.             default-rehash-threshold
  409.             (lambda (x)
  410.               (and (real? x)
  411.                (< 0 x)
  412.                (<= x 1)))
  413.             "real number between 0 (exclusive) and 1 (inclusive)"
  414.             'SET-HASH-TABLE/REHASH-THRESHOLD!)))
  415.     (without-interrupts
  416.      (lambda ()
  417.        (set-table-rehash-threshold! table threshold)
  418.        (new-size! table (table-grow-size table))))))
  419.  
  420. (define (set-hash-table/rehash-size! table size)
  421.   (guarantee-hash-table table 'SET-HASH-TABLE/REHASH-SIZE!)
  422.   (let ((size
  423.      (check-arg size
  424.             default-rehash-size
  425.             (lambda (x)
  426.               (cond ((exact-integer? x) (< 0 x))
  427.                 ((real? x) (< 1 x))
  428.                 (else #f)))
  429.             "real number < 1 or exact integer >= 1"
  430.             'SET-HASH-TABLE/REHASH-SIZE!)))
  431.     (without-interrupts
  432.      (lambda ()
  433.        (set-table-rehash-size! table size)
  434.        (reset-shrink-size! table)
  435.        (if (< (table-count table) (table-shrink-size table))
  436.        (shrink-table! table))))))
  437.  
  438. ;;;; Cleansing
  439.  
  440. (define (hash-table/clear! table)
  441.   (guarantee-hash-table table 'HASH-TABLE/CLEAR!)
  442.   (without-interrupts
  443.    (lambda ()
  444.      (if (not (table-initial-size-in-effect? table))
  445.      (set-table-grow-size! table minimum-size))
  446.      (set-table-count! table 0)
  447.      (reset-table! table))))
  448.  
  449. (define (hash-table/clean! table)
  450.   (guarantee-hash-table table 'HASH-TABLE/CLEAN!)
  451.   (if (not (eq? strong-valid? (table-entry-valid? table)))
  452.       (without-interrupts
  453.        (lambda ()
  454.      (clean-table! table)
  455.      (if (< (table-count table) (table-shrink-size table))
  456.          (shrink-table! table))))))
  457.  
  458. (define (clean-table! table)
  459.   (let ((buckets (table-buckets table))
  460.     (entry-valid? (table-entry-valid? table)))
  461.     (let ((n-buckets (vector-length buckets)))
  462.       (do ((i 0 (fix:+ i 1)))
  463.       ((fix:= i n-buckets))
  464.     (letrec
  465.         ((scan-head
  466.           (lambda (entries)
  467.         (cond ((null? entries)
  468.                (vector-set! buckets i entries))
  469.               ((entry-valid? (car entries))
  470.                (vector-set! buckets i entries)
  471.                (scan-tail entries (cdr entries)))
  472.               (else
  473.                (decrement-table-count! table)
  474.                (scan-head (cdr entries))))))
  475.          (scan-tail
  476.           (lambda (previous entries)
  477.         (cond ((null? entries)
  478.                unspecific)
  479.               ((entry-valid? (car entries))
  480.                (scan-tail entries (cdr entries)))
  481.               (else
  482.                (decrement-table-count! table)
  483.                (let loop ((entries (cdr entries)))
  484.              (cond ((null? entries)
  485.                 (set-cdr! previous entries))
  486.                    ((entry-valid? (car entries))
  487.                 (set-cdr! previous entries)
  488.                 (scan-tail entries (cdr entries)))
  489.                    (else
  490.                 (decrement-table-count! table)
  491.                 (loop (cdr entries))))))))))
  492.       (let ((entries (vector-ref buckets i)))
  493.         (cond ((null? entries)
  494.            unspecific)
  495.           ((entry-valid? (car entries))
  496.            (scan-tail entries (cdr entries)))
  497.           (else
  498.            (decrement-table-count! table)
  499.            (scan-head (cdr entries))))))))))
  500.  
  501. (define-integrable (decrement-table-count! table)
  502.   (set-table-count! table (fix:- (table-count table) 1)))
  503.  
  504. ;;;; Resizing
  505.  
  506. (define (grow-table! table)
  507.   (let loop ((size (table-grow-size table)))
  508.     (if (> (table-count table) size)
  509.     (loop (increment-size table size))
  510.     (new-size! table size)))
  511.   (set-table-initial-size-in-effect?! table #f))
  512.  
  513. (define (shrink-table! table)
  514.   (if (not (table-initial-size-in-effect? table))
  515.       (let loop ((size (table-grow-size table)))
  516.     (cond ((<= size minimum-size)
  517.            (new-size! table minimum-size))
  518.           ((< (table-count table) (compute-shrink-size table size))
  519.            (loop (decrement-size table size)))
  520.           (else
  521.            (new-size! table size))))))
  522.  
  523. (define (new-size! table size)
  524.   (set-table-grow-size! table size)
  525.   (let ((old-buckets (table-buckets table)))
  526.     (reset-table! table)
  527.     (rehash-table-from-old-buckets! table old-buckets)))
  528.  
  529. (define (reset-table! table)
  530.   (reset-shrink-size! table)
  531.   (let ((primes
  532.      (let ((size
  533.         (round->exact (/ (table-grow-size table)
  534.                  (table-rehash-threshold table)))))
  535.        (let loop
  536.            ((primes
  537.          (if (< size (stream-car (table-primes table)))
  538.              prime-numbers-stream
  539.              (table-primes table))))
  540.          (if (<= size (stream-car primes))
  541.          primes
  542.          (loop (stream-cdr primes)))))))
  543.     (set-table-primes! table primes)
  544.     (set-table-buckets! table (make-vector (stream-car primes) '()))))
  545.  
  546. (define (reset-shrink-size! table)
  547.   (set-table-shrink-size! table
  548.               (compute-shrink-size table (table-grow-size table))))
  549.  
  550. (define (compute-shrink-size table size)
  551.   (if (<= size minimum-size)
  552.       0
  553.       (max 0 (decrement-size table (decrement-size table size)))))
  554.  
  555. (define (increment-size table size)
  556.   (let ((rehash-size (table-rehash-size table)))
  557.     (if (exact-integer? rehash-size)
  558.     (+ size rehash-size)
  559.     (let ((size* (round->exact (* size rehash-size))))
  560.       (if (> size* size)
  561.           size*
  562.           (+ size 1))))))
  563.  
  564. (define (decrement-size table size)
  565.   (let ((rehash-size (table-rehash-size table)))
  566.     (if (exact-integer? rehash-size)
  567.     (- size rehash-size)
  568.     (let ((size* (round->exact (/ size rehash-size))))
  569.       (if (< size* size)
  570.           size*
  571.           (- size 1))))))
  572.  
  573. ;;;; Rehashing
  574.  
  575. (define (rehash-table-from-old-buckets! table buckets)
  576.   (let ((n-buckets (vector-length buckets)))
  577.     (set-table-needs-rehash?! table #f)
  578.     (do ((i 0 (fix:+ i 1)))
  579.     ((fix:= i n-buckets))
  580.       (let ((entries (vector-ref buckets i)))
  581.     (if (not (null? entries))
  582.         (rehash-table-entries! table entries)))))
  583.   (maybe-shrink-table! table))
  584.  
  585. (define (rehash-table-entries! table entries)
  586.   (let ((buckets (table-buckets table))
  587.     (entry-valid? (table-entry-valid? table))
  588.     (entry-key (table-entry-key table))
  589.     (key-hash (table-key-hash table)))
  590.     (let ((n-buckets (vector-length buckets)))
  591.       (let loop ((entries entries))
  592.     (if (not (null? entries))
  593.         (let ((rest (cdr entries)))
  594.           (if (entry-valid? (car entries))
  595.           (let ((hash
  596.              (key-hash (entry-key (car entries)) n-buckets)))
  597.             (set-cdr! entries (vector-ref buckets hash))
  598.             (vector-set! buckets hash entries))
  599.           (decrement-table-count! table))
  600.           (loop rest)))))))
  601.  
  602. (define (maybe-shrink-table! table)
  603.   ;; Since the rehashing also deletes invalid entries, the count
  604.   ;; might have been reduced.  So check to see if it's necessary to
  605.   ;; shrink the table even further.
  606.   (if (< (table-count table) (table-shrink-size table))
  607.       (shrink-table! table)))
  608.  
  609. (define (rehash-table! table)
  610.   (let ((entries (extract-table-entries! table)))
  611.     (set-table-needs-rehash?! table #f)
  612.     (rehash-table-entries! table entries))
  613.   (maybe-shrink-table! table))
  614.  
  615. (define (extract-table-entries! table)
  616.   (let ((buckets (table-buckets table)))
  617.     (let ((n-buckets (vector-length buckets)))
  618.       (let ((entries '()))
  619.     (do ((i 0 (fix:+ i 1)))
  620.         ((fix:= i n-buckets))
  621.       (let ((bucket (vector-ref buckets i)))
  622.         (if (not (null? bucket))
  623.         (begin
  624.           (let loop ((bucket bucket))
  625.             (if (null? (cdr bucket))
  626.             (set-cdr! bucket entries)
  627.             (loop (cdr bucket))))
  628.           (set! entries bucket)
  629.           (vector-set! buckets i '())))))
  630.     entries))))
  631.  
  632. ;;;; Address-Hash Tables
  633.  
  634. ;;; Address-hash tables compute their hash number from the address of
  635. ;;; the key.  Because the address is changed by the garbage collector,
  636. ;;; it is necessary to rehash the table after a garbage collection.
  637.  
  638. ;;; Rehashing the table during the garbage collection is undesirable
  639. ;;; for these reasons:
  640. ;;; 1. The time required to rehash the table is proportional to the
  641. ;;;    number of items in the table, which can be quite large.  It's
  642. ;;;    undesirable for the garbage collection time to be extended this
  643. ;;;    way.
  644. ;;; 2. If the garbage collector rearranges the internals of the table,
  645. ;;;    then nearly every operation on the table must be locked to
  646. ;;;    prevent garbage collection from occurring while it runs.  This
  647. ;;;    means long periods with interrupts disabled, plus the overhead
  648. ;;;    of interrupt locking that is otherwise unnecessary.
  649. ;;; 3. If the table isn't used in between two garbage collections,
  650. ;;;    then the effort to rehash it during the first garbage
  651. ;;;    collection is wasted.
  652.  
  653. ;;; For these reasons, rehashing of the table is performed lazily.
  654. ;;; When the garbage collector runs, it sets the table's NEEDS-REHASH?
  655. ;;; flag.  This flag is examined by all of the hash-table operations
  656. ;;; to see if it is necessary to rehash the table before performing
  657. ;;; the operation.  Since the only reason for rehashing the table is
  658. ;;; to ensure consistency between the table's contents and the result
  659. ;;; of the address hashing operation, it is sufficient to check this
  660. ;;; flag whenever the address hashing is performed.  This means that
  661. ;;; the rehashing of the table and the computing of the corresponding
  662. ;;; address hash must occur atomically with respect to the garbage
  663. ;;; collector.
  664.  
  665. ;;; The only tricky part about this algorithm is that the garbage
  666. ;;; collector might run while the table is being resized.  If this
  667. ;;; occurs, part of the table might be hashed correctly, while the
  668. ;;; rest would be incorrect.  This is not a problem because resizing
  669. ;;; (with one exception) is always the last thing done by an
  670. ;;; operation.  If the garbage collection occurs during a resizing,
  671. ;;; the NEEDS-REHASH? flag will be true after the resizing is
  672. ;;; completed, and the next operation will rehash the table.
  673.  
  674. ;;; The exception to this rule is COMPUTE-KEY-HASH, which might have
  675. ;;; to shrink the table due to keys which have been reclaimed by the
  676. ;;; garbage collector.  REHASH-TABLE! explicitly checks for this
  677. ;;; possibility, and rehashes the table again if necessary.
  678.  
  679. (define (compute-key-hash table key)
  680.   (let ((key-hash (table-key-hash table)))
  681.     (if (table-rehash-after-gc? table)
  682.     (let loop ()
  683.       (let ((hash (key-hash key (vector-length (table-buckets table)))))
  684.         (if (not (table-needs-rehash? table))
  685.         hash
  686.         (begin
  687.           (without-interrupts (lambda () (rehash-table! table)))
  688.           (loop)))))
  689.     (key-hash key (vector-length (table-buckets table))))))
  690.  
  691. (define-integrable (eq-hash-mod key modulus)
  692.   (fix:remainder (eq-hash key) modulus))
  693.  
  694. (define-integrable (eq-hash object)
  695.   (let ((n
  696.      ((ucode-primitive primitive-object-set-type)
  697.       (ucode-type positive-fixnum)
  698.       object)))
  699.     (if (fix:< n 0)
  700.     (fix:not n)
  701.     n)))
  702.  
  703. (define (eqv-hash-mod key modulus)
  704.   (int:remainder (eqv-hash key) modulus))
  705.  
  706. (define (eqv-hash key)
  707.   (cond ((%bignum? key) (%bignum->nonneg-int key))
  708.     ((%ratnum? key) (%ratnum->nonneg-int key))
  709.     ((flo:flonum? key) (%flonum->nonneg-int key))
  710.     ((%recnum? key) (%recnum->nonneg-int key))
  711.     (else (eq-hash key))))
  712.  
  713. (define (equal-hash-mod key modulus)
  714.   (int:remainder (equal-hash key) modulus))
  715.  
  716. (define (equal-hash key)
  717.   (cond ((pair? key)
  718.      (int:+ (equal-hash (car key))
  719.         (equal-hash (cdr key))))
  720.     ((vector? key)
  721.      (let ((length (vector-length key)))
  722.        (do ((i 0 (fix:+ i 1))
  723.         (accum 0
  724.                (int:+ accum
  725.                   (equal-hash (vector-ref key i)))))
  726.            ((fix:= i length) accum))))
  727.     ((cell? key)
  728.      (equal-hash (cell-contents key)))
  729.     ((%bignum? key)
  730.      (%bignum->nonneg-int key))
  731.     ((%ratnum? key)
  732.      (%ratnum->nonneg-int key))
  733.     ((flo:flonum? key)
  734.      (%flonum->nonneg-int key))
  735.     ((%recnum? key)
  736.      (%recnum->nonneg-int key))
  737.     ((string? key)
  738.      (string-hash key))
  739.     ((bit-string? key)
  740.      (bit-string->unsigned-integer key))
  741.     ((pathname? key)
  742.      (string-hash (->namestring key)))
  743.     (else
  744.      (eq-hash key))))
  745.  
  746. (define-integrable (%bignum? object)
  747.   (object-type? (ucode-type big-fixnum) object))
  748.  
  749. (define-integrable (%ratnum? object)
  750.   (object-type? (ucode-type ratnum) object))
  751.  
  752. (define-integrable (%recnum? object)
  753.   (object-type? (ucode-type recnum) object))
  754.  
  755. (define-integrable (%bignum->nonneg-int bignum)
  756.   (int:abs bignum))
  757.  
  758. (define-integrable (%ratnum->nonneg-int ratnum)
  759.   (int:abs (int:+ (system-pair-car ratnum) (system-pair-cdr ratnum))))
  760.  
  761. (define-integrable (%flonum->nonneg-int flonum)
  762.   (int:abs
  763.    (flo:truncate->exact
  764.     ((ucode-primitive flonum-denormalize 2)
  765.      (car ((ucode-primitive flonum-normalize 1) flonum))
  766.      microcode-id/floating-mantissa-bits))))
  767.  
  768. (define-integrable (%recnum->nonneg-int recnum)
  769.   (let ((%real->nonneg-int
  770.      (lambda (real)
  771.        (cond ((%ratnum? real) (%ratnum->nonneg-int real))
  772.          ((flo:flonum? real) (%flonum->nonneg-int real))
  773.          (else (%bignum->nonneg-int real))))))
  774.     (int:+ (%real->nonneg-int (system-pair-car recnum))
  775.        (%real->nonneg-int (system-pair-cdr recnum)))))
  776.  
  777. (declare (integrate-operator int:abs))
  778. (define (int:abs n)
  779.   (if (int:negative? n) (int:negate n) n))
  780.  
  781. (define (mark-address-hash-tables!)
  782.   (let loop ((previous #f) (tables address-hash-tables))
  783.     (cond ((null? tables)
  784.        unspecific)
  785.       ((system-pair-car tables)
  786.        (set-table-needs-rehash?! (system-pair-car tables) #t)
  787.        (loop tables (system-pair-cdr tables)))
  788.       (else
  789.        (if previous
  790.            (system-pair-set-cdr! previous (system-pair-cdr tables))
  791.            (set! address-hash-tables (system-pair-cdr tables)))
  792.        (loop previous (system-pair-cdr tables))))))
  793.  
  794. ;;;; Miscellany
  795.  
  796. (define address-hash-tables)
  797. (define make-eq-hash-table)
  798. (define make-eqv-hash-table)
  799. (define make-equal-hash-table)
  800. (define make-string-hash-table)
  801.  
  802. ;; Define old names for compatibility:
  803. (define hash-table/entry-value hash-table/entry-datum)
  804. (define hash-table/set-entry-value! hash-table/set-entry-datum!)
  805. (define make-symbol-hash-table)
  806. (define make-object-hash-table)
  807.  
  808. (define (initialize-package!)
  809.   (set! address-hash-tables '())
  810.   (add-primitive-gc-daemon! mark-address-hash-tables!)
  811.   (set! make-eq-hash-table (weak-hash-table/constructor eq-hash-mod eq? #t))
  812.   ;; EQV? hash tables are weak except for numbers and #F.  It's
  813.   ;; important to keep numbers in the table, and handling #F specially
  814.   ;; makes it easier to deal with weak pairs.
  815.   (set! make-eqv-hash-table
  816.     (hash-table/constructor eqv-hash-mod
  817.                 eqv?
  818.                 (lambda (key datum)
  819.                   (if (or (not key) (number? key))
  820.                       (cons key datum)
  821.                       (system-pair-cons (ucode-type weak-cons)
  822.                             key
  823.                             datum)))
  824.                 (lambda (entry)
  825.                   (or (pair? entry)
  826.                       (system-pair-car entry)))
  827.                 (lambda (entry)
  828.                   (system-pair-car entry))
  829.                 (lambda (entry)
  830.                   (system-pair-cdr entry))
  831.                 (lambda (entry datum)
  832.                   (system-pair-set-cdr! entry datum))
  833.                 #t))
  834.   (set! make-equal-hash-table
  835.     (strong-hash-table/constructor equal-hash-mod equal? #t))
  836.   (set! make-symbol-hash-table make-eq-hash-table)
  837.   (set! make-object-hash-table make-eqv-hash-table)
  838.   (set! make-string-hash-table
  839.     (strong-hash-table/constructor string-hash-mod string=? #f))
  840.   unspecific)
  841.  
  842. (define (check-arg object default predicate description procedure)
  843.   (cond ((predicate object) object)
  844.     ((not object) default)
  845.     (else (error:wrong-type-argument object description procedure))))
  846.  
  847. (define-integrable (without-interrupts thunk)
  848.   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
  849.     (thunk)
  850.     (set-interrupt-enables! interrupt-mask)
  851.     unspecific))