home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / table.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  9.6 KB  |  305 lines
  1. (herald table 
  2.   (env tsys))
  3.  
  4. ;;; What a lot of code!!
  5.  
  6. ;;; This needs testing to determine the best size for various constants:
  7. ;;;
  8. ;;;  How big should a table become before it starts hashing its entries?
  9. ;;;  How big should a hash bucket be?
  10. ;;;  What percentage of a table's vector should be used for overflow buckets?
  11. ;;;
  12.  
  13. ;;; Interface:
  14. ;;;  MAKE-TABLE
  15. ;;;  MAKE-TABLE-OF-SIZE
  16. ;;;  MAKE-STRING-TABLE
  17. ;;;  MAKE-STRING-TABLE-OF-SIZE
  18. ;;;  MAKE-HASH-TABLE
  19. ;;;  MAKE-HASH-TABLE-OF-SIZE
  20. ;;;  HASH-TABLE?
  21. ;;;  TABLE?
  22. ;;;  STRING-TABLE?
  23. ;;;  TABLE-ENTRY
  24. ;;;  TABLE-WALK
  25. ;;;  WALK-TABLE
  26. ;;;  FIND-TABLE-ENTRY
  27. ;;;  COPY-TABLE
  28. ;;;  CLEAN-TABLE
  29. ;;;  RETURN-TABLE-TO-POOL
  30.  
  31. ;;; Obsolete interface:
  32.  
  33. (define (remove-table-entry table key)
  34.   (set (table-entry table key) nil))
  35.  
  36. (define (set-table-entry table key value)
  37.   (set (table-entry table key) value))
  38.  
  39. ;;; Hash buckets built into table vectors.   The first part of the vector
  40. ;;; contains the hash buckets, the rest is divided into overflow buckets.
  41. ;;; Each bucket looks like:
  42. ;;;
  43. ;;;            val0
  44. ;;;            key0
  45. ;;;            ...
  46. ;;;            valN
  47. ;;;            keyN
  48. ;;;            #f
  49. ;;;            #f
  50. ;;;
  51. ;;; where N < 4.  If there are more than three entries in the bucket an
  52. ;;; overflow bucket is added:
  53. ;;;
  54. ;;;            val0
  55. ;;;            key0
  56. ;;;            ...
  57. ;;;            val3
  58. ;;;            key3
  59. ;;;            #f  
  60. ;;;            index of the start of the overflow bucket
  61. ;;;
  62. ;;; The size of the buckets is power of two to make it easy to convert hash
  63. ;;; numbers into vector indices.  It isn't really necessary.
  64. ;;;
  65. ;;; Tables below a certain size are kept in a single large bucket and no
  66. ;;; hashing is done.
  67.  
  68. (define (make-table . maybe-id)
  69.   (create-%table (if maybe-id (car maybe-id) nil)
  70.                  0 t true descriptor-hash eq?))
  71.  
  72. (define (make-table-of-size start-size . maybe-id)
  73.   (create-%table (if maybe-id (car maybe-id) nil)
  74.                  start-size t true descriptor-hash eq?))
  75.  
  76. (define make-table-with-size make-table-of-size)
  77.  
  78. (define (make-string-table . maybe-id)
  79.   (create-%table (if maybe-id (car maybe-id) nil)
  80.                  0 nil string? string-hash string-equal?))
  81.  
  82. (define (make-string-table-of-size start-size . maybe-id)
  83.   (create-%table (if maybe-id (car maybe-id) nil)
  84.                  start-size nil string? string-hash string-equal?))
  85.  
  86. (define make-string-table-with-size make-string-table-of-size)
  87.  
  88. (define (make-symbol-table . maybe-id)
  89.   (create-%table (if maybe-id (car maybe-id) nil)
  90.                  0 nil symbol? symbol-hash eq?))
  91.  
  92. (define (make-symbol-table-of-size start-size . maybe-id)
  93.   (create-%table (if maybe-id (car maybe-id) nil)
  94.                  start-size nil symbol? symbol-hash eq?))
  95.  
  96. (define make-symbol-table-with-size make-symbol-table-of-size)
  97.  
  98. (define (make-hash-table type hash comparison gc-sensitive? . maybe-id)
  99.   (let ((type       (enforce procedure? type))
  100.         (hash       (enforce procedure? hash))
  101.         (comparison (enforce procedure? comparison)))
  102.     (create-%table (if maybe-id (car maybe-id) nil)
  103.                    0
  104.                    gc-sensitive?
  105.                    type
  106.                    hash
  107.                    comparison)))
  108.  
  109. (define (make-hash-table-of-size start-size type hash
  110.                                  comparison gc-sensitive? . maybe-id)
  111.   (let ((start-size (enforce nonnegative-fixnum? start-size))
  112.         (type       (enforce procedure? type))
  113.         (hash       (enforce procedure? hash))
  114.         (comparison (enforce procedure? comparison)))
  115.     (create-%table (if maybe-id (car maybe-id) nil)
  116.                    start-size
  117.                    gc-sensitive?
  118.                    type
  119.                    hash
  120.                    comparison)))
  121.  
  122. (define (hash-table? x)
  123.   (%table? x))
  124.  
  125. ;;; The following predicates are not very exact.
  126.  
  127. (define (table? x)
  128.   (and (%table? x)
  129.        (eq? (%table-type x) true)
  130.        (eq? (%table-compare x) eq?)))
  131.  
  132. (define (string-table? x)
  133.   (and (%table? x)
  134.        (eq? (%table-type x) string?)
  135.        (eq? (%table-compare x) string-equal?)))
  136.  
  137. (define (symbol-table? x)
  138.   (and (%table? x)
  139.        (eq? (%table-type x) symbol?)
  140.        (eq? (%table-compare x) eq?)))
  141.  
  142.  
  143. ;;;                  %TABLE structures
  144. ;;;==========================================================================
  145.  
  146. ;;;   #F is used as the end-of-bucket marker in the table's vector and thus it
  147. ;;; cannot be used as a key in the vector.  %TABLE structures have a slot to
  148. ;;; store the value of #F if it is used as a key.  %TABLE-COUNT is the number
  149. ;;; of values in the vector.  It doesn't count the value (if any) of #F.
  150.  
  151. (define-structure-type %table
  152.   id            ; Identification
  153.   count         ; Number of entries
  154.   vector        ; Vector of entries
  155.   mask          ; mask used to cut hashes to correct size
  156.   next          ; index of next overflow bucket
  157.   type          ; type predicate for keys
  158.   hash          ; Hash procedure
  159.   compare       ; Comparison procedure
  160.   gc-stamp      ; Stamp of last GC this table was hashed after.  Nil if hash
  161.                 ;   is not GC sensitive.
  162.   (((recycle self)
  163.      (return-table-to-pool self))
  164.     ((print self port)
  165.      (format port "#{Table~_~S~_~S}"
  166.              (object-hash self)
  167.              (%table-id self)))
  168.     ((identification self) (%table-id self))
  169.     ((set-identification self id)
  170.      (if (not (%table-id self)) (set (%table-id self) id)))))
  171.  
  172. (define (create-%table id size gc? type hash compare)
  173.   (let ((table (obtain-from-pool *table-pool*)))
  174.     (set (%table-id       table) id)
  175.     (set (%table-count    table) 0)
  176.     (set (%table-type     table) type)
  177.     (set (%table-hash     table) hash)   
  178.     (set (%table-compare  table) compare)
  179.     (set (%table-gc-stamp table) (if gc? (gc-stamp) nil))
  180.     (receive (vec mask next)
  181.              (get-table-vector size)
  182.       (set (%table-mask   table) mask)
  183.       (set (%table-vector table) vec)
  184.       (set (%table-next   table) next)
  185.       table)))
  186.  
  187. (lset *table-pool* nil)
  188.  
  189. (define (initialize-table-pool)
  190.   (set *table-pool* (make-pool '*table-pool* make-%table 1 %table?)))
  191.  
  192. ;;;                   Storage allocation for tables
  193. ;;;============================================================================
  194.  
  195. ;;; Numbers:
  196. ;;;   Start at one entry per bucket
  197. ;;;   size of vector = table-count * 8 => one per bucket
  198. ;;;
  199. ;;;   Overflow buckets / Hash buckets => 1 / 1
  200. ;;;
  201.  
  202. ;;; A vector for empty tables.
  203.  
  204. (define empty-vec (make-vector 2))
  205.  
  206. ;;; The number of elements at which we start hashing:
  207.  
  208. (define-constant *minimum-hashing-size* 32)
  209.  
  210. ;;; Get a vector appropriate for a table with COUNT entries.  Returns the
  211. ;;; vector, a mask to turn hash numbers into bucket indices, and the start of
  212. ;;; the first overflow bucket.
  213.  
  214. (define table-grow-factor 4)
  215.  
  216. (define (get-table-vector count)
  217.   (let* ((size (enforce fixnum? count)))
  218.     (cond ((fx>= count *minimum-hashing-size*)
  219.            (let* ((vec (obtain-from-pool
  220.                         (table-vector-pool (fx* table-grow-factor count))))
  221.                   (size (fixnum-ashr (vector-length vec) 1)))
  222.              (vector-fill vec nil)
  223.              (return vec (fixnum-logand (fixnum-lognot 7) (fx- size 1)) size)))
  224.           ((fx> count 0)
  225.            (let ((vec (obtain-from-pool
  226.                        (table-vector-pool (fx* 2 (fx+ 1 size))))))
  227.              (vector-fill vec nil)
  228.              (return vec 0 (vector-length vec))))
  229.           (else
  230.            (return empty-vec 0 0)))))
  231.  
  232. (define (get-table-next vec-length mask)
  233.   (if (fx= mask 0)
  234.       vec-length
  235.       (fixnum-ashr vec-length 1)))
  236.  
  237. ;++ is there another way to do this?
  238. ;++ Should an error be returned is a table is larger then the maximum size? 
  239.  
  240. ;;; Vector sizes are currently of the form 2**n.
  241.  
  242. (define-constant *minimum-table-vector-size* 7)
  243. (define-constant *number-of-table-vector-pools* 16)
  244.  
  245. (define *table-vector-pools*
  246.   (make-vector *number-of-table-vector-pools*))
  247.  
  248. (define (initialize-table-vector-pool)
  249.   (do ((i 0 (fx+ i 1))
  250.        (size (fx+ *minimum-table-vector-size* 1) (fixnum-ashl size 1)))
  251.       ((fx>= i *number-of-table-vector-pools*) t)
  252.     (set (vref *table-vector-pools* i)
  253.          (make-pool `(*table-vector-pool* ,i)
  254.                      (lambda () (make-vector size))
  255.                      1
  256.                      vector?))))
  257.  
  258. ;++ Coalesce this code with that in buffer.t.
  259. ;-- Only if buffers want vectors of size 2**n.
  260.  
  261. (define table-vector-pool
  262.   (let ((flag nil))
  263.     (lambda (size)
  264.       (cond ((fx< size *minimum-table-vector-size*)
  265.              (vref *table-vector-pools* 0))
  266.             (else
  267.              (let ((i (fx- (fixnum-howlong (fx- size 1)) 3)))
  268.                (cond ((fx<= i 15)
  269.                       (vref *table-vector-pools* i))
  270.                      (flag
  271.                       (vref *table-vector-pools* 15))
  272.                      (else
  273.                       (warning "table size exceeds maximum - using maximum.")
  274.                       (warning "~t Please inform implementors.~%")
  275.                       (vref *table-vector-pools* 15)))))))))
  276.  
  277. ;;; Return a vector to the appropriate pool.
  278.  
  279. (define (release-table-vector vec)
  280.   (let ((vec (enforce vector? vec)))
  281.     (if (neq? vec empty-vec)
  282.         (return-to-pool (table-vector-pool (vector-length vec)) vec))))
  283.  
  284. ;;; Remove all the entries from a table.
  285.  
  286. (define (clean-table table)
  287.   (let ((table (enforce %table? table)))
  288.     (vector-fill (%table-vector table) nil)
  289.     (set (%table-count table) 0)
  290.     (set (%table-next table)
  291.          (get-table-next (vector-length (%table-vector table))
  292.                          (%table-mask table)))
  293.     table))
  294.  
  295. ;;; Return storage used by a table.
  296.  
  297. (define (return-table-to-pool table)
  298.   (let ((table (enforce %table? table)))
  299.     (release-table-vector (%table-vector table))
  300.     (return-to-pool *table-pool* table)))
  301.  
  302. (initialize-table-pool)
  303. (initialize-table-vector-pool)
  304. (vector-fill empty-vec nil)
  305.