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 / hash.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  305 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: hash.scm,v 14.6 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; Object Hashing
  23. ;;; package: (runtime hash)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Object hashing
  28.  
  29. ;;; The hashing code depends on weak conses supported by the
  30. ;;; microcode.  In particular, it depends on the fact that the car of
  31. ;;; a weak cons becomes #F if the object is garbage collected.
  32.  
  33. ;;; Important: This code must be rewritten for a parallel processor,
  34. ;;; since two processors may be updating the data structures
  35. ;;; simultaneously.
  36.  
  37. ;;; How this works:
  38.  
  39. ;;; There are two tables, the hash table and the unhash table:
  40.  
  41. ;;; - The hash table associates objects to their hash numbers.  The
  42. ;;; entries are keyed according to the address (datum) of the object,
  43. ;;; and thus must be recomputed after every relocation (ie. band
  44. ;;; loading, garbage collection, etc.).
  45.  
  46. ;;; - The unhash table associates the hash numbers with the
  47. ;;; corresponding objects.  It is keyed according to the numbers
  48. ;;; themselves.
  49.  
  50. ;;; In order to make the hash and unhash tables weakly hold the
  51. ;;; objects hashed, the following mechanism is used:
  52.  
  53. ;;; The hash table, a vector, has a SNMV header before all the
  54. ;;; buckets, and therefore the garbage collector will skip it and will
  55. ;;; not relocate its buckets.  It becomes invalid after a garbage
  56. ;;; collection and the first thing the daemon does is clear it.  Each
  57. ;;; bucket is a normal alist with the objects in the cars, and the
  58. ;;; numbers in the cdrs, thus assq can be used to find an object in
  59. ;;; the bucket.
  60.  
  61. ;;; The unhash table, also a vector, holds the objects by means of
  62. ;;; weak conses.  These weak conses are the same as the pairs in the
  63. ;;; buckets in the hash table, but with their type codes changed.
  64. ;;; Each of the buckets in the unhash table is headed by an extra pair
  65. ;;; whose car is usually #T.  This pair is used by the splicing code.
  66. ;;; The daemon treats buckets headed by #F differently from buckets
  67. ;;; headed by #T.  A bucket headed by #T is compressed: Those pairs
  68. ;;; whose cars have disappeared are spliced out from the bucket.  On
  69. ;;; the other hand, buckets headed by #F are not compressed.  The
  70. ;;; intent is that while object-unhash is traversing a bucket, the
  71. ;;; bucket is locked so that the daemon will not splice it out behind
  72. ;;; object-unhash's back.  Then object-unhash does not need to be
  73. ;;; locked against garbage collection.
  74.  
  75. (define default/hash-table-size 313)
  76. (define default-hash-table)
  77. (define all-hash-tables)
  78.  
  79. (define (initialize-package!)
  80.   (set! all-hash-tables (weak-cons 0 '()))
  81.   (set! default-hash-table (hash-table/make))
  82.   (add-event-receiver! event:after-restore (lambda () (gc-flip)))
  83.   (add-primitive-gc-daemon! rehash-all-gc-daemon))
  84.  
  85. (define-structure (hash-table
  86.            (conc-name hash-table/)
  87.            (constructor %hash-table/make))
  88.   (size)
  89.   (next-number)
  90.   (hash-table)
  91.   (unhash-table))
  92.  
  93. (define (hash-table/make #!optional size)
  94.   (let* ((size (if (default-object? size)
  95.            default/hash-table-size
  96.            size))
  97.      (table
  98.       (%hash-table/make
  99.        size
  100.        1
  101.        (let ((table (make-vector (1+ size) '())))
  102.          (vector-set! table
  103.               0
  104.               ((ucode-primitive primitive-object-set-type)
  105.                (ucode-type manifest-special-nm-vector)
  106.                (make-non-pointer-object size)))
  107.          ((ucode-primitive primitive-object-set-type)
  108.           (ucode-type non-marked-vector)
  109.           table))
  110.        (let ((table (make-vector size '())))
  111.          (let loop ((n 0))
  112.            (if (fix:< n size)
  113.            (begin
  114.              (vector-set! table n (cons true '()))
  115.              (loop (fix:+ n 1)))))
  116.          table))))
  117.     (weak-set-cdr! all-hash-tables
  118.            (weak-cons table (weak-cdr all-hash-tables)))
  119.     table))
  120.  
  121. (define (hash x #!optional table)
  122.   (if (eq? x false)
  123.       0
  124.       (object-hash x
  125.            (if (default-object? table) default-hash-table table)
  126.            true)))
  127.  
  128. (define (unhash n #!optional table)
  129.   (if (zero? n)
  130.       false
  131.       (let ((object
  132.          (object-unhash n
  133.                 (if (default-object? table)
  134.                 default-hash-table
  135.                 table))))
  136.     (if (not object)
  137.         (error:bad-range-argument n 'UNHASH))
  138.     object)))
  139.  
  140. (define (valid-hash-number? n #!optional table)
  141.   (or (zero? n)
  142.       (object-unhash n (if (default-object? table) default-hash-table table))))
  143.  
  144. (define (object-hashed? x #!optional table)
  145.   (or (eq? x false)
  146.       (object-hash x
  147.            (if (default-object? table) default-hash-table table)
  148.            false)))  
  149.  
  150. ;;; This is not dangerous because assq is a primitive and does not
  151. ;;; cons.  The rest of the consing (including that by the interpreter)
  152. ;;; is a small bounded amount.
  153. ;;;
  154. ;;; NOTE: assq is no longer a primitive.  This works fine if assq is
  155. ;;; compiled, but can lose if it is interpreted.
  156.  
  157. (define (object-hash object #!optional table insert?)
  158.   (let ((table
  159.      (if (default-object? table)
  160.          default-hash-table
  161.          (begin
  162.            (if (not (hash-table? table))
  163.            (error:wrong-type-argument table
  164.                           "object-hash table"
  165.                           'OBJECT-HASH))
  166.            table)))
  167.     (insert? (or (default-object? insert?) insert?)))
  168.     (with-absolutely-no-interrupts
  169.       (lambda ()
  170.     (let* ((hash-index (fix:+ 1
  171.                   (modulo (object-datum object)
  172.                       (hash-table/size table))))
  173.            (the-hash-table
  174.         ((ucode-primitive primitive-object-set-type)
  175.          (ucode-type vector)
  176.          (hash-table/hash-table table)))
  177.            (bucket (vector-ref the-hash-table hash-index))
  178.            (association (assq object bucket)))
  179.       (cond (association
  180.          (cdr association))
  181.         ((not insert?)
  182.          false)
  183.         (else
  184.          (let ((result (hash-table/next-number table)))
  185.            (let ((pair (cons object result))
  186.              (unhash-bucket
  187.               (vector-ref (hash-table/unhash-table table)
  188.                       (modulo result
  189.                           (hash-table/size table)))))
  190.              (set-hash-table/next-number! table (1+ result))
  191.              (vector-set! the-hash-table
  192.                   hash-index
  193.                   (cons pair bucket))
  194.              (set-cdr! unhash-bucket
  195.                    (cons (object-new-type (ucode-type weak-cons)
  196.                               pair)
  197.                      (cdr unhash-bucket)))
  198.              result)))))))))
  199.  
  200. ;;; This is safe because it locks the garbage collector out only for a
  201. ;;; little time, enough to tag the bucket being searched, so that the
  202. ;;; daemon will not splice that bucket.
  203.  
  204. (define (object-unhash number #!optional table)
  205.   (let* ((table
  206.       (if (default-object? table)
  207.           default-hash-table
  208.           (begin
  209.         (if (not (hash-table? table))
  210.             (error:wrong-type-argument table
  211.                            "object-hash table"
  212.                            'OBJECT-UNHASH))
  213.         table)))
  214.      (index (modulo number (hash-table/size table))))
  215.     (with-absolutely-no-interrupts
  216.       (lambda ()
  217.     (let ((bucket (vector-ref (hash-table/unhash-table table) index)))
  218.       (set-car! bucket false)
  219.       (let ((result
  220.          (without-interrupts
  221.            (lambda ()
  222.              (let loop ((l (cdr bucket)))
  223.                (cond ((null? l) false)
  224.                  ((= number (system-pair-cdr (car l)))
  225.                   (system-pair-car (car l)))
  226.                  (else (loop (cdr l)))))))))
  227.         (set-car! bucket true)
  228.         result))))))
  229.  
  230. ;;;; Rehash daemon
  231.  
  232. ;;; The following is dangerous because of the (unnecessary) consing
  233. ;;; done by the interpreter while it executes the loops.  It runs with
  234. ;;; interrupts turned off.  The (necessary) consing done by rehash is
  235. ;;; not dangerous because at least that much storage was freed by the
  236. ;;; garbage collector.  To understand this, notice that the hash table
  237. ;;; has a SNMV header, so the garbage collector does not trace the
  238. ;;; hash table buckets, therefore freeing their storage.  The header
  239. ;;; is SNM rather than NM to make the buckets be relocated at band
  240. ;;; load/restore time.
  241.  
  242. ;;; Until this code is compiled, and therefore safe, it is replaced by
  243. ;;; a primitive.  See the installation code below.
  244. #|
  245. (define (hash-table/rehash table)
  246.   (let ((hash-table-size (hash-table/size table))
  247.     (hash-table ((ucode-primitive primitive-object-set-type)
  248.              (ucode-type vector)
  249.              (hash-table/hash-table table)))
  250.     (unhash-table (hash-table/unhash-table table)))
  251.  
  252.     (define (rehash weak-pair)
  253.       (let ((index
  254.          (fix:+ 1 (modulo (object-datum (system-pair-car weak-pair))
  255.                   hash-table-size))))
  256.     (vector-set! hash-table
  257.              index
  258.              (cons (object-new-type (ucode-type pair) weak-pair)
  259.                (vector-ref hash-table index)))
  260.     unspecific))
  261.  
  262.     (let cleanup ((n hash-table-size))
  263.       (if (not (fix:= n 0))
  264.       (begin
  265.         (vector-set! hash-table n '())
  266.         (cleanup (fix:- n 1)))))
  267.  
  268.     (let outer ((n (fix:- hash-table-size 1)))
  269.       (if (not (fix:< n 0))
  270.       (let ((bucket (vector-ref unhash-table n)))
  271.         (if (car bucket)
  272.         (let inner1 ((l1 bucket) (l2 (cdr bucket)))
  273.           (cond ((null? l2)
  274.              (outer (fix:- n 1)))
  275.             ((eq? (system-pair-car (car l2)) false)
  276.              (set-cdr! l1 (cdr l2))
  277.              (inner1 l1 (cdr l1)))
  278.             (else
  279.              (rehash (car l2))
  280.              (inner1 l2 (cdr l2)))))
  281.         (let inner2 ((l (cdr bucket)))
  282.           (cond ((null? l)
  283.              (outer (fix:- n 1)))
  284.             ((eq? (system-pair-car (car l)) false)
  285.              (inner2 (cdr l)))
  286.             (else
  287.              (rehash (car l))
  288.              (inner2 (cdr l)))))))))))
  289. |#
  290.  
  291. (define-integrable (hash-table/rehash table)
  292.   ((ucode-primitive rehash) (hash-table/unhash-table table)
  293.                 (hash-table/hash-table table)))
  294.  
  295. (define (rehash-all-gc-daemon)
  296.   (let loop ((l all-hash-tables)
  297.          (n (weak-cdr all-hash-tables)))
  298.     (cond ((null? n)
  299.        (weak-set-cdr! l n))
  300.       ((not (weak-pair/car? n))
  301.        (loop l (weak-cdr n)))
  302.       (else
  303.        (weak-set-cdr! l n)
  304.        (hash-table/rehash (weak-car n))
  305.        (loop n (weak-cdr n))))))