; -*-cold-load:t; Mode:common-Lisp; Package:System-Internals; Base:8 -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved. ;A hash table that the user sees is a flavor instance. ;The guts of it is a named-structure array defined below. ;The contents of the array is divided into n-word blocks. ;Each block corresponds to one hash key. The first word of the block is the key. ;The remaining words are associated data. Normally there is only one of them. ;Each key and its associated data words form a cdr-next list. ;The third value of GETHASH points to this list. ;Extra args to PUTHASH can be used to set data words past the first. ;A DTP-NULL is used in the table in the key position to mark an empty slot. ;DTP-NULL with nonzero pointer means a slot that was "deleted" and ;which search must continue past. ;A flavor's method hash table is actually the array, not the flavor instance. ;The array points to the flavor instance it belongs to, so that the ;flavor code can find the instance to send messages to it. ;This also enables flavors to be bootstrapped. ;This file defines only the non flavor hash support ;The file HASHFL, loaded after flavors are loaded, ;defines the hash table flavors which are used only as mixins. ;;PHD 5/5/87 Changed hashing algorithm for collision. ;;PHD 4/28/87 Changed pointer management to avoid going beyond the array. ;phd 2/27/86 add a binding to prevent scavenging while accessing hash tables. ;;PHD 1/2/87 Added INLINE declaration for HASH-TABLE-P inside PUTHASH and GETHASH ;;PHD optimizes clrhash for trivial cases (the hash table is empty). (proclaim '(inline follow-structure)) (PROCLAIM '(special %gc-generation-number)) (defun follow-structure (x) (WITHOUT-INTERRUPTS (do ((x x (%MAKE-POINTER (%DATA-TYPE X) (%P-CONTENTS-AS-LOCATIVE X)))) ((/= (%P-DATA-TYPE X) DTP-HEADER-FORWARD) x)))) ;;AB 8-5-87. Fix this to follow forwarding by default. [SPR 6101] (PROCLAIM '(inline hash-table-funcallable-p)) (defun hash-table-funcallable-p (hash-table &optional (follow-forwarding t)) (and (array-has-leader-p hash-table) (not (zerop (LDB %%array-leader-funcall-as-hash-table (%P-POINTER (%MAKE-POINTER-OFFSET DTP-Locative (IF follow-forwarding (follow-structure hash-table) hash-table) -1))))))) (defvar *incompatible-generation* 0) (proclaim '(inline rehash-for-gc)) (DEFUN rehash-for-gc (HASH-TABLE) "THIS PREDICATE IS USED TO DETERMINE IF A HASH-TABLE NEEDS A REHASH BECAUSE OF A GC-FLIP." (AND (/= (hash-table-gc-generation-number hash-table) %gc-generation-number) (or (neq (hash-table-hash-function hash-table ) 'equal-hash) (<= (hash-table-gc-generation-number hash-table) *incompatible-generation*)))) ;Note: the microcode knows the index of HASH-TABLE-MODULUS ;as well as the organization of the entries and how to hash them, ;in the special case that the modulus is a power of 2. ;See label CALL-INSTANCE-ARRAY in the microcode. (defstruct (hash-table :named :ARRAY-LEADER (:constructor make-hash-array-internal) (:conc-name nil) (:callable-constructors nil) (:copier nil)) (hash-table-rehash-function 'hash-table-rehash) ;A function when rehash is required. First argument is the hash-table, ;second is NIL to just rehash or the rehash-size to grow it first. ;The function must return the hash-table (which may have been moved ;by adjust-array-size) (hash-table-rehash-size 1.3) ;How much to grow by when the time comes. A flonum is the ratio to ;increase by, a fixnum is the number of entries to add. ;These will get rounded up to the next appropriate size. (hash-table-gc-generation-number %gc-generation-number) ;Used to decide when rehash required because the GC may have moved ;some objects, changing their %POINTER and hence their hash code. hash-table-modulus ;The number of blocks. Used for remainder to get hash code. (hash-table-fullness 0) ;The number of valid entries currently in the array. (hash-table-block-length 2) (hash-table-rehash-threshold 0.7s0) ;Rehash if we get more than this fraction full. (hash-table-number-of-deleted-entries 0) ;Number of "deleted" entries (entries no longer valid ;but which you must keep searching past). ;Used together with the FULLNESS to make sure there is always one ;slot that has never been used. (hash-table-lock ()) ;This function computes a numeric key from an object. NIL means use the object. hash-table-hash-function ;This function compares an object key with a key in the table. (hash-table-compare-function 'eq) ;This is the instance whose HASH-ARRAY we are. hash-table-instance) ;;;PHD 6/23/86 Added new Common Lisp functions (defun hash-table-size (hash-table) "returns the size of the hash-table (in entries)" (check-type hash-table hash-table ) (/ (array-total-size hash-table) (hash-table-block-length hash-table))) (defun hash-table-test (hash-table) "returns the test function of hash-table" (check-type hash-table hash-table) (case (hash-table-compare-function hash-table) (nil #'eq) (equal-hash #'equal) (eql-hash #'eql))) (DEFUN EQUAL-HASH (KEY) (SXHASH KEY nil)) ;; TGC (DEFUN EQL-HASH (KEY) (IF (AND (NUMBERP KEY) (NOT (FIXNUMP KEY))) (SXHASH KEY) KEY)) ;Subroutine of hashing. ;Given a hash-table and a key, return a locative to the start ;of the block in the array which may contain an association from that key. ;Cannot use ALOC because it gets an error if there is a DTP-NULL in the array. ;;AB 8-05-87. Change call to HASH-TABLE-FUNCALLABLE-P not to follow forwarding. ;; Hash table has been forwarded at this point. [SPR 6101] ;; Also fix LDB constant munged by our mode line and by a base problem ;; in System-3-4. This requires incrementing *incompatible-generation* ;; to force all hash tables to rehash. (PROCLAIM '(inline hash-block-pointer)) (defun hash-block-pointer (hash-table key blen modulus) (let* ((func-p (hash-table-funcallable-p hash-table nil)) (ph (ldb (byte (1- (byte-size %%q-pointer)) 0) (rot (%pointer key) (if func-p 0 (case (%data-type key) (#.dtp-symbol -2) (#.dtp-array -1) (#.dtp-list -1) (#.dtp-instance -1) (otherwise 0) )))))) (values (%make-pointer-offset dtp-locative hash-table (+ (* (REM ph modulus) blen) (IF (not (ZEROP (%p-ldb-offset %%array-simple-bit hash-table 0))) 1 (1+ (%p-ldb-offset %%array-long-length-flag hash-table 0))))) (if func-p 0 ph)))) (defsubst %p-contents-eq (p x) (And (neq (%p-data-type p) dtp-null) (eq (car p) x))) (defun make-hash-array (&key &optional (size 100) area ((:rehash-function rhf) 'hash-table-rehash) ((:rehash-size rhs) 1.3s0) growth-factor (number-of-values 1) actual-size (rehash-threshold 0.7s0) funcallable-p hash-function (compare-function 'eq) test instance &aux ht blen) ;;Note: regular (non-funcallable) hash tables MUST be sized to a prime number. ;; ACTUAL-SIZE should not be supplied unless it is prime. (cond (funcallable-p ;; Funcallable hash tables are looked at by the microcode ;; and require that the modulus be a power of 2. (setq rhf 'hash-table-double-size-rehash) (setq size (or actual-size (lsh 1 (integer-length size)))) (setq hash-function ()) (setq compare-function 'eq) (setq number-of-values 2)) (t (setq size (or actual-size (hash-table-good-size size))))) (when test (setq compare-function test) (setq hash-function (select test (('eq #'eq) nil) (('equal #'equal) 'equal-hash) (('eql #'eql) 'eql-hash) (t (ferror () "Argument TEST is not EQ, EQL or EQUAL."))))) (when (integerp rehash-threshold) (setq rehash-threshold (min .9s0 (/ (coerce rehash-threshold 'short-float) size)))) (setq blen (+ 1 number-of-values (if hash-function 1 0))) (setq ht (make-hash-array-internal :make-array (:LENGTH (* SIZE BLEN) :AREA AREA :TYPE ART-Q-LIST) :hash-table-modulus size :hash-table-block-length blen :hash-table-rehash-threshold rehash-threshold :hash-table-rehash-function rhf :hash-table-rehash-size (or growth-factor rhs) :hash-table-hash-function hash-function :hash-table-compare-function compare-function :HASH-TABLE-INSTANCE INSTANCE )) (%p-store-pointer-offset (DPB (if funcallable-p 1 0) %%array-leader-funcall-as-hash-table (%p-pointer-offset ht -1)) ht -1) ;; Fix instance for flavors to point back to itself so the old code still works. (when (and funcallable-p (null instance)) (setf (hash-table-instance ht ) ht)) (clear-hash-array ht) ht) ;;AB-PHD 5/19/87 Changed hash-table-good-size so it returns a prime number. (DEFPARAMETER *ht-prime-list* (COPY-LIST (LIST 23. 41. 71. 103. 149. 179. 223. 257. 311. 373. 449. 541. 643. 773. 929. 1117. 1361. 1601. 1931. 2309. 2767. 3319. 3989. 4783. 5737. 6883. 8263. 9923. 11897. 14281. 17137. 20563. 24671. 29599. 35521. 42641. 51151. 61379. 73651. 88397. 106087. 127271. 152729. 183283. 219931. 263909. 316691. 380041. 456037. 547241. 656701. 788027. 945647. 1134769. 1361713. 1634069. 1960867. 2353049. 2823661. 3388379. 4066063. 4879267. 5855141. 7026167.) )) ;; Convert SIZE (a number of array elements) to a guaranteed prime number. (defun hash-table-good-size (size) (OR (car (member size *ht-prime-list* :test #'<=)) (FERROR nil "Hash table size ~a exceeds system maximum of ~a" size (LAST *ht-prime-list*)))) ;;; This is a separate function from the :CLEAR-HASH operation ;;; for the sake of bootstrapping flavors. ;;AB 07-24-87. Add :WHOSTATE "Hash Table Lock" to WITH-LOCK. [SPR 5796] (defun clear-hash-array (hash-table ) "Clear out a hash array; leave it with no entries." (with-lock ((hash-table-lock hash-table) :whostate "Hash Table Lock") ;; Set all of hash table to NIL with cdr-next. (without-interrupts (setf hash-table (follow-structure hash-table)) (setf (aref hash-table 0) ()) (%p-store-cdr-code (aloc hash-table 0) cdr-next) (%blt-typed (aloc hash-table 0) (aloc hash-table 1) (1- (array-total-size hash-table)) 1) ;; Set first word of each group to DTP-NULL, 0. (let ((elt-0 (aloc hash-table 0)) (blen (hash-table-block-length hash-table))) (%P-STORE-DATA-TYPE-AND-POINTER elt-0 dtp-null 0) (%blt-typed elt-0 (%make-pointer-offset dtp-locative elt-0 blen) (1- (truncate (array-total-size hash-table) blen)) blen) ;; Set last word of each group to CDR-NIL (%p-store-cdr-code (aloc hash-table (+ blen -1)) cdr-nil) (%blt-typed (aloc hash-table (+ blen -1)) (aloc hash-table (+ blen blen -1)) (1- (truncate (array-total-size hash-table) blen)) blen)) (setf (hash-table-fullness hash-table) 0) (setf (hash-table-number-of-deleted-entries hash-table) 0) (setf (hash-table-gc-generation-number hash-table) %gc-generation-number) hash-table))) ;Named-structure handler ;;PHD 5/26/87, added an otherwise clause to error-off when a message is sent to a hash-table. (defun (:property hash-table named-structure-invoke) (message self &rest args) (case message (:which-operations '(:print-self :fasload-fixup)) (:fasload-fixup ;Force rehash as if due to gc, because hash codes are all wrong now. ;; Also fix up cdr codes. (setf self (follow-structure self)) (setf (hash-table-gc-generation-number self) -1) (do ((i 0 (+ i blen)) (blen (hash-table-block-length self)) (length (array-total-size self ))) ((>= i length)) (dotimes (j (1- blen)) (%p-store-cdr-code (aloc self (+ i j)) cdr-next)) (%p-store-cdr-code (aloc self (+ i blen -1)) cdr-nil))) (:print-self (let ((stream (car args))) (format stream "#<~S-~A ~O>" (function-name (hash-table-compare-function self)) (if (hash-table-funcallable-p self) "HASH-TABLE (Funcallable)" "HASH-TABLE") (%pointer self)))) (otherwise (ferror nil "Message sending is not supported anymore on HASH-TABLEs. Use HASH-TABLE-MIXIN if you want Flavor based hash-tables.")))) ;;; Rehashing of hash arrays. ;Add a new entry to a hash table being constructed for rehashing an old one. ;CONTENTS is a pointer to the first word of the entry in the old hash table, ;so its CAR is the hash code. ;There is no need to lock the hash table since nobody else knows about it yet. ;;;Edited by LEVY 7 Feb 91 17:15 (defun rehash-put (hash-table contents &optional for-gc &aux (hash-code ;; Use the same hash code as before, to avoid swapping, ;; unless this is rehashing due to GC. (if (and for-gc (hash-table-hash-function hash-table)) (funcall (hash-takble-hash-function hash-table) (%p-contents-offset contents 1)) (car contents)))) (let* ((blen (hash-table-block-length hash-table)) (mod (hash-table-modulus hash-table))) (multiple-value-bind (p ph ) (hash-block-pointer hash-table hash-code blen mod) (do* ((ksize) (delta) (p p (if (> (%pointer-difference p hash-table) (or ksize (setf ksize (- (array-total-size hash-table) (setf delta (* (1+ (rem ph (- mod 2))) blen)))))) (setq p (%make-pointer-offset dtp-locative p (- ksize))) (%make-pointer-offset dtp-locative p delta)))) ;; Make P wrap around at end of table. ;; > is used because the pointer-difference, when time to wrap, ;; is actually 1 or 2 more than the array length (because it includes the header); ;; if BLEN is 2, we could wrap too soon if >= were used. (nil) ;; Install this key in the first empty slot. ;; We know the key cannot already be present, and there are no deleted slots, ;; and we don't need to rehash because that's what we are doing. (cond ((= (%p-data-type p) dtp-null) (%blt-typed contents p blen 1) (setf (car p) hash-code) (return))))))) ;;AB 8-05-87. Change call to HASH-TABLE-FUNCALLABLE-P. [SPR 6101] ;;PHD 5/19/87 make sure to call hash-table-good-size if *incompatible-generation* ;;has been bumped up. ;Standard rehash function. Returns new hash array (possibly the same one). ;GROW is either the hash table's rehash-size or NIL meaning use same size array. ;ACTUAL-SIZE is so that this can be used as a subroutine of another ;rehash function which differs only in how to compute the new size. (defun hash-table-rehash (hash-table grow &optional actual-size &aux old-hash-table) ;;;phd 3/7/86 Added without-interrupts so we can be sure ;; that only one process will do that. ;; ;; Changed WITHOUT-INTERRUPTS to INHIBIT-GC-FLIPS. Also changed PUTHASH and ;; GETHASH callers to LOCK hash table before calling, and not call us from ;; WITHOUT-INTERRUPTS. 3-24-87, -ab (inhibit-gc-flips (setq old-hash-table hash-table hash-table (follow-structure hash-table)) (let* ((new-size (if (null grow) (if (or (> (hash-table-gc-generation-number hash-table) *incompatible-generation* ) (hash-table-funcallable-p hash-table nil)) (hash-table-modulus hash-table) (progn (setf grow 1.3) (hash-table-good-size (hash-table-modulus hash-table)))) (hash-table-good-size (if (floatp grow) (floor (* (hash-table-modulus hash-table) grow)) (+ (hash-table-modulus hash-table) grow))))) (new-hash-table (make-hash-array :size new-size :area (if grow (%area-number hash-table) background-cons-area) :rehash-function (hash-table-rehash-function hash-table) :rehash-size (hash-table-rehash-size hash-table) :hash-function (hash-table-hash-function hash-table) :compare-function (hash-table-compare-function hash-table) :funcallable-p (hash-table-funcallable-p hash-table nil) :instance (hash-table-instance hash-table) :actual-size (if grow actual-size (hash-table-modulus hash-table)) :number-of-values (- (hash-table-block-length hash-table) 1 (if (hash-table-hash-function hash-table) 1 0)) :rehash-threshold (hash-table-rehash-threshold hash-table)))) (declare (special new-hash-table)) ;; Scan the old hash table and find all nonempty entries. (do ((p (%make-pointer-offset dtp-locative hash-table (if (plusp (%p-ldb %%array-simple-bit hash-table)) 1 (1+ (%p-ldb %%array-long-length-flag hash-table)))) (%make-pointer-offset dtp-locative p blen)) (blen (hash-table-block-length hash-table)) (i 0 (+ i blen)) (n (array-total-size hash-table))) ((>= i n)) (cond ((/= (%p-data-type p) dtp-null) ;; And store each one in the new hash table. (rehash-put new-hash-table p (null grow))))) (setf (hash-table-fullness new-hash-table) (hash-table-fullness hash-table)) (cond ((null grow) (setq hash-table (follow-structure-forwarding hash-table)) (setf (hash-table-lock new-hash-table) (hash-table-lock hash-table)) (%blt-typed (%find-structure-leader new-hash-table) (%find-structure-leader hash-table) (%structure-total-size hash-table) 1) (return-array (prog1 new-hash-table (setf new-hash-table nil))) hash-table) (t (structure-forward hash-table new-hash-table) (when (= (%p-data-type old-hash-table) dtp-header-forward) ;; Forwarded at least once already. Skip intermediate structures. (%P-STORE-DATA-TYPE-AND-POINTER old-hash-table DTP-Header-Forward new-hash-table))))))) ;Rehash a hash table to be exactly double the size. ;Use this as a rehash function for a hash table. ;It ignores the :REHASH-SIZE parameter. (defun hash-table-double-size-rehash (hash-table grow) (hash-table-rehash hash-table grow (* 2 (hash-table-modulus hash-table)))) (unless (fboundp 'puthash-array) (fset 'puthash-array 'puthash)) (unless (fboundp 'make-flavor-hash-array) (fset 'make-flavor-hash-array 'make-flavor-hash-array-bootstrap)) (defun make-flavor-hash-array-bootstrap (area size) (make-hash-array ':area area ':size size ':funcallable-p t ':rehash-threshold 0.8s0 ':number-of-values 2)) (fset 'maphash-array 'maphash) ;;; Compatibility functions. ;;AB 7-23-87. o Un-support :ACTUAL-SIZE arg. If present as keyword, change to size. Also ;; remove :ACTUAL-SIZE documentation. The actual size MUST be forced to prime. [SPR 6037] ;; o For GLOBAL:MAKE-HASH-TABLE only: if :HASH-FUNCTION is present along with a :TEST, ;; change :TEST to :COMPARE-FUNCTION so that MAKE-HASH-ARRAY won't override :HASH-FUNCTION. ;; [SPR 4680] (defun global:make-hash-table (&rest options ) "Create a hash table. Keyword args are as follows: COMPARE-FUNCTION: the function for comparing the key against keys stored in the table. Usually EQ or EQUAL. HASH-FUNCTION: the function to compute a hash code from a key. NIL (the default) is for EQ hash tables, and SYS:EQUAL-HASH is used for EQUAL hash tables. TEST: Common Lisp way to specify the compare-function. For EQ, EQL or EQUAL a suitable hash function will be used automatically unless HASH-FUNCTION is also supplied. AREA: area to cons the table in. SIZE: lower bound for number of entries (rounded up). Note that the table cannot actually hold that many keys. NUMBER-OF-VALUES: number of values to associate with each key (default 1). Each PUTHASH can set all the values, and GETHASH retrieves them all. REHASH-THRESHOLD: a flonum between 0 and 1 (default 0.7). When that fraction of the table is full, it is made larger. REHASH-FUNCTION: a function which accepts a hash table and returns a larger one. REHASH-SIZE: the ratio by which the default REHASH-FUNCTION will increase the size of the table. By default, 1.3. The keyword :GROWTH-FACTOR is synonymous with this." (declare (arglist &key &optional test compare-function hash-function area size number-of-values rehash-threshold rehash-function rehash-size)) (LET ((tem (MEMBER :actual-size options :test #'EQ))) (WHEN tem (SETF (CAR tem) :size))) (WHEN (member :hash-function options :test #'eq) (LET ((tem (MEMBER :test options :test #'EQ))) (WHEN tem (SETF (CAR tem) :compare-function)))) (apply 'make-hash-array :allow-other-keys t options)) ;;AB 7-23-87. o Un-support :ACTUAL-SIZE arg. If present as keyword, change to size. Also ;; remove :ACTUAL-SIZE documentation. The actual size MUST be forced to prime. [SPR 6037] (DEFUN cli:MAKE-HASH-TABLE (&REST OPTIONS) "Creates and returns a new hash table. TEST determines how keys are compared. Use EQ, EQL or EQUAL. The default is EQL. SIZE is the initial size of the table in entries, rounded up. REHASH-SIZE is the ratio by which the default REHASH-FUNCTION will increase the size of the table. By default, 1.3. REHASH-THRESHOLD is a flonum between 0 and 1 (default 0.7). When that fraction of the table is full, it is made larger. COMPARE-FUNCTION: the function for comparing the key against keys stored in the table. Ignored if TEST supplied. Defaults to EQL. HASH-FUNCTION is the function to compute a hash code from a key. Ignored if TEST supplied. Defaults to SYS:EQL-HASH. AREA is the area to cons the table in. NUMBER-OF-VALUES is the number of values to associate with each key (default 1). REHASH-FUNCTION is a function used to increase the size of the hash table." (DECLARE (ARGLIST &KEY TEST SIZE REHASH-SIZE REHASH-THRESHOLD &EXTENSION COMPARE-FUNCTION HASH-FUNCTION AREA NUMBER-OF-VALUES REHASH-FUNCTION)) (LET ((tem (MEMBER :actual-size options :test #'EQ))) (WHEN tem (SETF (CAR tem) :size))) (APPLY 'MAKE-hash-array (COND ((OR (MEMBER :TEST OPTIONS :TEST #'EQ) (AND (MEMBER :COMPARE-FUNCTION OPTIONS :TEST #'EQ) (MEMBER :HASH-FUNCTION OPTIONS :TEST #'EQ))) OPTIONS) ((MEMBER :COMPARE-FUNCTION OPTIONS :TEST #'EQ) (APPEND '(:HASH-FUNCTION EQL-HASH) OPTIONS)) ((MEMBER :HASH-FUNCTION OPTIONS :TEST #'EQ) (APPEND '(:COMPARE-FUNCTION EQL) OPTIONS)) (T (APPEND '(:TEST EQL) OPTIONS))))) (defun hash-table-count (hash-table) "Returns the number of associations currently stored in HASH-TABLE." (hash-table-fullness hash-table)) ;;AB 07-24-87. When hash table empty, update GC generation number anyway. [SPR 5858] ;;AB 07-24-87. Add :WHOSTATE "Hash Table Lock" to WITH-LOCK. [SPR 5796] ;;CLM for PHD 12/10/87. Added some performance improvements. (defun clrhash (hash-table &optional ignore ) "Clear out a hash table; leave it with no entries." (CHECK-ARG hash-table hash-table-p "a hash table") (with-lock ((hash-table-lock hash-table) :whostate "Hash Table Lock") (without-interrupts (when (and (zerop (hash-table-fullness hash-table)) (zerop (hash-table-number-of-deleted-entries hash-table))) ;; Just update GC generation number. (setf (hash-table-gc-generation-number hash-table) %gc-generation-number) (return-from clrhash hash-table)) (setq hash-table (follow-structure hash-table)) ;; Set all of hash table to NIL with cdr-next. ; (setf (aref hash-table 0) ()) ; (%p-store-cdr-code (aloc hash-table 0) cdr-next) ; (%blt-typed (aloc hash-table 0) (aloc hash-table 1) (1- (array-total-size hash-table)) 1) ;; Set first word of each group to DTP-NULL, 0. (let* ((elt-0 (aloc hash-table 0)) (blen (hash-table-block-length hash-table)) (count (1- (truncate (array-total-size hash-table) blen)))) (setf (contents elt-0) nil) (%P-STORE-DATA-TYPE-AND-POINTER elt-0 DTP-Null 0) (%p-store-cdr-code (aloc hash-table 0) cdr-next) (%blt-typed elt-0 (%make-pointer-offset dtp-locative elt-0 blen) count blen) ;; Set last word of each group to CDR-NIL. (setf (aref hash-table (+ blen -1)) nil) (%p-store-cdr-code (aloc hash-table (+ blen -1)) cdr-nil) (%blt-typed (aloc hash-table (+ blen -1)) (aloc hash-table (+ blen blen -1)) count blen) (dotimes (i (- blen 2)) (setf (aref hash-table (+ i 1)) nil) (%p-store-cdr-code (aloc hash-table (+ i 1)) cdr-next) (%blt-typed (aloc hash-table (+ i 1)) (aloc hash-table (+ i blen 1)) count blen))) (setf (hash-table-fullness hash-table) 0) (setf (hash-table-number-of-deleted-entries hash-table) 0) (setf (hash-table-gc-generation-number hash-table) %gc-generation-number) hash-table))) ;;phd 5/14/87 added default-value in the recursive function call. ;;AB 07-24-87. Add :WHOSTATE "Hash Table Lock" to WITH-LOCK. [SPR 5796] (defun gethash (key hash-table &optional default-value ) "Read the values associated with KEY in HASH-TABLE. Returns: 1) The primary value associated with KEY (DEFAULT-VALUE if KEY is not found), 2) a flag which is T if KEY was found, 3) a pointer to the list (inside the hash table) which holds the key and the associated values (NIL if KEY is not found)." (declare (values value key-found-flag entry-pointer) (inline hash-table-p)) (CHECK-ARG hash-table hash-table-p "a hash table") (let* ((previous-inhibit-scheduling-flag inhibit-scheduling-flag) ;save scheduling state -ab (hash-function (hash-table-hash-function hash-table)) (compare-function (hash-table-compare-function hash-table)) (hash-code (if hash-function (funcall hash-function key) key))) (with-lock-fast ((hash-table-lock hash-table)) (setq hash-table (follow-structure hash-table)) (let* ((blen (hash-table-block-length hash-table)) (mod (hash-table-modulus hash-table))) (multiple-value-bind (p ph) (hash-block-pointer hash-table hash-code blen mod) (do* ((ksize) (delta) (p p (if (> (%pointer-difference p hash-table) (or ksize (setf ksize (- (array-total-size hash-table) (setf delta (* (1+ (rem ph (- mod 2))) blen)))))) (setq p (%make-pointer-offset dtp-locative p (- ksize))) (%make-pointer-offset dtp-locative p delta)))) ;; > is used because the pointer-difference, when time to wrap, ;; is actually 1 or 2 more than the array length (because it includes the header); ;; if BLEN is 2, we could wrap too soon if >= were used. (nil) (and (%p-contents-eq p hash-code) (or (null hash-function) (funcall compare-function key (%p-contents-offset p 1))) (progn (if hash-function (setq p (%make-pointer-offset dtp-list p 1))) (return (%p-contents-offset p 1) t (%make-pointer dtp-list p)))) ;; If we find a slot that has never been used, this key is not present. ;; We assume that not all slots are used! (if (and (= (%p-data-type p) dtp-null) (zerop (%p-pointer p))) (cond ((rehash-for-gc hash-table) ;; Some %POINTER's may have changed, try rehashing. ;; First, undo any WITHOUT-INTERRUPTS we did so that we don't cause the rehash ;; to lock out everything else. But do lock the hash table so someone else ;; won't access it. 3-24-87, -ab (with-lock ((hash-table-lock hash-table) :whostate "Hash Table Lock") (let ((inhibit-scheduling-flag previous-inhibit-scheduling-flag)) (funcall (hash-table-rehash-function hash-table) hash-table ()))) (return (gethash key hash-table default-value))) (t (return default-value () ())))))))))) ;;PHD 2/16/87 Fix a bug in the recursive calls. ;;AB 07-24-87. Add :WHOSTATE "Hash Table Lock" to WITH-LOCK. [SPR 5796] (defun puthash (key value hash-table &rest additional-values ) "Set the values associated with KEY in HASH-TABLE. The first value is set from VALUE. If the hash table associates more than one value with each key, the remaining values are set from ADDITIONAL-VALUES. Returns: 1) VALUE, 2) the previous value (or NIL), 3) T if KEY already had an entry in the table, 4) a pointer to the list (inside the hash table) which holds the key and the associated values." (declare (values value old-value key-found-flag entry-pointer) (inline hash-table-p)) (CHECK-ARG hash-table hash-table-p "a hash table") (let*((previous-inhibit-scheduling-flag inhibit-scheduling-flag) ;save scheduling state -ab (hash-function (hash-table-hash-function hash-table)) (compare-function (hash-table-compare-function hash-table)) (values-left (cons value additional-values )) (hash-code (if hash-function (funcall hash-function key) key)) (modulus (hash-table-modulus hash-table))) (with-lock-fast ((hash-table-lock hash-table)) (setq hash-table (follow-structure hash-table)) (let* ((blen (hash-table-block-length hash-table)) (mod (hash-table-modulus hash-table))) (multiple-value-bind (p ph) (hash-block-pointer hash-table hash-code blen mod) (do* ((ksize) (delta) (old-value)(emptyp ()) (p p (if (> (%pointer-difference p hash-table) (or ksize (setf ksize (- (array-total-size hash-table) (setf delta (* (1+ (rem ph (- mod 2))) blen)))))) (setq p (%make-pointer-offset dtp-locative p (- ksize))) (%make-pointer-offset dtp-locative p delta)))) (nil) (cond ((and (%p-contents-eq p hash-code) ;Found existing entry (or (null hash-function) (funcall compare-function (%p-contents-offset p 1) key))) (let ((value-index (if hash-function 2 1))) (setq old-value (%p-contents-offset p value-index)) (do ((i value-index (1+ i))) ((= i blen)) (%p-store-contents-offset (pop values-left) p i)) (return value old-value t (%make-pointer-offset dtp-list p (1- value-index))))) ((= (%p-data-type p) dtp-null) (or emptyp (setq emptyp p)) (when (zerop (%p-pointer p)) (cond ((rehash-for-gc hash-table) ;; Some %POINTER's may have changed, try rehashing ;; First, undo any WITHOUT-INTERRUPTS we did so that we don't cause the rehash ;; to lock out everything else. But do lock the hash table so someone else ;; won't access it. 3-24-87, -ab (with-lock ((hash-table-lock hash-table) :whostate "Hash Table Lock") (let ((inhibit-scheduling-flag previous-inhibit-scheduling-flag)) (funcall (hash-table-rehash-function hash-table) hash-table ()))) (return (apply #'puthash key value hash-table additional-values ))) ;; Also, if we are nearly full, rehash in a larger array. ;; Don't allow the hash table to become full. ((>= (+ (hash-table-fullness hash-table) (hash-table-number-of-deleted-entries hash-table)) (floor (* (if (floatp (hash-table-rehash-threshold hash-table)) (hash-table-rehash-threshold hash-table) 0.7s0) (- modulus 2)))) ;; First, undo any WITHOUT-INTERRUPTS we did so that we don't cause the rehash ;; to lock out everything else. But do lock the hash table so someone else ;; won't access it. 3-24-87, -ab (with-lock ((hash-table-lock hash-table) :whostate "Hash Table Lock") (let ((inhibit-scheduling-flag previous-inhibit-scheduling-flag)) (funcall (hash-table-rehash-function hash-table) hash-table (hash-table-rehash-size hash-table)))) (return (apply #'puthash key value hash-table additional-values ))) (t ;Add to table using empty slot found (%p-store-contents emptyp hash-code) (cond (hash-function (%p-store-contents-offset key emptyp 1) (do ((i 2 (1+ i))) ((= i blen)) (%p-store-contents-offset (pop values-left) emptyp i))) (t (do ((i 1 (1+ i))) ((= i blen)) (%p-store-contents-offset (pop values-left) emptyp i)))) (incf (hash-table-fullness hash-table)) ;; If reusing a deleted slot, decrement number of them slots. (or (eq emptyp p) (decf (hash-table-number-of-deleted-entries hash-table))) (return value)))))))))))) ;Used by SETF of GETHASH. (defun sethash (key hash-table value) (puthash key value hash-table)) ;;; 9/23/86 rla for phd - changed following call to PUTHASH to use APPLY (defun swaphash (key value hash-table &rest additional-values) "Set the values associated with KEY in HASH-TABLE, returning the previous values. The first value is set to VALUE. If the hash table holds more than one value per entry, the additional values are set from ADDITIONAL-VALUES. The values returned by SWAPHASH are the same as those of GETHASH." (declare (values old-value old-value-p location)) (multiple-value-bind (nil old-value old-value-p location) (apply #'puthash key value hash-table additional-values) (values old-value old-value-p location))) (defun modifyhash (key hash-table function &rest additional-args &aux new-value) (multiple-value-bind (value key-found-p values-list) (gethash key hash-table) (setq new-value (apply function key value key-found-p additional-args)) (if key-found-p (setf (cadr values-list) new-value) (puthash key new-value hash-table)) new-value)) ;;AB 07-24-87. Add :WHOSTATE "Hash Table Lock" to WITH-LOCK. [SPR 5796] (defun remhash (key hash-table ) "Delete any entry for KEY in HASH-TABLE. Return T if there was one." (CHECK-ARG hash-table hash-table-p "a hash table") (let*((previous-inhibit-scheduling-flag inhibit-scheduling-flag) ;save scheduling state -ab (compare-function (hash-table-compare-function hash-table)) (hash-function (hash-table-hash-function hash-table)) (hash-code (if hash-function (funcall hash-function key) key))) (with-lock ((hash-table-lock hash-table) :whostate "Hash Table Lock") (without-interrupts (setq hash-table (follow-structure hash-table)) (let* ((blen (hash-table-block-length hash-table)) (mod(hash-table-modulus hash-table))) (multiple-value-bind (p ph) (hash-block-pointer hash-table hash-code blen mod) (do* ((ksize) (delta) (p p (if (> (%pointer-difference p hash-table) (or ksize (setf ksize (- (array-total-size hash-table) (setf delta (* (1+ (rem ph (- mod 2))) blen)))))) (setq p (%make-pointer-offset dtp-locative p (- ksize))) (%make-pointer-offset dtp-locative p delta)))) (nil);; Make P wrap around at end of table. ;; > is used because the pointer-difference, when time to wrap, ;; is actually 1 or 2 more than the array length (because it includes the header); ;; if BLEN is 2, we could wrap too soon if >= were used. (when (and (%p-contents-eq p hash-code) ;Found existing entry (or (null hash-function) (funcall compare-function (%p-contents-offset p 1) key))) (do ((i 1 (1+ i))) ((= i blen)) (%p-store-contents-offset () p i)) ;Wipe out old values (%P-STORE-DATA-TYPE-AND-POINTER p dtp-null 1) (decf (hash-table-fullness hash-table)) (incf (hash-table-number-of-deleted-entries hash-table)) (return t)) (when (and (= (%p-data-type p) dtp-null) (zerop (%p-pointer p))) (return (cond ((rehash-for-gc hash-table) ;; Some %POINTER's may have changed, try rehashing ;; First, undo any WITHOUT-INTERRUPTS we did so that we don't cause the rehash ;; to lock out everything else. But do lock the hash table so someone else ;; won't access it. 3-24-87, -ab (with-lock ((hash-table-lock hash-table) :whostate "Hash Table Lock") (let ((inhibit-scheduling-flag previous-inhibit-scheduling-flag)) (funcall (hash-table-rehash-function hash-table) hash-table ()))) (remhash key hash-table)) (t nil))))))))))) ;;AB 07-24-87. Add :WHOSTATE "Hash Table Lock" to WITH-LOCK. [SPR 5796] ;;JHO 02/29/88. Add inhibit-gc-flips around the body of the maphash [SPR 7332] (defun maphash (function hash-table &rest extra-args) "Apply FUNCTION to each item in HASH-TABLE; ignore values. FUNCTION's arguments are the key followed by the values associated with it, followed by the EXTRA-ARGS." (CHECK-ARG hash-table hash-table-p "a hash table") (with-lock ((hash-table-lock hash-table) :whostate "Hash Table Lock") ;; 3-24-87, -ab. Put re-hash inside the WITH-LOCK. (when (rehash-for-gc hash-table) ;; Some %POINTER's may have changed, try rehashing (funcall (hash-table-rehash-function hash-table) hash-table ())) (setq hash-table (follow-structure hash-table)) (let* ((blen (hash-table-block-length hash-table)) (block-offset (if (hash-table-hash-function hash-table) 1 0)) (argcount (- (+ blen (Length extra-args)) block-offset))) (%assure-PDL-room argcount) (inhibit-gc-flips (do( (i 0 (+ i blen)) (n (array-total-size hash-table))) ((>= i n)) (unless (without-interrupts (= (%p-data-type (aloc hash-table i)) dtp-null)) (without-interrupts (%spread (%make-pointer-offset dtp-list (aloc hash-table i) block-offset))) (%spread extra-args) (%call function argcount)) ))) hash-table)) ;;AB 07-24-87. Add :WHOSTATE "Hash Table Lock" to WITH-LOCK. [SPR 5796] (defun maphash-return (function hash-table &optional (return-function 'list) &aux values ) "Apply FUNCTION to each item in HASH-TABLE; apply RETURN-FUNCTION to list of results. FUNCTION's arguments are the key followed by the values associated with it. The values returned by FUNCTION are put in a list. At the end, RETURN-FUNCTION is applied to that list to get the final value." (CHECK-ARG hash-table hash-table-p "a hash table") (with-lock ((hash-table-lock hash-table) :whostate "Hash Table Lock") ;; 3-24-87, -ab. Put re-hash inside the WITH-LOCK. (when (rehash-for-gc hash-table) ;; Some %POINTER's may have changed, try rehashing (funcall (hash-table-rehash-function hash-table) hash-table ())) (setq hash-table (follow-structure hash-table)) (do ((blen (hash-table-block-length hash-table)) (block-offset (if (hash-table-hash-function hash-table) 1 0)) (i 0 (+ i blen)) (n (array-total-size hash-table))) ((>= i n)) (cond ((without-interrupts (/=(%p-data-type (aloc hash-table i)) dtp-null)) (let ((value (apply function (without-interrupts (%make-pointer-offset dtp-list (aloc hash-table i) block-offset))))) (case return-function (nconc (setq values (nconc value values))) (t (push value values))))))) (if (member return-function '(list nconc) :test #'eq) values (apply return-function values))))