Skip to content

Commit

Permalink
ハッシュ・比較関数カスタマイズ ＆ 関数inline展開用の枠組みが概ね完成
Browse files Browse the repository at this point in the history
  • Loading branch information
@sile
sile committed Sep 24, 2011
1 parent 7f8920f commit 3344087
Show file tree
Hide file tree
Showing 3 changed files with 138 additions and 62 deletions.
2 changes: 1 addition & 1 deletion package.lisp
View file
Expand Up @@ -19,7 +19,7 @@
(deftype buckets () '(simple-array bucket))

(eval-when (:compile-toplevel :load-toplevel)
(defparameter *fastest* '(optimize (speed 3) (safety 0) (debug 0)))
(defparameter *fastest* '(optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)))
(defparameter *interface* '(optimize (speed 3) (safety 2) (debug 1)))
(defparameter *normal* '(optimize (speed 1) (safety 3) (debug 2)))
(defparameter *muffle-note* #-SBCL '()
Expand Down
2 changes: 1 addition & 1 deletion sol-hash.asd
View file
Expand Up @@ -2,7 +2,7 @@

(defsystem sol-hash
:name "sol-hash"
:version "0.0.6"
:version "0.1.0"
:author "Takeru Ohta"
:description "A hash table implementation using Split-Ordered-Lists"

Expand Down
196 changes: 136 additions & 60 deletions sol-hash.lisp
View file
@@ -1,7 +1,7 @@
(in-package :sol-hash)

(declaim #.*fastest*
(inline make get (setf get) remove map count clear
(inline make count clear map get (setf get) remove

make-node node-next node-hash node-key node-value
make-map map-buckets map-bitlen map-count
Expand All @@ -10,8 +10,8 @@
next sentinel sentinel? ordinal?
bit-reverse lower-bits
hashcode-and-bucket-id set-pred-next
find-candidate find-node
set-impl))
find-candidate
))

;;;;;;;;;;
;;; struct
Expand All @@ -22,15 +22,24 @@
(key t :type t)
(value t :type t)))

(deftype set-fn () '(function (t t map) t))
(deftype get-fn () '(function (t map t) (values t boolean)))
(deftype rem-fn () '(function (t map) boolean))

(defstruct map
(custom nil :type t)
(buckets #() :type buckets)
(bucket-size 0 :type positive-fixnum)
(bitlen 0 :type hashcode-width)
(count 0 :type positive-fixnum)
(resize-border 0 :type positive-fixnum)
(resize-threshold 0 :type number)
(hash-fn t :type hash-fn)
(test-fn t :type test-fn))
(test-fn t :type test-fn)

(set-fn t :type set-fn)
(get-fn t :type get-fn)
(rem-fn t :type rem-fn))

(defmethod print-object ((o map) stream)
(declare #.*normal*)
Expand Down Expand Up @@ -72,12 +81,13 @@
(hashcode-width width))
(ldb (byte width 0) n))

(defun hashcode-and-bucket-id (key map)
(with-slots (hash-fn bitlen) (the map map)
(let* ((h1 (lower-bits +HASHCODE_BITLEN+ (funcall hash-fn key)))
(h2 (bit-reverse h1)))
(values h2 ; key's hashcode
(lower-bits bitlen h1))))) ; bucket-id
(defun hashcode-and-bucket-id (raw-hash bitlen)
(declare (positive-fixnum raw-hash)
(hashcode-width bitlen))
(let* ((h1 (lower-bits +HASHCODE_BITLEN+ raw-hash))
(h2 (bit-reverse h1)))
(values h2 ; key's hashcode
(lower-bits bitlen h1)))) ; bucket-id

(defun find-candidate (hash head)
(declare (hashcode hash))
Expand All @@ -95,21 +105,27 @@
(setf (aref buckets bucket-id) next)
(setf (node-next pred-node) next)))

(defun find-node (key map)
(with-slots (test-fn buckets) (the map map)
(multiple-value-bind (hash bucket-id)
(hashcode-and-bucket-id key map)
(declare (hashcode hash))
(multiple-value-bind (pred cur)
(find-candidate hash (aref buckets bucket-id))
(labels ((recur (pred cur)
(if (or (/= hash (node-hash cur))
(sentinel? cur))
(values nil cur pred bucket-id hash)
(if (funcall test-fn key (node-key cur))
(values t cur pred bucket-id hash)
(recur cur (next cur))))))
(recur pred cur))))))
(defmacro find-node (key map &key test hash )
(let ((hashcode (gensym))
(bucket-id (gensym))
(pred (gensym))
(cur (gensym))
(recur (gensym))
(test (or test `(lambda (x y) (funcall (map-test-fn ,map) x y))))
(hash (or hash `(lambda (x) (funcall (map-hash-fn ,map) x)))))
`(multiple-value-bind (,hashcode ,bucket-id)
(hashcode-and-bucket-id (,hash ,key) (map-bitlen ,map))
(declare (hashcode ,hashcode))
(multiple-value-bind (,pred ,cur)
(find-candidate ,hashcode (aref (map-buckets ,map) ,bucket-id))
(labels ((,recur (,pred ,cur)
(if (or (/= ,hashcode (node-hash ,cur))
(sentinel? ,cur))
(values nil ,cur ,pred ,bucket-id ,hashcode)
(if (,test ,key (node-key ,cur))
(values t ,cur ,pred ,bucket-id ,hashcode)
(,recur ,cur (next ,cur))))))
(,recur ,pred ,cur))))))

(defmacro each-bucket ((head-node bucket-id map &key start end return) &body body)
(let ((buckets (gensym))
Expand Down Expand Up @@ -160,12 +176,31 @@

;;;;;;;;;;;;;;;;;;;;;
;;; external function
(defun make (&key (size 4) (hash #'sxhash) (test #'eql) (rehash-threshold 0.75))
(defstruct cus
(set-fn t :type set-fn)
(get-fn t :type get-fn)
(rem-fn t :type rem-fn))

(defparameter *customs* '())
(defmacro defcustom (name hash test)
`(push (cons ,name
(make-cus :set-fn (gen-set-fn ,hash ,test)
:get-fn (gen-get-fn ,hash ,test)
:rem-fn (gen-rem-fn ,hash ,test)))
*customs*))

(defun get-custom (name)
(declare (symbol name))
(cdr (assoc name *customs*)))

(defun make (&key (size 4) (hash #'sxhash) (test #'eql) (rehash-threshold 0.75)
custom)
(declare #.*interface*
(hash-fn hash)
(test-fn test)
(positive-fixnum size)
(number rehash-threshold))
(number rehash-threshold)
(symbol custom))
(locally
(declare #.*fastest*)
(let* ((bitlen (ceiling (log (max 2 size) 2)))
Expand All @@ -178,48 +213,92 @@
:resize-border (calc-border bucket-size rehash-threshold)
:resize-threshold rehash-threshold
:buckets buckets
:bucket-size bucket-size))))
:bucket-size bucket-size
:custom (when custom
(get-custom custom))

:set-fn (if (get-custom custom)
(cus-set-fn (get-custom custom))
(gen-set-fn))

:get-fn (if (get-custom custom)
(cus-get-fn (get-custom custom))
(gen-get-fn))

:rem-fn (if (get-custom custom)
(cus-rem-fn (get-custom custom))
(gen-rem-fn))
))))

(defmacro gen-get-fn (&optional hash test)
(let ((exists? (gensym))
(node (gensym))
(key (gensym))
(map (gensym))
(default (gensym)))
`(lambda (,key ,map ,default)
(declare #.*fastest*)
(multiple-value-bind (,exists? ,node) (find-node ,key ,map :test ,test :hash ,hash)
(if ,exists?
(values (node-value ,node) t)
(values ,default nil))))))

(defmacro gen-set-fn (&optional hash test)
(let ((exists? (gensym))
(node (gensym))
(pred (gensym))
(bucket-id (gensym))
(hashcode (gensym))
(new-value (gensym))
(key (gensym))
(map (gensym)))
`(lambda (,new-value ,key ,map)
(declare #.*fastest*)
(multiple-value-bind (,exists? ,node ,pred ,bucket-id ,hashcode)
(find-node ,key ,map :test ,test :hash ,hash)

(if ,exists?
(setf (node-value ,node) ,new-value)
(progn
(set-pred-next ,pred (map-buckets ,map) ,bucket-id
:next (make-node :key ,key :value ,new-value
:next ,node :hash ,hashcode))
(incf (map-count ,map))
(when (> (map-count ,map) (map-resize-border ,map))
(resize ,map))
,new-value))))))

(defmacro gen-rem-fn (&optional hash test)
(let ((exists? (gensym))
(node (gensym))
(pred (gensym))
(bucket-id (gensym))
(key (gensym))
(map (gensym)))
`(lambda (,key ,map)
(declare #.*fastest*)
(multiple-value-bind (,exists? ,node ,pred ,bucket-id)
(find-node ,key ,map :test ,test :hash ,hash)
(when ,exists?
(set-pred-next ,pred (map-buckets ,map) ,bucket-id :next (next ,node))
(decf (map-count ,map))
t)))))

(defun get (key map &optional default)
(declare #.*interface*)
(multiple-value-bind (exists? node) (find-node key map)
(declare #.*fastest*)
(if exists?
(values (node-value node) t)
(values default nil))))

(defun set-impl (new-value key map)
(multiple-value-bind (exists? node pred bucket-id hash) (find-node key map)
(if exists?
(setf (node-value node) new-value)
(with-slots (buckets count resize-border) (the map map)
(set-pred-next pred buckets bucket-id
:next (make-node :key key :value new-value
:hash hash :next node))
(incf count)
(when (> count resize-border)
(resize map))
new-value))))

(funcall (map-get-fn map) key map default))

(defun (setf get) (new-value key map)
(declare #.*interface*)
(locally
(declare #.*fastest*)
(set-impl new-value key map)))
(funcall (map-set-fn map) new-value key map))

(defun count (map)
(declare #.*interface*)
(map-count map))

(defun remove (key map)
(declare #.*interface*)
(multiple-value-bind (exists? node pred bucket-id) (find-node key map)
(declare #.*fastest*)
(when exists?
(with-slots (buckets count) (the map map)
(set-pred-next pred buckets bucket-id :next (next node))
(decf count))
t)))
(funcall (map-rem-fn map) key map))

(defmacro each ((key value map &optional return-form) &body body)
(let ((id (gensym))
Expand Down Expand Up @@ -251,6 +330,3 @@
resize-border (calc-border 4 resize-threshold))
(fill buckets (sentinel)))
t))



0 comments on commit 3344087

Please sign in to comment.