persistent HAMT!!

gistfile1.lisp

(in-package :cl-user)

;; TODO: maybe I should use CLOS

(defpackage hamt
  (:use :common-lisp)
  (:export put get make-hamt)
  (:shadow put get))

(in-package :hamt)

(defun ctpop (bitmap &key (start 0) (end 32))
  (logcount (ldb (byte (- end start) start) bitmap)))

(defun mask (hash shift)
  (ldb (byte 5 (* shift 5)) hash))

(defun insert (array pos item)
  (let ((new-array (adjust-array array (1+ (length array)))))
    (loop for i from (1- (length array)) downto pos do
      (setf (aref new-array (1+ i))
            (aref array i)))
    (setf (aref new-array pos) item)
    new-array))

(declaim (inline key))
(defun key (keyval-pair)
  (car keyval-pair))

(declaim (inline value))
(defun val (keyval-pair)
  (cdr keyval-pair))

(declaim (inline make-keyval-pair))
(defun make-keyval-pair (key val)
  (cons key val))

(defstruct array-node
  (entries (make-array 32 :initial-element nil) :type simple-vector))

(defstruct bitmap-node
  (bitmap   0   :type (unsigned-byte 32))
  (entries  #() :type simple-vector))

(defstruct hamt
  (root (make-array-node) :type array-node)
  (hash-fun #'sxhash      :type function)
  (test-fun #'equal       :type function))

(defun bitmap-node-find (node key &key (shift 0) hash (hash-fun #'sxhash) (test-fun #'equal))
  (declare (optimize (speed 3) (safety 0)))
  (declare (bitmap-node node)
           (fixnum shift))
  (with-slots (bitmap entries) node
    (when (null hash)
      (setf hash (funcall hash-fun key)))
    (let* ((lastbits (mask hash shift))
           (bitmap-bit (ldb (byte 1 lastbits) bitmap)))
      (unless (zerop bitmap-bit)
        (let* ((array-index (ctpop bitmap :end lastbits))
               (entry (aref entries array-index)))
          (cond ((null entry) nil)
                ((listp entry) (if (funcall test-fun (key entry) key)
                                   (val entry)
                                   nil))
                (t (bitmap-node-find entry key :shift (1+ shift)
                                               :hash hash))))))))

(defun array-node-find (node key &key (shift 0) hash (hash-fun #'sxhash) (test-fun #'equal))
  (declare (optimize (speed 3) (safety 0)))
  (declare (array-node node)
           (fixnum shift))
  (with-slots (entries) node
    (when (null hash)
      (setf hash (funcall hash-fun key)))
    (let* ((array-index (mask hash shift))
           (item (aref entries array-index)))
      (cond ((null item) nil)
            ((listp item) (if (funcall test-fun (key item) key)
                              (val item)
                              nil))
            (t (bitmap-node-find item key :shift (1+ shift)
                                          :hash hash))))))

(defun bitmap-node-put (node keyval &key (shift 0) hash (hash-fun #'sxhash) (test-fun #'equal))
  (declare (optimize (speed 3) (safety 0)))
  (declare (bitmap-node node)
           (fixnum shift)
           (list keyval))
  (with-slots (bitmap entries) node
    (when (null hash)
      (setf hash (funcall hash-fun (key keyval))))
    (let* ((lastbits (mask hash shift))
           (bitmap-bit (ldb (byte 1 lastbits) bitmap)))
      (let ((array-index (ctpop bitmap :end lastbits)))
        (if (zerop bitmap-bit)
            (progn (setf entries (insert entries array-index keyval))
                   (setf (ldb (byte 1 lastbits) bitmap) 1))
            (let ((entry (aref entries array-index)))
              (if (listp entry)
                  (if (funcall test-fun (key keyval) (key entry))
                      (setf (aref entries array-index) keyval)
                      (let ((new-node (make-bitmap-node)))
                        (bitmap-node-put new-node keyval :hash hash :shift (1+ shift))
                        (bitmap-node-put new-node (aref entries array-index) :shift (1+ shift))
                        (setf (aref entries array-index) new-node)))
                  (let ((new-bitmap-node (make-bitmap-node :bitmap (bitmap-node-bitmap entry)
                                                           :entries (copy-seq (bitmap-node-entries entry)))))
                    (setf (aref entries array-index) new-bitmap-node)
                    (bitmap-node-put new-bitmap-node keyval :hash hash :shift (1+ shift))))))))))

(defun array-node-put (node keyval &key (shift 0) hash (hash-fun #'sxhash) (test-fun #'equal))
  (declare (optimize (speed 3) (safety 0)))
  (declare (array-node node)
           (fixnum shift)
           (list keyval))
  (with-slots (entries) node
    (when (null hash)
      (setf hash (funcall hash-fun (key keyval))))
    (let* ((array-index (mask hash shift))
           (item (aref entries array-index)))
      (cond ((or (null item))
             (setf (aref entries array-index) keyval))
            ((listp item)
             (if (funcall test-fun (key item) (key keyval))
                 (setf (aref entries array-index) keyval)
                 (let ((new-node (make-bitmap-node)))
                   (bitmap-node-put new-node keyval :shift (1+ shift)
                                                    :hash hash)
                   (bitmap-node-put new-node (aref entries array-index)
                                    :shift (1+ shift))
                   (setf (aref entries array-index) new-node))))
            (t (let* ((entry (aref entries array-index))
                      (new-bitmap-node (make-bitmap-node :bitmap  (bitmap-node-bitmap entry)
                                                         :entries (copy-seq (bitmap-node-entries entry)))))
                 (setf (aref entries array-index) new-bitmap-node)
                 (bitmap-node-put new-bitmap-node keyval
                                  :shift (1+ shift)
                                  :hash hash)))))))

(defun put (hamt keyval)
  (with-slots (root hash-fun test-fun) hamt
    (let ((new-root (if (null root)
                    (make-array-node)
                    (make-array-node :entries (copy-seq (array-node-entries root))))))
      (array-node-put new-root keyval :hash-fun hash-fun :test-fun test-fun)
      (make-hamt :root new-root :hash-fun hash-fun :test-fun test-fun))))

(defun get (hamt key)
  (with-slots (root hash-fun test-fun) hamt
    (unless (null root)
      (array-node-find root key :hash-fun hash-fun
                                :test-fun test-fun))))

(format t "generating key-val pairs -----------~%")

(defun generate-random-str (&optional (length 10))
  (map 'string #'code-char (loop for i from 0 to length collect (+ 97 (random 26)))))

(defvar test-keyvals '())
(dotimes (i 10000)
  (setf test-keyvals (cons (make-keyval-pair (generate-random-str (random 20))
                                             (generate-random-str (random 20))) test-keyvals)))


(format t "adding to cl hash-table ---------~%")
(defvar test-hash-table (make-hash-table :test #'equal))
(time (dotimes (i 10000)
        (let ((keyval (nth i test-keyvals)))
          (setf (gethash (key keyval) test-hash-table) (val keyval)))))

(format t "adding to hamt -------------~%")
(defvar hamt (make-hamt))
(time (dotimes (i 10000)
        (setf hamt (put hamt (nth i test-keyvals)))))


#|

cl:hash-table --------------
Evaluation took:
  0.655 seconds of real time
  0.659900 seconds of total run time (0.659900 user, 0.000000 system)
  100.76% CPU
  1,743,567,776 processor cycles
  1,305,024 bytes consed
  
hamt ------------------------
Evaluation took:
  0.710 seconds of real time
  0.713892 seconds of total run time (0.713892 user, 0.000000 system)
  100.56% CPU
  1,890,525,031 processor cycles
  2,685,984 bytes consed

|#

#| how it works:
HAMT> (setf hamt (make-hamt))
#S(HAMT
   :ROOT #S(ARRAY-NODE
            :ENTRIES #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       NIL NIL NIL NIL))
   :HASH-FUN #<FUNCTION SXHASH>
   :TEST-FUN #<FUNCTION EQUAL>)
HAMT> (setf hamt1 (put hamt (cons "key1" "val1")))
#S(HAMT
   :ROOT #S(ARRAY-NODE
            :ENTRIES #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       ("key1" . "val1") NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))
   :HASH-FUN #<FUNCTION SXHASH>
   :TEST-FUN #<FUNCTION EQUAL>)
HAMT> (setf hamt2 (put hamt1 (cons "key2" "val2")))
#S(HAMT
   :ROOT #S(ARRAY-NODE
            :ENTRIES #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       ("key2" . "val2") ("key1" . "val1") NIL NIL NIL NIL NIL
                       NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       NIL))
   :HASH-FUN #<FUNCTION SXHASH>
   :TEST-FUN #<FUNCTION EQUAL>)
HAMT> hamt1
#S(HAMT
   :ROOT #S(ARRAY-NODE
            :ENTRIES #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       ("key1" . "val1") NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))
   :HASH-FUN #<FUNCTION SXHASH>
   :TEST-FUN #<FUNCTION EQUAL>)
HAMT> (setf hamt3 (put hamt2 (cons "key3" "val3")))
#S(HAMT
   :ROOT #S(ARRAY-NODE
            :ENTRIES #(NIL NIL NIL NIL NIL NIL NIL ("key3" . "val3") NIL NIL
                       NIL ("key2" . "val2") ("key1" . "val1") NIL NIL NIL NIL
                       NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       NIL))
   :HASH-FUN #<FUNCTION SXHASH>
   :TEST-FUN #<FUNCTION EQUAL>)
HAMT> (setf hamt4 (put hamt2 (cons "key4" "val4")))
#S(HAMT
   :ROOT #S(ARRAY-NODE
            :ENTRIES #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       ("key2" . "val2")
                       #S(BITMAP-NODE
                          :BITMAP 32770
                          :ENTRIES #(("key1" . "val1") ("key4" . "val4")))
                       NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
                       NIL NIL NIL NIL NIL))
   :HASH-FUN #<FUNCTION SXHASH>
   :TEST-FUN #<FUNCTION EQUAL>)
|#