;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:10; Readtable:CL -*-

;;; Following COMMON-LISP functions are defined in this file:
;	  CLRHASH
;	  GETHASH
;	  HASH-TABLE-P
;	  MAKE-HASH-TABLE
;	  MAPHASH
;	  REMHASH
;         SXHASH

	  
;;; HASH TABLE STRUCTURE 
;;;     $$DTP-HASH-TABLE-HEADER (with total number of Q's used by hash table)
;;;     test-function (0-2 for eq, eql, equal respectively)
;;;     rehash-size   (fixnum amount to grow by)
;;;     rehash-threshold (fixnum count of rehash threshold)
;;;     current-used   (fixnum number of currently used slots)
;;;     data-ptr       (locative to first element of simple vector holding the data)

;;;  Simple vector, 3 times size of hash table
;;;     sxhash-key ...... 
;;;     original-key ....
;;;     data ............
;;;
;;; Pointed to by $$DTP-HASH-TABLE
;;;

;-------------------------------------------------------------------------------
; Useful constants for hash table code

(defconstant hash-table-header-size 7)
(defconstant hash-table-max-size    #.(- (lisp:truncate (lisp:expt 2 23.) 3) hash-table-header-size 1))

;-------------------------------------------------------------------------------
; Hash table accessors

(defsubst %hash-table-size (ht)
  (cons:contents-offset ht 1))

(defsubst %hash-table-size-set (ht data)
  (cons:store-contents-offset ht 1 data))

(defsetf %hash-table-size %hash-table-size-set)

(defsubst %hash-table-use-count (ht)
  (cons:contents-offset ht 2))

(defsubst %hash-table-use-count-set (ht data)
  (cons:store-contents-offset ht 2 data))

(defsetf %hash-table-use-count %hash-table-use-count-set)

(defsubst %hash-table-test (ht)
  (cons:contents-offset ht 3))

(defsubst %hash-table-test-set (ht data)
  (cons:store-contents-offset ht 3 data))

(defsetf %hash-table-test %hash-table-test-set)

(defsubst %hash-table-rehash-size (ht)
  (cons:contents-offset ht 4))

(defsubst %hash-table-rehash-size-set (ht data)
  (cons:store-contents-offset ht 4 data))

(defsetf %hash-table-rehash-size %hash-table-rehash-size-set)

(defsubst %hash-table-rehash-threshold (ht)
  (cons:contents-offset ht 5))

(defsubst %hash-table-rehash-threshold-set (ht data)
  (cons:store-contents-offset ht 5 data))

(defsetf %hash-table-rehash-threshold %hash-table-rehash-threshold-set)

(defsubst %hash-table-data-ptr (ht)
  (cons:contents-offset ht 6))

(defsubst %hash-table-data-ptr-set (ht data)
  (cons:store-contents-offset ht 6 data))

(defsetf %hash-table-data-ptr %hash-table-data-ptr-set)


;-------------------------------------------------------------------------------

(defun MAKE-HASH-TABLE (&key
			(test 'eql)
			(size 23.)
			(rehash-size nil rehash-size-p)
			(rehash-threshold nil rehash-threshold-p))
  (when (or (not (vinc:fixnump size)) (<= size 0) (>= size hash-table-max-size))
    (error "Bad size to make-hash-table" size))
  (setq test (cond
	       ((eq test 'eq)      0)
	       ((eq test 'eql)     1)
	       ((eq test 'equal)   2)
	       ((eq test #'eq)     0)
	       ((eq test #'eql)    1)
	       ((eq test #'equal)  2)
	       (t (error "Bad test to make-hash-table" test))))
  (if rehash-size-p
       (unless (or (and (vinc:fixnump rehash-size) (> rehash-size 0))
		   (and (floatp rehash-size) (> rehash-size 1)))
	 (error "Bad rehash-size to make-hash-table" rehash-size))
    (setq rehash-size size))
  (if rehash-threshold-p
      (cond ((and (vinc:fixnump rehash-threshold) (> rehash-threshold 0) (< rehash-threshold size)) t)
	    ((and (floatp rehash-threshold) (> rehash-threshold 0) (< rehash-threshold 1))
	     (setq rehash-threshold (truncate (* rehash-threshold size))))
	    (t
	     (error "Bad rehash-threshold to mask-hash-table" rehash-threshold)))
    (setq rehash-threshold (ash (+ size size size) -2))) ;default threshold = 3/4
  (let* ((ht (cons:allocate-structure
	       hash-table-header-size
	       0
	       vinc:$$dtp-hash-table
	       (hw:dpb-unboxed vinc:$$dtp-hash-table-header vinc:%%data-type hash-table-header-size))))
    (setf (%hash-table-size ht)             size)
    (setf (%hash-table-use-count ht)        0)
    (setf (%hash-table-test ht)             test)
    (setf (%hash-table-rehash-size ht)      rehash-size)
    (setf (%hash-table-rehash-threshold ht) rehash-threshold)
    (setf (%hash-table-data-ptr ht)         (hw:24+ 1 (cons:make-pointer vinc:$$dtp-locative
									 (array:make-vector (+ size size size)))))
    ht))

;-------------------------------------------------------------------------------
    
(defsubst HASH-TABLE-P (object)
  (vinc:type-test object vinc:$$dtp-hash-table))

;-------------------------------------------------------------------------------

(defsubst %sxhash-raw-32 (raw-32 key)
  (hw:32+ raw-32
	  (hw:32-rotate-up
	    (hw:dpb-xor raw-32 (byte 16. -16.) key)
	    1)))

(defsubst %sxhash-nil (key)
  (let ((magic-number (hw:unboxed-constant #X87654321)))
    (%sxhash-raw-32 magic-number key)))

(defsubst %sxhash-fixnum (fixnum key)
  (%sxhash-raw-32 fixnum key))

(defun %sxhash-string (string key)
  (let ((len (length string)))
    (dotimes (i len key)
      (setq key (%sxhash-raw-32 (svref string i) key)))))

(defun %sxhash-bignum (bignum key)
  (let ((len (hw:ldb (array:%vm-read32 bignum 0) vinc:%%fixnum-field 0)))
      (dotimes (i len key)
	(setq key (%sxhash-raw-32 (array:%vm-read32 bignum (1+ i)) key)))))

(defun %sxhash-single-float (float key)
  (%sxhash-raw-32 (array:%vm-read32 float 1) key))

(defsubst %sxhash-double-float (float key)
  (%sxhash-raw-32 (array:%vm-read32 float 1) (%sxhash-raw-32 (array:%vm-read32 float 2) key)))

(defun %sxhash-array (array key)
  (cond ((vectorp array)
	 (let ((len (length array)))
	   (dotimes (i len)
	     (setq key (%sxhash-1 (svref array i) key)))))
	(t (%sxhash-raw-32 (array:%vm-read32 array -1) key))))

(defsubst %sxhash-structure (struct key)
  (%sxhash-raw-32 (array:%vm-read32 struct 0) (%sxhash-1 (cons:contents-offset struct 1) key)))

(defun %sxhash-1 (object key)
  (dispatch vinc:%%data-type object
     (vinc:$$dtp-nil            (%sxhash-nil key))
     (vinc:$$dtp-symbol 	(%sxhash-string (symbol-name object) key))
     (vinc:$$dtp-fixnum		(%sxhash-fixnum object key))
     (vinc:$$dtp-bignum 	(%sxhash-bignum object key))
     (vinc:$$dtp-rational	(%sxhash-1 (nm:numerator object) (%sxhash-1 (nm:denominator object) key)))
     (vinc:$$dtp-complex	(%sxhash-1 (nm:realpart  object) (%sxhash-1 (nm:imagpart    object) key)))
     (vinc:$$dtp-short-float	(%sxhash-raw-32 object key))
     (vinc:$$dtp-single-float	(%sxhash-single-float object key))
     (vinc:$$dtp-double-float	(%sxhash-double-float object key))
     (vinc:$$dtp-cons		(%sxhash-1 (car object) (%sxhash-1 (cdr object) key)))
     (vinc:$$dtp-compiled-function (%sxhash-1 (k2:%compiled-function-name object) key)) ;this doesn't work- fix it someday
     (vinc:$$dtp-array		(%sxhash-array object key))
     (vinc:$$dtp-structure	(%sxhash-structure object key))
     (vinc:$$dtp-character      (%sxhash-raw-32 object key))
     (t (error "I can't SXHASH that yet!" object))))

(defun SXHASH (object)
  (hw:ldb (%sxhash-1 object (hw:unboxed-constant #x89abcdef))
	  (byte 23. 0)
	  0))

;-------------------------------------------------------------------------------

(defun %lochash (key hash-table)
  (if (not (hash-table-p hash-table))
      (error "Not a hash-table to %lochash" hash-table)
    (let* ((size (%hash-table-size hash-table))
	   (sxkey (sxhash key))
	   (msxkey (rem (sxhash key) size))
	   (ptr (hw:24+ msxkey (%hash-table-data-ptr hash-table))))
      (values
	ptr
	sxkey
	size))))

(defun %inc-ptr (ptr hash-table)
  (setq ptr (hw:24+ 1 ptr))
  (let* ((size       (%hash-table-size hash-table))
	 (sxkey-base (%hash-table-data-ptr hash-table)))
    (if (hw:32< ptr (hw:24+ size sxkey-base))
	ptr
      sxkey-base)))

(defun %cmphash (key hkey cmp)
  (dispatch (byte 2 0) cmp
     (0 (eq key hkey))
     (1 (eql key hkey))
     (2 (equal key hkey))
     (3 (error "Bad compare code to %cmphash" cmp))))
;-------------------------------------------------------------------------------

(defun GETHASH (key hash-table &optional default)
  (multiple-value-bind (ptr sxkey size) (%lochash key hash-table)
    (let ((test (%hash-table-test hash-table)))
      (do () (())
	(let ((hsxkey (cons:contents-offset ptr 0)))
	  (cond
	    ((and (eql sxkey hsxkey)
		  (%cmphash key (cons:contents-offset ptr size) test))
	     (return-from gethash (values (cons:contents-offset ptr (ash size 1)) t)))
	    ((null hsxkey)
	     (return-from gethash (values default nil)))
	    (t
	     (setq ptr (%inc-ptr ptr hash-table)))))))))

(defun %sethash (key hash-table data)
  (multiple-value-bind (ptr sxkey size) (%lochash key hash-table)
    (let* ((test  (%hash-table-test hash-table)))
      (do () (())
	(let ((hsxkey (cons:contents-offset ptr 0)))
	  (cond
	    ((and (eql sxkey hsxkey)
		  (%cmphash key (cons:contents-offset ptr size) test))
	     (cons:store-contents-offset ptr size key)
	     (cons:store-contents-offset ptr (ash size 1) data)
	     (return-from %sethash (values data t)))
	    ((null hsxkey)
	     (let ((count (1+ (%hash-table-use-count hash-table)))
		   (limit (%hash-table-rehash-threshold hash-table)))
	       (if (>= count limit)
		   (return-from %sethash (%sethash key (%rehash hash-table) data))
		 (progn
		   (setf (%hash-table-use-count hash-table) count)
		   (cons:store-contents-offset ptr 0 sxkey)
		   (cons:store-contents-offset ptr size key)
		   (cons:store-contents-offset ptr (ash size 1) data)
		   (return-from %sethash (values data nil))))))
	    (t
	     (setq ptr (%inc-ptr ptr hash-table)))))))))

(defsetf gethash  (key hash-table &optional default) (value)
  `(%sethash ,key ,hash-table ,value))

;-------------------------------------------------------------------------------

(defun REMHASH (key hash-table)
  (multiple-value-bind (ptr sxkey size) (%lochash key hash-table)
    (let* ((test  (%hash-table-test hash-table)))
      (do () (())
	(let ((hsxkey (cons:contents-offset ptr 0)))
	  (cond
	    ((and (eql sxkey hsxkey)
		  (%cmphash key (cons:contents-offset ptr size) test))
	     (decf (%hash-table-use-count hash-table))
	     (cons:store-contents-offset ptr 0 nil)
	     (cons:store-contents-offset ptr size nil)
	     (cons:store-contents-offset ptr (ash size 1) nil)
	     (return-from remhash t))
	    ((null hsxkey)
	     (return-from remhash nil))
	    (t
	     (setq ptr (%inc-ptr ptr hash-table)))))))))

;-------------------------------------------------------------------------------

(defun MAPHASH (function hash-table)
  (if (not (hash-table-p hash-table))
      (error "Not a hash-table to maphash" hash-table)
    (let* ((size (%hash-table-size hash-table))
	   (ptr  (%hash-table-data-ptr hash-table)))
      (dotimes (i size)
	(let ((hsxkey  (cons:contents-offset ptr 0)))
	  (when hsxkey
	    (funcall function
		     (cons:contents-offset ptr size)
		     (cons:contents-offset ptr (ash size 1)))))
	(setq ptr (hw:24+ 1 ptr)))))
  nil)

;-------------------------------------------------------------------------------

(defun CLRHASH (function hash-table)
  (if (not (hash-table-p hash-table))
      (error "Not a hash-table to maphash" hash-table)
    (let* ((size (%hash-table-size hash-table))
	   (ptr  (%hash-table-data-ptr hash-table)))
      (dotimes (i size)
	(cons:store-contents-offset ptr 0 nil)
	(cons:store-contents-offset ptr size nil)
	(cons:store-contents-offset ptr (ash size 1) nil)
	(setq ptr (hw:24+ 1 ptr)))))
  nil)
		      
;-------------------------------------------------------------------------------

(defun HASH-TABLE-COUNT (hash-table)
  (if (not (hash-table-p hash-table))
      (error "Not a hash-table to hash-table-count" hash-table)
    (%hash-table-use-count hash-table)))

;-------------------------------------------------------------------------------

(defun %rehash (old-hash-table)
  (let* ((size             (%hash-table-size old-hash-table))
	 (test             (dispatch (byte 2 0) (%hash-table-test old-hash-table)
				     (0 'eq)
				     (1 'eql)
				     (2 'equal)))
	 (rehash-size      (%hash-table-rehash-size old-hash-table))
	 (rehash-threshold (%hash-table-rehash-threshold old-hash-table))
	 (percent-grow     (if (vinc:fixnump rehash-size)
			       (/ (+ rehash-size size) size)
			     (rehash-size)))
	 (new-hash-table (make-hash-table
			   :test 	     test
			   :size 	     (truncate (* percent-grow size))
			   :rehash-size      (truncate (* percent-grow rehash-size)))
			   :rehash-threshold (if (vinc:fixnump rehash-size)
						 (truncate (* percent-grow rehash-threshold))
					       rehash-threshold))
	 (ptr (%hash-table-data-ptr old-hash-table)))
    (dotimes (i size)
      (when (cons:contents-offset ptr 0)
	(let ((hkey  (cons:contents-offset ptr size))
	      (hdata (cons:contents-offset ptr (ash size 1))))
	  (setf (gethash hkey new-hash-table) hdata)))
      (setq ptr (hw:24+ 1 ptr)))
    (setf (%hash-table-size old-hash-table)             (%hash-table-size new-hash-table))
    (setf (%hash-table-test old-hash-table)             (%hash-table-test new-hash-table))
    (setf (%hash-table-rehash-size old-hash-table)      (%hash-table-rehash-size new-hash-table))
    (setf (%hash-table-rehash-threshold old-hash-table) (%hash-table-rehash-threshold new-hash-table))
    (setf (%hash-table-data-ptr old-hash-table)         (%hash-table-data-ptr new-hash-table))
    old-hash-table))