From 96b11a7f65241b238154578005d50393c0d1e5a4 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Wed, 6 Aug 2025 15:14:21 -0700 Subject: [PATCH 01/16] Extend a62badd to map & bag intersection. --- Code/wb-trees.lisp | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index 7650d22..e27beed 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -2947,6 +2947,14 @@ (defstruct (WB-Bag-Tree-Node lo cmp-fn)) (or (eq hi Hedge-Positive-Infinity) (less-than?-cmp (svref (car tree) 0) hi cmp-fn)) + ;; If it contains no elements within the range, also drop it. + (let ((split-point-lo (if (eq lo Hedge-Negative-Infinity) + 0 + (Vector-Set-Binary-Search-Lo (car tree) lo cmp-fn))) + (split-point-hi (if (eq hi Hedge-Positive-Infinity) + (length (the simple-vector (car tree))) + (Vector-Set-Binary-Search-Hi (car tree) hi cmp-fn)))) + (> split-point-hi split-point-lo)) tree)) (t (let ((val (WB-Bag-Tree-Node-Value tree))) @@ -5114,6 +5122,14 @@ (defstruct (WB-Map-Tree-Node lo key-cmp-fn)) (or (eq hi Hedge-Positive-Infinity) (less-than?-cmp (svref (car tree) 0) hi key-cmp-fn)) + ;; If it contains no elements within the range, also drop it. + (let ((split-point-lo (if (eq lo Hedge-Negative-Infinity) + 0 + (Vector-Set-Binary-Search-Lo (car tree) lo key-cmp-fn))) + (split-point-hi (if (eq hi Hedge-Positive-Infinity) + (length (the simple-vector (car tree))) + (Vector-Set-Binary-Search-Hi (car tree) hi key-cmp-fn)))) + (> split-point-hi split-point-lo)) tree)) (t (let ((key (WB-Map-Tree-Node-Key tree))) -- GitLab From 525de334ceeb54362673b4ca159aecb1e34ee02d Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Fri, 8 Aug 2025 14:56:22 -0700 Subject: [PATCH 02/16] WIP, checkpoint. This has hash-wise iteration working, I think, but I'm probably going to change (back) to entries-then-subnodes. --- Code/champ.lisp | 377 ++++++++++++++++++++++++++++++++++++---------- Code/fset.lisp | 90 ++++++++--- Code/hash.lisp | 10 +- Code/macros.lisp | 80 ++++++---- Code/testing.lisp | 166 ++++++++++---------- 5 files changed, 510 insertions(+), 213 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index 7c5bb26..d565b85 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -33,16 +33,27 @@ (defconstant champ-node-radix (ash 1 champ-hash-bits-per-level)) (defconstant champ-hash-level-mask (1- champ-node-radix)) +(declaim (inline 1-bits-below)) +(defun 1-bits-below (idx mask) + "The number of 1 bits in `mask' at bit positions (strictly) less than `idx'." + (declare (optimize (speed 3)) + (type (integer 0 #.(integer-length most-positive-fixnum)) idx) + (fixnum mask)) + (logcount (logand (1- (the fixnum (ash 1 idx))) mask))) + +(declaim (inline least-1-bit)) +(defun least-1-bit (n) + (declare (fixnum n)) + (1- (logcount (logxor n (1- n))))) + (defmacro do-bit-indices ((idx-var val &optional result) &body body) (let ((val-var (gensymx #:val-))) - `(flet ((least-1-bit (n) - (1- (logcount (logxor n (1- n)))))) - (declare (inline least-1-bit)) - (let ((,val-var ,val)) - (do ((,idx-var (least-1-bit ,val-var) (least-1-bit ,val-var))) - ((= 0 ,val-var) ,result) - (logandc2f ,val-var (ash 1 ,idx-var)) - . ,body))))) + `(let ((,val-var ,val)) + (declare (fixnum ,val-var)) + (do ((,idx-var (least-1-bit ,val-var) (least-1-bit ,val-var))) + ((= 0 ,val-var) ,result) + (logandc2f ,val-var (ash 1 ,idx-var)) + . ,body)))) ;;; Verification utility, used to recover hash bits from masks. (defun bit-indices (mask) @@ -92,12 +103,14 @@ (defstruct (ch-set-node ;; can't completely prevent a client from stupidly bashing them. (entry-mask 0 :type fixnum) (subnode-mask 0 :type fixnum) - (size 0 :type integer) ; total number of elements at or below this node + (size 0 :type fixnum) ; total number of elements at or below this node (hash-value 0 :type fixnum)) (defconstant ch-set-node-header-size 4) (defun ch-set-tree-with (tree value hash-fn compare-fn &optional (depth 0)) - ;(declare (optimize (speed 3) (safety 0))) + (declare (optimize (speed 3) (safety 0)) + (type function hash-fn compare-fn) + (type (integer 0 64) depth)) (let ((value-hash (hash-to-fixnum value hash-fn))) (declare (fixnum value-hash)) (rlabels (rec tree (ash value-hash (- (* champ-hash-bits-per-level depth))) depth) @@ -137,10 +150,10 @@ (defstruct (ch-set-node value node))))))) ;; Normal case (let ((entry-mask (ch-set-node-entry-mask node)) - ((entry-raw-idx (logcount (logand (1- (ash 1 hash-bits)) entry-mask))) + ((entry-raw-idx (1-bits-below hash-bits entry-mask)) ((entry-idx (+ ch-set-node-header-size entry-raw-idx)))) (subnode-mask (ch-set-node-subnode-mask node)) - ((subnode-raw-idx (logcount (logand (1- (ash 1 hash-bits)) subnode-mask))) + ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) ((subnode-idx (- (the fixnum (length node)) 1 subnode-raw-idx))))) (declare (fixnum entry-mask entry-raw-idx entry-idx subnode-mask subnode-raw-idx subnode-idx)) (if (logbitp hash-bits entry-mask) @@ -231,7 +244,7 @@ (defstruct (ch-set-node (and node (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (entry-mask (ch-set-node-entry-mask node)) - ((entry-raw-idx (logcount (logand (1- (ash 1 hash-bits)) entry-mask))) + ((entry-raw-idx (1-bits-below hash-bits entry-mask)) ((entry-idx (+ ch-set-node-header-size entry-raw-idx)))) (subnode-mask (ch-set-node-subnode-mask node))) (if (logbitp hash-bits entry-mask) @@ -246,7 +259,7 @@ (defstruct (ch-set-node (decf (ch-set-node-size n)) (logxorf (ch-set-node-hash-value n) value-hash) (values n value-hash))))) - (let ((subnode-raw-idx (logcount (logand (1- (ash 1 hash-bits)) subnode-mask))) + (let ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) ((subnode-idx (- (length node) 1 subnode-raw-idx)))) (if (not (logbitp hash-bits subnode-mask)) (values node 0) @@ -284,8 +297,7 @@ (defstruct (ch-set-node (= 0 (ch-set-node-subnode-mask new-subnode))) ;; New subnode contains only a single entry: pull it up into this node (let ((new-entry-idx - (+ ch-set-node-header-size - (logcount (logand (1- (ash 1 hash-bits)) entry-mask)))) + (+ ch-set-node-header-size (1-bits-below hash-bits entry-mask))) ((n (vector-ins-1-rem-1 node new-entry-idx (svref new-subnode ch-set-node-header-size) subnode-idx)))) @@ -343,14 +355,12 @@ (defstruct (ch-set-node (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (entry-mask (ch-set-node-entry-mask node))) (if (logbitp hash-bits entry-mask) - (let ((entry-idx (+ ch-set-node-header-size - (logcount (logand (1- (ash 1 hash-bits)) entry-mask)))) + (let ((entry-idx (+ ch-set-node-header-size (1-bits-below hash-bits entry-mask))) ((ex-value (svref node entry-idx)))) (equal?-cmp ex-value value compare-fn)) (let ((subnode-mask (ch-set-node-subnode-mask node))) (and (logbitp hash-bits subnode-mask) - (let ((subnode-idx (- (length node) 1 - (logcount (logand (1- (ash 1 hash-bits)) subnode-mask)))) + (let ((subnode-idx (- (length node) 1 (1-bits-below hash-bits subnode-mask))) ((subnode (svref node subnode-idx)))) (rec subnode value (ash hash-shifted (- champ-hash-bits-per-level)))))))))))))) @@ -417,7 +427,7 @@ (defstruct (ch-set-node ((merged-mask (logior entry-mask subnode-mask))) (entry-idx 0) (subnode-idx 0)) - (do-bit-indices (idx merged-mask (error "'Bug in ch-set-tree-index-element'")) + (do-bit-indices (idx merged-mask (error "Bug in 'ch-set-tree-index-element'")) (cond ((logbitp idx entry-mask) (when (= index 0) (return (svref tree (+ ch-set-node-header-size entry-idx)))) @@ -429,17 +439,21 @@ (defstruct (ch-set-node (when (< index subnode-size) (return (rec subnode index))) (decf index subnode-size) - (incf subnode-idx)))))))))) + (incf subnode-idx))) + (t (error "Bug in 'do-bit-indices'"))))))))) (defun ch-set-tree-union (tree1 tree2 hash-fn compare-fn) - (declare (optimize (debug 3))) + (declare (optimize (speed 3) (safety 0)) + (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) + (declare (type (integer 0 64) depth)) (cond ((null tree1) tree2) ((null tree2) tree1) ((and (consp tree1) (consp tree2)) (let ((tree-result (wb-set-tree-union (cdr tree1) (cdr tree2) compare-fn)) (chash 0)) + (declare (fixnum chash)) (do-wb-set-tree-members (v tree-result) (logxorf chash (hash-to-fixnum v hash-fn))) (cons chash tree-result))) @@ -473,12 +487,16 @@ (defstruct (ch-set-node (isubnode 0) (size 0) (content-hash 0)) + (declare (fixnum entries subnodes size content-hash) + (type (integer 0 64) ientry1 isubnode1 ientry2 isubnode2 ientry isubnode)) (flet ((add-entry (idx val) + (declare (type (integer 0 32) idx)) (setf (svref n (+ ch-set-node-header-size (postincf ientry))) val) (logiorf entries (ash 1 idx)) (incf size) (logxorf content-hash (hash-to-fixnum val hash-fn))) (add-subnode (idx subnode) + (declare (type (integer 0 32) idx)) ;; It's possible for `subnode' to contain only a collision subnode -- we must pull it up. (when (and (not (consp subnode)) (= 0 (ch-set-node-entry-mask subnode)) @@ -487,8 +505,8 @@ (defstruct (ch-set-node (setq subnode (svref subnode (1- (length subnode))))) (setf (svref n (- new-len (postincf isubnode) 1)) subnode) (logiorf subnodes (ash 1 idx)) - (incf size (ch-set-tree-size subnode)) - (logxorf content-hash (ch-set-tree-hash-value subnode))) + (incf size (the fixnum (ch-set-tree-size subnode))) + (logxorf content-hash (the fixnum (ch-set-tree-hash-value subnode)))) (set-tree-with (tree value depth) (ch-set-tree-with tree value hash-fn compare-fn depth))) (do-bit-indices (idx everything) @@ -584,30 +602,27 @@ (defstruct (ch-set-node (setf (svref n (- new-len (postincf isubnode) 1)) subnode) (logiorf subnodes (ash 1 idx)) (incf size (ch-set-tree-size subnode)) - (logxorf content-hash (ch-set-tree-hash-value subnode)))))) - ;; The trick we used in `union' of just incrementing indices doesn't work here. - (bits-below (idx mask) - (logcount (logand (1- (ash 1 idx)) mask)))) + (logxorf content-hash (ch-set-tree-hash-value subnode))))))) (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) (logand entries1 subnodes2) (logand subnodes1 entries2))) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) - (let ((val1 (svref tree1 (+ ch-set-node-header-size (bits-below idx entries1)))) - (val2 (svref tree2 (+ ch-set-node-header-size (bits-below idx entries2))))) + (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1)))) + (val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) (when (equal?-cmp val1 val2 compare-fn) (add-entry idx val1)))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) - (let ((val (svref tree1 (+ ch-set-node-header-size (bits-below idx entries1))))) - (when (ch-set-tree-contains? (svref tree2 (- (length tree2) (bits-below idx subnodes2) 1)) + (let ((val (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) + (when (ch-set-tree-contains? (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) val hash-fn compare-fn (1+ depth)) (add-entry idx val)))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) - (let ((val (svref tree2 (+ ch-set-node-header-size (bits-below idx entries2))))) - (when (ch-set-tree-contains? (svref tree1 (- (length tree1) (bits-below idx subnodes1) 1)) + (let ((val (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (when (ch-set-tree-contains? (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) val hash-fn compare-fn (1+ depth)) (add-entry idx val)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) - (add-subnode idx (rec (svref tree1 (- (length tree1) (bits-below idx subnodes1) 1)) - (svref tree2 (- (length tree2) (bits-below idx subnodes2) 1)) + (add-subnode idx (rec (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) + (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) (1+ depth))))))) ;; Returns `nil' if empty. (and (or (/= 0 ientry) (/= 0 isubnode)) @@ -638,30 +653,28 @@ (defstruct (ch-set-node (entries2 (ch-set-node-entry-mask tree2)) (subnodes1 (ch-set-node-subnode-mask tree1)) (subnodes2 (ch-set-node-subnode-mask tree2))) - (labels ((bits-below (idx mask) - (logcount (logand (1- (ash 1 idx)) mask)))) - (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) - (logand entries1 subnodes2) (logand subnodes1 entries2)) - t) - (cond ((and (logbitp idx entries1) (logbitp idx entries2)) - (let ((val1 (svref tree1 (+ ch-set-node-header-size (bits-below idx entries1)))) - (val2 (svref tree2 (+ ch-set-node-header-size (bits-below idx entries2))))) - (when (equal?-cmp val1 val2 compare-fn) - (return nil)))) - ((and (logbitp idx entries1) (logbitp idx subnodes2)) - (let ((val (svref tree1 (+ ch-set-node-header-size (bits-below idx entries1))))) - (when (ch-set-tree-contains? (svref tree2 (- (length tree2) (bits-below idx subnodes2) 1)) - val hash-fn compare-fn (1+ depth)) - (return nil)))) - ((and (logbitp idx subnodes1) (logbitp idx entries2)) - (let ((val (svref tree2 (+ ch-set-node-header-size (bits-below idx entries2))))) - (when (ch-set-tree-contains? (svref tree1 (- (length tree1) (bits-below idx subnodes1) 1)) - val hash-fn compare-fn (1+ depth)) - (return nil)))) - ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) - (rec (svref tree1 (- (length tree1) (bits-below idx subnodes1) 1)) - (svref tree2 (- (length tree2) (bits-below idx subnodes2) 1)) - (1+ depth)))))))))))) + (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) + (logand entries1 subnodes2) (logand subnodes1 entries2)) + t) + (cond ((and (logbitp idx entries1) (logbitp idx entries2)) + (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1)))) + (val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (when (equal?-cmp val1 val2 compare-fn) + (return nil)))) + ((and (logbitp idx entries1) (logbitp idx subnodes2)) + (let ((val (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) + (when (ch-set-tree-contains? (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) + val hash-fn compare-fn (1+ depth)) + (return nil)))) + ((and (logbitp idx subnodes1) (logbitp idx entries2)) + (let ((val (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (when (ch-set-tree-contains? (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) + val hash-fn compare-fn (1+ depth)) + (return nil)))) + ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) + (rec (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) + (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) + (1+ depth))))))))))) (defun vector-remove-n-at (vec idx n) (declare (optimize (speed 3) (safety 0)) @@ -676,6 +689,10 @@ (defstruct (ch-set-node (setf (svref new-vec (+ idx i)) (svref vec (+ idx i n)))) new-vec))) + +;;; -------------------------------- +;;; Iteration primitives + (defmacro do-ch-set-tree-members ((value-var tree-form &optional value-form) &body body) (let ((body-fn (gensymx #:body-)) @@ -688,14 +705,89 @@ (defstruct (ch-set-node (if (consp tree) (do-wb-set-tree-members (,value-var (cdr tree)) (,body-fn ,value-var)) - (progn - (dotimes (i (logcount (ch-set-node-entry-mask tree))) - (,body-fn (svref tree (+ i ch-set-node-header-size)))) - (dotimes (i (logcount (ch-set-node-subnode-mask tree))) - (,recur-fn (svref tree (- (length tree) 1 i))))))))) + (let ((entries (ch-set-node-entry-mask tree)) + (subnodes (ch-set-node-subnode-mask tree))) + (do-bit-indices (idx (logior entries subnodes)) + (if (logbitp idx (ch-set-node-entry-mask tree)) + (,body-fn (svref tree (+ ch-set-node-header-size (1-bits-below idx entries)))) + (,recur-fn (svref tree (- (length (the simple-vector tree)) 1 + (1-bits-below idx subnodes))))))))))) (,recur-fn ,tree-form)) ,value-form))) +;;; ---------------- +;;; Stateful iterator + +(defun make-ch-set-tree-iterator (tree) + (let ((iter (make-ch-set-tree-iterator-internal tree))) + (lambda (op) + (ecase opm + (:get (ch-set-tree-iterator-get iter)) + (:done? (ch-set-tree-iterator-done? iter)) + (:more? (not (ch-set-tree-iterator-done? iter))))))) + +(defun make-ch-set-tree-iterator-internal (tree) + ;; Unlike with the WB-trees, the maximum depth here is not a function of the set size. + (let ((iter (make-array (+ 1 (* 2 (ceiling (integer-length most-positive-fixnum) champ-hash-bits-per-level)))))) + (if (null tree) + (setf (svref iter 0) -1) + (progn + (setf (svref iter 0) 1) ; the stack pointer + (setf (svref iter 1) tree) + (setf (svref iter 2) (logior (ch-set-node-entry-mask tree) (ch-set-node-subnode-mask tree))) + (ch-set-tree-iterator-canonicalize iter))) + iter)) + +(defun ch-set-tree-iterator-canonicalize (iter) + (declare (optimize (debug 3))) + (let ((sp (svref iter 0)) + ((mask (svref iter (1+ sp))))) + (when (if (null mask) + (wb-set-tree-iterator-done? (svref iter sp)) + (zerop mask)) + (decf sp 2) + (setq mask (svref iter (1+ sp)))) + (unless (< sp 0) + (let ((node (svref iter sp))) + (loop + (when (null mask) + (return)) + (let ((idx (least-1-bit mask))) + (if (logbitp idx (ch-set-node-entry-mask node)) + (return) + (progn + (logandc2f mask (ash 1 idx)) + (unless (zerop mask) ; TCO + (setf (svref iter (1+ sp)) mask) + (incf sp 2)) + (setq node (svref node (- (length (the simple-vector node)) 1 + (1-bits-below idx (ch-set-node-subnode-mask node))))) + (if (consp node) + (setq node (make-wb-set-tree-iterator-internal (cdr node)) + mask nil) + (setq mask (logior (ch-set-node-entry-mask node) (ch-set-node-subnode-mask node)))) + (setf (svref iter sp) node) + (setf (svref iter (1+ sp)) mask)))))) + (setf (svref iter 0) sp)))) + +(defun ch-set-tree-iterator-done? (iter) + (< (svref iter 0) 0)) + +(defun ch-set-tree-iterator-get (iter) + (let ((sp (svref iter 0))) + (and (> sp 0) + (let ((node (svref iter sp)) + (mask (svref iter (1+ sp)))) + (if (null mask) + (let ((val (wb-set-tree-iterator-get node))) + (ch-set-tree-iterator-canonicalize iter) + (values val t)) + (let ((idx (least-1-bit mask))) + (logandc2f (svref iter (1+ sp)) (ash 1 idx)) + (ch-set-tree-iterator-canonicalize iter) + (values (svref node (+ ch-set-node-header-size (1-bits-below idx (ch-set-node-entry-mask node)))) + t))))))) + (defun ch-set-tree-verify (tree hash-fn) (declare (optimize (debug 3))) (or (null tree) @@ -787,12 +879,13 @@ (defstruct (ch-map-node (hash-value 0 :type fixnum)) (defconstant ch-map-node-header-size 4) -(defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) +(defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0)) (declare (optimize (speed 3) (safety 0)) - (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) + (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) + (type (integer 0 1000) depth)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) (declare (fixnum key-hash)) - (rlabels (rec tree key-hash 0) + (rlabels (rec tree (ash key-hash (- (* champ-hash-bits-per-level depth))) depth) (rec (node hash-shifted depth) (declare (fixnum hash-shifted) (type (integer 0 64) depth)) @@ -801,10 +894,10 @@ (defstruct (ch-map-node (vector (ash 1 hash-bits) 0 1 (logxor key-hash (hash-to-fixnum value val-hash-fn)) key value) (let ((entry-mask (ch-map-node-entry-mask node)) - ((entry-raw-idx (logcount (logand (1- (ash 1 hash-bits)) entry-mask))) + ((entry-raw-idx (1-bits-below hash-bits entry-mask)) ((entry-idx (+ ch-map-node-header-size (* 2 entry-raw-idx))))) (subnode-mask (ch-map-node-subnode-mask node)) - ((subnode-raw-idx (logcount (logand (1- (ash 1 hash-bits)) subnode-mask))) + ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) ((subnode-idx (- (length node) 1 subnode-raw-idx))))) (if (logbitp hash-bits entry-mask) ;; Entry found @@ -960,7 +1053,7 @@ (defstruct (ch-map-node (and node (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (entry-mask (ch-map-node-entry-mask node)) - ((entry-raw-idx (logcount (logand (1- (ash 1 hash-bits)) entry-mask))) + ((entry-raw-idx (1-bits-below hash-bits entry-mask)) ((entry-idx (+ ch-map-node-header-size (* 2 entry-raw-idx))))) (subnode-mask (ch-map-node-subnode-mask node))) (if (logbitp hash-bits entry-mask) @@ -977,7 +1070,7 @@ (defstruct (ch-map-node (let ((kv-hash (logxor key-hash ex-value-hash))) (logxorf (ch-map-node-hash-value n) kv-hash) (values n kv-hash)))))) - (let ((subnode-raw-idx (logcount (logand (1- (ash 1 hash-bits)) subnode-mask))) + (let ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) ((subnode-idx (- (the fixnum (length node)) 1 subnode-raw-idx)))) (declare (fixnum subnode-raw-idx subnode-idx)) (if (not (logbitp hash-bits subnode-mask)) @@ -1022,7 +1115,7 @@ (defstruct (ch-map-node ;; New subnode contains only a single entry: pull it up into this node (let ((new-entry-idx (+ ch-map-node-header-size - (* 2 (logcount (logand (1- (ash 1 hash-bits)) entry-mask))))) + (* 2 (1-bits-below hash-bits entry-mask)))) ((n (vector-ins-2-rem-1 node new-entry-idx (svref new-subnode ch-map-node-header-size) (svref new-subnode (1+ ch-map-node-header-size)) @@ -1087,19 +1180,145 @@ (defstruct (ch-map-node (entry-mask (ch-map-node-entry-mask node))) (if (logbitp hash-bits entry-mask) (let ((entry-idx (+ ch-map-node-header-size - (* 2 (logcount (logand (1- (ash 1 hash-bits)) entry-mask))))) + (* 2 (1-bits-below hash-bits entry-mask)))) ((ex-key (svref node entry-idx)))) (and (equal?-cmp ex-key key key-cmp-fn) (values t (svref node (1+ entry-idx))))) (let ((subnode-mask (ch-map-node-subnode-mask node))) (and (logbitp hash-bits subnode-mask) (let ((subnode-idx (- (the fixnum (length node)) - 1 (logcount (logand (1- (ash 1 hash-bits)) subnode-mask)))) + 1 (1-bits-below hash-bits subnode-mask))) ((subnode (svref node subnode-idx)))) (if (consp subnode) (wb-map-tree-lookup (cdr subnode) key key-cmp-fn) (rec subnode key (ash hash-shifted (- champ-hash-bits-per-level)))))))))))))) +(defun ch-map-tree-index-pair (tree index) + (rlabels (rec tree index) + (rec (tree index) + (if (consp tree) + (wb-map-tree-rank-pair tree index) + (let ((len (length tree)) + (entry-mask (ch-map-node-entry-mask tree)) + (subnode-mask (ch-map-node-subnode-mask tree)) + ((merged-mask (logior entry-mask subnode-mask))) + (entry-idx 0) + (subnode-idx 0)) + (do-bit-indices (idx merged-mask (error "Bug in 'ch-map-tree-index-pair")) + (cond ((logbitp idx entry-mask) + (when (= index 0) + (return (values (svref tree (+ ch-map-node-header-size (* 2 entry-idx))) + (svref tree (+ ch-map-node-header-size (* 2 entry-idx) 1))))) + (decf index) + (incf entry-idx)) + ((logbitp idx subnode-mask) + (let ((subnode (svref tree (- len subnode-idx 1))) + ((subnode-size (ch-map-tree-size subnode)))) + (when (< index subnode-size) + (return (rec subnode idx))) + (decf index subnode-size) + (incf subnode-idx))) + (t (error "Bug in 'do-bit-indices'"))))))))) + +(defun ch-map-tree-union (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) + (declare (optimize (debug 3)) + (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) + (rlabels (rec tree1 tree2 0) + (rec (tree1 tree2 depth) + (declare (type (integer 0 64) depth)) + (cond ((null tree1) tree2) + ((null tree2) tree1) + ((and (consp tree1) (consp tree2)) + (let ((tree-result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn)) + (chash 0)) + (do-wb-map-tree-pairs (k v tree-result) + (logxorf chash (hash-to-fixnum k key-hash-fn) (hash-to-fixnum v val-hash-fn))) + (cons chash tree-result))) + ((or (consp tree1) (consp tree2)) + (let ((collision-node normal-node (if (consp tree1) (values tree1 tree2) (values tree2 tree1)))) + (do-wb-map-tree-pairs (k v (cdr collision-node)) + (setq normal-node (ch-map-tree-with normal-node k v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn + depth))) + normal-node)) + (t + (let ((entries1 (ch-map-node-entry-mask tree1)) + (entries2 (ch-map-node-entry-mask tree2)) + (subnodes1 (ch-map-node-subnode-mask tree1)) + (subnodes2 (ch-map-node-subnode-mask tree2)) + ((all-entries (logior entries1 entries2)) + (all-subnodes (logior subnodes1 subnodes2)) + ((everything (logior all-entries all-subnodes)) + ((new-len (+ ch-map-node-header-size + (* 2 (- (logcount all-entries) + (logcount (logand entries1 subnodes2)) + (logcount (logand entries2 subnodes1)))) + (logcount all-subnodes))) + ((res-n (make-array new-len)))))) + (ientry1 0) + (isubnode1 0) + (ientry2 0) + (isubnode2 0) + (res-entries 0) + (res-subnodes 0) + (res-ientry 0) + (res-isubnode 0) + (res-size 0) + (res-content-hash 0)) + (flet ((add-entry (idx key val) + (setf (svref res-n (+ ch-map-node-header-size (* 2 res-ientry))) key) + (setf (svref res-n (+ ch-map-node-header-size (1+ (* 2 res-ientry)))) val) + (incf res-ientry) + (logiorf res-entries (ash 1 idx)) + (incf res-size) + (logxorf res-content-hash (hash-to-fixnum key key-hash-fn) (hash-to-fixnum val val-hash-fn))) + (add-subnode (idx subnode) + (when (and (not (consp subnode)) + (= 0 (ch-set-node-entry-mask subnode)) + (= 1 (logcount (ch-set-node-subnode-mask subnode))) + (consp (svref subnode (1- (length subnode))))) + (setq subnode (svref subnode (1- (length subnode))))) + (setf (svref res-n (- new-len (postincf res-isubnode) 1)) subnode) + (logiorf res-subnodes (ash 1 idx)) + (incf res-size (ch-map-tree-size subnode)) + (logxorf res-content-hash (ch-set-tree-hash-value subnode))) + (map-tree-with (tree key value depth) + (ch-map-tree-with tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) + (do-bit-indices (idx everything) + (cond ((and (logbitp idx entries1) (logbitp idx entries2)) + (let ((key1 (svref tree1 (+ ch-map-node-header-size (* 2 ientry1)))) + (key2 (svref tree2 (+ ch-map-node-header-size (* 2 ientry2)))) + ((val1 (svref tree1 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry1)))))) + (val2 (svref tree2 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry2)))))))) + (if (equal?-cmp key1 key2 key-cmp-fn) + (add-entry idx key1 (funcall val-fn val1 val2)) + (add-subnode idx (map-tree-with (map-tree-with nil key1 val1 (1+ depth)) + key2 val2 (1+ depth)))))) + ((logbitp idx entries1) + (let ((key (svref tree1 (+ ch-map-node-header-size (* 2 ientry1)))) + ((val (svref tree1 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry1)))))))) + (if (logbitp idx subnodes2) + (let ((subnode (svref tree2 (- (length tree2) (postincf isubnode2) 1)))) + (add-subnode idx (map-tree-with subnode key val (1+ depth)))) + (add-entry idx key val)))) + ((logbitp idx entries2) + (let ((key (svref tree2 (+ ch-map-node-header-size (* 2 ientry2)))) + ((val (svref tree2 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry2)))))))) + (if (logbitp idx subnodes1) + (let ((subnode (svref tree1 (- (length tree1) (postincf isubnode1) 1)))) + (add-subnode idx (map-tree-with subnode key val (1+ depth)))) + (add-entry idx key val)))) + ((logbitp idx subnodes1) + (add-subnode idx (svref tree1 (- (length tree1) (postincf isubnode1) 1)))) + ((logbitp idx subnodes2) + (add-subnode idx (svref tree2 (- (length tree2) (postincf isubnode2) 1)))) + (t (error "Bug in 'ch-map-tree-union'"))))) + (assert (= new-len (+ ch-map-node-header-size (* 2 res-ientry) res-isubnode))) + (setf (ch-map-node-entry-mask res-n) res-entries) + (setf (ch-map-node-subnode-mask res-n) res-subnodes) + (setf (ch-map-node-size res-n) res-size) + (setf (ch-map-node-hash-value res-n) res-content-hash) + res-n)))))) + (defmacro do-ch-map-tree-pairs ((key-var value-var tree-form &optional value-form) &body body) (let ((body-fn (gensymx #:body-)) @@ -1112,11 +1331,13 @@ (defstruct (ch-map-node (if (consp tree) (do-wb-map-tree-pairs (,key-var ,value-var (cdr tree)) (,body-fn ,key-var ,value-var)) + (let ((entries (ch-map-node-entry-mask tree)) + (subnodes (ch-map-node-subnode-mask tree)))) (progn - (dotimes (i (logcount (ch-map-node-entry-mask tree))) + (dotimes (i (logcount )) (let ((idx (+ (* 2 i) ch-map-node-header-size))) (,body-fn (svref tree idx) (svref tree (1+ idx))))) - (dotimes (i (logcount (ch-map-node-subnode-mask tree))) + (dotimes (i (logcount )) (,recur-fn (svref tree (- (the fixnum (length tree)) 1 i))))))))) (,recur-fn ,tree-form)) ,value-form))) diff --git a/Code/fset.lisp b/Code/fset.lisp index 3134684..ab63f4b 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -146,7 +146,11 @@ the pair with that rank as two values. Note that if there are values/keys that are unequal but equivalent in the collection, an arbitrary order will be imposed on them for this purpose; but another collection that is `equal?' -but not `eq' to this one will in general order them differently.")) +but not `eq' to this one will in general order them differently. + +Also, if the collection is hash-based (`ch-set' etc.), the ordering will be +based on the hash values, so it won't be predictable or usable for any other +purpose, though it will be deterministic.")) (defgeneric with (collection value1 &optional value2) (:documentation @@ -2059,18 +2063,16 @@ (defmethod count-if-not (pred (s set) &key key) (gmap:def-gmap-res-type wb-set (&key filterp compare-fn-name) "Returns a set of the values, optionally filtered by `filterp'. If `compare-fn-name' is nonnull, it specifies a custom ordering." - (let ((proto-var (gensymx #:prototype-)) - (cfn-var (gensymx #:cfn-)) + (let ((org-var (gensymx #:org-)) (cf-var (gensymx #:cmp-))) `(nil #'(lambda (s x) (WB-Set-Tree-With s x ,cf-var)) #'(lambda (s) - (if (or (null ,cfn-var) (eq (wb-set-compare-fn ,proto-var) #'compare)) + (if (eq ,cf-var #'compare) (make-wb-set s) - (make-wb-custom-set s (wb-custom-set-org ,proto-var)))) + (make-wb-custom-set s ,org-var))) ,filterp - ((,proto-var (empty-wb-set ,compare-fn-name)) - ((,cfn-var (wb-set-compare-fn-name ,proto-var)) - (,cf-var (wb-set-compare-fn ,proto-var))))))) + ((,org-var (wb-set-org (empty-wb-set ,compare-fn-name))) + ((,cf-var (tree-set-org-compare-fn ,org-var))))))) (gmap:def-gmap-res-type union (&key filterp) @@ -2265,18 +2267,18 @@ (defmethod image ((fn bag) (s ch-set)) (hash-set-org-compare-fn hsorg)))) (make-ch-set result hsorg))) -;;; Analogous to `at-rank' on a WB-Set, but I didn't want to make this a method of that, because -;;; the ordering, though deterministic, is not one that will make any sense to a client. -;;; &&& Needs `defgeneric' -(defmethod at-index ((s ch-set) index) +(defmethod at-rank ((s ch-set) index) (let ((contents (ch-set-contents s)) ((size (ch-set-tree-size contents)))) (unless (and (>= index 0) (< index size)) (error 'simple-type-error :datum index :expected-type `(integer 0 (,size)) - :format-control "Index ~D out of bounds on ~A" + :format-control "Index ~D out of bounds on ~A" :format-arguments (list index s))) (ch-set-tree-index-element contents index))) +(defmethod hash-value ((s ch-set)) + (ch-set-tree-hash-value (ch-set-contents s))) + (defmethod compare ((s1 ch-set) (s2 ch-set)) (if-same-ch-set-orgs (s1 s2 hsorg) (ch-set-tree-compare (ch-set-contents s1) (ch-set-contents s2) @@ -2301,14 +2303,7 @@ (defmethod internal-do-set ((s ch-set) elt-fn value-fn) (funcall elt-fn x))) (defmethod iterator ((s ch-set) &key) - ;; O(log n) per element. &&& Write a proper tree iterator. - (let ((tree (ch-set-contents s)) - (idx 0)) - (lambda (op) - (ecase op - (:get (ch-set-tree-index-element tree (postincf idx))) - (:done? (>= idx (ch-set-tree-size tree))) - (:more? (< idx (ch-set-tree-size tree))))))) + (make-ch-set-tree-iterator (ch-set-contents s))) (defmethod convert ((to-type (eql 'ch-set)) (s set) &key compare-fn-name) (convert-to-ch-set s nil @@ -2356,6 +2351,35 @@ (defmethod convert ((to-type (eql 'ch-set)) (s sequence) &key compare-fn-name) (pprint-newline :linear stream) (write x :stream stream)))) +(gmap:def-gmap-res-type ch-set (&key filterp compare-fn-name) + "Returns a set of the values, optionally filtered by `filterp'. If +`compare-fn-name' is nonnull, it specifies a custom ordering." + (let ((proto-var (gensymx #:prototype-)) + (cfn-var (gensymx #:cfn-)) + (cf-var (gensymx #:cmp-))) + `(nil #'(lambda (s x) (ch-set-tree-with s x ,cf-var)) + #'(lambda (s) + (if (eq ,cf-var #'compare) + (make-ch-set s) + (make-wb-custom-set s (wb-custom-set-org ,proto-var)))) + ,filterp + ((,proto-var (empty-ch-set ,compare-fn-name)) + ((,cfn-var (hash-set-org-compare-fn-name (ch-set-org ,proto-var))) + (,cf-var (hash-set-org-compare-fn (ch-set-org ,proto-var)))))))) + +(gmap:def-gmap-res-type ch-set (&key filterp compare-fn-name) + "Returns a set of the values, optionally filtered by `filterp'. If +`compare-fn-name' is nonnull, it specifies a custom ordering." + (let ((org-var (gensymx #:org-)) + (hf-var (gensymx #:hash-)) + (cf-var (gensymx #:cmp-))) + `(nil #'(lambda (s x) (ch-set-tree-with s x ,hf-var ,cf-var)) + #'(lambda (s) (make-ch-set s ,org-var)) + ,filterp + ((,org-var (ch-set-org (empty-ch-set ,compare-fn-name))) + ((,hf-var (hash-set-org-hash-fn ,org-var)) + (,cf-var (hash-set-org-compare-fn ,org-var))))))) + (defmethod make-load-form ((s ch-set) &optional environment) (declare (ignore environment)) `(convert 'ch-set ',(convert 'list s) :compare-fn-name ',(hash-set-org-compare-fn-name (ch-set-org s)))) @@ -3540,8 +3564,8 @@ (defmethod map-union ((map1 wb-map) (map2 wb-map) (make-wb-map (WB-Map-Tree-Union (wb-map-contents map1) (wb-map-contents map2) (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg)) tmorg (let ((def1 (map-default map1)) - (def2 (map-default map2))) - (and (or def1 def2) (funcall val-fn def1 def2)))) + (def2 (map-default map2))) + (and (or def1 def2) (funcall val-fn def1 def2)))) (call-next-method))) (defmethod map-intersection ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2))) @@ -4108,10 +4132,30 @@ (defmethod lookup ((m ch-map) key) ;; Our internal convention is the reverse of the external one. (values (if val? val (map-default m)) val?))) +(defmethod at-rank ((m ch-map) index) + (let ((contents (ch-map-contents m)) + ((size (ch-map-tree-size contents)))) + (unless (and (>= index 0) (< index size)) + (error 'simple-type-error :datum index :expected-type `(integer 0 (,size)) + :format-control "Index ~D out of bounds on ~A" + :format-arguments (list index m))) + (ch-map-tree-index-pair contents index))) + (defmethod domain-contains? ((m ch-map) x) (let ((hmorg (ch-map-org m))) (ch-map-tree-lookup (ch-map-contents m) x (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg)))) +(defmethod map-union ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2))) + (if-same-ch-map-orgs (m1 m2 hmorg) + (make-ch-map (ch-map-tree-union (ch-map-contents m1) (ch-map-contents m2) + (coerce val-fn 'function) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)) + hmorg (let ((def1 (map-default m1)) + (def2 (map-default m2))) + (and (or def1 def2) (funcall val-fn def1 def2)))) + (call-next-method))) + (defmethod internal-do-map ((m ch-map) elt-fn value-fn) (declare ;(optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) diff --git a/Code/hash.lisp b/Code/hash.lisp index 89cf911..ef6fdaf 100644 --- a/Code/hash.lisp +++ b/Code/hash.lisp @@ -16,6 +16,9 @@ (define-hash-function compare hash-value) ;;; As of this writing, these methods are tentative. They should be gone over for performance ;;; and hash quality (well-distributed-ness) in the major Lisp implementations. +;;; Oh, this is interesting: SBCL limits length/depth when hashing list structure (search for +;;; "depthoid"). Maybe I should too. + (defmethod hash-value ((x identity-equality-mixin)) ;; &&& Seems to work in SBCL (logxor (sxhash (class-of x)) (slot-value x 'serial-number))) @@ -27,9 +30,10 @@ (defmethod hash-value ((x identity-ordering-mixin)) (defmethod hash-value ((x real)) (sxhash x)) -(defmethod hash-value ((x fixnum)) - ;; Seems reasonable for our purposes - ;; &&& Oops -- should strip sign bit? +(defmethod hash-value ((x integer)) + ;; &&& This will make the tree structure sensitive to powers of 32, but seems like any reasonably + ;; simple bit-twiddling will risk causing some such artifact. Still, have a look at + ;; `sxhash-fixnum-xform' in the SBCL sources, for example. x) (defmethod hash-value ((x character)) diff --git a/Code/macros.lisp b/Code/macros.lisp index e732e80..6c567b3 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -779,52 +779,68 @@ (defmethod ,name ,(mod-param-list 'wb-custom-set) `(make-wb-custom-set ,contents (wb-custom-set-org ,like-coll)))) . ,body)))))) -(defmacro if-same-ch-set-orgs ((s1 s2 hscomp-var) then else) +(defmacro if-same-ch-set-orgs ((s1 s2 hsorg-var) then else) (let ((s1-var (gensymx #:s1-)) (s2-var (gensymx #:s2-)) - (hscomp1-var (gensymx #:hscomp1-)) - (hscomp2-var (gensymx #:hscomp2-))) + (hsorg1-var (gensymx #:hsorg1-)) + (hsorg2-var (gensymx #:hsorg2-))) `(let ((,s1-var ,s1) (,s2-var ,s2) - ((,hscomp1-var (ch-set-org ,s1-var)) - (,hscomp2-var (ch-set-org ,s2-var)))) - (if (or (eq ,hscomp1-var ,hscomp2-var) - (and (eq (hash-set-org-hash-fn ,hscomp1-var) (hash-set-org-hash-fn ,hscomp2-var)) - (eq (hash-set-org-compare-fn ,hscomp1-var) (hash-set-org-compare-fn ,hscomp2-var)))) - (let ((,hscomp-var ,hscomp1-var)) + ((,hsorg1-var (ch-set-org ,s1-var)) + (,hsorg2-var (ch-set-org ,s2-var)))) + (if (or (eq ,hsorg1-var ,hsorg2-var) + (and (eq (hash-set-org-hash-fn ,hsorg1-var) (hash-set-org-hash-fn ,hsorg2-var)) + (eq (hash-set-org-compare-fn ,hsorg1-var) (hash-set-org-compare-fn ,hsorg2-var)))) + (let ((,hsorg-var ,hsorg1-var)) ,then) ,else)))) -(defmacro if-same-wb-bag-orgs ((b1 b2 tscomp-var) then else) +(defmacro if-same-wb-bag-orgs ((b1 b2 tsorg-var) then else) (let ((b1-var (gensymx #:b1-)) (b2-var (gensymx #:b2-)) - (tscomp1-var (gensymx #:tscomp1-)) - (tscomp2-var (gensymx #:tscomp2-))) + (tsorg1-var (gensymx #:tsorg1-)) + (tsorg2-var (gensymx #:tsorg2-))) `(let ((,b1-var ,b1) (,b2-var ,b2) - ((,tscomp1-var (wb-bag-org ,b1-var)) - (,tscomp2-var (wb-bag-org ,b2-var)))) - (if (or (eq ,tscomp1-var ,tscomp2-var) - (eq (tree-set-org-compare-fn ,tscomp1-var) (tree-set-org-compare-fn ,tscomp2-var))) - (let ((,tscomp-var ,tscomp1-var)) + ((,tsorg1-var (wb-bag-org ,b1-var)) + (,tsorg2-var (wb-bag-org ,b2-var)))) + (if (or (eq ,tsorg1-var ,tsorg2-var) + (eq (tree-set-org-compare-fn ,tsorg1-var) (tree-set-org-compare-fn ,tsorg2-var))) + (let ((,tsorg-var ,tsorg1-var)) ,then) ,else)))) -(defmacro if-same-wb-map-orgs ((m2 b2 tmcomp-var) then else) - (let ((m2-var (gensymx #:m2-)) - (b2-var (gensymx #:b2-)) - (tmcomp1-var (gensymx #:tmcomp1-)) - (tmcomp2-var (gensymx #:tmcomp2-))) - `(let ((,m2-var ,m2) - (,b2-var ,b2) - ((,tmcomp1-var (wb-map-org ,m2-var)) - (,tmcomp2-var (wb-map-org ,b2-var)))) - (if (or (eq ,tmcomp1-var ,tmcomp2-var) - (and (eq (tree-map-org-key-compare-fn ,tmcomp1-var) - (tree-map-org-key-compare-fn ,tmcomp2-var)) - (eq (tree-map-org-val-compare-fn ,tmcomp1-var) - (tree-map-org-val-compare-fn ,tmcomp2-var)))) - (let ((,tmcomp-var ,tmcomp1-var)) +(defmacro if-same-wb-map-orgs ((m1 m2 tmorg-var) then else) + (let ((m1-var (gensymx #:m1-)) + (m2-var (gensymx #:m2-)) + (tmorg1-var (gensymx #:tmorg1-)) + (tmorg2-var (gensymx #:tmorg2-))) + `(let ((,m1-var ,m1) + (,m2-var ,m2) + ((,tmorg1-var (wb-map-org ,m1-var)) + (,tmorg2-var (wb-map-org ,m2-var)))) + (if (or (eq ,tmorg1-var ,tmorg2-var) + (and (eq (tree-map-org-key-compare-fn ,tmorg1-var) (tree-map-org-key-compare-fn ,tmorg2-var)) + (eq (tree-map-org-val-compare-fn ,tmorg1-var) (tree-map-org-val-compare-fn ,tmorg2-var)))) + (let ((,tmorg-var ,tmorg1-var)) + ,then) + ,else)))) + +(defmacro if-same-ch-map-orgs ((m1 m2 hmorg-var) then else) + (let ((m1-var (gensymx #:m1-)) + (m2-var (gensymx #:m2-)) + (hmorg1-var (gensymx #:hmorg1-)) + (hmorg2-var (gensymx #:hmorg2-))) + `(let ((,m1-var ,m1) + (,m2-var ,m2) + ((,hmorg1-var (ch-map-org ,m1-var)) + (,hmorg2-var (ch-map-org ,m2-var)))) + (if (or (eq ,hmorg1-var ,hmorg2-var) + (and (eq (hash-map-org-key-hash-fn ,hmorg1-var) (hash-map-org-key-hash-fn ,hmorg2-var)) + (eq (hash-map-org-key-compare-fn ,hmorg1-var) (hash-map-org-key-compare-fn ,hmorg2-var)) + (eq (hash-map-org-val-hash-fn ,hmorg1-var) (hash-map-org-val-hash-fn ,hmorg2-var)) + (eq (hash-map-org-val-compare-fn ,hmorg1-var) (hash-map-org-val-compare-fn ,hmorg2-var)))) + (let ((,hmorg-var ,hmorg1-var)) ,then) ,else)))) diff --git a/Code/testing.lisp b/Code/testing.lisp index f0f30a1..3cb9b78 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -87,7 +87,11 @@ (define-hash-function erapmoc hash-value-negated) (Test-Map-Operations i (Test-Set-Operations i)) (Test-Bag-Operations i) (Test-Seq-Operations i) - (Test-Tuple-Operations i)))) + (Test-Tuple-Operations i)) + ;; These take longer. + (progn + (test-champ-sets (max 2 (floor n-iterations 3))) + (test-champ-maps (max 2 (floor n-iterations 3)))))) (defun Test-Misc-0 () @@ -3816,62 +3820,54 @@ (defmethod verify ((br wb-2-relation)) (defmethod hash-value ((x my-integer)) ;; Drop the two low-order bits to force collisions, and spread the bits out to force more levels - ;; to be created. + ;; to be created. Also, values equal mod 256 will have the same hash. (let ((val (ash (my-integer-value x) -2))) - (dpb (ldb (byte 2 8) val) - (byte 2 20) - (dpb (ldb (byte 2 6) val) - (byte 2 15) - (dpb (ldb (byte 2 4) val) - (byte 2 10) - (dpb (ldb (byte 2 2) val) - (byte 2 5) - (ldb (byte 2 0) val))))))) + (dpb (ldb (byte 2 6) val) + (byte 2 15) + (dpb (ldb (byte 2 4) val) + (byte 2 10) + (dpb (ldb (byte 2 2) val) + (byte 2 5) + (ldb (byte 2 0) val)))))) (defmethod verify ((s ch-set)) (ch-set-tree-verify (ch-set-contents s) (hash-set-org-hash-fn (ch-set-org s)))) -(defvar *champ-set-test-values* (seq)) - -(defun test-champ-sets (n &optional random-seed) +(defun test-champ-sets (n) (declare (optimize (speed 0) (debug 3))) - (let ((*random-state* (make-random-state random-seed))) + (let ((saved-wbs nil) + (saved-chs nil)) (dotimes (i n) - (setq *champ-set-test-values* (seq)) (let ((wbs (wb-set)) - (chs (ch-set)) - (saved-wbs nil) - (saved-chs nil)) - (dotimes (i 4096) + (chs (ch-set))) + (dotimes (j 256) (let ((mi (make-my-integer (random 1024))) (prev-wbs wbs) (prev-chs chs)) (unless (eqv (contains? chs mi) (contains? wbs mi)) - (error "CONTAINS? failed")) + (error "ch-set contains? failed")) (if (< (random 100) 20) (progn - (push-last *champ-set-test-values* `(- ,mi)) (excludef wbs mi) (excludef chs mi) (unless (or (contains? prev-wbs mi) (eq chs prev-chs)) - (error "LESS failed to detect no change"))) + (error "ch-set less failed to detect no change"))) (progn - (push-last *champ-set-test-values* `(+ ,mi)) (includef wbs mi) (includef chs mi))) (unless (verify chs) - (error "Verification failed")) + (error "ch-set verification failed")) (let ((wbs-from-ch (convert 'wb-set chs))) (unless (equal? wbs wbs-from-ch) - (error "CONVERT 'WB-SET or EQUAL? failed"))) - (when (let ((quot rem (floor i 32))) + (error "ch-set convert 'wb-set or equal? failed"))) + (when (let ((quot rem (floor j 32))) (and (= 0 rem) (>= quot 1))) (let ((elts (wb-set))) - (dotimes (i (size chs)) - (includef elts (at-index chs i))) + (dotimes (k (size chs)) + (includef elts (at-index chs k))) (unless (equal? elts wbs) - (error "AT-INDEX failed"))) + (error "ch-set at-index failed"))) (let ((idx (random (size chs))) ((elt (at-index chs idx)) ((tmp-chs (with (less chs elt) @@ -3882,61 +3878,77 @@ (defmethod verify ((s ch-set)) ;; nonetheless differ. (unless (and (eq (compare chs tmp-chs) ':less) (eq (compare tmp-chs chs) ':greater)) - (error "COMPARE failed"))) + (error "ch-set compare failed"))) (unless (equal? chs (convert 'ch-set wbs)) - (error "CONVERT 'CH-SET or EQUAL? failed")) + (error "convert 'ch-set or equal? failed")) (unless (equal? chs (convert 'ch-set (convert 'seq wbs))) - (error "CONVERT 'CH-SET from seq failed")) + (error "convert 'ch-set from seq failed")) (unless (equal? chs (convert 'ch-set (convert 'vector wbs))) - (error "CONVERT 'CH-SET from vector failed")) - (when saved-chs - (let ((chs-union (union chs saved-chs))) - (unless (verify chs-union) - (error "UNION verification failed")) - (unless (equal? (convert 'wb-set chs-union) (union wbs saved-wbs)) - (error "UNION failed"))) - (let ((chs-intersection (intersection chs saved-chs))) - (unless (verify chs-intersection) - (error "INTERSECTION verification failed")) - (unless (equal? (convert 'wb-set chs-intersection) (intersection wbs saved-wbs)) - (error "INTERSECTION failed")))) - (setq saved-wbs wbs) - (setq saved-chs chs)))))))) + (error "convert 'ch-set from vector failed")) + (let ((i 0) + (it (iterator chs))) + (do-set (x chs) + (unless (equal? x (at-rank chs i)) + (error "ch-set at-rank failed")) + (incf i) + (unless (funcall it ':more?) + (error "ch-set iterator exhausted")) + (let ((itval (funcall it ':get))) + (unless (and (funcall it ':more?) (equal? x itval)) + (error "ch-set iterator failed: ~A: ~A vs ~A" i x itval)))))))) + (when saved-chs + (let ((chs-union (union chs saved-chs))) + (unless (verify chs-union) + (error "ch-set union verification failed")) + (unless (equal? (convert 'wb-set chs-union) (union wbs saved-wbs)) + (error "ch-set union failed"))) + (let ((chs-intersection (intersection chs saved-chs))) + (unless (verify chs-intersection) + (error "ch-set intersection verification failed")) + (unless (equal? (convert 'wb-set chs-intersection) (intersection wbs saved-wbs)) + (error "ch-set intersection failed")))) + (setq saved-wbs wbs) + (setq saved-chs chs))))) (defmethod verify ((m ch-map)) (ch-map-tree-verify (ch-map-contents m))) -(defvar *champ-map-test-pairs* (seq)) - (defun test-champ-maps (n) (declare (optimize (speed 0) (debug 3))) - (dotimes (i n) - (setq *champ-map-test-pairs* (seq)) - (let ((wbm (wb-map)) - (chm (ch-map))) - (dotimes (j 4096) - (let ((mi (make-my-integer (random 1024))) - (val (random 65536)) - (prev-wbm wbm) - (prev-chm chm)) - (unless (eql (lookup chm mi) (lookup wbm mi)) - (error "LOOKUP failed")) - (if (< (random 100) 20) + (let ((saved-wbm nil) + (saved-chm nil)) + (dotimes (i n) + (let ((wbm (wb-map)) + (chm (ch-map))) + (dotimes (j 256) + (let ((mi (make-my-integer (random 1024))) + (val (random 65536)) + (prev-wbm wbm) + (prev-chm chm)) + (unless (eql (lookup chm mi) (lookup wbm mi)) + (error "ch-map lookup failed")) + (if (< (random 100) 20) + (progn + (excludef wbm mi) + (excludef chm mi) + (unless (or (domain-contains? prev-wbm mi) + (eq chm prev-chm)) + (error "ch-map less failed to detect no change"))) (progn - ;; (push-last *champ-map-test-pairs* (list '- mi val)) - (excludef wbm mi) - (excludef chm mi) - (unless (or (domain-contains? prev-wbm mi) - (eq chm prev-chm)) - (error "LESS failed to detect no change"))) - (progn - ;; (push-last *champ-map-test-pairs* (list '+ mi val)) - (setf (@ wbm mi) val) - (setf (@ chm mi) val))) - (unless (verify chm) - (error "Verification failed on ~A; prev ~A" chm prev-chm)) - (let ((wbm-from-ch (convert 'wb-map chm))) - (unless (equal? wbm wbm-from-ch) - (error "EQUAL? failed on ~A~%vs. ~A:~%diffs ~A~%prev ~A" wbm chm - (multiple-value-list (map-difference-2 wbm wbm-from-ch)) prev-chm)))))))) + (setf (@ wbm mi) val) + (setf (@ chm mi) val))) + (unless (verify chm) + (error "Verification failed on ~A; prev ~A" chm prev-chm)) + (let ((wbm-from-ch (convert 'wb-map chm))) + (unless (equal? wbm wbm-from-ch) + (error "ch-map equal? failed on ~A~%vs. ~A:~%diffs ~A~%prev ~A" wbm chm + (multiple-value-list (map-difference-2 wbm wbm-from-ch)) prev-chm))))) + (when saved-chm + (let ((chm-union (map-union chm saved-chm))) + (unless (verify chm-union) + (error "ch-map union verification failed")) + (unless (equal? (convert 'wb-map chm-union) (map-union wbm saved-wbm)) + (error "ch-map union failed")))) + (setq saved-wbm wbm) + (setq saved-chm chm))))) -- GitLab From e48a98990355109dd6bde295f51da9e4c0b536d5 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Tue, 12 Aug 2025 01:01:00 -0700 Subject: [PATCH 03/16] Another checkpoint. Map union seems to be working. --- Code/champ.lisp | 590 +++++++++++++++++++++++--------------- Code/complement-sets.lisp | 2 + Code/defs.lisp | 4 +- Code/fset.lisp | 216 +++++++++++--- Code/replay.lisp | 7 + Code/swank.lisp | 8 +- Code/testing.lisp | 44 ++- Code/wb-trees.lisp | 84 +++--- 8 files changed, 624 insertions(+), 331 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index d565b85..1b2905e 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -108,7 +108,7 @@ (defstruct (ch-set-node (defconstant ch-set-node-header-size 4) (defun ch-set-tree-with (tree value hash-fn compare-fn &optional (depth 0)) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 03)) (type function hash-fn compare-fn) (type (integer 0 64) depth)) (let ((value-hash (hash-to-fixnum value hash-fn))) @@ -205,7 +205,7 @@ (defstruct (ch-set-node n))))))))))) (defun vector-rem-1-ins-1 (vec rem-idx ins-idx ins-val) - (declare ;(optimize (speed 3) (safety 0)) + (declare ;(optimize (speed 3) (safety 03)) (simple-vector vec) (fixnum rem-idx ins-idx)) (assert (<= rem-idx (the fixnum (1- ins-idx)))) @@ -235,7 +235,7 @@ (defstruct (ch-set-node (t (ch-set-node-hash-value tree)))) (defun ch-set-tree-less (tree value hash-fn compare-fn) - ;(declare (optimize (speed 3) (safety 0))) + ;(declare (optimize (speed 3) (safety 03))) (let ((value-hash (hash-to-fixnum value hash-fn))) (declare (fixnum value-hash)) (rlabels (rec tree value-hash) @@ -316,7 +316,7 @@ (defstruct (ch-set-node (values n content-hash-delta))))))))))))))) (defun vector-ins-1-rem-1 (vec ins-idx ins-val rem-idx) - (declare ;(optimize (speed 3) (safety 0)) + (declare ;(optimize (speed 3) (safety 03)) (simple-vector vec) (fixnum ins-idx rem-idx)) (assert (<= ins-idx rem-idx)) @@ -343,7 +343,7 @@ (defstruct (ch-set-node (svref tree ch-set-node-header-size)))) (defun ch-set-tree-contains? (tree value hash-fn compare-fn &optional (depth 0)) - ;(declare (optimize (speed 3) (safety 0))) + ;(declare (optimize (speed 3) (safety 03))) (let ((value-hash (hash-to-fixnum value hash-fn))) (declare (fixnum value-hash)) (rlabels (rec tree value (ash value-hash (- (* champ-hash-bits-per-level depth)))) @@ -357,7 +357,8 @@ (defstruct (ch-set-node (if (logbitp hash-bits entry-mask) (let ((entry-idx (+ ch-set-node-header-size (1-bits-below hash-bits entry-mask))) ((ex-value (svref node entry-idx)))) - (equal?-cmp ex-value value compare-fn)) + (and (equal?-cmp ex-value value compare-fn) + (values t ex-value))) (let ((subnode-mask (ch-set-node-subnode-mask node))) (and (logbitp hash-bits subnode-mask) (let ((subnode-idx (- (length node) 1 (1-bits-below hash-bits subnode-mask))) @@ -415,6 +416,37 @@ (defstruct (ch-set-node (return-from ch-set-tree-compare cmp))))) default)))))))))))) +(defun ch-set-tree-index (tree value hash-fn compare-fn) + (let ((value-hash (hash-to-fixnum value hash-fn))) + (declare (fixnum value-hash)) + (rlabels (rec tree value 0 value-hash) + (rec (node value base hash-shifted) + (declare (fixnum base hash-shifted)) + (and node + (if (consp node) + (let ((found? idx (wb-set-tree-rank (cdr node) value compare-fn))) + (and found? (+ idx base))) + (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) + (entry-mask (ch-set-node-entry-mask node))) + (if (logbitp hash-bits entry-mask) + (let ((ientry (1-bits-below hash-bits entry-mask)) + ((entry-idx (+ ch-set-node-header-size ientry)) + ((ex-value (svref node entry-idx))))) + (and (equal?-cmp ex-value value compare-fn) + (+ base ientry))) + (let ((subnode-mask (ch-set-node-subnode-mask node))) + (incf base (logcount entry-mask)) + (if (logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + (len (length (the simple-vector node))) + ((subnode-idx (- len 1 isubnode)) + ((subnode (svref node subnode-idx))))) + (dotimes (i isubnode) + (incf base (ch-set-tree-size (svref node (- len 1 i))))) + (rec subnode value base + (ash hash-shifted (- champ-hash-bits-per-level)))) + base)))))))))) + (defun ch-set-tree-index-element (tree index) (declare (optimize (debug 3))) (rlabels (rec tree index) @@ -423,33 +455,27 @@ (defstruct (ch-set-node (wb-set-tree-rank-element (cdr tree) index) (let ((len (length tree)) (entry-mask (ch-set-node-entry-mask tree)) - (subnode-mask (ch-set-node-subnode-mask tree)) - ((merged-mask (logior entry-mask subnode-mask))) - (entry-idx 0) - (subnode-idx 0)) - (do-bit-indices (idx merged-mask (error "Bug in 'ch-set-tree-index-element'")) - (cond ((logbitp idx entry-mask) - (when (= index 0) - (return (svref tree (+ ch-set-node-header-size entry-idx)))) - (decf index) - (incf entry-idx)) - ((logbitp idx subnode-mask) - (let ((subnode (svref tree (- len subnode-idx 1))) - ((subnode-size (ch-set-tree-size subnode)))) - (when (< index subnode-size) - (return (rec subnode index))) - (decf index subnode-size) - (incf subnode-idx))) - (t (error "Bug in 'do-bit-indices'"))))))))) + ((n-entries (logcount entry-mask)))) + (if (< index n-entries) + (svref tree (+ ch-set-node-header-size index)) + (let ((subnode-mask (ch-set-node-subnode-mask tree))) + (decf index n-entries) + (dotimes (i (logcount subnode-mask)) + (let ((subnode (svref tree (- len i 1))) + ((subnode-size (ch-set-tree-size subnode)))) + (when (< index subnode-size) + (return (rec subnode index))) + (decf index subnode-size)))))))))) (defun ch-set-tree-union (tree1 tree2 hash-fn compare-fn) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 03)) (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) (declare (type (integer 0 64) depth)) (cond ((null tree1) tree2) ((null tree2) tree1) + ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) (let ((tree-result (wb-set-tree-union (cdr tree1) (cdr tree2) compare-fn)) (chash 0)) @@ -677,7 +703,7 @@ (defstruct (ch-set-node (1+ depth))))))))))) (defun vector-remove-n-at (vec idx n) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 03)) (type simple-vector vec) (type (unsigned-byte 24) idx n)) (let ((len (length vec))) @@ -693,6 +719,9 @@ (defstruct (ch-set-node ;;; -------------------------------- ;;; Iteration primitives +;;; This ordering has the slight downside that it can seem unstable; adding or removing an element +;;; can cause a different element to change places (because an entry becomes a subnode or conversely). +;;; But doing it hash-wise is noticeably slower, like a factor of 2 on a straightforward micro-benchmark. (defmacro do-ch-set-tree-members ((value-var tree-form &optional value-form) &body body) (let ((body-fn (gensymx #:body-)) @@ -705,13 +734,11 @@ (defstruct (ch-set-node (if (consp tree) (do-wb-set-tree-members (,value-var (cdr tree)) (,body-fn ,value-var)) - (let ((entries (ch-set-node-entry-mask tree)) - (subnodes (ch-set-node-subnode-mask tree))) - (do-bit-indices (idx (logior entries subnodes)) - (if (logbitp idx (ch-set-node-entry-mask tree)) - (,body-fn (svref tree (+ ch-set-node-header-size (1-bits-below idx entries)))) - (,recur-fn (svref tree (- (length (the simple-vector tree)) 1 - (1-bits-below idx subnodes))))))))))) + (progn + (dotimes (i (logcount (ch-set-node-entry-mask tree))) + (,body-fn (svref tree (+ i ch-set-node-header-size)))) + (dotimes (i (logcount (ch-set-node-subnode-mask tree))) + (,recur-fn (svref tree (- (length tree) 1 i))))))))) (,recur-fn ,tree-form)) ,value-form))) @@ -721,7 +748,7 @@ (defstruct (ch-set-node (defun make-ch-set-tree-iterator (tree) (let ((iter (make-ch-set-tree-iterator-internal tree))) (lambda (op) - (ecase opm + (ecase op (:get (ch-set-tree-iterator-get iter)) (:done? (ch-set-tree-iterator-done? iter)) (:more? (not (ch-set-tree-iterator-done? iter))))))) @@ -734,60 +761,131 @@ (defstruct (ch-set-node (progn (setf (svref iter 0) 1) ; the stack pointer (setf (svref iter 1) tree) - (setf (svref iter 2) (logior (ch-set-node-entry-mask tree) (ch-set-node-subnode-mask tree))) + (setf (svref iter 2) 0) (ch-set-tree-iterator-canonicalize iter))) iter)) (defun ch-set-tree-iterator-canonicalize (iter) - (declare (optimize (debug 3))) + (declare (optimize (speed 3) (safety 03))) (let ((sp (svref iter 0)) - ((mask (svref iter (1+ sp))))) - (when (if (null mask) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (type (or null fixnum) idx)) + (when (if (null idx) (wb-set-tree-iterator-done? (svref iter sp)) - (zerop mask)) + (= idx (- (length (the simple-vector node)) ch-set-node-header-size))) (decf sp 2) - (setq mask (svref iter (1+ sp)))) + (unless (< sp 0) + (setq node (svref iter sp)) + (setq idx (svref iter (1+ sp))))) (unless (< sp 0) - (let ((node (svref iter sp))) - (loop - (when (null mask) + (loop + (when (null idx) + (return)) + (let ((n-entries (logcount (ch-set-node-entry-mask node)))) + (when (< idx n-entries) (return)) - (let ((idx (least-1-bit mask))) - (if (logbitp idx (ch-set-node-entry-mask node)) - (return) - (progn - (logandc2f mask (ash 1 idx)) - (unless (zerop mask) ; TCO - (setf (svref iter (1+ sp)) mask) - (incf sp 2)) - (setq node (svref node (- (length (the simple-vector node)) 1 - (1-bits-below idx (ch-set-node-subnode-mask node))))) - (if (consp node) - (setq node (make-wb-set-tree-iterator-internal (cdr node)) - mask nil) - (setq mask (logior (ch-set-node-entry-mask node) (ch-set-node-subnode-mask node)))) - (setf (svref iter sp) node) - (setf (svref iter (1+ sp)) mask)))))) - (setf (svref iter 0) sp)))) + (let ((len (length (the simple-vector node)))) + (setq node (svref node (- len (- idx n-entries) 1))) + (incf idx) + (unless (= idx (- len ch-set-node-header-size)) ; TCO + (setf (svref iter (1+ sp)) idx) + (incf sp 2)) + (if (consp node) + (setq node (make-wb-set-tree-iterator-internal (cdr node)) + idx nil) + (setq idx 0)) + (setf (svref iter sp) node) + (setf (svref iter (1+ sp)) idx))))) + (setf (svref iter 0) sp))) (defun ch-set-tree-iterator-done? (iter) - (< (svref iter 0) 0)) + (declare (optimize (speed 3) (safety 03))) + (< (the fixnum (svref iter 0)) 0)) (defun ch-set-tree-iterator-get (iter) + (declare (optimize (speed 3) (safety 03))) (let ((sp (svref iter 0))) + (declare (fixnum sp)) (and (> sp 0) (let ((node (svref iter sp)) - (mask (svref iter (1+ sp)))) - (if (null mask) + (idx (svref iter (1+ sp)))) + (declare (type (or null fixnum) idx)) + (if (null idx) (let ((val (wb-set-tree-iterator-get node))) (ch-set-tree-iterator-canonicalize iter) (values val t)) - (let ((idx (least-1-bit mask))) - (logandc2f (svref iter (1+ sp)) (ash 1 idx)) + (progn + (setf (svref iter (1+ sp)) (1+ idx)) (ch-set-tree-iterator-canonicalize iter) - (values (svref node (+ ch-set-node-header-size (1-bits-below idx (ch-set-node-entry-mask node)))) + (values (svref node (+ ch-set-node-header-size idx)) t))))))) +;;; ---------------- +;;; Functional iterator + +(defun ch-set-tree-fun-iter (tree) + (declare (optimize (speed 3) (safety 03))) + (rlabels (walk tree (lambda (op) + (ecase op + (:first (values nil nil)) + (:empty? t) + (:more? nil)))) + (walk (node cont) + (if (consp node) + (wb-set-tree-fun-iter (cdr node) cont) + (let ((n-entries (logcount (ch-set-node-entry-mask node))) + (n-subnodes (logcount (ch-set-node-subnode-mask node)))) + (rlabels (entry 0) + (entry (i) + (declare (fixnum i)) + (if (< i n-entries) + (lambda (op) + (ecase op + (:first (values (svref node (+ ch-set-node-header-size i)) t)) + (:rest (entry (1+ i))) + (:empty? nil) + (:more? t))) + (subnode 0))) + (subnode (i) + (declare (fixnum i)) + (if (< i n-subnodes) + (walk (svref node (- (+ ch-set-node-header-size n-entries n-subnodes) + i 1)) + (lambda (op) (funcall (the function (subnode (1+ i))) op))) + cont)))))))) + +(defun ch-set-tree-rev-fun-iter (tree) + (declare (optimize (speed 3) (safety 03))) + (rlabels (walk tree (lambda (op) + (ecase op + (:first (values nil nil)) + (:empty? t) + (:more? nil)))) + (walk (node cont) + (if (consp node) + (wb-set-tree-rev-fun-iter (cdr node) cont) + (let ((n-entries (logcount (ch-set-node-entry-mask node))) + (n-subnodes (logcount (ch-set-node-subnode-mask node)))) + (rlabels (subnode (1- n-subnodes)) + (entry (i) + (declare (fixnum i)) + (if (>= i 0) + (lambda (op) + (ecase op + (:first (values (svref node (+ ch-set-node-header-size i)) t)) + (:rest (entry (1- i))) + (:empty? nil) + (:more? t))) + cont)) + (subnode (i) + (declare (fixnum i)) + (if (>= i 0) + (walk (svref node (- (+ ch-set-node-header-size n-entries n-subnodes) + i 1)) + (lambda (op) (funcall (the function (subnode (1- i))) op))) + (entry (1- n-entries)))))))))) + (defun ch-set-tree-verify (tree hash-fn) (declare (optimize (debug 3))) (or (null tree) @@ -880,7 +978,7 @@ (defstruct (ch-map-node (defconstant ch-map-node-header-size 4) (defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0)) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 03)) (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (type (integer 0 1000) depth)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) @@ -893,112 +991,112 @@ (defstruct (ch-map-node (if (null node) (vector (ash 1 hash-bits) 0 1 (logxor key-hash (hash-to-fixnum value val-hash-fn)) key value) - (let ((entry-mask (ch-map-node-entry-mask node)) - ((entry-raw-idx (1-bits-below hash-bits entry-mask)) - ((entry-idx (+ ch-map-node-header-size (* 2 entry-raw-idx))))) - (subnode-mask (ch-map-node-subnode-mask node)) - ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) - ((subnode-idx (- (length node) 1 subnode-raw-idx))))) - (if (logbitp hash-bits entry-mask) - ;; Entry found - (let ((ex-key (svref node entry-idx)) - (ex-val (svref node (1+ entry-idx)))) - (if (equal?-cmp key ex-key key-cmp-fn) - (if (equal?-cmp value ex-val val-cmp-fn) - node ; Key found, value equal: nothing to do - ;; Key found, value differs: just update value - (let ((n (vector-update node (+ entry-idx 1) value))) - (logxorf (ch-map-node-hash-value n) (hash-to-fixnum ex-val val-hash-fn) - (hash-to-fixnum value val-hash-fn)) - n)) - ;; Entry with different key found: make a subnode - (let ((hash-shifted (ash hash-shifted (- champ-hash-bits-per-level))) - (ex-key-hash (hash-to-fixnum ex-key key-hash-fn)) - ((ex-key-hash-shifted (ash ex-key-hash (* (- champ-hash-bits-per-level) (1+ depth)))) - ((n2 (if (= hash-shifted ex-key-hash-shifted) - ;; Collision! Fall back to WB-tree. - (cons (logxor key-hash (hash-to-fixnum value val-hash-fn) ex-key-hash - (hash-to-fixnum ex-val val-hash-fn)) - (wb-map-tree-with (wb-map-tree-with nil ex-key ex-val key-cmp-fn val-cmp-fn) - key value key-cmp-fn val-cmp-fn)) - ;; Creates a little garbage; &&& hand-integrate later. - (rec (vector (ash 1 (logand ex-key-hash-shifted champ-hash-level-mask)) - 0 1 (logxor ex-key-hash (hash-to-fixnum ex-val val-hash-fn)) - ex-key ex-val) - hash-shifted (1+ depth)))) - ;; The `1+' is because we're inserting _after_ `subnode-idx', because the subnodes - ;; are in reverse order. - ((n (vector-rem-2-ins-1 node entry-idx (1+ subnode-idx) n2)))))) - (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) - (logiorf (ch-map-node-subnode-mask n) (ash 1 hash-bits)) - (incf (ch-map-node-size n)) - (logxorf (ch-map-node-hash-value n) key-hash (hash-to-fixnum value val-hash-fn)) - n))) - ;; No entry found: check for subnode - (if (logbitp hash-bits subnode-mask) - ;; Subnode found - (let ((subnode (svref node subnode-idx)) - ((new-subnode - ;; We can create collision nodes at any level (see above). - (if (consp subnode) - (let ((wb-hash-shifted - (ash (hash-to-fixnum (wb-map-tree-arb-pair (cdr subnode)) key-hash-fn) - (* (- champ-hash-bits-per-level) (1+ depth)))) - (hash-shifted (ash hash-shifted (- champ-hash-bits-per-level))) - (size (1+ (wb-map-tree-size (cdr subnode))))) - (declare (fixnum wb-hash-shifted hash-shifted size)) - (if (= hash-shifted wb-hash-shifted) - ;; Update the collision node. - (let ((new-wb-tree - (wb-map-tree-with (cdr subnode) key value key-cmp-fn val-cmp-fn))) - (cond ((eq new-wb-tree (cdr subnode)) - subnode) - ((= (wb-map-tree-size new-wb-tree) (wb-map-tree-size (cdr subnode))) - ;; The key was already present, but the value was updated. - (let ((ig old-value (wb-map-tree-lookup (cdr subnode) key key-cmp-fn))) - (declare (ignore ig)) - (cons (logxor (the fixnum (car subnode)) - (hash-to-fixnum old-value val-hash-fn) - (hash-to-fixnum value val-hash-fn)) - new-wb-tree))) - (t ; New entry in collision node - (cons (logxor (the fixnum (car subnode)) key-hash - (hash-to-fixnum value val-hash-fn)) - new-wb-tree)))) - ;; Oh, this is fun. We add enough levels to get to where the hashes differ. - (rlabels (build hash-shifted wb-hash-shifted) - (build (hash-shifted wb-hash-shifted) - (declare (fixnum hash-shifted wb-hash-shifted)) - (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) - (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask)) - (content-hash (logxor (the fixnum (car subnode)) key-hash - (hash-to-fixnum value val-hash-fn)))) - (if (= hash-bits wb-hash-bits) - (vector 0 (ash 1 hash-bits) size content-hash - (build (ash hash-shifted (- champ-hash-bits-per-level)) - (ash wb-hash-shifted (- champ-hash-bits-per-level)))) - (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size content-hash - key value subnode))))))) - (rec subnode (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth)))))) - (if (eq new-subnode subnode) - node ; no change - ;; New subnode - (let ((n (vector-update node subnode-idx new-subnode))) - (setf (ch-map-node-size n) - (the fixnum (+ (ch-map-node-size n) (- (the fixnum (ch-map-tree-size new-subnode)) - (the fixnum (ch-map-tree-size subnode)))))) - (logxorf (ch-map-node-hash-value n) (the fixnum (ch-map-tree-hash-value subnode)) - (the fixnum (ch-map-tree-hash-value new-subnode))) + (if (consp node) + ;; Collision node. + (let ((wb-hash-shifted + (ash (hash-to-fixnum (wb-map-tree-arb-pair (cdr node)) key-hash-fn) + (* (- champ-hash-bits-per-level) depth))) + (size (1+ (wb-map-tree-size (cdr node))))) + (declare (fixnum wb-hash-shifted hash-shifted size)) + (if (= hash-shifted wb-hash-shifted) + ;; Update the collision node. + (let ((new-wb-tree + (wb-map-tree-with (cdr node) key value key-cmp-fn val-cmp-fn))) + (cond ((eq new-wb-tree (cdr node)) + node) + ((= (wb-map-tree-size new-wb-tree) (wb-map-tree-size (cdr node))) + ;; The key was already present, but the value was updated. + (let ((ig old-value (wb-map-tree-lookup (cdr node) key key-cmp-fn))) + (declare (ignore ig)) + (cons (logxor (the fixnum (car node)) (hash-to-fixnum old-value val-hash-fn) + (hash-to-fixnum value val-hash-fn)) + new-wb-tree))) + (t ; New entry in collision node + (cons (logxor (the fixnum (car node)) key-hash + (hash-to-fixnum value val-hash-fn)) + new-wb-tree)))) + ;; Oh, this is fun. We add enough levels to get to where the hashes differ. + (rlabels (build hash-shifted wb-hash-shifted) + (build (hash-shifted wb-hash-shifted) + (declare (fixnum hash-shifted wb-hash-shifted)) + (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) + (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask)) + (content-hash (logxor (the fixnum (car node)) key-hash + (hash-to-fixnum value val-hash-fn)))) + (if (= hash-bits wb-hash-bits) + (vector 0 (ash 1 hash-bits) size content-hash + (build (ash hash-shifted (- champ-hash-bits-per-level)) + (ash wb-hash-shifted (- champ-hash-bits-per-level)))) + (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size content-hash + key value node))))))) + ;; Normal case. + (let ((entry-mask (ch-map-node-entry-mask node)) + ((entry-raw-idx (1-bits-below hash-bits entry-mask)) + ((entry-idx (+ ch-map-node-header-size (* 2 entry-raw-idx))))) + (subnode-mask (ch-map-node-subnode-mask node)) + ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) + ((subnode-idx (- (length node) 1 subnode-raw-idx))))) + (if (logbitp hash-bits entry-mask) + ;; Entry found + (let ((ex-key (svref node entry-idx)) + (ex-val (svref node (1+ entry-idx)))) + (if (equal?-cmp key ex-key key-cmp-fn) + (if (equal?-cmp value ex-val val-cmp-fn) + node ; Key found, value equal: nothing to do + ;; Key found, value differs: just update value + (let ((n (vector-update node (+ entry-idx 1) value))) + (logxorf (ch-map-node-hash-value n) (hash-to-fixnum ex-val val-hash-fn) + (hash-to-fixnum value val-hash-fn)) + n)) + ;; Entry with different key found: make a subnode + (let ((hash-shifted (ash hash-shifted (- champ-hash-bits-per-level))) + (ex-key-hash (hash-to-fixnum ex-key key-hash-fn)) + ((ex-key-hash-shifted (ash ex-key-hash (* (- champ-hash-bits-per-level) (1+ depth)))) + ((n2 (if (= hash-shifted ex-key-hash-shifted) + ;; Collision! Fall back to WB-tree. + (cons (logxor key-hash (hash-to-fixnum value val-hash-fn) ex-key-hash + (hash-to-fixnum ex-val val-hash-fn)) + (wb-map-tree-with (wb-map-tree-with nil ex-key ex-val + key-cmp-fn val-cmp-fn) + key value key-cmp-fn val-cmp-fn)) + ;; Creates a little garbage; &&& hand-integrate later. + (rec (vector (ash 1 (logand ex-key-hash-shifted champ-hash-level-mask)) + 0 1 (logxor ex-key-hash (hash-to-fixnum ex-val val-hash-fn)) + ex-key ex-val) + hash-shifted (1+ depth)))) + ;; The `1+' is because we're inserting _after_ `subnode-idx', because the subnodes + ;; are in reverse order. + ((n (vector-rem-2-ins-1 node entry-idx (1+ subnode-idx) n2)))))) + (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) + (logiorf (ch-map-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-map-node-size n)) + (logxorf (ch-map-node-hash-value n) key-hash (hash-to-fixnum value val-hash-fn)) n))) - ;; Neither entry nor subnode found: make new entry - (let ((n (vector-insert-2 node entry-idx key value))) - (logiorf (ch-map-node-entry-mask n) (ash 1 hash-bits)) - (incf (ch-map-node-size n)) - (logxorf (ch-map-node-hash-value n) key-hash (hash-to-fixnum value val-hash-fn)) - n)))))))))) + ;; No entry found: check for subnode + (if (logbitp hash-bits subnode-mask) + ;; Subnode found + (let ((subnode (svref node subnode-idx)) + ((new-subnode (rec subnode (ash hash-shifted (- champ-hash-bits-per-level)) + (1+ depth))))) + (if (eq new-subnode subnode) + node ; no change + ;; New subnode + (let ((n (vector-update node subnode-idx new-subnode))) + (setf (ch-map-node-size n) + (the fixnum (+ (ch-map-node-size n) (- (the fixnum (ch-map-tree-size new-subnode)) + (the fixnum (ch-map-tree-size subnode)))))) + (logxorf (ch-map-node-hash-value n) (the fixnum (ch-map-tree-hash-value subnode)) + (the fixnum (ch-map-tree-hash-value new-subnode))) + n))) + ;; Neither entry nor subnode found: make new entry + (let ((n (vector-insert-2 node entry-idx key value))) + (logiorf (ch-map-node-entry-mask n) (ash 1 hash-bits)) + (incf (ch-map-node-size n)) + (logxorf (ch-map-node-hash-value n) key-hash (hash-to-fixnum value val-hash-fn)) + n))))))))))) (defun vector-rem-2-ins-1 (vec rem-idx ins-idx ins-val) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 03)) (simple-vector vec) (fixnum rem-idx ins-idx)) (assert (<= rem-idx (the fixnum (- ins-idx 2)))) @@ -1017,7 +1115,7 @@ (defstruct (ch-map-node v)) (defun vector-insert-2 (vec idx ins-0 ins-1) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 03)) (simple-vector vec) (fixnum idx)) (let ((len (length vec)) @@ -1043,7 +1141,7 @@ (defstruct (ch-map-node (t (ch-map-node-hash-value tree)))) (defun ch-map-tree-less (tree key key-hash-fn key-cmp-fn val-hash-fn) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 03)) (type function key-hash-fn key-cmp-fn val-hash-fn)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) (declare (fixnum key-hash)) @@ -1135,7 +1233,7 @@ (defstruct (ch-map-node (values n content-hash-delta))))))))))))))) (defun vector-remove-2-at (vec idx) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 03)) (simple-vector vec) (fixnum idx)) (let ((len (length vec)) @@ -1149,7 +1247,7 @@ (defstruct (ch-map-node v)) (defun vector-ins-2-rem-1 (vec ins-idx ins-0 ins-1 rem-idx) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 03)) (simple-vector vec) (fixnum ins-idx rem-idx)) (assert (<= ins-idx rem-idx)) @@ -1167,58 +1265,52 @@ (defstruct (ch-map-node (setf (svref v (+ rem-idx i 2)) (svref vec (+ rem-idx i 1)))) v)) -(defun ch-map-tree-lookup (tree key key-hash-fn key-cmp-fn) - (declare (optimize (speed 3) (safety 0)) - (type function key-hash-fn key-cmp-fn)) +(defun ch-map-tree-lookup (tree key key-hash-fn key-cmp-fn &optional (depth 0)) + (declare (optimize (speed 3) (safety 03)) + (type function key-hash-fn key-cmp-fn) + (type (integer 0 64) depth)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) (declare (fixnum key-hash)) - (rlabels (rec tree key key-hash) + (rlabels (rec tree key (ash key-hash (- (* champ-hash-bits-per-level depth)))) (rec (node key hash-shifted) (declare (fixnum hash-shifted)) (and node - (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) - (entry-mask (ch-map-node-entry-mask node))) - (if (logbitp hash-bits entry-mask) - (let ((entry-idx (+ ch-map-node-header-size - (* 2 (1-bits-below hash-bits entry-mask)))) - ((ex-key (svref node entry-idx)))) - (and (equal?-cmp ex-key key key-cmp-fn) - (values t (svref node (1+ entry-idx))))) - (let ((subnode-mask (ch-map-node-subnode-mask node))) - (and (logbitp hash-bits subnode-mask) - (let ((subnode-idx (- (the fixnum (length node)) - 1 (1-bits-below hash-bits subnode-mask))) - ((subnode (svref node subnode-idx)))) - (if (consp subnode) - (wb-map-tree-lookup (cdr subnode) key key-cmp-fn) + (if (consp node) + (wb-map-tree-lookup (cdr node) key key-cmp-fn) + (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) + (entry-mask (ch-map-node-entry-mask node))) + (if (logbitp hash-bits entry-mask) + (let ((entry-idx (+ ch-map-node-header-size + (* 2 (1-bits-below hash-bits entry-mask)))) + ((ex-key (svref node entry-idx)))) + (and (equal?-cmp ex-key key key-cmp-fn) + (values t (svref node (1+ entry-idx))))) + (let ((subnode-mask (ch-map-node-subnode-mask node))) + (and (logbitp hash-bits subnode-mask) + (let ((subnode-idx (- (the fixnum (length node)) + 1 (1-bits-below hash-bits subnode-mask))) + ((subnode (svref node subnode-idx)))) (rec subnode key (ash hash-shifted (- champ-hash-bits-per-level)))))))))))))) (defun ch-map-tree-index-pair (tree index) (rlabels (rec tree index) (rec (tree index) (if (consp tree) - (wb-map-tree-rank-pair tree index) + (wb-map-tree-rank-pair (cdr tree) index) (let ((len (length tree)) (entry-mask (ch-map-node-entry-mask tree)) - (subnode-mask (ch-map-node-subnode-mask tree)) - ((merged-mask (logior entry-mask subnode-mask))) - (entry-idx 0) - (subnode-idx 0)) - (do-bit-indices (idx merged-mask (error "Bug in 'ch-map-tree-index-pair")) - (cond ((logbitp idx entry-mask) - (when (= index 0) - (return (values (svref tree (+ ch-map-node-header-size (* 2 entry-idx))) - (svref tree (+ ch-map-node-header-size (* 2 entry-idx) 1))))) - (decf index) - (incf entry-idx)) - ((logbitp idx subnode-mask) - (let ((subnode (svref tree (- len subnode-idx 1))) - ((subnode-size (ch-map-tree-size subnode)))) - (when (< index subnode-size) - (return (rec subnode idx))) - (decf index subnode-size) - (incf subnode-idx))) - (t (error "Bug in 'do-bit-indices'"))))))))) + ((n-entries (logcount entry-mask)))) + (if (< index n-entries) + (let ((idx (+ ch-map-node-header-size (* 2 index)))) + (values (svref tree idx) (svref tree (1+ idx)))) + (let ((subnode-mask (ch-map-node-subnode-mask tree))) + (decf index n-entries) + (dotimes (i (logcount subnode-mask)) + (let ((subnode (svref tree (- len i 1))) + ((subnode-size (ch-map-tree-size subnode)))) + (when (< index subnode-size) + (return (rec subnode index))) + (decf index subnode-size)))))))))) (defun ch-map-tree-union (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (declare (optimize (debug 3)) @@ -1228,18 +1320,25 @@ (defstruct (ch-map-node (declare (type (integer 0 64) depth)) (cond ((null tree1) tree2) ((null tree2) tree1) + ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) (let ((tree-result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn)) (chash 0)) (do-wb-map-tree-pairs (k v tree-result) (logxorf chash (hash-to-fixnum k key-hash-fn) (hash-to-fixnum v val-hash-fn))) (cons chash tree-result))) - ((or (consp tree1) (consp tree2)) - (let ((collision-node normal-node (if (consp tree1) (values tree1 tree2) (values tree2 tree1)))) - (do-wb-map-tree-pairs (k v (cdr collision-node)) - (setq normal-node (ch-map-tree-with normal-node k v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn - depth))) - normal-node)) + ((consp tree1) + (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) + (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) + (setq tree2 (ch-map-tree-with tree2 k1 (if v2? (funcall val-fn v1 v2) v1) + key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth)))) + tree2) + ((consp tree2) + (do-wb-map-tree-pairs (k2 v2 (cdr tree2)) + (let ((v1? v1 (ch-map-tree-lookup tree1 k2 key-hash-fn key-cmp-fn depth))) + (setq tree1 (ch-map-tree-with tree1 k2 (if v1? (funcall val-fn v1 v2) v2) + key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth)))) + tree1) (t (let ((entries1 (ch-map-node-entry-mask tree1)) (entries2 (ch-map-node-entry-mask tree2)) @@ -1248,6 +1347,8 @@ (defstruct (ch-map-node ((all-entries (logior entries1 entries2)) (all-subnodes (logior subnodes1 subnodes2)) ((everything (logior all-entries all-subnodes)) + ;; Entry collisions can change to subnodes, but they can't then collide with existing subnodes. + ;; But we do have to subtract out entry/subnode collisions. ((new-len (+ ch-map-node-header-size (* 2 (- (logcount all-entries) (logcount (logand entries1 subnodes2)) @@ -1272,15 +1373,16 @@ (defstruct (ch-map-node (incf res-size) (logxorf res-content-hash (hash-to-fixnum key key-hash-fn) (hash-to-fixnum val val-hash-fn))) (add-subnode (idx subnode) + ;; It's possible for `subnode' to contain only a collision subnode -- we must pull it up. (when (and (not (consp subnode)) - (= 0 (ch-set-node-entry-mask subnode)) - (= 1 (logcount (ch-set-node-subnode-mask subnode))) + (= 0 (ch-map-node-entry-mask subnode)) + (= 1 (logcount (ch-map-node-subnode-mask subnode))) (consp (svref subnode (1- (length subnode))))) (setq subnode (svref subnode (1- (length subnode))))) (setf (svref res-n (- new-len (postincf res-isubnode) 1)) subnode) (logiorf res-subnodes (ash 1 idx)) (incf res-size (ch-map-tree-size subnode)) - (logxorf res-content-hash (ch-set-tree-hash-value subnode))) + (logxorf res-content-hash (ch-map-tree-hash-value subnode))) (map-tree-with (tree key value depth) (ch-map-tree-with tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) (do-bit-indices (idx everything) @@ -1297,27 +1399,41 @@ (defstruct (ch-map-node (let ((key (svref tree1 (+ ch-map-node-header-size (* 2 ientry1)))) ((val (svref tree1 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry1)))))))) (if (logbitp idx subnodes2) - (let ((subnode (svref tree2 (- (length tree2) (postincf isubnode2) 1)))) - (add-subnode idx (map-tree-with subnode key val (1+ depth)))) + (let ((subnode (svref tree2 (- (length tree2) (postincf isubnode2) 1))) + ;; &&& Here and several similar places, we're rehashing the key. + ((val2? val2 (ch-map-tree-lookup tree2 key key-hash-fn key-cmp-fn depth)))) + (add-subnode idx (map-tree-with subnode key (if val2? (funcall val-fn val val2) val) + (1+ depth)))) (add-entry idx key val)))) ((logbitp idx entries2) (let ((key (svref tree2 (+ ch-map-node-header-size (* 2 ientry2)))) ((val (svref tree2 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry2)))))))) (if (logbitp idx subnodes1) - (let ((subnode (svref tree1 (- (length tree1) (postincf isubnode1) 1)))) - (add-subnode idx (map-tree-with subnode key val (1+ depth)))) + (let ((subnode (svref tree1 (- (length tree1) (postincf isubnode1) 1))) + ((val1? val1 (ch-map-tree-lookup subnode key key-hash-fn key-cmp-fn depth)))) + (add-subnode idx (map-tree-with subnode key (if val1? (funcall val-fn val1 val) val) + (1+ depth)))) (add-entry idx key val)))) + ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) + (add-subnode idx (rec (svref tree1 (- (length tree1) (postincf isubnode1) 1)) + (svref tree2 (- (length tree2) (postincf isubnode2) 1)) + (1+ depth)))) ((logbitp idx subnodes1) (add-subnode idx (svref tree1 (- (length tree1) (postincf isubnode1) 1)))) ((logbitp idx subnodes2) (add-subnode idx (svref tree2 (- (length tree2) (postincf isubnode2) 1)))) (t (error "Bug in 'ch-map-tree-union'"))))) - (assert (= new-len (+ ch-map-node-header-size (* 2 res-ientry) res-isubnode))) - (setf (ch-map-node-entry-mask res-n) res-entries) - (setf (ch-map-node-subnode-mask res-n) res-subnodes) - (setf (ch-map-node-size res-n) res-size) - (setf (ch-map-node-hash-value res-n) res-content-hash) - res-n)))))) + ;; When two entries meet and become a subnode, we no longer need the value slot. Compact. + (let ((len-needed (+ ch-map-node-header-size (* 2 res-ientry) res-isubnode))) + (assert (>= new-len len-needed)) + (let ((extra (- new-len len-needed)) + ((res-n (if (= 0 extra) res-n + (vector-remove-n-at res-n (+ ch-map-node-header-size (* 2 res-ientry)) extra))))) + (setf (ch-map-node-entry-mask res-n) res-entries) + (setf (ch-map-node-subnode-mask res-n) res-subnodes) + (setf (ch-map-node-size res-n) res-size) + (setf (ch-map-node-hash-value res-n) res-content-hash) + res-n)))))))) (defmacro do-ch-map-tree-pairs ((key-var value-var tree-form &optional value-form) &body body) @@ -1331,14 +1447,12 @@ (defstruct (ch-map-node (if (consp tree) (do-wb-map-tree-pairs (,key-var ,value-var (cdr tree)) (,body-fn ,key-var ,value-var)) - (let ((entries (ch-map-node-entry-mask tree)) - (subnodes (ch-map-node-subnode-mask tree)))) - (progn - (dotimes (i (logcount )) + (let ((len (the fixnum (length (the simple-vector tree))))) + (dotimes (i (logcount (ch-map-node-entry-mask tree))) (let ((idx (+ (* 2 i) ch-map-node-header-size))) (,body-fn (svref tree idx) (svref tree (1+ idx))))) - (dotimes (i (logcount )) - (,recur-fn (svref tree (- (the fixnum (length tree)) 1 i))))))))) + (dotimes (i (logcount (ch-map-node-subnode-mask tree))) + (,recur-fn (svref tree (- len 1 i))))))))) (,recur-fn ,tree-form)) ,value-form))) diff --git a/Code/complement-sets.lisp b/Code/complement-sets.lisp index 6b9e465..5c0c58e 100644 --- a/Code/complement-sets.lisp +++ b/Code/complement-sets.lisp @@ -40,6 +40,8 @@ (defmethod complement ((cs complement-set)) (complement-set-complement cs)) (defun full-set () + "The set containing everything. It is a complement set, so it cannot be +enumerated, but certain other operations are defined on it." (make-complement-set (empty-set))) (defmethod contains? ((cs complement-set) x &optional (y nil y?)) diff --git a/Code/defs.lisp b/Code/defs.lisp index dc17f26..ecc8ebd 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -57,7 +57,7 @@ #:empty-wb-set #:empty-wb-bag #:empty-wb-map #:empty-wb-seq #:empty-dyn-tuple #:empty-ch-set #:empty-ch-map #:empty-replay-set #:empty-wb-replay-set #:empty-replay-map #:empty-wb-replay-map - #:least #:greatest #:lookup #:rank #:at-rank #:at-index #:@ + #:least #:greatest #:lookup #:rank #:at-rank #:index #:at-index #:@ #:with #:less #:split-from #:split-above #:split-through #:split-below #:union #:bag-sum #:intersection #:bag-product #:complement #:set-difference #:set-difference-2 #:bag-difference #:bag-pairs @@ -175,7 +175,7 @@ #:empty-set #:empty-bag #:empty-map #:empty-seq #:empty-tuple #:empty-wb-set #:empty-wb-bag #:empty-wb-map #:empty-wb-seq #:empty-dyn-tuple - #:least #:greatest #:lookup #:rank #:at-rank #:@ + #:least #:greatest #:lookup #:rank #:at-rank #:index #:at-index #:@ #:with #:less #:split-from #:split-above #:split-through #:split-below #:union #:bag-sum #:intersection #:bag-product #:complement #:set-difference #:set-difference-2 #:bag-difference #:bag-pairs diff --git a/Code/fset.lisp b/Code/fset.lisp index ab63f4b..4af0223 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -127,7 +127,9 @@ (defgeneric rank (collection value) (:documentation - "If `collection' is a set or bag that contains `value', returns the rank + "Defined on tree \(WB\) collections only. See `index'. + +If `collection' is a set or bag that contains `value', returns the rank of `value' in the ordering defined by `compare', and a true second value. If `collection' is a map whose domain contains `value', returns the rank of `value' in the domain of the map, and a true second value. If `value' is @@ -141,7 +143,9 @@ (defgeneric at-rank (collection rank) (:documentation - "On a set, returns the element with rank `rank'; on a bag, returns + "Defined on tree \(WB\) collections only. See `at-index'. + +On a set, returns the element with rank `rank'; on a bag, returns that element with its multiplicity as a second value; on a map, returns the pair with that rank as two values. Note that if there are values/keys that are unequal but equivalent in the collection, an arbitrary order will be @@ -152,6 +156,17 @@ based on the hash values, so it won't be predictable or usable for any other purpose, though it will be deterministic.")) +(defgeneric index (collection value) + (:documentation + "If `collection' contains `value' \(or for a map, if its domain does\), +returns the index of `value' in the collection's iteration order; otherwise +null. On `wb-set', `wb-map', and `wb-bag', the index is the same as the rank +\(see `rank'\).")) + +(defgeneric at-index (collection index) + (:documentation + "Returns the element/pair whose index in the iteration order is `index'.")) + (defgeneric with (collection value1 &optional value2) (:documentation "On a set, adds `value1' to it, returning the updated set. On a bag, adds @@ -170,6 +185,26 @@ at index `value1', if that index is in bounds, and shifts subsequent elements down, returning the updated seq.")) +(defgeneric split-from (collection value) + (:documentation + "Defined on tree \(WB\) collections only. Returns the subcollection with +elements/keys greater than or equal to `value'.")) + +(defgeneric split-above (collection value) + (:documentation + "Defined on tree \(WB\) collections only. Returns the subcollection with +elements/keys greater than `value'.")) + +(defgeneric split-through (collection value) + (:documentation + "Defined on tree \(WB\) collections only. Returns the subcollection with +elements/keys less than or equal to `value'.")) + +(defgeneric split-below (collection value) + (:documentation + "Defined on tree \(WB\) collections only. Returns the subcollection with +elements/keys less than `value'.")) + (defgeneric union (set-or-bag1 set-or-bag2 &key) (:documentation "Returns the union of the two sets/bags. The result is a set if both @@ -1621,6 +1656,13 @@ (define-wb-set-methods at-rank ((s wb-set) rank) :format-arguments (list rank s))) (WB-Set-Tree-Rank-Element contents rank))) +(defmethod index ((s wb-set) x) + (let ((rank found? (rank s x))) + (and found? rank))) + +(defmethod at-index ((s wb-set) idx) + (at-rank s idx)) + (define-wb-set-methods least ((s wb-set)) (let ((tree (contents s))) (if tree (values (WB-Set-Tree-Least tree) t) @@ -1808,6 +1850,14 @@ (define-wb-set-methods filter ((pred map) (s wb-set)) (setq result (WB-Set-Tree-With result x compare-fn)))) result)) +;;; A set is another kind of boolean-valued map. +(defmethod filter ((pred set) (s set)) + (intersection pred s)) + +;;; A bag is yet another kind of boolean-valued map. +(defmethod filter ((pred bag) (s set)) + (intersection pred s)) + (define-wb-set-methods partition ((pred function) (s wb-set)) (let ((res1 res2 (wb-set-partition pred (contents s) (compare-fn s)))) (values (make s res1) (make s res2)))) @@ -1831,14 +1881,6 @@ (define-wb-set-methods partition ((pred map) (s wb-set)) (setq result-2 (WB-Set-Tree-With result-2 x compare-fn)))) (values result-1 result-2))) -;;; A set is another kind of boolean-valued map. -(defmethod filter ((pred set) (s set)) - (intersection pred s)) - -;;; A bag is yet another kind of boolean-valued map. -(defmethod filter ((pred bag) (s set)) - (intersection pred s)) - (define-wb-set-methods image ((fn function) (s wb-set)) (make s (wb-set-image fn (contents s) (compare-fn s)))) @@ -2077,11 +2119,18 @@ (defmethod count-if-not (pred (s set) &key key) (gmap:def-gmap-res-type union (&key filterp) "Returns the union of the values, optionally filtered by `filterp'." - `((set) #'union nil ,filterp)) + ;; Written to take the implementation and organization from the first value. + `(nil #'(lambda (s x) (if (null s) x (union s x))) + #'(lambda (s) (or s (set))) + ,filterp)) (gmap:def-gmap-res-type intersection (&key filterp) - "Returns the intersection of the values, optionally filtered by `filterp'." - `((complement (set)) #'intersection nil ,filterp)) + "Returns the intersection of the values, optionally filtered by `filterp'. +\(If no values are supplied, returns the full set; see `full-set'.\)" + ;; Written to take the implementation and organization from the first value. + `(nil #'(lambda (s x) (if (null s) x (intersection s x))) + #'(lambda (s) (or s (full-set))) + ,filterp)) (defmethod make-load-form ((s wb-set) &optional environment) (declare (ignore environment)) @@ -2181,6 +2230,25 @@ (defmethod contains? ((s ch-set) x &optional (y nil y?)) (ch-set-tree-contains? (ch-set-contents s) x (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)))) +(defmethod lookup ((s ch-set) key) + (let ((hsorg (ch-set-org s))) + (ch-set-tree-contains? (ch-set-contents s) key (hash-set-org-hash-fn hsorg) + (hash-set-org-compare-fn hsorg)))) + +(defmethod index ((s ch-set) x) + (let ((hsorg (ch-set-org s))) + (ch-set-tree-index (ch-set-contents s) x (hash-set-org-hash-fn hsorg) + (hash-set-org-compare-fn hsorg)))) + +(defmethod at-index ((s ch-set) index) + (let ((contents (ch-set-contents s)) + ((size (ch-set-tree-size contents)))) + (unless (and (>= index 0) (< index size)) + (error 'simple-type-error :datum index :expected-type `(integer 0 (,size)) + :format-control "Index ~D out of bounds on ~A" + :format-arguments (list index s))) + (ch-set-tree-index-element contents index))) + (defmethod with ((s ch-set) value &optional (arg2 nil arg2?)) (declare (ignore arg2)) (check-two-arguments arg2? 'with 'ch-set) @@ -2267,15 +2335,6 @@ (defmethod image ((fn bag) (s ch-set)) (hash-set-org-compare-fn hsorg)))) (make-ch-set result hsorg))) -(defmethod at-rank ((s ch-set) index) - (let ((contents (ch-set-contents s)) - ((size (ch-set-tree-size contents)))) - (unless (and (>= index 0) (< index size)) - (error 'simple-type-error :datum index :expected-type `(integer 0 (,size)) - :format-control "Index ~D out of bounds on ~A" - :format-arguments (list index s))) - (ch-set-tree-index-element contents index))) - (defmethod hash-value ((s ch-set)) (ch-set-tree-hash-value (ch-set-contents s))) @@ -2297,7 +2356,7 @@ (defmethod compare ((s1 ch-set) (s2 ch-set)) (error "Can't compare ch-sets with uninterned compare-fn-names with same symbol-name")))))) (defmethod internal-do-set ((s ch-set) elt-fn value-fn) - (declare ;(optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) (do-ch-set-tree-members (x (ch-set-contents s) (funcall value-fn)) (funcall elt-fn x))) @@ -2305,6 +2364,11 @@ (defmethod internal-do-set ((s ch-set) elt-fn value-fn) (defmethod iterator ((s ch-set) &key) (make-ch-set-tree-iterator (ch-set-contents s))) +(defmethod fun-iterator ((s ch-set) &key from-end?) + (if from-end? + (ch-set-tree-rev-fun-iter (ch-set-contents s)) + (ch-set-tree-fun-iter (ch-set-contents s)))) + (defmethod convert ((to-type (eql 'ch-set)) (s set) &key compare-fn-name) (convert-to-ch-set s nil (let ((tree nil)) @@ -2351,21 +2415,11 @@ (defmethod convert ((to-type (eql 'ch-set)) (s sequence) &key compare-fn-name) (pprint-newline :linear stream) (write x :stream stream)))) -(gmap:def-gmap-res-type ch-set (&key filterp compare-fn-name) - "Returns a set of the values, optionally filtered by `filterp'. If -`compare-fn-name' is nonnull, it specifies a custom ordering." - (let ((proto-var (gensymx #:prototype-)) - (cfn-var (gensymx #:cfn-)) - (cf-var (gensymx #:cmp-))) - `(nil #'(lambda (s x) (ch-set-tree-with s x ,cf-var)) - #'(lambda (s) - (if (eq ,cf-var #'compare) - (make-ch-set s) - (make-wb-custom-set s (wb-custom-set-org ,proto-var)))) - ,filterp - ((,proto-var (empty-ch-set ,compare-fn-name)) - ((,cfn-var (hash-set-org-compare-fn-name (ch-set-org ,proto-var))) - (,cf-var (hash-set-org-compare-fn (ch-set-org ,proto-var)))))))) +;;; A bit faster than `set', if you know it's a `ch-set'. +(gmap:def-gmap-arg-type ch-set (set) + `((make-ch-set-tree-iterator-internal (ch-set-contents ,set)) + #'ch-set-tree-iterator-done? + #'ch-set-tree-iterator-get)) (gmap:def-gmap-res-type ch-set (&key filterp compare-fn-name) "Returns a set of the values, optionally filtered by `filterp'. If @@ -2491,6 +2545,13 @@ (defmethod at-rank ((s wb-bag) rank) :format-arguments (list rank s))) (WB-Bag-Tree-Rank-Pair contents rank))) +(defmethod index ((b wb-bag) x) + (let ((rank found? (rank b x))) + (and found? rank))) + +(defmethod at-index ((b wb-bag) idx) + (at-rank b idx)) + (defmethod least ((b wb-bag)) (let ((tree (wb-bag-contents b))) (if tree @@ -2532,6 +2593,30 @@ (defmethod less ((b wb-bag) value &optional (multiplicity 1)) multiplicity) (wb-bag-org b)))) +(defmethod split-from ((b wb-bag) value) + (let ((compare-fn (tree-set-org-compare-fn (wb-bag-org b))) + ((new-contents (WB-Bag-Tree-Split-Above (wb-bag-contents b) value compare-fn)))) + (make-wb-bag (if (< 0 (WB-Bag-Tree-Multiplicity (wb-bag-contents b) value compare-fn)) + (WB-Bag-Tree-With new-contents value compare-fn) + new-contents) + (wb-bag-org b)))) + +(defmethod split-above ((b wb-bag) value) + (make-wb-bag (WB-Bag-Tree-Split-Above (wb-bag-contents b) value (tree-set-org-compare-fn (wb-bag-org b))) + (wb-bag-org b))) + +(defmethod split-through ((b wb-bag) value) + (let ((compare-fn (tree-set-org-compare-fn (wb-bag-org b))) + ((new-contents (WB-Bag-Tree-Split-Below (wb-bag-contents b) value compare-fn)))) + (make-wb-bag (if (< 0 (WB-Bag-Tree-Multiplicity (wb-bag-contents b) value compare-fn)) + (WB-Bag-Tree-With new-contents value compare-fn) + new-contents) + (wb-bag-org b)))) + +(defmethod split-below ((b wb-bag) value) + (make-wb-bag (WB-Bag-Tree-Split-Below (wb-bag-contents b) value (tree-set-org-compare-fn (wb-bag-org b))) + (wb-bag-org b))) + (defmethod union ((b1 bag) (b2 bag) &key) "Fallback method for mixed implementations." (let ((result b1)) @@ -3382,6 +3467,13 @@ (defmethod at-rank ((m wb-map) rank) :format-arguments (list rank m))) (WB-Map-Tree-Rank-Pair contents rank))) +(defmethod index ((m wb-map) x) + (let ((rank found? (rank m x))) + (and found? rank))) + +(defmethod at-index ((m wb-map) idx) + (at-rank m idx)) + (defmethod with ((m wb-map) key &optional (value nil value?)) (check-three-arguments value? 'with 'wb-map) (let ((contents (wb-map-contents m)) @@ -3402,6 +3494,32 @@ (defmethod less ((m wb-map) key &optional (arg2 nil arg2?)) m (make-wb-map new-contents tmorg (map-default m))))) +(defmethod split-from ((m wb-map) key) + (let ((tmorg (wb-map-org m)) + ((key-compare-fn (tree-map-org-key-compare-fn tmorg)) + ((new-contents (WB-Map-Tree-Split-Above (wb-map-contents m) key key-compare-fn)) + (val? val (WB-Map-Tree-Lookup (wb-map-contents m) key key-compare-fn))))) + (make-wb-map (if val? (WB-Map-Tree-With new-contents key val key-compare-fn (tree-map-org-val-compare-fn tmorg)) + new-contents) + tmorg (map-default m)))) + +(defmethod split-above ((m wb-map) key) + (make-wb-map (WB-Map-Tree-Split-Above (wb-map-contents m) key (tree-map-org-key-compare-fn (wb-map-org m))) + (wb-map-org m) (map-default m))) + +(defmethod split-through ((m wb-map) key) + (let ((tmorg (wb-map-org m)) + ((key-compare-fn (tree-map-org-key-compare-fn tmorg)) + ((new-contents (WB-Map-Tree-Split-Below (wb-map-contents m) key key-compare-fn)) + (val? val (WB-Map-Tree-Lookup (wb-map-contents m) key key-compare-fn))))) + (make-wb-map (if val? (WB-Map-Tree-With new-contents key val key-compare-fn (tree-map-org-val-compare-fn tmorg)) + new-contents) + tmorg (map-default m)))) + +(defmethod split-below ((m wb-map) key) + (make-wb-map (WB-Map-Tree-Split-Below (wb-map-contents m) key (tree-map-org-key-compare-fn (wb-map-org m))) + (wb-map-org m) (map-default m))) + (defmethod domain ((m wb-map)) (let ((tmorg (wb-map-org m)) ((set-prototype (empty-wb-set (tree-map-org-key-compare-fn-name tmorg))))) @@ -3450,7 +3568,6 @@ (defmethod compare ((map1 wb-map) (map2 wb-map)) (defmethod internal-do-map ((m wb-map) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) - ;; Expect Python note about "can't use known return convention" (Do-WB-Map-Tree-Pairs (x y (wb-map-contents m) (funcall value-fn)) (funcall elt-fn x y))) @@ -4132,7 +4249,7 @@ (defmethod lookup ((m ch-map) key) ;; Our internal convention is the reverse of the external one. (values (if val? val (map-default m)) val?))) -(defmethod at-rank ((m ch-map) index) +(defmethod at-index ((m ch-map) index) (let ((contents (ch-map-contents m)) ((size (ch-map-tree-size contents)))) (unless (and (>= index 0) (< index size)) @@ -4157,7 +4274,7 @@ (defmethod map-union ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2) (call-next-method))) (defmethod internal-do-map ((m ch-map) elt-fn value-fn) - (declare ;(optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) (do-ch-map-tree-pairs (x y (ch-map-contents m) (funcall value-fn)) (funcall elt-fn x y))) @@ -4188,6 +4305,23 @@ (defmethod convert ((to-type (eql 'wb-map)) (m ch-map) &key key-compare-fn-name (let (#+sbcl (sb-pretty:*pprint-quote-with-syntactic-sugar* nil)) (write (list x y) :stream stream))))) +(gmap:def-gmap-res-type ch-map (&key filterp default key-compare-fn-name val-compare-fn-name) + "Consumes two values from the mapped function; returns a wb-map of the pairs. +Note that `filterp', if supplied, must take two arguments." + (let ((org-var (gensymx #:org-)) + (khf-var (gensymx #:key-hash-)) + (kcf-var (gensymx #:key-cmp-)) + (vhf-var (gensymx #:val-hash-)) + (vcf-var (gensymx #:val-cmp-))) + `(nil (:consume 2 (fn (tree k v) (ch-map-tree-with tree k v ,khf-var ,kcf-var ,vhf-var ,vcf-var))) + #'(lambda (tree) (make-ch-map tree ,org-var ,default)) + ,filterp + ((,org-var (ch-map-org (empty-ch-map nil ,key-compare-fn-name ,val-compare-fn-name))) + ((,khf-var (hash-map-org-key-hash-fn ,org-var)) + (,kcf-var (hash-map-org-key-compare-fn ,org-var)) + (,vhf-var (hash-map-org-val-hash-fn ,org-var)) + (,vcf-var (hash-map-org-val-compare-fn ,org-var))))))) + ;;; ================================================================================ ;;; Seqs diff --git a/Code/replay.lisp b/Code/replay.lisp index ef4cd04..aec47a9 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -93,6 +93,13 @@ (defmethod greatest ((s wb-replay-set)) (if tree (values (WB-Set-Tree-Greatest tree) t) (values nil nil)))) +(defmethod index ((s wb-replay-set) x) + (let ((idx 0) + (compare-fn (tree-set-org-compare-fn (wb-replay-set-org s)))) + (do-wb-set-tree-members (e (wb-replay-set-contents s)) + (when (equal?-cmp e x compare-fn) + (return idx))))) + (defmethod at-index ((m wb-replay-set) index) (let ((ordering (wb-replay-set-ordering m)) ((size (wb-seq-tree-size ordering)))) diff --git a/Code/swank.lisp b/Code/swank.lisp index b73cec4..198eec3 100644 --- a/Code/swank.lisp +++ b/Code/swank.lisp @@ -30,7 +30,7 @@ (defmethod swank::emacs-inspect ((s set)) (defmethod emacs-inspect-partial ((s set) lo hi) (append (if (<= hi (+ lo 32)) (gmap (:result append) - (fn (i) (swank::label-value-line i (at-rank s i))) + (fn (i) (swank::label-value-line i (at-index s i))) (:arg index lo hi)) ;; It may seem odd to start in the middle, but it lets you do binary search to get to ;; any element; starting at the beginning is much slower in many cases. @@ -88,7 +88,7 @@ (defmethod swank::emacs-inspect ((m map)) (defmethod emacs-inspect-partial ((m map) lo hi) (append (if (<= hi (+ lo 16)) (gmap (:result append) - (fn (i) (let ((k v (at-rank m i))) + (fn (i) (let ((k v (at-index m i))) (append (swank::label-value-line (format nil "Key ~D" i) k) (swank::label-value-line (format nil "Value ~D" i) v)))) (:arg index lo hi)) @@ -124,7 +124,7 @@ (defmethod swank::emacs-inspect ((b bag)) (defmethod emacs-inspect-partial ((b bag) lo hi) (append (if (<= hi (+ lo 16)) (gmap (:result append) - (fn (i) (let ((v m (at-rank b i))) + (fn (i) (let ((v m (at-index b i))) (append (swank::label-value-line (format nil "Value ~D" i) v) (swank::label-value-line (format nil "Count ~D" i) m)))) (:arg index lo hi)) @@ -153,7 +153,7 @@ (defmethod swank::emacs-inspect ((tup tuple)) (defmethod emacs-inspect-partial ((tup tuple) lo hi) (if (<= hi (+ lo 32)) (gmap (:result append) - (fn (i) (let ((k v (at-rank tup i))) + (fn (i) (let ((k v (at-index tup i))) (swank::label-value-line (format nil "~A~32T" (tuple-key-name k)) v))) (:arg index lo hi)) (let ((mid (floor (+ lo hi) 2)) diff --git a/Code/testing.lisp b/Code/testing.lisp index 3cb9b78..da2ddb9 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -3885,17 +3885,33 @@ (defmethod verify ((s ch-set)) (error "convert 'ch-set from seq failed")) (unless (equal? chs (convert 'ch-set (convert 'vector wbs))) (error "convert 'ch-set from vector failed")) - (let ((i 0) - (it (iterator chs))) + (let ((k 0) + (it (iterator chs)) + (f-it (fun-iterator chs))) (do-set (x chs) - (unless (equal? x (at-rank chs i)) - (error "ch-set at-rank failed")) - (incf i) + (unless (equal? x (at-index chs k)) + (error "ch-set at-index failed")) (unless (funcall it ':more?) (error "ch-set iterator exhausted")) - (let ((itval (funcall it ':get))) - (unless (and (funcall it ':more?) (equal? x itval)) - (error "ch-set iterator failed: ~A: ~A vs ~A" i x itval)))))))) + (when (funcall f-it ':empty?) + (error "ch-set fun-iterator exhausted")) + (let ((itval (funcall it ':get)) + (f-itval (funcall f-it ':first))) + (unless (equal? x itval) + (error "ch-set iterator failed: ~D: ~A vs ~A" k x itval)) + (unless (equal? x f-itval) + (error "ch-set fun-iterator failed: ~D: ~A vs ~A" k x f-itval))) + (unless (= (index chs x) k) + (error "ch-set index failed: ~D vs ~D" (index chs x) k)) + (incf k) + (setq f-it (funcall f-it ':rest))) + (unless (funcall it ':done?) + (error "ch-set iterator failed to terminate")) + (unless (funcall f-it ':empty?) + (error "ch-set fun-iterator failed to terminate"))) + (unless (equal? (reverse (convert 'seq chs)) + (gmap (:result seq) nil (:arg fun-sequence chs :from-end? t))) + (error "ch-set reverse fun-iterator failed"))))) (when saved-chs (let ((chs-union (union chs saved-chs))) (unless (verify chs-union) @@ -3913,6 +3929,8 @@ (defmethod verify ((s ch-set)) (defmethod verify ((m ch-map)) (ch-map-tree-verify (ch-map-contents m))) +(defvar *champ-map-test-pairs* (seq)) + (defun test-champ-maps (n) (declare (optimize (speed 0) (debug 3))) (let ((saved-wbm nil) @@ -3920,6 +3938,7 @@ (defmethod verify ((m ch-map)) (dotimes (i n) (let ((wbm (wb-map)) (chm (ch-map))) + (setq *champ-map-test-pairs* (seq)) (dotimes (j 256) (let ((mi (make-my-integer (random 1024))) (val (random 65536)) @@ -3929,12 +3948,14 @@ (defmethod verify ((m ch-map)) (error "ch-map lookup failed")) (if (< (random 100) 20) (progn + (push-last *champ-map-test-pairs* (list '- mi val)) (excludef wbm mi) (excludef chm mi) (unless (or (domain-contains? prev-wbm mi) (eq chm prev-chm)) (error "ch-map less failed to detect no change"))) (progn + (push-last *champ-map-test-pairs* (list '+ mi val)) (setf (@ wbm mi) val) (setf (@ chm mi) val))) (unless (verify chm) @@ -3947,8 +3968,11 @@ (defmethod verify ((m ch-map)) (let ((chm-union (map-union chm saved-chm))) (unless (verify chm-union) (error "ch-map union verification failed")) - (unless (equal? (convert 'wb-map chm-union) (map-union wbm saved-wbm)) - (error "ch-map union failed")))) + (let ((wbm-union (map-union wbm saved-wbm)) + ((chm-union-as-wbm (convert 'wb-map chm-union)))) + (unless (equal? chm-union-as-wbm wbm-union) + (let ((ch-only wb-only (map-difference-2 chm-union-as-wbm wbm-union))) + (error "ch-map union failed: ~A, ~A" ch-only wb-only)))))) (setq saved-wbm wbm) (setq saved-chm chm))))) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index e27beed..9b14f2f 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -45,6 +45,19 @@ (in-package :fset) +(defmacro equal?-fn (cmp-fn) + `(lambda (a b) (eq (funcall ,cmp-fn a b) ':equal))) + +(defmacro equal?-cmp (a b cmp-fn) + `(eq (funcall ,cmp-fn ,a ,b) ':equal)) + +(defmacro less-than?-cmp (a b cmp-fn) + `(eq (funcall ,cmp-fn ,a ,b) ':less)) + +(defmacro greater-than?-cmp (a b cmp-fn) + `(eq (funcall ,cmp-fn ,a ,b) ':greater)) + + ;;; ================================================================================ ;;; ================================================================================ ;;; Weight-balanced trees @@ -252,7 +265,7 @@ (defstruct (Equivalent-Node (:equal t) ((:unequal) (and (Equivalent-Node? node-val) - (member value (Equivalent-Node-List node-val) :test #'equal?))) + (member value (Equivalent-Node-List node-val) :test (equal?-fn cmp-fn)))) ((:less) (WB-Set-Tree-Member? (WB-Set-Tree-Node-Left tree) value cmp-fn)) ((:greater) @@ -279,18 +292,6 @@ (defstruct (Equivalent-Node ((:greater) (WB-Set-Tree-Find-Equivalent (WB-Set-Tree-Node-Right tree) value cmp-fn))))))) -(defmacro equal?-fn (cmp-fn) - `(lambda (a b) (eq (funcall ,cmp-fn a b) ':equal))) - -(defmacro equal?-cmp (a b cmp-fn) - `(eq (funcall ,cmp-fn ,a ,b) ':equal)) - -(defmacro less-than?-cmp (a b cmp-fn) - `(eq (funcall ,cmp-fn ,a ,b) ':less)) - -(defmacro greater-than?-cmp (a b cmp-fn) - `(eq (funcall ,cmp-fn ,a ,b) ':greater)) - (defun WB-Set-Tree-Find-Equal (tree value cmp-fn) "If `tree' contains a value equal to `value', returns (first value) true and \(second value) the value; otherwise `nil'." @@ -300,20 +301,19 @@ (defstruct (Equivalent-Node (cond ((null tree) nil) ((simple-vector-p tree) (let ((found? idx (Vector-Set-Binary-Search tree value cmp-fn))) - (and found? - (let ((v (svref tree idx))) - (and (equal?-cmp v value cmp-fn) - (values t (svref tree idx))))))) + (and (eq found? ':equal) + (values t (svref tree idx))))) (t (let ((node-val (WB-Set-Tree-Node-Value tree)) ((comp (funcall cmp-fn value node-val)))) (ecase comp - ((:equal :unequal) - (if (Equivalent-Node? node-val) - (let ((v (cl:find value (Equivalent-Node-List node-val) - :test (equal?-fn cmp-fn)))) - (and v (values t v))) - (values t node-val))) + (:equal (values t (if (Equivalent-Node? node-val) + (car (Equivalent-Node-List node-val)) + node-val))) + (:unequal + (and (Equivalent-Node? node-val) + (let ((mem (member value (Equivalent-Node-List node-val) :test (equal?-fn cmp-fn)))) + (and mem (values t (car mem)))))) ((:less) (WB-Set-Tree-Find-Equal (WB-Set-Tree-Node-Left tree) value cmp-fn)) ((:greater) @@ -1652,7 +1652,7 @@ (defstruct (Equivalent-Node (if (null node) (values nil nil) (progn - (incf (the fixnum (svref iter (1+ sp)))) + (setf (svref iter (1+ sp)) (1+ idx)) (WB-Set-Tree-Iterator-Canonicalize iter) (values (if (simple-vector-p node) (svref node idx) (let ((val (WB-Set-Tree-Node-Value node))) @@ -1665,13 +1665,13 @@ (defstruct (Equivalent-Node ;;; ---------------- ;;; Functional iterators. Fun!!! -(defun WB-Set-Tree-Fun-Iter (tree) +(defun WB-Set-Tree-Fun-Iter (tree &optional (cont (lambda (op) + (ecase op + (:first (values nil nil)) + (:empty? t) + (:more? nil))))) (declare (optimize (speed 3) (safety 0))) - (rlabels (walk tree (lambda (op) - (ecase op - (:first (values nil nil)) - (:empty? t) - (:more? nil)))) + (rlabels (walk tree cont) (walk (node cont) (cond ((null node) cont) @@ -1709,13 +1709,13 @@ (defstruct (Equivalent-Node (:empty? nil) (:more? t))))))))))) -(defun WB-Set-Tree-Rev-Fun-Iter (tree) +(defun WB-Set-Tree-Rev-Fun-Iter (tree &optional (cont (lambda (op) + (ecase op + (:first (values nil nil)) + (:empty? t) + (:more? nil))))) (declare (optimize (speed 3) (safety 0))) - (rlabels (walk tree (lambda (op) - (ecase op - (:first (values nil nil)) - (:empty? t) - (:more? nil)))) + (rlabels (walk tree cont) (walk (node cont) (cond ((null node) cont) @@ -2890,6 +2890,12 @@ (defstruct (WB-Bag-Tree-Node new-left new-right) (Make-Raw-WB-Set-Tree-Node size value new-left new-right)))))) +(defun WB-Bag-Tree-Split-Above (tree value cmp-fn) + (WB-Bag-Tree-Split tree value Hedge-Positive-Infinity cmp-fn)) + +(defun WB-Bag-Tree-Split-Below (tree value cmp-fn) + (WB-Bag-Tree-Split tree Hedge-Negative-Infinity value cmp-fn)) + ;;; ================================================================================ ;;; Support routines for the above (bags) @@ -5065,6 +5071,12 @@ (defstruct (WB-Map-Tree-Node (if (less-than?-cmp left-last right-last key-cmp-fn) right-last left-last)))))))) (recur len))) +(defun WB-Map-Tree-Split-Above (tree value cmp-fn) + (WB-Map-Tree-Split tree value Hedge-Positive-Infinity cmp-fn)) + +(defun WB-Map-Tree-Split-Below (tree value cmp-fn) + (WB-Map-Tree-Split tree Hedge-Negative-Infinity value cmp-fn)) + ;;; ================================================================================ ;;; Support routines for the above (maps) -- GitLab From dd4bb6a909e7eea38ea1450bf17ce80faa556101 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 14 Aug 2025 02:24:41 -0700 Subject: [PATCH 04/16] I think ch-sets are done! --- Code/champ.lisp | 544 ++++++++++++++++++++++++++++++--------------- Code/fset.lisp | 56 ++++- Code/macros.lisp | 13 +- Code/testing.lisp | 176 ++++++++------- Code/wb-trees.lisp | 6 +- 5 files changed, 510 insertions(+), 285 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index 1b2905e..b508ac2 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -13,11 +13,12 @@ #|| Our implementation differs slightly from the published CHAMP algorithm. It is agnostic as to the -number of bits in the hash values; it will use as many as are provided. A collision can be detected -at any level, when two members/keys hash to the same value but `equal?' is false on them. When that -happens, we fall back to using a WB-tree for those entries. The resulting collision node will be as -high in the tree as possible given that it can contain only keys with that hash value; this can -require pushing it down an arbitrary number of levels when adding a new key. +number of bits in the hash values; it will use as many as are provided, up to the fixnum size. A +collision can be detected at any level, when two members/keys hash to the same value but `equal?' +is false on them. When that happens, we fall back to using a WB-tree for those entries. The +resulting collision node will be as high in the tree as possible given that it can contain only +keys with that hash value; this can require pushing it down an arbitrary number of levels when +adding a new key. As Steindorfer recommends, we do go to the trouble to canonicalize on deletion, so that the shape of the tree is a function of the members/keys, i.e., is independent of how the tree was constructed. @@ -29,15 +30,18 @@ ;;; ================================================================================ ;;; Global constants -(defconstant champ-hash-bits-per-level 5) +(defconstant champ-hash-bits-per-level + ;; Drops to 4 on 32-bit implementations. + (min 5 (- (integer-length (1+ (* 2 (integer-length most-positive-fixnum)))) 2))) (defconstant champ-node-radix (ash 1 champ-hash-bits-per-level)) (defconstant champ-hash-level-mask (1- champ-node-radix)) +(deftype champ-bit-index () `(integer 0 ,(1- champ-node-radix))) (declaim (inline 1-bits-below)) (defun 1-bits-below (idx mask) "The number of 1 bits in `mask' at bit positions (strictly) less than `idx'." (declare (optimize (speed 3)) - (type (integer 0 #.(integer-length most-positive-fixnum)) idx) + (type champ-bit-index idx) (fixnum mask)) (logcount (logand (1- (the fixnum (ash 1 idx))) mask))) @@ -223,97 +227,92 @@ (defstruct (ch-set-node (setf (svref v (+ ins-idx i)) (svref vec (+ ins-idx i)))) v)) +(declaim (inline ch-set-tree-size)) (defun ch-set-tree-size (tree) (cond ((null tree) 0) ((consp tree) (wb-set-tree-size (cdr tree))) (t (ch-set-node-size tree)))) +(declaim (inline ch-set-tree-hash-value)) (defun ch-set-tree-hash-value (tree) (cond ((null tree) 0) - ((consp tree) (car tree)) + ((consp tree) (the fixnum (car tree))) (t (ch-set-node-hash-value tree)))) -(defun ch-set-tree-less (tree value hash-fn compare-fn) +(defun ch-set-tree-less (tree value hash-fn compare-fn &optional (depth 0)) ;(declare (optimize (speed 3) (safety 03))) (let ((value-hash (hash-to-fixnum value hash-fn))) (declare (fixnum value-hash)) - (rlabels (rec tree value-hash) + (rlabels (rec tree (ash value-hash (- (* champ-hash-bits-per-level depth)))) (rec (node hash-shifted) (declare (fixnum hash-shifted)) (and node - (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) - (entry-mask (ch-set-node-entry-mask node)) - ((entry-raw-idx (1-bits-below hash-bits entry-mask)) - ((entry-idx (+ ch-set-node-header-size entry-raw-idx)))) - (subnode-mask (ch-set-node-subnode-mask node))) - (if (logbitp hash-bits entry-mask) - (let ((ex-value (svref node entry-idx))) - (cond ((not (equal?-cmp ex-value value compare-fn)) - (values node 0)) - ((and (= (logcount entry-mask) 1) (= 0 subnode-mask)) - (values nil value-hash)) - (t - (let ((n (vector-remove-at node entry-idx))) - (logandc2f (ch-set-node-entry-mask n) (ash 1 hash-bits)) - (decf (ch-set-node-size n)) - (logxorf (ch-set-node-hash-value n) value-hash) - (values n value-hash))))) - (let ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) - ((subnode-idx (- (length node) 1 subnode-raw-idx)))) - (if (not (logbitp hash-bits subnode-mask)) + (if (consp node) + (let ((new-wb-tree (wb-set-tree-less (cdr node) value #'compare))) + (if (eq new-wb-tree (cdr node)) (values node 0) - (let ((subnode (svref node subnode-idx))) - (if (consp subnode) - (let ((new-wb-tree (wb-set-tree-less (cdr subnode) value #'compare))) - (if (eq new-wb-tree (cdr subnode)) - (values node 0) - (if (= 1 (wb-set-tree-size new-wb-tree)) - ;; Removing next-to-last entry of collision node: turn remaining value into entry - (let ((rem-val (wb-set-tree-arb new-wb-tree)) - ;; `entry-idx' is still valid from above; the hash bits must be the same - ((n (vector-ins-1-rem-1 node entry-idx rem-val subnode-idx)))) - (logiorf (ch-set-node-entry-mask n) (ash 1 hash-bits)) - (logandc2f (ch-set-node-subnode-mask n) (ash 1 hash-bits)) - (decf (ch-set-node-size n)) - (logxorf (ch-set-node-hash-value n) value-hash) - (values n value-hash)) - (let ((n (vector-update node subnode-idx - (cons (logxor (the fixnum (car subnode)) value-hash) - new-wb-tree)))) - (decf (ch-set-node-size n)) - (logxorf (ch-set-node-hash-value n) value-hash) - (values n value-hash))))) - (let ((new-subnode content-hash-delta - (rec subnode (ash hash-shifted (- champ-hash-bits-per-level))))) - (declare (fixnum content-hash-delta)) - (if (eq new-subnode subnode) - (values node 0) - (let ((n (cond ((null new-subnode) - (let ((n (vector-remove-at node subnode-idx))) - (logandc2f (ch-set-node-subnode-mask n) (ash 1 hash-bits)) - n)) - ((and (= 1 (logcount (ch-set-node-entry-mask new-subnode))) - (= 0 (ch-set-node-subnode-mask new-subnode))) - ;; New subnode contains only a single entry: pull it up into this node - (let ((new-entry-idx - (+ ch-set-node-header-size (1-bits-below hash-bits entry-mask))) - ((n (vector-ins-1-rem-1 node new-entry-idx - (svref new-subnode ch-set-node-header-size) - subnode-idx)))) - (logiorf (ch-set-node-entry-mask n) (ash 1 hash-bits)) - (logandc2f (ch-set-node-subnode-mask n) (ash 1 hash-bits)) - n)) - ((and (= 0 (ch-set-node-entry-mask new-subnode)) - (= 1 (logcount (ch-set-node-subnode-mask new-subnode))) - (consp (svref new-subnode ch-set-node-header-size))) - ;; New subnode contains only a collision node: pull it up into this node - (vector-update node subnode-idx - (svref new-subnode ch-set-node-header-size))) - (t (vector-update node subnode-idx new-subnode))))) - (decf (ch-set-node-size n)) - (logxorf (ch-set-node-hash-value n) content-hash-delta) - (values n content-hash-delta))))))))))))))) + (if (= 1 (wb-set-tree-size new-wb-tree)) + ;; Removing next-to-last entry of collision node: turn remaining value into entry + (let ((rem-val (wb-set-tree-arb new-wb-tree)) + (hash-bits (logand hash-shifted champ-hash-level-mask))) + (values (vector (ash 1 hash-bits) 0 1 value-hash rem-val) value-hash)) + (values (cons (logxor (the fixnum (car node)) value-hash) new-wb-tree) + value-hash)))) + (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) + (entry-mask (ch-set-node-entry-mask node)) + ((entry-raw-idx (1-bits-below hash-bits entry-mask)) + ((entry-idx (+ ch-set-node-header-size entry-raw-idx)))) + (subnode-mask (ch-set-node-subnode-mask node))) + (if (logbitp hash-bits entry-mask) + (let ((ex-value (svref node entry-idx))) + (cond ((not (equal?-cmp ex-value value compare-fn)) + (values node 0)) + ((and (= (logcount entry-mask) 1) (= 0 subnode-mask)) + (values nil value-hash)) + (t + (let ((n (vector-remove-at node entry-idx))) + (logandc2f (ch-set-node-entry-mask n) (ash 1 hash-bits)) + (decf (ch-set-node-size n)) + (logxorf (ch-set-node-hash-value n) value-hash) + (values n value-hash))))) + (let ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) + ((subnode-idx (- (length node) 1 subnode-raw-idx)))) + (if (not (logbitp hash-bits subnode-mask)) + (values node 0) + (let ((subnode (svref node subnode-idx)) + ((new-subnode content-hash-delta + (rec subnode (ash hash-shifted (- champ-hash-bits-per-level)))))) + (declare (fixnum content-hash-delta)) + (if (eq new-subnode subnode) + (values node 0) + (let ((n (cond ((null new-subnode) + (let ((n (vector-remove-at node subnode-idx))) + (logandc2f (ch-set-node-subnode-mask n) (ash 1 hash-bits)) + n)) + ((consp new-subnode) + (vector-update node subnode-idx new-subnode)) + ((and (= 1 (logcount (ch-set-node-entry-mask new-subnode))) + (= 0 (ch-set-node-subnode-mask new-subnode))) + ;; New subnode contains only a single entry: pull it up into this node + (let ((new-entry-idx + (+ ch-set-node-header-size (1-bits-below hash-bits entry-mask))) + ((n (vector-ins-1-rem-1 node new-entry-idx + (svref new-subnode ch-set-node-header-size) + subnode-idx)))) + (logiorf (ch-set-node-entry-mask n) (ash 1 hash-bits)) + (logandc2f (ch-set-node-subnode-mask n) (ash 1 hash-bits)) + n)) + ((and (= 0 (ch-set-node-entry-mask new-subnode)) + (= 1 (logcount (ch-set-node-subnode-mask new-subnode))) + (consp (svref new-subnode ch-set-node-header-size))) + ;; New subnode contains only a collision node: pull it up into this node + (vector-update node subnode-idx + (svref new-subnode ch-set-node-header-size))) + (t (vector-update node subnode-idx new-subnode))))) + (decf (ch-set-node-size n)) + (logxorf (ch-set-node-hash-value n) content-hash-delta) + (values n content-hash-delta)))))))))))))) (defun vector-ins-1-rem-1 (vec ins-idx ins-val rem-idx) (declare ;(optimize (speed 3) (safety 03)) @@ -351,7 +350,7 @@ (defstruct (ch-set-node (declare (fixnum hash-shifted)) (and node (if (consp node) - (wb-set-tree-member? (cdr node) value compare-fn) + (wb-set-tree-find-equal (cdr node) value compare-fn) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (entry-mask (ch-set-node-entry-mask node))) (if (logbitp hash-bits entry-mask) @@ -467,6 +466,52 @@ (defstruct (ch-set-node (return (rec subnode index))) (decf index subnode-size)))))))))) +(declaim (inline ch-set-add-entry)) +(defun ch-set-add-entry (n idx val hash-fn) + (declare (optimize (speed 3)) + (type champ-bit-index idx) + (type function hash-fn)) + (setf (svref n (+ ch-set-node-header-size (logcount (ch-set-node-entry-mask n)))) val) + (logiorf (ch-set-node-entry-mask n) (ash 1 idx)) + (incf (ch-set-node-size n)) + (logxorf (ch-set-node-hash-value n) (hash-to-fixnum val hash-fn))) + +(declaim (inline ch-set-add-subnode)) +(defun ch-set-add-subnode (n idx subnode hash-fn) + (declare (optimize (speed 3)) + (type champ-bit-index idx) + (type function hash-fn)) + (when subnode + (if (and (not (consp subnode)) + (= 1 (logcount (ch-set-node-entry-mask subnode))) + (= 0 (ch-set-node-subnode-mask subnode))) + ;; `subnode' contains only an entry -- pull it up. + (ch-set-add-entry n idx (svref subnode ch-set-node-header-size) hash-fn) + (progn + (when (and (not (consp subnode)) + (= 0 (ch-set-node-entry-mask subnode)) + (= 1 (logcount (ch-set-node-subnode-mask subnode))) + (consp (svref subnode (1- (length subnode))))) + ;; `subnode' contains only a collision subnode -- pull it up. + (setq subnode (svref subnode (1- (length subnode))))) + (setf (svref n (- (length (the simple-vector n)) + (logcount (ch-set-node-subnode-mask n)) 1)) + subnode) + (logiorf (ch-set-node-subnode-mask n) (ash 1 idx)) + (incf (ch-set-node-size n) (ch-set-tree-size subnode)) + (logxorf (ch-set-node-hash-value n) (ch-set-tree-hash-value subnode)))))) + +(defun ch-set-compact-node (n) + (declare (optimize (speed 3))) + (let ((entries (ch-set-node-entry-mask n)) + (subnodes (ch-set-node-subnode-mask n))) + (and (or (/= entries 0) (/= subnodes 0)) + (let ((len (length (the simple-vector n))) + (n-entries (logcount entries)) + ((extra (- len ch-set-node-header-size n-entries (logcount subnodes))))) + (if (= extra 0) n + (vector-remove-n-at n (+ ch-set-node-header-size n-entries) extra)))))) + (defun ch-set-tree-union (tree1 tree2 hash-fn compare-fn) (declare (optimize (speed 3) (safety 03)) (type function hash-fn compare-fn)) @@ -477,12 +522,12 @@ (defstruct (ch-set-node ((null tree2) tree1) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((tree-result (wb-set-tree-union (cdr tree1) (cdr tree2) compare-fn)) + (let ((result (wb-set-tree-union (cdr tree1) (cdr tree2) compare-fn)) (chash 0)) (declare (fixnum chash)) - (do-wb-set-tree-members (v tree-result) + (do-wb-set-tree-members (v result) (logxorf chash (hash-to-fixnum v hash-fn))) - (cons chash tree-result))) + (cons chash result))) ((or (consp tree1) (consp tree2)) (let ((collision-node normal-node (if (consp tree1) (values tree1 tree2) (values tree2 tree1)))) ;; Garbagey, but nontrivial to improve on, AFAICS. @@ -501,59 +546,36 @@ (defstruct (ch-set-node ;; But we do have to subtract out entry/subnode collisions. ((new-len (- (+ ch-set-node-header-size (logcount all-entries) (logcount all-subnodes)) (logcount (logand entries1 subnodes2)) (logcount (logand entries2 subnodes1)))) - ((n (make-array new-len)))))) + ((res-n (make-array new-len)))))) (ientry1 0) (isubnode1 0) (ientry2 0) - (isubnode2 0) - ;; About the result... - (entries 0) - (subnodes 0) - (ientry 0) - (isubnode 0) - (size 0) - (content-hash 0)) - (declare (fixnum entries subnodes size content-hash) - (type (integer 0 64) ientry1 isubnode1 ientry2 isubnode2 ientry isubnode)) + (isubnode2 0)) + (declare (type (integer 0 64) ientry1 isubnode1 ientry2 isubnode2)) (flet ((add-entry (idx val) - (declare (type (integer 0 32) idx)) - (setf (svref n (+ ch-set-node-header-size (postincf ientry))) val) - (logiorf entries (ash 1 idx)) - (incf size) - (logxorf content-hash (hash-to-fixnum val hash-fn))) + (ch-set-add-entry res-n idx val hash-fn)) (add-subnode (idx subnode) - (declare (type (integer 0 32) idx)) - ;; It's possible for `subnode' to contain only a collision subnode -- we must pull it up. - (when (and (not (consp subnode)) - (= 0 (ch-set-node-entry-mask subnode)) - (= 1 (logcount (ch-set-node-subnode-mask subnode))) - (consp (svref subnode (1- (length subnode))))) - (setq subnode (svref subnode (1- (length subnode))))) - (setf (svref n (- new-len (postincf isubnode) 1)) subnode) - (logiorf subnodes (ash 1 idx)) - (incf size (the fixnum (ch-set-tree-size subnode))) - (logxorf content-hash (the fixnum (ch-set-tree-hash-value subnode)))) - (set-tree-with (tree value depth) - (ch-set-tree-with tree value hash-fn compare-fn depth))) + (ch-set-add-subnode res-n idx subnode hash-fn)) + (set-tree-with (tree value) + (ch-set-tree-with tree value hash-fn compare-fn (1+ depth)))) (do-bit-indices (idx everything) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) (let ((val1 (svref tree1 (+ ch-set-node-header-size (postincf ientry1)))) (val2 (svref tree2 (+ ch-set-node-header-size (postincf ientry2))))) (if (equal?-cmp val1 val2 compare-fn) (add-entry idx val1) - (add-subnode idx (set-tree-with (set-tree-with nil val1 (1+ depth)) - val2 (1+ depth)))))) + (add-subnode idx (set-tree-with (set-tree-with nil val1) val2))))) ((logbitp idx entries1) (let ((val (svref tree1 (+ ch-set-node-header-size (postincf ientry1))))) (if (logbitp idx subnodes2) (let ((subnode (svref tree2 (- (length tree2) (postincf isubnode2) 1)))) - (add-subnode idx (set-tree-with subnode val (1+ depth)))) + (add-subnode idx (set-tree-with subnode val))) (add-entry idx val)))) ((logbitp idx entries2) (let ((val (svref tree2 (+ ch-set-node-header-size (postincf ientry2))))) (if (logbitp idx subnodes1) (let ((subnode (svref tree1 (- (length tree1) (postincf isubnode1) 1)))) - (add-subnode idx (set-tree-with subnode val (1+ depth)))) + (add-subnode idx (set-tree-with subnode val))) (add-entry idx val)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) (add-subnode idx (rec (svref tree1 (- (length tree1) (postincf isubnode1) 1)) @@ -564,24 +586,24 @@ (defstruct (ch-set-node ((logbitp idx subnodes2) (add-subnode idx (svref tree2 (- (length tree2) (postincf isubnode2) 1)))) (t (error "Bug in 'ch-set-tree-union'"))))) - (assert (= new-len (+ ch-set-node-header-size ientry isubnode))) - (setf (ch-set-node-entry-mask n) entries) - (setf (ch-set-node-subnode-mask n) subnodes) - (setf (ch-set-node-size n) size) - (setf (ch-set-node-hash-value n) content-hash) - n)))))) + res-n)))))) (defun ch-set-tree-intersection (tree1 tree2 hash-fn compare-fn) (declare (optimize (debug 3))) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) (cond ((or (null tree1) (null tree2)) nil) + ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((tree-result (wb-set-tree-intersect (cdr tree1) (cdr tree2) compare-fn)) + (let ((result (wb-set-tree-intersect (cdr tree1) (cdr tree2) compare-fn)) (chash 0)) - (do-wb-set-tree-members (v tree-result) + (do-wb-set-tree-members (v result) (logxorf chash (hash-to-fixnum v hash-fn))) - (cons chash tree-result))) + (case (wb-set-tree-size result) + (0 nil) + (1 (ch-set-tree-with nil (wb-set-tree-arb result) hash-fn compare-fn depth)) + (t (cons chash result))) + (cons chash result))) ((or (consp tree1) (consp tree2)) (let ((collision-node normal-node (if (consp tree1) (values tree1 tree2) (values tree2 tree1))) (result nil)) @@ -598,37 +620,13 @@ (defstruct (ch-set-node ;; Unlike in the union case, where we can compute the size in advance, for the intersection ;; we can only compute an upper bound -- the result could even be empty. ((new-len (min (length tree1) (length tree2))) - ((n (make-array new-len)))) - ;; About the result... - (entries 0) - (subnodes 0) - (ientry 0) - (isubnode 0) - (size 0) - (content-hash 0)) - (labels ((add-entry (idx val) - (setf (svref n (+ ch-set-node-header-size (postincf ientry))) val) - (logiorf entries (ash 1 idx)) - (incf size) - (logxorf content-hash (hash-to-fixnum val hash-fn))) - (add-subnode (idx subnode) - (when subnode - (if (and (not (consp subnode)) - (= 1 (logcount (ch-set-node-entry-mask subnode))) - (= 0 (ch-set-node-subnode-mask subnode))) - ;; `subnode' contains only an entry -- pull it up. - (add-entry idx (svref subnode ch-set-node-header-size)) - (progn - ;; `subnode' contains only a collision subnode -- pull it up. - (when (and (not (consp subnode)) - (= 0 (ch-set-node-entry-mask subnode)) - (= 1 (logcount (ch-set-node-subnode-mask subnode))) - (consp (svref subnode (1- (length subnode))))) - (setq subnode (svref subnode (1- (length subnode))))) - (setf (svref n (- new-len (postincf isubnode) 1)) subnode) - (logiorf subnodes (ash 1 idx)) - (incf size (ch-set-tree-size subnode)) - (logxorf content-hash (ch-set-tree-hash-value subnode))))))) + ((res-n (make-array new-len))))) + (flet ((add-entry (idx val) + (ch-set-add-entry res-n idx val hash-fn)) + (add-subnode (idx subnode) + (ch-set-add-subnode res-n idx subnode hash-fn)) + (subtree-contains? (tree val) + (ch-set-tree-contains? tree val hash-fn compare-fn (1+ depth)))) (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) (logand entries1 subnodes2) (logand subnodes1 entries2))) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) @@ -638,34 +636,219 @@ (defstruct (ch-set-node (add-entry idx val1)))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) (let ((val (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) - (when (ch-set-tree-contains? (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) - val hash-fn compare-fn (1+ depth)) + (when (subtree-contains? (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) + val) (add-entry idx val)))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) (let ((val (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) - (when (ch-set-tree-contains? (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) - val hash-fn compare-fn (1+ depth)) + (when (subtree-contains? (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) + val) (add-entry idx val)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) (add-subnode idx (rec (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) (1+ depth))))))) - ;; Returns `nil' if empty. - (and (or (/= 0 ientry) (/= 0 isubnode)) - (let ((extra (- new-len (+ ch-set-node-header-size ientry isubnode))) - ((n (if (= 0 extra) n - (vector-remove-n-at n (+ ch-set-node-header-size ientry) extra))))) - (setf (ch-set-node-entry-mask n) entries) - (setf (ch-set-node-subnode-mask n) subnodes) - (setf (ch-set-node-size n) size) - (setf (ch-set-node-hash-value n) content-hash) - n)))))))) + (ch-set-compact-node res-n))))))) + +(defun ch-set-tree-difference (tree1 tree2 hash-fn compare-fn) + (rlabels (rec tree1 tree2 0) + (rec (tree1 tree2 depth) + (cond ((null tree1) nil) + ((null tree2) tree1) + ((eq tree1 tree2) nil) + ((consp tree1) + (if (consp tree2) + (let ((result (wb-set-tree-diff (cdr tree1) (cdr tree2) compare-fn)) + (chash 0)) + (do-wb-set-tree-members (v result) + (logxorf chash (hash-to-fixnum v hash-fn))) + (cons chash result)) + (let ((result (cdr tree1)) + (chash (car tree1))) + ;; This could be improved by comparing hashes, but collision nodes will be vanishingly + ;; rare in practice anyway. Or should be... + (do-ch-set-tree-members (v tree2) + (let ((tmp (wb-set-tree-less result v compare-fn))) + (unless (eq tmp result) + (setq result tmp) + (logxorf chash (hash-to-fixnum v hash-fn))))) + (case (wb-set-tree-size result) + (0 nil) + (1 (ch-set-tree-with nil (wb-set-tree-arb result) hash-fn compare-fn depth)) + (t (cons chash result)))))) + ((consp tree2) + (do-wb-set-tree-members (v (cdr tree2)) + (setq tree1 (ch-set-tree-less tree1 v hash-fn compare-fn depth))) + tree1) + (t + (let ((entries1 (ch-set-node-entry-mask tree1)) + (entries2 (ch-set-node-entry-mask tree2)) + (subnodes1 (ch-set-node-subnode-mask tree1)) + (subnodes2 (ch-set-node-subnode-mask tree2)) + ((new-len (length (the simple-vector tree1))) ; upper bound + ((res-n (make-array new-len))))) + (flet ((add-entry (idx val) + (ch-set-add-entry res-n idx val hash-fn)) + (add-subnode (idx subnode) + (ch-set-add-subnode res-n idx subnode hash-fn))) + (do-bit-indices (idx (logior entries1 subnodes1)) + (cond ((logbitp idx entries1) + (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) + (cond ((logbitp idx entries2) + (let ((val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (unless (equal?-cmp val1 val2 compare-fn) + (add-entry idx val1)))) + ((logbitp idx subnodes2) + (let ((subnode (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)))) + (unless (ch-set-tree-contains? subnode val1 hash-fn compare-fn (1+ depth)) + (add-entry idx val1)))) + (t (add-entry idx val1))))) + ((logbitp idx subnodes1) + (let ((subnode1 (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)))) + (cond ((logbitp idx subnodes2) + (let ((subnode2 (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)))) + (add-subnode idx (rec subnode1 subnode2 (1+ depth))))) + ((logbitp idx entries2) + (let ((val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (add-subnode idx (ch-set-tree-less subnode1 val2 hash-fn compare-fn (1+ depth))))) + (t (add-subnode idx subnode1)))))))) + (ch-set-compact-node res-n))))))) + +(defun ch-set-tree-difference-2 (tree1 tree2 hash-fn compare-fn) + (declare (optimize (debug 3))) + (rlabels (rec tree1 tree2 0) + (rec (tree1 tree2 depth) + (cond ((null tree1) (values nil tree2)) + ((null tree2) (values tree1 nil)) + ((consp tree1) + (if (consp tree2) + (let ((result1 result2 (wb-set-tree-diff-2 (cdr tree1) (cdr tree2) compare-fn)) + (chash1 0) + (chash2 0)) + (do-wb-set-tree-members (v result1) + (logxorf chash1 (hash-to-fixnum v hash-fn))) + (do-wb-set-tree-members (v result2) + (logxorf chash2 (hash-to-fixnum v hash-fn))) + (values (cons chash1 result1) (cons chash2 result2))) + (let ((result1 (cdr tree1)) + (chash1 (car tree1))) + (do-ch-set-tree-members (v tree2) + (let ((tmp (wb-set-tree-less result1 v compare-fn))) + (unless (eq tmp result1) + (setq result1 tmp) + (logxorf chash1 (hash-to-fixnum v hash-fn))))) + (do-wb-set-tree-members (v (cdr tree1)) + (setq tree2 (ch-set-tree-less tree2 v hash-fn compare-fn depth))) + (values (case (wb-set-tree-size result1) + (0 nil) + (1 (ch-set-tree-with nil (wb-set-tree-arb result1) hash-fn compare-fn depth)) + (t (cons chash1 result1))) + tree2)))) + ((consp tree2) + (let ((res2 res1 (rec tree2 tree1 depth))) + (values res1 res2))) + (t + (let ((entries1 (ch-set-node-entry-mask tree1)) + (entries2 (ch-set-node-entry-mask tree2)) + (subnodes1 (ch-set-node-subnode-mask tree1)) + (subnodes2 (ch-set-node-subnode-mask tree2)) + ((new-len1 (length (the simple-vector tree1))) ; upper bound + ((res-n1 (make-array new-len1 :initial-element 0)))) + ((new-len2 (length (the simple-vector tree2))) + ((res-n2 (make-array new-len2 :initial-element 0))))) + (flet ((add-entry (n idx val) + (ch-set-add-entry n idx val hash-fn)) + (add-subnode (n idx subnode) + (ch-set-add-subnode n idx subnode hash-fn)) + (subtree-less (subtree val) + (ch-set-tree-less subtree val hash-fn compare-fn (1+ depth))) + (subtree-contains? (subtree val) + (ch-set-tree-contains? subtree val hash-fn compare-fn (1+ depth)))) + (do-bit-indices (idx (logior entries1 subnodes1 entries2 subnodes2)) + (cond ((logbitp idx entries1) + (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) + (cond ((logbitp idx entries2) + (let ((val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (unless (equal?-cmp val1 val2 compare-fn) + (add-entry res-n1 idx val1) + (add-entry res-n2 idx val2)))) + ((logbitp idx subnodes2) + (let ((subnode2 (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)))) + (unless (subtree-contains? subnode2 val1) + (add-entry res-n1 idx val1)) + (add-subnode res-n2 idx (subtree-less subnode2 val1)))) + (t (add-entry res-n1 idx val1))))) + ((logbitp idx subnodes1) + (let ((subnode1 (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)))) + (cond ((logbitp idx subnodes2) + (let ((subnode2 (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1))) + ((new-sn1 new-sn2 (rec subnode1 subnode2 (1+ depth))))) + (add-subnode res-n1 idx new-sn1) + (add-subnode res-n2 idx new-sn2))) + ((logbitp idx entries2) + (let ((val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (add-subnode res-n1 idx (subtree-less subnode1 val2)) + (unless (subtree-contains? subnode1 val2) + (add-entry res-n2 idx val2)))) + (t (add-subnode res-n1 idx subnode1))))) + ((logbitp idx entries2) + (add-entry res-n2 idx (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + ((logbitp idx subnodes2) + (add-subnode res-n2 idx (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)))) + (t (error "Bug in ch-set-tree-difference-2"))))) + (values (ch-set-compact-node res-n1) (ch-set-compact-node res-n2)))))))) + +(defun ch-set-tree-subset? (tree1 tree2 hash-fn compare-fn) + (declare (optimize (debug 3))) + (rlabels (rec tree1 tree2 0) + (rec (tree1 tree2 depth) + (cond ((null tree1) t) + ((null tree2) nil) + ((eq tree1 tree2) t) + ((and (consp tree1) (consp tree2)) + (wb-set-tree-subset? (cdr tree1) (cdr tree2) compare-fn)) + ((consp tree1) + (do-wb-set-tree-members (x (cdr tree1) t) + (unless (ch-set-tree-contains? tree2 x hash-fn compare-fn depth) + (return nil)))) + ((consp tree2) + (do-ch-set-tree-members (x tree1 t) + (unless (wb-set-tree-contains? (cdr tree2) x compare-fn) + (return nil)))) + (t + (let ((entries1 (ch-set-node-entry-mask tree1)) + (entries2 (ch-set-node-entry-mask tree2)) + (subnodes1 (ch-set-node-subnode-mask tree1)) + (subnodes2 (ch-set-node-subnode-mask tree2))) + (do-bit-indices (idx (logior entries1 subnodes1) + t) + (cond ((logbitp idx entries1) + (cond ((logbitp idx entries2) + (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1)))) + (val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (unless (equal?-cmp val1 val2 compare-fn) + (return nil)))) + ((logbitp idx subnodes2) + (let ((val (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) + (unless (ch-set-tree-contains? (svref tree2 (- (length tree2) + (1-bits-below idx subnodes2) 1)) + val hash-fn compare-fn (1+ depth)) + (return nil)))) + (t (return nil)))) + ((logbitp idx subnodes1) + (cond ((logbitp idx subnodes2) + (unless (rec (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) + (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) + (1+ depth)) + (return nil))) + (t (return nil)))))))))))) (defun ch-set-tree-disjoint? (tree1 tree2 hash-fn compare-fn) (declare (optimize (debug 3))) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) (cond ((or (null tree1) (null tree2)) t) + ((eq tree1 tree2) nil) ((and (consp tree1) (consp tree2)) (wb-set-tree-disjoint? (cdr tree1) (cdr tree2) compare-fn)) ((or (consp tree1) (consp tree2)) @@ -679,8 +862,7 @@ (defstruct (ch-set-node (entries2 (ch-set-node-entry-mask tree2)) (subnodes1 (ch-set-node-subnode-mask tree1)) (subnodes2 (ch-set-node-subnode-mask tree2))) - (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) - (logand entries1 subnodes2) (logand subnodes1 entries2)) + (do-bit-indices (idx (logand (logior entries1 subnodes1) (logior entries2 subnodes2)) t) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1)))) @@ -698,9 +880,10 @@ (defstruct (ch-set-node val hash-fn compare-fn (1+ depth)) (return nil)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) - (rec (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) - (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) - (1+ depth))))))))))) + (unless (rec (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) + (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) + (1+ depth)) + (return nil))))))))))) (defun vector-remove-n-at (vec idx n) (declare (optimize (speed 3) (safety 03)) @@ -1322,11 +1505,11 @@ (defstruct (ch-map-node ((null tree2) tree1) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((tree-result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn)) + (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn)) (chash 0)) - (do-wb-map-tree-pairs (k v tree-result) + (do-wb-map-tree-pairs (k v result) (logxorf chash (hash-to-fixnum k key-hash-fn) (hash-to-fixnum v val-hash-fn))) - (cons chash tree-result))) + (cons chash result))) ((consp tree1) (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) @@ -1400,7 +1583,6 @@ (defstruct (ch-map-node ((val (svref tree1 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry1)))))))) (if (logbitp idx subnodes2) (let ((subnode (svref tree2 (- (length tree2) (postincf isubnode2) 1))) - ;; &&& Here and several similar places, we're rehashing the key. ((val2? val2 (ch-map-tree-lookup tree2 key key-hash-fn key-cmp-fn depth)))) (add-subnode idx (map-tree-with subnode key (if val2? (funcall val-fn val val2) val) (1+ depth)))) diff --git a/Code/fset.lisp b/Code/fset.lisp index 4af0223..95cfe6b 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -1637,7 +1637,7 @@ (define-wb-set-methods arb ((s wb-set)) (define-wb-set-methods contains? ((s wb-set) x &optional (y nil y?)) (declare (ignore y)) (check-two-arguments y? 'contains? 'wb-set) - (WB-Set-Tree-Member? (contents s) x (compare-fn s))) + (WB-Set-Tree-Contains? (contents s) x (compare-fn s))) ;;; Note, first value is `t' or `nil'. (define-wb-set-methods lookup ((s wb-set) key) @@ -1693,7 +1693,7 @@ (define-wb-set-methods less ((s wb-set) value &optional (arg2 nil arg2?)) (define-wb-set-methods split-from ((s wb-set) value) (let ((new-contents (WB-Set-Tree-Split-Above (contents s) value (compare-fn s)))) - (make s (if (WB-Set-Tree-Member? (contents s) value (compare-fn s)) + (make s (if (WB-Set-Tree-Contains? (contents s) value (compare-fn s)) (WB-Set-Tree-With new-contents value (compare-fn s)) new-contents)))) @@ -1702,7 +1702,7 @@ (define-wb-set-methods split-above ((s wb-set) value) (define-wb-set-methods split-through ((s wb-set) value) (let ((new-contents (WB-Set-Tree-Split-Below (contents s) value (compare-fn s)))) - (make s (if (WB-Set-Tree-Member? (contents s) value (compare-fn s)) + (make s (if (WB-Set-Tree-Contains? (contents s) value (compare-fn s)) (WB-Set-Tree-With new-contents value (compare-fn s)) new-contents)))) @@ -2286,12 +2286,62 @@ (defmethod intersection ((s1 ch-set) (s2 ch-set) &key) hsorg) (call-next-method))) +(defmethod set-difference ((s1 ch-set) (s2 ch-set) &key) + (if-same-ch-set-orgs (s1 s2 hsorg) + (make-ch-set (ch-set-tree-difference (ch-set-contents s1) (ch-set-contents s2) + (hash-set-org-hash-fn hsorg) + (hash-set-org-compare-fn hsorg)) + hsorg) + (call-next-method))) + +(defmethod set-difference-2 ((s1 ch-set) (s2 ch-set)) + (if-same-ch-set-orgs (s1 s2 hsorg) + (let ((s1-diff-s2 s2-diff-s1 (ch-set-tree-difference-2 (ch-set-contents s1) (ch-set-contents s2) + (hash-set-org-hash-fn hsorg) + (hash-set-org-compare-fn hsorg)))) + (values (make-ch-set s1-diff-s2 hsorg) (make-ch-set s2-diff-s1 hsorg))) + (call-next-method))) + +(defmethod subset? ((s1 ch-set) (s2 ch-set)) + (if-same-ch-set-orgs (s1 s2 hsorg) + (ch-set-tree-subset? (ch-set-contents s1) (ch-set-contents s2) + (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)) + (call-next-method))) + (defmethod disjoint? ((s1 ch-set) (s2 ch-set)) (if-same-ch-set-orgs (s1 s2 hsorg) (ch-set-tree-disjoint? (ch-set-contents s1) (ch-set-contents s2) (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)) (call-next-method))) +(define-wb-set-methods partition ((pred function) (s ch-set)) + (let ((hsorg (ch-set-org s)) + ((res1 res2 (ch-set-partition pred (ch-set-contents s) hsorg)))) + (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) + +(defmethod partition ((pred symbol) (s ch-set)) + (let ((hsorg (ch-set-org s)) + ((res1 res2 (ch-set-partition (coerce-to-function pred) (ch-set-contents s) hsorg)))) + (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) + +(defmethod partition ((pred map) (s ch-set)) + (let ((hsorg (ch-set-org s)) + ((res1 res2 (ch-set-partition #'(lambda (x) (lookup pred x)) (ch-set-contents s) hsorg)))) + (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) + +(defun ch-set-partition (pred contents hsorg) + (declare (optimize (speed 3) (safety 0)) + (type function pred)) + (let ((result-1 nil) + (result-2 nil) + (hash-fn (hash-set-org-hash-fn hsorg)) + (compare-fn (hash-set-org-compare-fn hsorg))) + (do-ch-set-tree-members (x contents) + (if (funcall pred x) + (setq result-1 (ch-set-tree-with result-1 x hash-fn compare-fn)) + (setq result-2 (ch-set-tree-with result-2 x hash-fn compare-fn)))) + (values result-1 result-2))) + (defmethod filter ((pred function) (s ch-set)) (ch-set-filter pred s)) diff --git a/Code/macros.lisp b/Code/macros.lisp index 6c567b3..4c6bd18 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -19,15 +19,10 @@ (defmacro gensymx (arg) `(gensym (string ',arg))) -(defmacro postincf (place &optional (delta 1) &environment env) - (let ((vars vals store-vars setter getter (get-setf-expansion place env)) - (tmp (gensymx #:tmp-))) - `(let* (,@(mapcar #'list vars vals) - (,(car store-vars) ,getter) - (,tmp ,(car store-vars))) - (incf ,(car store-vars) ,delta) - ,setter - ,tmp))) +(defmacro postincf (place &optional (delta 1)) + ;; I used to do the `get-setf-expansion' thing and save the value in a local, but this + ;; seems to give better code, at least on SBCL. + `(1- (incf ,place ,delta))) ;;; ================================================================================ diff --git a/Code/testing.lisp b/Code/testing.lisp index da2ddb9..9221ebb 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -3835,96 +3835,94 @@ (defmethod verify ((s ch-set)) (defun test-champ-sets (n) (declare (optimize (speed 0) (debug 3))) - (let ((saved-wbs nil) - (saved-chs nil)) - (dotimes (i n) - (let ((wbs (wb-set)) - (chs (ch-set))) - (dotimes (j 256) - (let ((mi (make-my-integer (random 1024))) - (prev-wbs wbs) - (prev-chs chs)) - (unless (eqv (contains? chs mi) (contains? wbs mi)) - (error "ch-set contains? failed")) - (if (< (random 100) 20) + (macrolet ((test (form) + `(unless ,form + (error "Test failed: ~S" ',form)))) + (let ((saved-wbs nil) + (saved-chs nil)) + (dotimes (i n) + (let ((wbs (wb-set)) + (chs (ch-set))) + (dotimes (j 256) + (let ((mi (make-my-integer (random 1024))) + (prev-wbs wbs) + (prev-chs chs)) + (test (eqv (contains? chs mi) (contains? wbs mi))) + (if (< (random 100) 20) + (progn + (excludef wbs mi) + (excludef chs mi) + (unless (or (contains? prev-wbs mi) + (eq chs prev-chs)) + (error "ch-set less failed to detect no change"))) (progn - (excludef wbs mi) - (excludef chs mi) - (unless (or (contains? prev-wbs mi) - (eq chs prev-chs)) - (error "ch-set less failed to detect no change"))) - (progn - (includef wbs mi) - (includef chs mi))) - (unless (verify chs) - (error "ch-set verification failed")) - (let ((wbs-from-ch (convert 'wb-set chs))) - (unless (equal? wbs wbs-from-ch) - (error "ch-set convert 'wb-set or equal? failed"))) - (when (let ((quot rem (floor j 32))) - (and (= 0 rem) (>= quot 1))) - (let ((elts (wb-set))) - (dotimes (k (size chs)) - (includef elts (at-index chs k))) - (unless (equal? elts wbs) - (error "ch-set at-index failed"))) - (let ((idx (random (size chs))) - ((elt (at-index chs idx)) - ((tmp-chs (with (less chs elt) - ;; Adding 4096 doesn't change the hash value. - (make-my-integer (+ (my-integer-value elt) 4096))))))) - ;; `ch-set-tree-compare' is tough to test thoroughly. This at least checks the case that is - ;; least obviously correct by inspection, where all the hash values are the same but two elements - ;; nonetheless differ. - (unless (and (eq (compare chs tmp-chs) ':less) - (eq (compare tmp-chs chs) ':greater)) - (error "ch-set compare failed"))) - (unless (equal? chs (convert 'ch-set wbs)) - (error "convert 'ch-set or equal? failed")) - (unless (equal? chs (convert 'ch-set (convert 'seq wbs))) - (error "convert 'ch-set from seq failed")) - (unless (equal? chs (convert 'ch-set (convert 'vector wbs))) - (error "convert 'ch-set from vector failed")) - (let ((k 0) - (it (iterator chs)) - (f-it (fun-iterator chs))) - (do-set (x chs) - (unless (equal? x (at-index chs k)) - (error "ch-set at-index failed")) - (unless (funcall it ':more?) - (error "ch-set iterator exhausted")) - (when (funcall f-it ':empty?) - (error "ch-set fun-iterator exhausted")) - (let ((itval (funcall it ':get)) - (f-itval (funcall f-it ':first))) - (unless (equal? x itval) - (error "ch-set iterator failed: ~D: ~A vs ~A" k x itval)) - (unless (equal? x f-itval) - (error "ch-set fun-iterator failed: ~D: ~A vs ~A" k x f-itval))) - (unless (= (index chs x) k) - (error "ch-set index failed: ~D vs ~D" (index chs x) k)) - (incf k) - (setq f-it (funcall f-it ':rest))) - (unless (funcall it ':done?) - (error "ch-set iterator failed to terminate")) - (unless (funcall f-it ':empty?) - (error "ch-set fun-iterator failed to terminate"))) - (unless (equal? (reverse (convert 'seq chs)) - (gmap (:result seq) nil (:arg fun-sequence chs :from-end? t))) - (error "ch-set reverse fun-iterator failed"))))) - (when saved-chs - (let ((chs-union (union chs saved-chs))) - (unless (verify chs-union) - (error "ch-set union verification failed")) - (unless (equal? (convert 'wb-set chs-union) (union wbs saved-wbs)) - (error "ch-set union failed"))) - (let ((chs-intersection (intersection chs saved-chs))) - (unless (verify chs-intersection) - (error "ch-set intersection verification failed")) - (unless (equal? (convert 'wb-set chs-intersection) (intersection wbs saved-wbs)) - (error "ch-set intersection failed")))) - (setq saved-wbs wbs) - (setq saved-chs chs))))) + (includef wbs mi) + (includef chs mi))) + (test (verify chs)) + (let ((wbs-from-ch (convert 'wb-set chs))) + (unless (equal? wbs wbs-from-ch) + (error "ch-set convert 'wb-set or equal? failed"))) + (test (eqv (subset? chs prev-chs) (subset? wbs prev-wbs))) + (when (let ((quot rem (floor j 32))) + (and (= 0 rem) (>= quot 1))) + (let ((elts (wb-set))) + (dotimes (k (size chs)) + (includef elts (at-index chs k))) + (unless (equal? elts wbs) + (error "ch-set at-index failed"))) + (let ((idx (random (size chs))) + ((elt (at-index chs idx)) + ((tmp-chs (with (less chs elt) + ;; Adding 4096 doesn't change the hash value. + (make-my-integer (+ (my-integer-value elt) 4096))))))) + ;; `ch-set-tree-compare' is tough to test thoroughly. This at least checks the case that is + ;; least obviously correct by inspection, where all the hash values are the same but two elements + ;; nonetheless differ. + (test (and (eq (compare chs tmp-chs) ':less) + (eq (compare tmp-chs chs) ':greater)))) + (test (equal? chs (convert 'ch-set wbs))) + (test (equal? chs (convert 'ch-set (convert 'seq wbs)))) + (test (equal? chs (convert 'ch-set (convert 'vector wbs)))) + (let ((chs-p0 chs-p1 (partition (fn (x) (evenp (my-integer-value x))) chs)) + (wbs-p0 wbs-p1 (partition (fn (x) (evenp (my-integer-value x))) wbs))) + (test (equal? (convert 'wb-set chs-p0) wbs-p0)) + (test (equal? chs-p1 (convert 'ch-set wbs-p1)))) + (let ((k 0) + (it (iterator chs)) + (f-it (fun-iterator chs))) + (do-set (x chs) + (test (equal? x (at-index chs k))) + (test (funcall it ':more?)) + (test (not (funcall f-it ':empty?))) + (let ((itval (funcall it ':get)) + (f-itval (funcall f-it ':first))) + (test (equal? x itval)) + (test (equal? x f-itval))) + (test (= (index chs x) k)) + (incf k) + (setq f-it (funcall f-it ':rest))) + (test (funcall it ':done?)) + (test (funcall f-it ':empty?))) + (test (equal? (reverse (convert 'seq chs)) + (gmap (:result seq) nil (:arg fun-sequence chs :from-end? t))))))) + (when saved-chs + (test (eqv (disjoint? chs saved-chs) (disjoint? wbs saved-wbs))) + (let ((chs-union (union chs saved-chs))) + (test (verify chs-union)) + (test (equal? (convert 'wb-set chs-union) (union wbs saved-wbs)))) + (let ((chs-intersection (intersection chs saved-chs))) + (test (verify chs-intersection)) + (test (equal? (convert 'wb-set chs-intersection) (intersection wbs saved-wbs)))) + (let ((chs-diff (set-difference chs saved-chs))) + (test (verify chs-diff)) + (test (equal? (convert 'wb-set chs-diff) (set-difference wbs saved-wbs))) + (let ((chs-diff-2a chs-diff-2b (set-difference-2 chs saved-chs))) + (test (verify chs-diff-2a)) + (test (verify chs-diff-2b)) + (test (equal? chs-diff-2a chs-diff)) + (test (equal? chs-diff-2b (set-difference saved-chs chs)))))) + (setq saved-wbs wbs) + (setq saved-chs chs)))))) (defmethod verify ((m ch-map)) (ch-map-tree-verify (ch-map-contents m))) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index 9b14f2f..3b604e0 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -250,7 +250,7 @@ (defstruct (Equivalent-Node (car (cl:last (Equivalent-Node-List val))) val)))))) -(defun WB-Set-Tree-Member? (tree value cmp-fn) +(defun WB-Set-Tree-Contains? (tree value cmp-fn) "Returns true iff `value' is a member of `tree'." (declare (optimize (speed 3) (safety 0)) (type WB-Set-Tree tree) @@ -267,9 +267,9 @@ (defstruct (Equivalent-Node (and (Equivalent-Node? node-val) (member value (Equivalent-Node-List node-val) :test (equal?-fn cmp-fn)))) ((:less) - (WB-Set-Tree-Member? (WB-Set-Tree-Node-Left tree) value cmp-fn)) + (WB-Set-Tree-Contains? (WB-Set-Tree-Node-Left tree) value cmp-fn)) ((:greater) - (WB-Set-Tree-Member? (WB-Set-Tree-Node-Right tree) value cmp-fn))))))) + (WB-Set-Tree-Contains? (WB-Set-Tree-Node-Right tree) value cmp-fn))))))) (defun WB-Set-Tree-Find-Equivalent (tree value cmp-fn) "If `tree' contains one or more values equivalent to `value', returns (first -- GitLab From 4f5a9067a5371b8c926111758a4b74e503f01bfb Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Fri, 15 Aug 2025 15:56:19 -0700 Subject: [PATCH 05/16] Build fixes (mostly code rearrangement). --- Code/champ.lisp | 400 +++++++++++++++++++++++++----------------------- 1 file changed, 205 insertions(+), 195 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index b508ac2..51dfbb8 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -111,6 +111,19 @@ (defstruct (ch-set-node (hash-value 0 :type fixnum)) (defconstant ch-set-node-header-size 4) +(declaim (inline ch-set-tree-size)) +(defun ch-set-tree-size (tree) + (cond ((null tree) 0) + ((consp tree) + (wb-set-tree-size (cdr tree))) + (t (ch-set-node-size tree)))) + +(declaim (inline ch-set-tree-hash-value)) +(defun ch-set-tree-hash-value (tree) + (cond ((null tree) 0) + ((consp tree) (the fixnum (car tree))) + (t (ch-set-node-hash-value tree)))) + (defun ch-set-tree-with (tree value hash-fn compare-fn &optional (depth 0)) (declare (optimize (speed 3) (safety 03)) (type function hash-fn compare-fn) @@ -227,19 +240,6 @@ (defstruct (ch-set-node (setf (svref v (+ ins-idx i)) (svref vec (+ ins-idx i)))) v)) -(declaim (inline ch-set-tree-size)) -(defun ch-set-tree-size (tree) - (cond ((null tree) 0) - ((consp tree) - (wb-set-tree-size (cdr tree))) - (t (ch-set-node-size tree)))) - -(declaim (inline ch-set-tree-hash-value)) -(defun ch-set-tree-hash-value (tree) - (cond ((null tree) 0) - ((consp tree) (the fixnum (car tree))) - (t (ch-set-node-hash-value tree)))) - (defun ch-set-tree-less (tree value hash-fn compare-fn &optional (depth 0)) ;(declare (optimize (speed 3) (safety 03))) (let ((value-hash (hash-to-fixnum value hash-fn))) @@ -512,6 +512,195 @@ (defstruct (ch-set-node (if (= extra 0) n (vector-remove-n-at n (+ ch-set-node-header-size n-entries) extra)))))) +(defun vector-remove-n-at (vec idx n) + (declare (optimize (speed 3) (safety 03)) + (type simple-vector vec) + (type (unsigned-byte 24) idx n)) + (let ((len (length vec))) + (declare (type fixnum len)) + (let ((new-vec (make-array (- len n)))) + (dotimes (i idx) + (setf (svref new-vec i) (svref vec i))) + (dotimes (i (- len idx n)) + (setf (svref new-vec (+ idx i)) (svref vec (+ idx i n)))) + new-vec))) + + +;;; -------------------------------- +;;; Iteration primitives + +;;; This ordering has the slight downside that it can seem unstable; adding or removing an element +;;; can cause a different element to change places (because an entry becomes a subnode or conversely). +;;; But doing it hash-wise is noticeably slower, like a factor of 2 on a straightforward micro-benchmark. +(defmacro do-ch-set-tree-members ((value-var tree-form &optional value-form) + &body body) + (let ((body-fn (gensymx #:body-)) + (recur-fn (gensymx #:recur-))) + `(block nil + (labels ((,body-fn (,value-var) + . ,body) + (,recur-fn (tree) + (when tree + (if (consp tree) + (do-wb-set-tree-members (,value-var (cdr tree)) + (,body-fn ,value-var)) + (progn + (dotimes (i (logcount (ch-set-node-entry-mask tree))) + (,body-fn (svref tree (+ i ch-set-node-header-size)))) + (dotimes (i (logcount (ch-set-node-subnode-mask tree))) + (,recur-fn (svref tree (- (length tree) 1 i))))))))) + (declare (inline ,body-fn)) + (,recur-fn ,tree-form)) + ,value-form))) + +;;; ---------------- +;;; Stateful iterator + +(defun make-ch-set-tree-iterator (tree) + (let ((iter (make-ch-set-tree-iterator-internal tree))) + (lambda (op) + (ecase op + (:get (ch-set-tree-iterator-get iter)) + (:done? (ch-set-tree-iterator-done? iter)) + (:more? (not (ch-set-tree-iterator-done? iter))))))) + +(defun make-ch-set-tree-iterator-internal (tree) + ;; Unlike with the WB-trees, the maximum depth here is not a function of the set size. + (let ((iter (make-array (+ 1 (* 2 (ceiling (integer-length most-positive-fixnum) champ-hash-bits-per-level)))))) + (if (null tree) + (setf (svref iter 0) -1) + (progn + (setf (svref iter 0) 1) ; the stack pointer + (setf (svref iter 1) tree) + (setf (svref iter 2) 0) + (ch-set-tree-iterator-canonicalize iter))) + iter)) + +(defun ch-set-tree-iterator-canonicalize (iter) + (declare (optimize (speed 3) (safety 03))) + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (type (or null fixnum) idx)) + (when (if (null idx) + (wb-set-tree-iterator-done? (svref iter sp)) + (= idx (- (length (the simple-vector node)) ch-set-node-header-size))) + (decf sp 2) + (unless (< sp 0) + (setq node (svref iter sp)) + (setq idx (svref iter (1+ sp))))) + (unless (< sp 0) + (loop + (when (null idx) + (return)) + (let ((n-entries (logcount (ch-set-node-entry-mask node)))) + (when (< idx n-entries) + (return)) + (let ((len (length (the simple-vector node)))) + (setq node (svref node (- len (- idx n-entries) 1))) + (incf idx) + (unless (= idx (- len ch-set-node-header-size)) ; TCO + (setf (svref iter (1+ sp)) idx) + (incf sp 2)) + (if (consp node) + (setq node (make-wb-set-tree-iterator-internal (cdr node)) + idx nil) + (setq idx 0)) + (setf (svref iter sp) node) + (setf (svref iter (1+ sp)) idx))))) + (setf (svref iter 0) sp))) + +(defun ch-set-tree-iterator-done? (iter) + (declare (optimize (speed 3) (safety 03))) + (< (the fixnum (svref iter 0)) 0)) + +(defun ch-set-tree-iterator-get (iter) + (declare (optimize (speed 3) (safety 03))) + (let ((sp (svref iter 0))) + (declare (fixnum sp)) + (and (> sp 0) + (let ((node (svref iter sp)) + (idx (svref iter (1+ sp)))) + (declare (type (or null fixnum) idx)) + (if (null idx) + (let ((val (wb-set-tree-iterator-get node))) + (ch-set-tree-iterator-canonicalize iter) + (values val t)) + (progn + (setf (svref iter (1+ sp)) (1+ idx)) + (ch-set-tree-iterator-canonicalize iter) + (values (svref node (+ ch-set-node-header-size idx)) + t))))))) + +;;; ---------------- +;;; Functional iterator + +(defun ch-set-tree-fun-iter (tree) + (declare (optimize (speed 3) (safety 03))) + (rlabels (walk tree (lambda (op) + (ecase op + (:first (values nil nil)) + (:empty? t) + (:more? nil)))) + (walk (node cont) + (if (consp node) + (wb-set-tree-fun-iter (cdr node) cont) + (let ((n-entries (logcount (ch-set-node-entry-mask node))) + (n-subnodes (logcount (ch-set-node-subnode-mask node)))) + (rlabels (entry 0) + (entry (i) + (declare (fixnum i)) + (if (< i n-entries) + (lambda (op) + (ecase op + (:first (values (svref node (+ ch-set-node-header-size i)) t)) + (:rest (entry (1+ i))) + (:empty? nil) + (:more? t))) + (subnode 0))) + (subnode (i) + (declare (fixnum i)) + (if (< i n-subnodes) + (walk (svref node (- (+ ch-set-node-header-size n-entries n-subnodes) + i 1)) + (lambda (op) (funcall (the function (subnode (1+ i))) op))) + cont)))))))) + +(defun ch-set-tree-rev-fun-iter (tree) + (declare (optimize (speed 3) (safety 03))) + (rlabels (walk tree (lambda (op) + (ecase op + (:first (values nil nil)) + (:empty? t) + (:more? nil)))) + (walk (node cont) + (if (consp node) + (wb-set-tree-rev-fun-iter (cdr node) cont) + (let ((n-entries (logcount (ch-set-node-entry-mask node))) + (n-subnodes (logcount (ch-set-node-subnode-mask node)))) + (rlabels (subnode (1- n-subnodes)) + (entry (i) + (declare (fixnum i)) + (if (>= i 0) + (lambda (op) + (ecase op + (:first (values (svref node (+ ch-set-node-header-size i)) t)) + (:rest (entry (1- i))) + (:empty? nil) + (:more? t))) + cont)) + (subnode (i) + (declare (fixnum i)) + (if (>= i 0) + (walk (svref node (- (+ ch-set-node-header-size n-entries n-subnodes) + i 1)) + (lambda (op) (funcall (the function (subnode (1- i))) op))) + (entry (1- n-entries)))))))))) + + +;;; -------------------------------- +;;; Union, intersection, set-difference, subset?, disjoint? + (defun ch-set-tree-union (tree1 tree2 hash-fn compare-fn) (declare (optimize (speed 3) (safety 03)) (type function hash-fn compare-fn)) @@ -885,189 +1074,9 @@ (defstruct (ch-set-node (1+ depth)) (return nil))))))))))) -(defun vector-remove-n-at (vec idx n) - (declare (optimize (speed 3) (safety 03)) - (type simple-vector vec) - (type (unsigned-byte 24) idx n)) - (let ((len (length vec))) - (declare (type fixnum len)) - (let ((new-vec (make-array (- len n)))) - (dotimes (i idx) - (setf (svref new-vec i) (svref vec i))) - (dotimes (i (- len idx n)) - (setf (svref new-vec (+ idx i)) (svref vec (+ idx i n)))) - new-vec))) - ;;; -------------------------------- -;;; Iteration primitives - -;;; This ordering has the slight downside that it can seem unstable; adding or removing an element -;;; can cause a different element to change places (because an entry becomes a subnode or conversely). -;;; But doing it hash-wise is noticeably slower, like a factor of 2 on a straightforward micro-benchmark. -(defmacro do-ch-set-tree-members ((value-var tree-form &optional value-form) - &body body) - (let ((body-fn (gensymx #:body-)) - (recur-fn (gensymx #:recur-))) - `(block nil - (labels ((,body-fn (,value-var) - . ,body) - (,recur-fn (tree) - (when tree - (if (consp tree) - (do-wb-set-tree-members (,value-var (cdr tree)) - (,body-fn ,value-var)) - (progn - (dotimes (i (logcount (ch-set-node-entry-mask tree))) - (,body-fn (svref tree (+ i ch-set-node-header-size)))) - (dotimes (i (logcount (ch-set-node-subnode-mask tree))) - (,recur-fn (svref tree (- (length tree) 1 i))))))))) - (,recur-fn ,tree-form)) - ,value-form))) - -;;; ---------------- -;;; Stateful iterator - -(defun make-ch-set-tree-iterator (tree) - (let ((iter (make-ch-set-tree-iterator-internal tree))) - (lambda (op) - (ecase op - (:get (ch-set-tree-iterator-get iter)) - (:done? (ch-set-tree-iterator-done? iter)) - (:more? (not (ch-set-tree-iterator-done? iter))))))) - -(defun make-ch-set-tree-iterator-internal (tree) - ;; Unlike with the WB-trees, the maximum depth here is not a function of the set size. - (let ((iter (make-array (+ 1 (* 2 (ceiling (integer-length most-positive-fixnum) champ-hash-bits-per-level)))))) - (if (null tree) - (setf (svref iter 0) -1) - (progn - (setf (svref iter 0) 1) ; the stack pointer - (setf (svref iter 1) tree) - (setf (svref iter 2) 0) - (ch-set-tree-iterator-canonicalize iter))) - iter)) - -(defun ch-set-tree-iterator-canonicalize (iter) - (declare (optimize (speed 3) (safety 03))) - (let ((sp (svref iter 0)) - ((node (svref iter sp)) - (idx (svref iter (1+ sp))))) - (declare (type (or null fixnum) idx)) - (when (if (null idx) - (wb-set-tree-iterator-done? (svref iter sp)) - (= idx (- (length (the simple-vector node)) ch-set-node-header-size))) - (decf sp 2) - (unless (< sp 0) - (setq node (svref iter sp)) - (setq idx (svref iter (1+ sp))))) - (unless (< sp 0) - (loop - (when (null idx) - (return)) - (let ((n-entries (logcount (ch-set-node-entry-mask node)))) - (when (< idx n-entries) - (return)) - (let ((len (length (the simple-vector node)))) - (setq node (svref node (- len (- idx n-entries) 1))) - (incf idx) - (unless (= idx (- len ch-set-node-header-size)) ; TCO - (setf (svref iter (1+ sp)) idx) - (incf sp 2)) - (if (consp node) - (setq node (make-wb-set-tree-iterator-internal (cdr node)) - idx nil) - (setq idx 0)) - (setf (svref iter sp) node) - (setf (svref iter (1+ sp)) idx))))) - (setf (svref iter 0) sp))) - -(defun ch-set-tree-iterator-done? (iter) - (declare (optimize (speed 3) (safety 03))) - (< (the fixnum (svref iter 0)) 0)) - -(defun ch-set-tree-iterator-get (iter) - (declare (optimize (speed 3) (safety 03))) - (let ((sp (svref iter 0))) - (declare (fixnum sp)) - (and (> sp 0) - (let ((node (svref iter sp)) - (idx (svref iter (1+ sp)))) - (declare (type (or null fixnum) idx)) - (if (null idx) - (let ((val (wb-set-tree-iterator-get node))) - (ch-set-tree-iterator-canonicalize iter) - (values val t)) - (progn - (setf (svref iter (1+ sp)) (1+ idx)) - (ch-set-tree-iterator-canonicalize iter) - (values (svref node (+ ch-set-node-header-size idx)) - t))))))) - -;;; ---------------- -;;; Functional iterator - -(defun ch-set-tree-fun-iter (tree) - (declare (optimize (speed 3) (safety 03))) - (rlabels (walk tree (lambda (op) - (ecase op - (:first (values nil nil)) - (:empty? t) - (:more? nil)))) - (walk (node cont) - (if (consp node) - (wb-set-tree-fun-iter (cdr node) cont) - (let ((n-entries (logcount (ch-set-node-entry-mask node))) - (n-subnodes (logcount (ch-set-node-subnode-mask node)))) - (rlabels (entry 0) - (entry (i) - (declare (fixnum i)) - (if (< i n-entries) - (lambda (op) - (ecase op - (:first (values (svref node (+ ch-set-node-header-size i)) t)) - (:rest (entry (1+ i))) - (:empty? nil) - (:more? t))) - (subnode 0))) - (subnode (i) - (declare (fixnum i)) - (if (< i n-subnodes) - (walk (svref node (- (+ ch-set-node-header-size n-entries n-subnodes) - i 1)) - (lambda (op) (funcall (the function (subnode (1+ i))) op))) - cont)))))))) - -(defun ch-set-tree-rev-fun-iter (tree) - (declare (optimize (speed 3) (safety 03))) - (rlabels (walk tree (lambda (op) - (ecase op - (:first (values nil nil)) - (:empty? t) - (:more? nil)))) - (walk (node cont) - (if (consp node) - (wb-set-tree-rev-fun-iter (cdr node) cont) - (let ((n-entries (logcount (ch-set-node-entry-mask node))) - (n-subnodes (logcount (ch-set-node-subnode-mask node)))) - (rlabels (subnode (1- n-subnodes)) - (entry (i) - (declare (fixnum i)) - (if (>= i 0) - (lambda (op) - (ecase op - (:first (values (svref node (+ ch-set-node-header-size i)) t)) - (:rest (entry (1- i))) - (:empty? nil) - (:more? t))) - cont)) - (subnode (i) - (declare (fixnum i)) - (if (>= i 0) - (walk (svref node (- (+ ch-set-node-header-size n-entries n-subnodes) - i 1)) - (lambda (op) (funcall (the function (subnode (1- i))) op))) - (entry (1- n-entries)))))))))) +;;; Verifier (defun ch-set-tree-verify (tree hash-fn) (declare (optimize (debug 3))) @@ -1445,7 +1454,7 @@ (defstruct (ch-map-node (setf (svref v (+ ins-idx i 2)) (svref vec (+ ins-idx i)))) (dotimes (i (- len rem-idx 1)) (declare (fixnum i)) - (setf (svref v (+ rem-idx i 2)) (svref vec (+ rem-idx i 1)))) + (setf (svref v (the fixnum (+ rem-idx i 2))) (svref vec (+ rem-idx i 1)))) v)) (defun ch-map-tree-lookup (tree key key-hash-fn key-cmp-fn &optional (depth 0)) @@ -1635,6 +1644,7 @@ (defstruct (ch-map-node (,body-fn (svref tree idx) (svref tree (1+ idx))))) (dotimes (i (logcount (ch-map-node-subnode-mask tree))) (,recur-fn (svref tree (- len 1 i))))))))) + (declare (inline ,body-fn)) (,recur-fn ,tree-form)) ,value-form))) -- GitLab From 1805f3475f1afc3a99a389c4083558674a6a62e3 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Wed, 27 Aug 2025 20:54:16 -0700 Subject: [PATCH 06/16] Use fixnum addition rather than XOR for combining hashes... ... on most platforms, anyway. --- Code/champ.lisp | 164 +++++++++++++++++++++------------------------- Code/port.lisp | 38 +++++++++++ Code/testing.lisp | 7 +- 3 files changed, 120 insertions(+), 89 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index 51dfbb8..11a76c1 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -30,11 +30,13 @@ ;;; ================================================================================ ;;; Global constants -(defconstant champ-hash-bits-per-level - ;; Drops to 4 on 32-bit implementations. - (min 5 (- (integer-length (1+ (* 2 (integer-length most-positive-fixnum)))) 2))) -(defconstant champ-node-radix (ash 1 champ-hash-bits-per-level)) -(defconstant champ-hash-level-mask (1- champ-node-radix)) +;;; `eval-when' needed in Allegro to make the `deftype' work. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant champ-hash-bits-per-level + ;; Drops to 4 on 32-bit implementations. + (min 5 (- (integer-length (1+ (* 2 (integer-length most-positive-fixnum)))) 2))) + (defconstant champ-node-radix (ash 1 champ-hash-bits-per-level)) + (defconstant champ-hash-level-mask (1- champ-node-radix))) (deftype champ-bit-index () `(integer 0 ,(1- champ-node-radix))) (declaim (inline 1-bits-below)) @@ -67,21 +69,6 @@ (push i result)))) -;;; Proclaiming a generic function to return a specific type doesn't stick -- at least on SBCL, -;;; recompiling a method removes the type. -(defun hash-value-fixnum (x) - (let ((h (hash-value x))) - (if (typep h 'fixnum) - h - ;; Anyway, using this wrapper lets us force the hash to be a fixnum. - (let ((len (integer-length h)) - (fixnum-len (integer-length most-positive-fixnum)) - (fh 0)) - (dotimes (i (ceiling len fixnum-len)) - (logxorf fh (ldb (byte fixnum-len (* fixnum-len i)) h))) - fh)))) -(declaim (ftype (function (t) fixnum) hash-value-fixnum)) - (defmacro hash-to-fixnum (val hash-fn) `(let ((h (funcall ,hash-fn ,val))) (if (typep h 'fixnum) @@ -93,7 +80,7 @@ (fixnum-len (integer-length most-positive-fixnum)) (fh 0)) (dotimes (i (ceiling len fixnum-len)) - (logxorf fh (ldb (byte fixnum-len (* fixnum-len i)) h))) + (mix-hashf fh (ldb (byte fixnum-len (* fixnum-len i)) h))) (if (< h 0) (- fh) fh))) (declaim (ftype (function (t) fixnum) squash-bignum-hash)) @@ -150,15 +137,14 @@ (defstruct (ch-set-node (if (eq new-wb-tree (cdr node)) node ;; New entry in collision node - (cons (logxor (the fixnum (car node)) value-hash) - new-wb-tree))) + (cons (mix-hash (car node) value-hash) new-wb-tree))) ;; Oh, this is fun. We add enough levels to get to where the hashes differ. (rlabels (build hash-shifted wb-hash-shifted) (build (hash-shifted wb-hash-shifted) (declare (fixnum hash-shifted wb-hash-shifted)) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask)) - (content-hash (logxor (the fixnum (car node)) value-hash))) + (content-hash (mix-hash (car node) value-hash))) (if (= hash-bits wb-hash-bits) (vector 0 (ash 1 hash-bits) size content-hash (build (ash hash-shifted (- champ-hash-bits-per-level)) @@ -184,7 +170,7 @@ (defstruct (ch-set-node ((ex-value-hash-shifted (ash ex-value-hash (* (- champ-hash-bits-per-level) (1+ depth)))) ((n2 (if (= hash-shifted ex-value-hash-shifted) ;; Collision! Fall back to WB-tree. - (cons (logxor value-hash ex-value-hash) + (cons (mix-hash value-hash ex-value-hash) (wb-set-tree-with (wb-set-tree-with nil ex-value compare-fn) value compare-fn)) ;; Creates a little garbage; &&& hand-integrate later. @@ -197,7 +183,7 @@ (defstruct (ch-set-node (logandc2f (ch-set-node-entry-mask n) (ash 1 hash-bits)) (logiorf (ch-set-node-subnode-mask n) (ash 1 hash-bits)) (incf (ch-set-node-size n)) - (logxorf (ch-set-node-hash-value n) value-hash) + (mix-hashf (ch-set-node-hash-value n) value-hash) n))) ;; No entry found: check for subnode (if (logbitp hash-bits subnode-mask) @@ -211,14 +197,14 @@ (defstruct (ch-set-node (setf (ch-set-node-size n) (the fixnum (+ (ch-set-node-size n) (- (the fixnum (ch-set-tree-size new-subnode)) (the fixnum (ch-set-tree-size subnode)))))) - (logxorf (ch-set-node-hash-value n) (the fixnum (ch-set-tree-hash-value subnode)) - (the fixnum (ch-set-tree-hash-value new-subnode))) + (mix-hashf (ch-set-node-hash-value n) (unmix-hash (ch-set-tree-hash-value new-subnode) + (ch-set-tree-hash-value subnode))) n))) ;; Neither entry nor subnode found: make new entry (let ((n (vector-insert node entry-idx value))) (logiorf (ch-set-node-entry-mask n) (ash 1 hash-bits)) (incf (ch-set-node-size n)) - (logxorf (ch-set-node-hash-value n) value-hash) + (mix-hashf (ch-set-node-hash-value n) value-hash) n))))))))))) (defun vector-rem-1-ins-1 (vec rem-idx ins-idx ins-val) @@ -257,7 +243,7 @@ (defstruct (ch-set-node (let ((rem-val (wb-set-tree-arb new-wb-tree)) (hash-bits (logand hash-shifted champ-hash-level-mask))) (values (vector (ash 1 hash-bits) 0 1 value-hash rem-val) value-hash)) - (values (cons (logxor (the fixnum (car node)) value-hash) new-wb-tree) + (values (cons (unmix-hash (car node) value-hash) new-wb-tree) value-hash)))) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (entry-mask (ch-set-node-entry-mask node)) @@ -274,7 +260,7 @@ (defstruct (ch-set-node (let ((n (vector-remove-at node entry-idx))) (logandc2f (ch-set-node-entry-mask n) (ash 1 hash-bits)) (decf (ch-set-node-size n)) - (logxorf (ch-set-node-hash-value n) value-hash) + (unmix-hashf (ch-set-node-hash-value n) value-hash) (values n value-hash))))) (let ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) ((subnode-idx (- (length node) 1 subnode-raw-idx)))) @@ -311,7 +297,7 @@ (defstruct (ch-set-node (svref new-subnode ch-set-node-header-size))) (t (vector-update node subnode-idx new-subnode))))) (decf (ch-set-node-size n)) - (logxorf (ch-set-node-hash-value n) content-hash-delta) + (unmix-hashf (ch-set-node-hash-value n) content-hash-delta) (values n content-hash-delta)))))))))))))) (defun vector-ins-1-rem-1 (vec ins-idx ins-val rem-idx) @@ -474,7 +460,7 @@ (defstruct (ch-set-node (setf (svref n (+ ch-set-node-header-size (logcount (ch-set-node-entry-mask n)))) val) (logiorf (ch-set-node-entry-mask n) (ash 1 idx)) (incf (ch-set-node-size n)) - (logxorf (ch-set-node-hash-value n) (hash-to-fixnum val hash-fn))) + (mix-hashf (ch-set-node-hash-value n) (hash-to-fixnum val hash-fn))) (declaim (inline ch-set-add-subnode)) (defun ch-set-add-subnode (n idx subnode hash-fn) @@ -499,7 +485,7 @@ (defstruct (ch-set-node subnode) (logiorf (ch-set-node-subnode-mask n) (ash 1 idx)) (incf (ch-set-node-size n) (ch-set-tree-size subnode)) - (logxorf (ch-set-node-hash-value n) (ch-set-tree-hash-value subnode)))))) + (mix-hashf (ch-set-node-hash-value n) (ch-set-tree-hash-value subnode)))))) (defun ch-set-compact-node (n) (declare (optimize (speed 3))) @@ -715,7 +701,7 @@ (defstruct (ch-set-node (chash 0)) (declare (fixnum chash)) (do-wb-set-tree-members (v result) - (logxorf chash (hash-to-fixnum v hash-fn))) + (mix-hashf chash (hash-to-fixnum v hash-fn))) (cons chash result))) ((or (consp tree1) (consp tree2)) (let ((collision-node normal-node (if (consp tree1) (values tree1 tree2) (values tree2 tree1)))) @@ -735,7 +721,7 @@ (defstruct (ch-set-node ;; But we do have to subtract out entry/subnode collisions. ((new-len (- (+ ch-set-node-header-size (logcount all-entries) (logcount all-subnodes)) (logcount (logand entries1 subnodes2)) (logcount (logand entries2 subnodes1)))) - ((res-n (make-array new-len)))))) + ((res-n (make-array new-len :initial-element 0)))))) (ientry1 0) (isubnode1 0) (ientry2 0) @@ -787,7 +773,7 @@ (defstruct (ch-set-node (let ((result (wb-set-tree-intersect (cdr tree1) (cdr tree2) compare-fn)) (chash 0)) (do-wb-set-tree-members (v result) - (logxorf chash (hash-to-fixnum v hash-fn))) + (mix-hashf chash (hash-to-fixnum v hash-fn))) (case (wb-set-tree-size result) (0 nil) (1 (ch-set-tree-with nil (wb-set-tree-arb result) hash-fn compare-fn depth)) @@ -809,7 +795,7 @@ (defstruct (ch-set-node ;; Unlike in the union case, where we can compute the size in advance, for the intersection ;; we can only compute an upper bound -- the result could even be empty. ((new-len (min (length tree1) (length tree2))) - ((res-n (make-array new-len))))) + ((res-n (make-array new-len :initial-element 0))))) (flet ((add-entry (idx val) (ch-set-add-entry res-n idx val hash-fn)) (add-subnode (idx subnode) @@ -850,7 +836,7 @@ (defstruct (ch-set-node (let ((result (wb-set-tree-diff (cdr tree1) (cdr tree2) compare-fn)) (chash 0)) (do-wb-set-tree-members (v result) - (logxorf chash (hash-to-fixnum v hash-fn))) + (mix-hashf chash (hash-to-fixnum v hash-fn))) (cons chash result)) (let ((result (cdr tree1)) (chash (car tree1))) @@ -860,7 +846,7 @@ (defstruct (ch-set-node (let ((tmp (wb-set-tree-less result v compare-fn))) (unless (eq tmp result) (setq result tmp) - (logxorf chash (hash-to-fixnum v hash-fn))))) + (unmix-hashf chash (hash-to-fixnum v hash-fn))))) (case (wb-set-tree-size result) (0 nil) (1 (ch-set-tree-with nil (wb-set-tree-arb result) hash-fn compare-fn depth)) @@ -875,7 +861,7 @@ (defstruct (ch-set-node (subnodes1 (ch-set-node-subnode-mask tree1)) (subnodes2 (ch-set-node-subnode-mask tree2)) ((new-len (length (the simple-vector tree1))) ; upper bound - ((res-n (make-array new-len))))) + ((res-n (make-array new-len :initial-element 0))))) (flet ((add-entry (idx val) (ch-set-add-entry res-n idx val hash-fn)) (add-subnode (idx subnode) @@ -915,9 +901,9 @@ (defstruct (ch-set-node (chash1 0) (chash2 0)) (do-wb-set-tree-members (v result1) - (logxorf chash1 (hash-to-fixnum v hash-fn))) + (mix-hashf chash1 (hash-to-fixnum v hash-fn))) (do-wb-set-tree-members (v result2) - (logxorf chash2 (hash-to-fixnum v hash-fn))) + (mix-hashf chash2 (hash-to-fixnum v hash-fn))) (values (cons chash1 result1) (cons chash2 result2))) (let ((result1 (cdr tree1)) (chash1 (car tree1))) @@ -925,7 +911,7 @@ (defstruct (ch-set-node (let ((tmp (wb-set-tree-less result1 v compare-fn))) (unless (eq tmp result1) (setq result1 tmp) - (logxorf chash1 (hash-to-fixnum v hash-fn))))) + (unmix-hashf chash1 (hash-to-fixnum v hash-fn))))) (do-wb-set-tree-members (v (cdr tree1)) (setq tree2 (ch-set-tree-less tree2 v hash-fn compare-fn depth))) (values (case (wb-set-tree-size result1) @@ -1106,7 +1092,7 @@ (defstruct (ch-set-node (gmap :and (fn (value-idx hash-bits) (let ((value (svref node (+ ch-set-node-header-size value-idx))) ((value-hash (hash-to-fixnum value hash-fn)))) - (logxorf content-hash value-hash) + (mix-hashf content-hash value-hash) (test (= (ldb (byte (* champ-hash-bits-per-level (1+ depth)) 0) value-hash) (new-partial-hash hash-bits depth partial-hash))))) @@ -1118,14 +1104,14 @@ (defstruct (ch-set-node (if (consp subnode) (let ((chash 0)) (do-wb-set-tree-members (v (cdr subnode)) - (logxorf chash (hash-to-fixnum v hash-fn))) - (logxorf content-hash chash) + (mix-hashf chash (hash-to-fixnum v hash-fn))) + (mix-hashf content-hash chash) (incf size (wb-set-tree-size (cdr subnode))) (test (= (car subnode) chash))) (and (rec subnode (1+ depth) (new-partial-hash hash-bits depth partial-hash)) (progn (incf size (ch-set-node-size subnode)) - (logxorf content-hash (ch-set-node-hash-value subnode)) + (mix-hashf content-hash (ch-set-node-hash-value subnode)) t))))) (:arg index 0) (:arg list subnode-bits)) @@ -1170,6 +1156,8 @@ (defstruct (ch-map-node (defconstant ch-map-node-header-size 4) (defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0)) + ;; &&& This would benefit from returning a hash delta, as in `ch-set-tree-less'. Ironically, + ;; the technique is not actually needed in that function. (declare (optimize (speed 3) (safety 03)) (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (type (integer 0 1000) depth)) @@ -1181,7 +1169,7 @@ (defstruct (ch-map-node (type (integer 0 64) depth)) (let ((hash-bits (logand hash-shifted champ-hash-level-mask))) (if (null node) - (vector (ash 1 hash-bits) 0 1 (logxor key-hash (hash-to-fixnum value val-hash-fn)) + (vector (ash 1 hash-bits) 0 1 (mix-hash key-hash (hash-to-fixnum value val-hash-fn)) key value) (if (consp node) ;; Collision node. @@ -1200,12 +1188,11 @@ (defstruct (ch-map-node ;; The key was already present, but the value was updated. (let ((ig old-value (wb-map-tree-lookup (cdr node) key key-cmp-fn))) (declare (ignore ig)) - (cons (logxor (the fixnum (car node)) (hash-to-fixnum old-value val-hash-fn) - (hash-to-fixnum value val-hash-fn)) + (cons (mix-hash (car node) (unmix-hash (hash-to-fixnum value val-hash-fn) + (hash-to-fixnum old-value val-hash-fn))) new-wb-tree))) (t ; New entry in collision node - (cons (logxor (the fixnum (car node)) key-hash - (hash-to-fixnum value val-hash-fn)) + (cons (mix-hash (car node) key-hash (hash-to-fixnum value val-hash-fn)) new-wb-tree)))) ;; Oh, this is fun. We add enough levels to get to where the hashes differ. (rlabels (build hash-shifted wb-hash-shifted) @@ -1213,8 +1200,7 @@ (defstruct (ch-map-node (declare (fixnum hash-shifted wb-hash-shifted)) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask)) - (content-hash (logxor (the fixnum (car node)) key-hash - (hash-to-fixnum value val-hash-fn)))) + (content-hash (mix-hash (car node) key-hash (hash-to-fixnum value val-hash-fn)))) (if (= hash-bits wb-hash-bits) (vector 0 (ash 1 hash-bits) size content-hash (build (ash hash-shifted (- champ-hash-bits-per-level)) @@ -1237,8 +1223,8 @@ (defstruct (ch-map-node node ; Key found, value equal: nothing to do ;; Key found, value differs: just update value (let ((n (vector-update node (+ entry-idx 1) value))) - (logxorf (ch-map-node-hash-value n) (hash-to-fixnum ex-val val-hash-fn) - (hash-to-fixnum value val-hash-fn)) + (mix-hashf (ch-map-node-hash-value n) (unmix-hash (hash-to-fixnum value val-hash-fn) + (hash-to-fixnum ex-val val-hash-fn))) n)) ;; Entry with different key found: make a subnode (let ((hash-shifted (ash hash-shifted (- champ-hash-bits-per-level))) @@ -1246,14 +1232,14 @@ (defstruct (ch-map-node ((ex-key-hash-shifted (ash ex-key-hash (* (- champ-hash-bits-per-level) (1+ depth)))) ((n2 (if (= hash-shifted ex-key-hash-shifted) ;; Collision! Fall back to WB-tree. - (cons (logxor key-hash (hash-to-fixnum value val-hash-fn) ex-key-hash - (hash-to-fixnum ex-val val-hash-fn)) + (cons (mix-hash key-hash (hash-to-fixnum value val-hash-fn) + ex-key-hash (hash-to-fixnum ex-val val-hash-fn)) (wb-map-tree-with (wb-map-tree-with nil ex-key ex-val key-cmp-fn val-cmp-fn) key value key-cmp-fn val-cmp-fn)) ;; Creates a little garbage; &&& hand-integrate later. (rec (vector (ash 1 (logand ex-key-hash-shifted champ-hash-level-mask)) - 0 1 (logxor ex-key-hash (hash-to-fixnum ex-val val-hash-fn)) + 0 1 (mix-hash ex-key-hash (hash-to-fixnum ex-val val-hash-fn)) ex-key ex-val) hash-shifted (1+ depth)))) ;; The `1+' is because we're inserting _after_ `subnode-idx', because the subnodes @@ -1262,7 +1248,7 @@ (defstruct (ch-map-node (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) (logiorf (ch-map-node-subnode-mask n) (ash 1 hash-bits)) (incf (ch-map-node-size n)) - (logxorf (ch-map-node-hash-value n) key-hash (hash-to-fixnum value val-hash-fn)) + (mix-hashf (ch-map-node-hash-value n) key-hash (hash-to-fixnum value val-hash-fn)) n))) ;; No entry found: check for subnode (if (logbitp hash-bits subnode-mask) @@ -1277,14 +1263,14 @@ (defstruct (ch-map-node (setf (ch-map-node-size n) (the fixnum (+ (ch-map-node-size n) (- (the fixnum (ch-map-tree-size new-subnode)) (the fixnum (ch-map-tree-size subnode)))))) - (logxorf (ch-map-node-hash-value n) (the fixnum (ch-map-tree-hash-value subnode)) - (the fixnum (ch-map-tree-hash-value new-subnode))) + (mix-hashf (ch-map-node-hash-value n) (unmix-hash (ch-map-tree-hash-value new-subnode) + (ch-map-tree-hash-value subnode))) n))) ;; Neither entry nor subnode found: make new entry (let ((n (vector-insert-2 node entry-idx key value))) (logiorf (ch-map-node-entry-mask n) (ash 1 hash-bits)) (incf (ch-map-node-size n)) - (logxorf (ch-map-node-hash-value n) key-hash (hash-to-fixnum value val-hash-fn)) + (mix-hashf (ch-map-node-hash-value n) key-hash (hash-to-fixnum value val-hash-fn)) n))))))))))) (defun vector-rem-2-ins-1 (vec rem-idx ins-idx ins-val) @@ -1351,14 +1337,15 @@ (defstruct (ch-map-node (cond ((not (equal?-cmp ex-key key key-cmp-fn)) (values node 0)) ((and (= (logcount entry-mask) 1) (= 0 subnode-mask)) - (values nil (logxor key-hash (hash-to-fixnum (svref node (1+ entry-idx)) val-hash-fn)))) + ;; &&& Check that this happens only at the root + (values nil (mix-hash key-hash (hash-to-fixnum (svref node (1+ entry-idx)) val-hash-fn)))) (t (let ((n (vector-remove-2-at node entry-idx)) (ex-value-hash (hash-to-fixnum (svref node (1+ entry-idx)) val-hash-fn))) (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) (decf (ch-map-node-size n)) - (let ((kv-hash (logxor key-hash ex-value-hash))) - (logxorf (ch-map-node-hash-value n) kv-hash) + (let ((kv-hash (mix-hash key-hash ex-value-hash))) + (unmix-hashf (ch-map-node-hash-value n) kv-hash) (values n kv-hash)))))) (let ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) ((subnode-idx (- (the fixnum (length node)) 1 subnode-raw-idx)))) @@ -1381,16 +1368,15 @@ (defstruct (ch-map-node (logiorf (ch-map-node-entry-mask n) (ash 1 hash-bits)) (logandc2f (ch-map-node-subnode-mask n) (ash 1 hash-bits)) (decf (ch-map-node-size n)) - (let ((kv-hash (logxor key-hash ex-value-hash))) - (logxorf (ch-map-node-hash-value n) kv-hash) + (let ((kv-hash (mix-hash key-hash ex-value-hash))) + (unmix-hashf (ch-map-node-hash-value n) kv-hash) (values n kv-hash))) - (let ((n (vector-update node subnode-idx - (cons (logxor (the fixnum (car subnode)) key-hash - ex-value-hash) - new-wb-tree)))) + (let ((kv-hash (mix-hash key-hash ex-value-hash)) + ((n (vector-update node subnode-idx + (cons (unmix-hash (car subnode) kv-hash) new-wb-tree))))) (decf (ch-map-node-size n)) - (logxorf (ch-map-node-hash-value n) key-hash ex-value-hash) - (values n (logxor key-hash ex-value-hash))))))) + (unmix-hashf (ch-map-node-hash-value n) kv-hash) + (values n kv-hash)))))) (let ((new-subnode content-hash-delta (rec subnode (ash hash-shifted (- champ-hash-bits-per-level))))) (declare (fixnum content-hash-delta)) @@ -1421,7 +1407,7 @@ (defstruct (ch-map-node (svref new-subnode ch-map-node-header-size))) (t (vector-update node subnode-idx new-subnode))))) (decf (ch-map-node-size n)) - (logxorf (ch-map-node-hash-value n) content-hash-delta) + (unmix-hashf (ch-map-node-hash-value n) content-hash-delta) (values n content-hash-delta))))))))))))))) (defun vector-remove-2-at (vec idx) @@ -1517,7 +1503,7 @@ (defstruct (ch-map-node (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn)) (chash 0)) (do-wb-map-tree-pairs (k v result) - (logxorf chash (hash-to-fixnum k key-hash-fn) (hash-to-fixnum v val-hash-fn))) + (mix-hashf chash (hash-to-fixnum k key-hash-fn) (hash-to-fixnum v val-hash-fn))) (cons chash result))) ((consp tree1) (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) @@ -1546,7 +1532,7 @@ (defstruct (ch-map-node (logcount (logand entries1 subnodes2)) (logcount (logand entries2 subnodes1)))) (logcount all-subnodes))) - ((res-n (make-array new-len)))))) + ((res-n (make-array new-len :initial-element 0)))))) (ientry1 0) (isubnode1 0) (ientry2 0) @@ -1563,7 +1549,7 @@ (defstruct (ch-map-node (incf res-ientry) (logiorf res-entries (ash 1 idx)) (incf res-size) - (logxorf res-content-hash (hash-to-fixnum key key-hash-fn) (hash-to-fixnum val val-hash-fn))) + (mix-hashf res-content-hash (hash-to-fixnum key key-hash-fn) (hash-to-fixnum val val-hash-fn))) (add-subnode (idx subnode) ;; It's possible for `subnode' to contain only a collision subnode -- we must pull it up. (when (and (not (consp subnode)) @@ -1574,7 +1560,7 @@ (defstruct (ch-map-node (setf (svref res-n (- new-len (postincf res-isubnode) 1)) subnode) (logiorf res-subnodes (ash 1 idx)) (incf res-size (ch-map-tree-size subnode)) - (logxorf res-content-hash (ch-map-tree-hash-value subnode))) + (mix-hashf res-content-hash (ch-map-tree-hash-value subnode))) (map-tree-with (tree key value depth) (ch-map-tree-with tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) (do-bit-indices (idx everything) @@ -1648,8 +1634,9 @@ (defstruct (ch-map-node (,recur-fn ,tree-form)) ,value-form))) -(defun ch-map-tree-verify (tree) - (declare (optimize (debug 3))) +(defun ch-map-tree-verify (tree key-hash-fn val-hash-fn) + (declare (optimize (debug 3)) + (type function key-hash-fn val-hash-fn)) (or (null tree) (rlabels (rec tree 0 0) (rec (node depth partial-hash) @@ -1676,9 +1663,10 @@ (defstruct (ch-map-node ;; Check entry key hashes (gmap :and (fn (key-idx hash-bits) (let ((key (svref node (+ ch-map-node-header-size (* 2 key-idx)))) - ((key-hash (hash-value-fixnum key))) + ((key-hash (hash-to-fixnum key key-hash-fn))) (value (svref node (+ ch-map-node-header-size (1+ (* 2 key-idx)))))) - (setq content-hash (logxor content-hash key-hash (hash-value-fixnum value))) + (setq content-hash (mix-hash content-hash key-hash + (hash-to-fixnum value val-hash-fn))) (test (= (ldb (byte (* champ-hash-bits-per-level (1+ depth)) 0) key-hash) (new-partial-hash hash-bits depth partial-hash))))) @@ -1690,15 +1678,15 @@ (defstruct (ch-map-node (if (consp subnode) (let ((chash 0)) (do-wb-map-tree-pairs (k v (cdr subnode)) - (setf chash (logxor chash (hash-value-fixnum k) (hash-value-fixnum v)))) - (setf content-hash (logxor content-hash chash)) + (setf chash (mix-hash chash (hash-to-fixnum k key-hash-fn) + (hash-to-fixnum v val-hash-fn)))) + (setf content-hash (mix-hash content-hash chash)) (incf size (wb-map-tree-size (cdr subnode))) (test (= (car subnode) chash))) (and (rec subnode (1+ depth) (new-partial-hash hash-bits depth partial-hash)) (progn (incf size (ch-map-node-size subnode)) - (setf content-hash - (logxor content-hash (ch-map-node-hash-value subnode))) + (mix-hashf content-hash (ch-map-node-hash-value subnode)) t))))) (:arg index 0) (:arg list subnode-bits)) diff --git a/Code/port.lisp b/Code/port.lisp index 17a39ce..428f642 100644 --- a/Code/port.lisp +++ b/Code/port.lisp @@ -372,6 +372,44 @@ . ,body)) +;;; ---------------- + +(defmacro mix-hash (&rest args) + ;; On implementations where we can reliably get fixnum addition and subtraction without + ;; overflow checks at speed-3 safety-0, using them will give us better distributional properties. + ;; On other implementations, we fall back to XOR. + #+(or sbcl ccl allegro lispworks) + ;; To make SBCL happy, we have to build a binary tree with `the fixnum' at each level. + (labels ((build (fn expr args) + (if (null args) expr + (build fn `(the fixnum (,fn ,expr (the fixnum ,(car args)))) (cdr args))))) + `(locally (declare (optimize (speed 3) (safety 0))) + ,(build '+ `(the fixnum ,(car args)) (cdr args)))) + ;; Oddly, addition doesn't seem to work on ABCL, even though it's using an `ladd' instruction; it + ;; makes a bignum (given suitable operands) anyway. + ;; CLASP also checks for overflow on addition. + #-(or sbcl ccl allegro lispworks) + `(locally (declare (optimize (speed 3) (safety 0))) + (the fixnum (logxor . ,(mapcar (fn (x) `(the fixnum ,x)) args))))) + +(defmacro unmix-hash (hash &rest to-unmix) + ;; As above. + #+(or sbcl ccl allegro lispworks) + (labels ((build (fn expr args) + (if (null args) expr + (build fn `(the fixnum (,fn ,expr (the fixnum ,(car args)))) (cdr args))))) + `(locally (declare (optimize (speed 3) (safety 0))) + ,(build '- `(the fixnum ,hash) to-unmix))) + #-(or sbcl ccl allegro lispworks) + `(locally (declare (optimize (speed 3) (safety 0))) + (the fixnum (logxor (the fixnum ,hash) . ,(mapcar (fn (x) `(the fixnum ,x)) to-unmix))))) + +(define-modify-macro mix-hashf (&rest args) + mix-hash) +(define-modify-macro unmix-hashf (hash &rest to-unmix) + unmix-hash) + + ;;; ---------------- ;;; A macro used mostly by the bag code to get generic arithmetic in speed-3 diff --git a/Code/testing.lisp b/Code/testing.lisp index 9221ebb..f12df40 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -2144,7 +2144,12 @@ (define-hash-function erapmoc hash-value-negated) (let ((ht (make-hash-table))) (setf (gethash 'a ht) 17) (setf (gethash 'b ht) 31) - (test (equal? (convert 'map ht) (map ('a 17) ('b 31))))))) + (test (equal? (convert 'map ht) (map ('a 17) ('b 31))))) + ;; Check that our hash mixing operations do NOT check for overflow. + (test (= (mix-hash-func most-negative-fixnum most-negative-fixnum) 0)))) + +(defun mix-hash-func (a b) + (mix-hash a b)) (defun Test-Reader () (macrolet ((test (str form) -- GitLab From 6fae9e7de0122e9d01c8de32ae2a13904f98fcc1 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Wed, 27 Aug 2025 20:55:12 -0700 Subject: [PATCH 07/16] Misc fixes. --- Code/fset.lisp | 12 ++++++++++-- Code/relations.lisp | 2 +- Code/replay.lisp | 2 +- Code/testing.lisp | 5 +++-- 4 files changed, 15 insertions(+), 6 deletions(-) diff --git a/Code/fset.lisp b/Code/fset.lisp index 95cfe6b..6aa3d59 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -2294,6 +2294,14 @@ (defmethod set-difference ((s1 ch-set) (s2 ch-set) &key) hsorg) (call-next-method))) +(defmethod set-difference-rev ((s1 ch-set) (s2 ch-set)) + (if-same-ch-set-orgs (s1 s2 hsorg) + (make-ch-set (ch-set-tree-difference (ch-set-contents s1) (ch-set-contents s2) + (hash-set-org-hash-fn hsorg) + (hash-set-org-compare-fn hsorg)) + hsorg) + (call-next-method))) + (defmethod set-difference-2 ((s1 ch-set) (s2 ch-set)) (if-same-ch-set-orgs (s1 s2 hsorg) (let ((s1-diff-s2 s2-diff-s1 (ch-set-tree-difference-2 (ch-set-contents s1) (ch-set-contents s2) @@ -2314,7 +2322,7 @@ (defmethod disjoint? ((s1 ch-set) (s2 ch-set)) (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)) (call-next-method))) -(define-wb-set-methods partition ((pred function) (s ch-set)) +(defmethod partition ((pred function) (s ch-set)) (let ((hsorg (ch-set-org s)) ((res1 res2 (ch-set-partition pred (ch-set-contents s) hsorg)))) (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) @@ -4116,7 +4124,7 @@ (defmethod count-if-not (pred (m map) &key key) "Consumes two values from the mapped function; returns a map of the pairs. Note that `filterp', if supplied, must take two arguments." `(nil (:consume 2 (fn (m x y) (WB-Map-Tree-With m x y #'compare #'compare))) - #'(lambda (tree) (make-wb-map tree +fset-default-tree-map-org+ ,default)) + #'(lambda (tree) (make-wb-map tree (wb-map-org *empty-wb-map*) ,default)) ,filterp)) (gmap:def-gmap-res-type wb-map (&key filterp default key-compare-fn-name val-compare-fn-name) diff --git a/Code/relations.lisp b/Code/relations.lisp index e93c9dc..03c4c45 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -70,7 +70,7 @@ (defmethod arb ((br wb-2-relation)) (defmethod contains? ((br wb-2-relation) x &optional (y nil y?)) (check-three-arguments y? 'contains? 'wb-2-relation) (let ((found? set-tree (WB-Map-Tree-Lookup (wb-2-relation-map0 br) x #'compare))) - (and found? (WB-Set-Tree-Member? set-tree y #'compare)))) + (and found? (WB-Set-Tree-Contains? set-tree y #'compare)))) ;;; &&& Aaagh -- not sure this makes sense -- (setf (lookup rel x) ...) doesn't do ;;; the right thing at all, relative to this. Maybe the setf expander for `lookup'/`@' diff --git a/Code/replay.lisp b/Code/replay.lisp index aec47a9..b542120 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -114,7 +114,7 @@ (defmethod at-index ((m wb-replay-set) index) (defmethod contains? ((s wb-replay-set) x &optional (y nil y?)) (declare (ignore y)) (check-two-arguments y? 'contains? 'wb-set) - (wb-set-tree-member? (wb-replay-set-contents s) x (tree-set-org-compare-fn (wb-replay-set-org s)))) + (wb-set-tree-contains? (wb-replay-set-contents s) x (tree-set-org-compare-fn (wb-replay-set-org s)))) (defmethod lookup ((s wb-replay-set) value) (wb-set-tree-find-equal (wb-replay-set-contents s) value diff --git a/Code/testing.lisp b/Code/testing.lisp index f12df40..dd6afc9 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -3793,7 +3793,7 @@ (defmethod verify ((br wb-2-relation)) (Do-WB-Set-Tree-Members (y s) (let ((ignore s1 (WB-Map-Tree-Lookup (wb-2-relation-map1 br) y #'compare))) (declare (ignore ignore)) - (unless (WB-Set-Tree-Member? s1 x #'compare) + (unless (WB-Set-Tree-Contains? s1 x #'compare) (format *debug-io* "Map discrepancy in wb-2-relation") (return nil)))))) (or (= size (wb-2-relation-size br)) @@ -3930,7 +3930,8 @@ (defmethod verify ((s ch-set)) (setq saved-chs chs)))))) (defmethod verify ((m ch-map)) - (ch-map-tree-verify (ch-map-contents m))) + (let ((hmorg (ch-map-org m))) + (ch-map-tree-verify (ch-map-contents m) (hash-map-org-key-hash-fn hmorg) (hash-map-org-val-hash-fn hmorg)))) (defvar *champ-map-test-pairs* (seq)) -- GitLab From f8cc1c86bc57240a52615f9f4eac159dc24c2f3e Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sun, 7 Sep 2025 01:20:02 -0700 Subject: [PATCH 08/16] WIP, checkpointing. --- Code/champ.lisp | 1038 ++++++++++++++++++++++++++++++--------------- Code/fset.lisp | 120 +++++- Code/hash.lisp | 20 +- Code/macros.lisp | 2 +- Code/port.lisp | 13 + Code/testing.lisp | 140 ++++-- 6 files changed, 918 insertions(+), 415 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index 11a76c1..e40bb00 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -38,6 +38,9 @@ (defconstant champ-node-radix (ash 1 champ-hash-bits-per-level)) (defconstant champ-hash-level-mask (1- champ-node-radix))) (deftype champ-bit-index () `(integer 0 ,(1- champ-node-radix))) +;;; These have the same bounds but are logically different types. +(deftype champ-entry-index () `(integer 0 ,(1- champ-node-radix))) +(deftype champ-subnode-index () `(integer 0 ,(1- champ-node-radix))) (declaim (inline 1-bits-below)) (defun 1-bits-below (idx mask) @@ -98,6 +101,9 @@ (defstruct (ch-set-node (hash-value 0 :type fixnum)) (defconstant ch-set-node-header-size 4) +(deftype ch-set-tree () + '(or null cons simple-vector)) + (declaim (inline ch-set-tree-size)) (defun ch-set-tree-size (tree) (cond ((null tree) 0) @@ -235,7 +241,7 @@ (defstruct (ch-set-node (declare (fixnum hash-shifted)) (and node (if (consp node) - (let ((new-wb-tree (wb-set-tree-less (cdr node) value #'compare))) + (let ((new-wb-tree (wb-set-tree-less (cdr node) value compare-fn))) (if (eq new-wb-tree (cdr node)) (values node 0) (if (= 1 (wb-set-tree-size new-wb-tree)) @@ -363,7 +369,7 @@ (defstruct (ch-set-node (cond ((< hash1 hash2) ':less) ((> hash1 hash2) ':greater) ((consp tree1) - (if (consp tree2) (wb-set-tree-compare (cdr tree1) (cdr tree2) #'compare) + (if (consp tree2) (wb-set-tree-compare (cdr tree1) (cdr tree2) compare-fn) ':less)) ((consp tree2) ':greater) (t @@ -421,16 +427,15 @@ (defstruct (ch-set-node (+ base ientry))) (let ((subnode-mask (ch-set-node-subnode-mask node))) (incf base (logcount entry-mask)) - (if (logbitp hash-bits subnode-mask) - (let ((isubnode (1-bits-below hash-bits subnode-mask)) - (len (length (the simple-vector node))) - ((subnode-idx (- len 1 isubnode)) - ((subnode (svref node subnode-idx))))) - (dotimes (i isubnode) - (incf base (ch-set-tree-size (svref node (- len 1 i))))) - (rec subnode value base - (ash hash-shifted (- champ-hash-bits-per-level)))) - base)))))))))) + (and (logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + (len (length (the simple-vector node))) + ((subnode-idx (- len 1 isubnode)) + ((subnode (svref node subnode-idx))))) + (dotimes (i isubnode) + (incf base (ch-set-tree-size (svref node (- len 1 i))))) + (rec subnode value base + (ash hash-shifted (- champ-hash-bits-per-level)))))))))))))) (defun ch-set-tree-index-element (tree index) (declare (optimize (debug 3))) @@ -452,52 +457,6 @@ (defstruct (ch-set-node (return (rec subnode index))) (decf index subnode-size)))))))))) -(declaim (inline ch-set-add-entry)) -(defun ch-set-add-entry (n idx val hash-fn) - (declare (optimize (speed 3)) - (type champ-bit-index idx) - (type function hash-fn)) - (setf (svref n (+ ch-set-node-header-size (logcount (ch-set-node-entry-mask n)))) val) - (logiorf (ch-set-node-entry-mask n) (ash 1 idx)) - (incf (ch-set-node-size n)) - (mix-hashf (ch-set-node-hash-value n) (hash-to-fixnum val hash-fn))) - -(declaim (inline ch-set-add-subnode)) -(defun ch-set-add-subnode (n idx subnode hash-fn) - (declare (optimize (speed 3)) - (type champ-bit-index idx) - (type function hash-fn)) - (when subnode - (if (and (not (consp subnode)) - (= 1 (logcount (ch-set-node-entry-mask subnode))) - (= 0 (ch-set-node-subnode-mask subnode))) - ;; `subnode' contains only an entry -- pull it up. - (ch-set-add-entry n idx (svref subnode ch-set-node-header-size) hash-fn) - (progn - (when (and (not (consp subnode)) - (= 0 (ch-set-node-entry-mask subnode)) - (= 1 (logcount (ch-set-node-subnode-mask subnode))) - (consp (svref subnode (1- (length subnode))))) - ;; `subnode' contains only a collision subnode -- pull it up. - (setq subnode (svref subnode (1- (length subnode))))) - (setf (svref n (- (length (the simple-vector n)) - (logcount (ch-set-node-subnode-mask n)) 1)) - subnode) - (logiorf (ch-set-node-subnode-mask n) (ash 1 idx)) - (incf (ch-set-node-size n) (ch-set-tree-size subnode)) - (mix-hashf (ch-set-node-hash-value n) (ch-set-tree-hash-value subnode)))))) - -(defun ch-set-compact-node (n) - (declare (optimize (speed 3))) - (let ((entries (ch-set-node-entry-mask n)) - (subnodes (ch-set-node-subnode-mask n))) - (and (or (/= entries 0) (/= subnodes 0)) - (let ((len (length (the simple-vector n))) - (n-entries (logcount entries)) - ((extra (- len ch-set-node-header-size n-entries (logcount subnodes))))) - (if (= extra 0) n - (vector-remove-n-at n (+ ch-set-node-header-size n-entries) extra)))))) - (defun vector-remove-n-at (vec idx n) (declare (optimize (speed 3) (safety 03)) (type simple-vector vec) @@ -687,6 +646,55 @@ (defstruct (ch-set-node ;;; -------------------------------- ;;; Union, intersection, set-difference, subset?, disjoint? +(declaim (inline ch-set-node-entry)) +(defun ch-set-node-entry (n ientry) + (declare (optimize (speed 3)) + (type simple-vector n) + (type champ-entry-index ientry)) + (svref n (+ ch-set-node-header-size ientry))) + +(declaim (inline ch-set-node-subnode)) +(defun ch-set-node-subnode (n isubnode) + (declare (optimize (speed 3)) + (type simple-vector n) + (type champ-subnode-index isubnode)) + (svref n (- (length n) isubnode 1))) + +(declaim (inline ch-set-node-add-entry)) +(defun ch-set-node-add-entry (n idx val hash-fn) + (declare (optimize (speed 3)) + (type champ-bit-index idx) + (type function hash-fn)) + (setf (svref n (+ ch-set-node-header-size (logcount (ch-set-node-entry-mask n)))) val) + (logiorf (ch-set-node-entry-mask n) (ash 1 idx)) + (incf (ch-set-node-size n)) + (mix-hashf (ch-set-node-hash-value n) (hash-to-fixnum val hash-fn))) + +(declaim (inline ch-set-node-add-subnode)) +(defun ch-set-node-add-subnode (n idx subnode hash-fn) + (declare (optimize (speed 3)) + (type champ-bit-index idx) + (type function hash-fn)) + (when subnode + (if (and (not (consp subnode)) + (= 1 (logcount (ch-set-node-entry-mask subnode))) + (= 0 (ch-set-node-subnode-mask subnode))) + ;; `subnode' contains only an entry -- pull it up. + (ch-set-node-add-entry n idx (svref subnode ch-set-node-header-size) hash-fn) + (progn + (when (and (not (consp subnode)) + (= 0 (ch-set-node-entry-mask subnode)) + (= 1 (logcount (ch-set-node-subnode-mask subnode))) + (consp (svref subnode (1- (length subnode))))) + ;; `subnode' contains only a collision subnode -- pull it up. + (setq subnode (svref subnode (1- (length subnode))))) + (setf (svref n (- (length (the simple-vector n)) + (logcount (ch-set-node-subnode-mask n)) 1)) + subnode) + (logiorf (ch-set-node-subnode-mask n) (ash 1 idx)) + (incf (ch-set-node-size n) (ch-set-tree-size subnode)) + (mix-hashf (ch-set-node-hash-value n) (ch-set-tree-hash-value subnode)))))) + (defun ch-set-tree-union (tree1 tree2 hash-fn compare-fn) (declare (optimize (speed 3) (safety 03)) (type function hash-fn compare-fn)) @@ -697,14 +705,10 @@ (defstruct (ch-set-node ((null tree2) tree1) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((result (wb-set-tree-union (cdr tree1) (cdr tree2) compare-fn)) - (chash 0)) - (declare (fixnum chash)) - (do-wb-set-tree-members (v result) - (mix-hashf chash (hash-to-fixnum v hash-fn))) - (cons chash result))) + (let ((result (wb-set-tree-union (cdr tree1) (cdr tree2) compare-fn))) + (ch-set-node-from-wb result hash-fn compare-fn depth))) ((or (consp tree1) (consp tree2)) - (let ((collision-node normal-node (if (consp tree1) (values tree1 tree2) (values tree2 tree1)))) + (let ((normal-node collision-node (if (consp tree1) (values tree2 tree1) (values tree1 tree2)))) ;; Garbagey, but nontrivial to improve on, AFAICS. (do-wb-set-tree-members (x (cdr collision-node)) (setq normal-node (ch-set-tree-with normal-node x hash-fn compare-fn depth))) @@ -716,50 +720,49 @@ (defstruct (ch-set-node (subnodes2 (ch-set-node-subnode-mask tree2)) ((all-entries (logior entries1 entries2)) (all-subnodes (logior subnodes1 subnodes2)) - ((everything (logior all-entries all-subnodes)) - ;; Entry collisions can change to subnodes, but they can't then collide with existing subnodes. - ;; But we do have to subtract out entry/subnode collisions. - ((new-len (- (+ ch-set-node-header-size (logcount all-entries) (logcount all-subnodes)) - (logcount (logand entries1 subnodes2)) (logcount (logand entries2 subnodes1)))) - ((res-n (make-array new-len :initial-element 0)))))) + ;; Entry collisions can change to subnodes, but they can't then collide with existing subnodes. + ;; But we do have to subtract out entry/subnode collisions. + ((new-len (- (+ ch-set-node-header-size (logcount all-entries) (logcount all-subnodes)) + (logcount (logand entries1 subnodes2)) (logcount (logand entries2 subnodes1)))) + ((res-n (make-array new-len :initial-element 0))))) (ientry1 0) (isubnode1 0) (ientry2 0) (isubnode2 0)) (declare (type (integer 0 64) ientry1 isubnode1 ientry2 isubnode2)) (flet ((add-entry (idx val) - (ch-set-add-entry res-n idx val hash-fn)) + (ch-set-node-add-entry res-n idx val hash-fn)) (add-subnode (idx subnode) - (ch-set-add-subnode res-n idx subnode hash-fn)) - (set-tree-with (tree value) + (ch-set-node-add-subnode res-n idx subnode hash-fn)) + (subtree-with (tree value) (ch-set-tree-with tree value hash-fn compare-fn (1+ depth)))) - (do-bit-indices (idx everything) + (do-bit-indices (idx (logior all-entries all-subnodes)) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) - (let ((val1 (svref tree1 (+ ch-set-node-header-size (postincf ientry1)))) - (val2 (svref tree2 (+ ch-set-node-header-size (postincf ientry2))))) + (let ((val1 (ch-set-node-entry tree1 (postincf ientry1))) + (val2 (ch-set-node-entry tree2 (postincf ientry2)))) (if (equal?-cmp val1 val2 compare-fn) (add-entry idx val1) - (add-subnode idx (set-tree-with (set-tree-with nil val1) val2))))) + (add-subnode idx (subtree-with (subtree-with nil val1) val2))))) ((logbitp idx entries1) - (let ((val (svref tree1 (+ ch-set-node-header-size (postincf ientry1))))) + (let ((val (ch-set-node-entry tree1 (postincf ientry1)))) (if (logbitp idx subnodes2) - (let ((subnode (svref tree2 (- (length tree2) (postincf isubnode2) 1)))) - (add-subnode idx (set-tree-with subnode val))) + (let ((subnode (ch-set-node-subnode tree2 (postincf isubnode2)))) + (add-subnode idx (subtree-with subnode val))) (add-entry idx val)))) ((logbitp idx entries2) - (let ((val (svref tree2 (+ ch-set-node-header-size (postincf ientry2))))) + (let ((val (ch-set-node-entry tree2 (postincf ientry2)))) (if (logbitp idx subnodes1) - (let ((subnode (svref tree1 (- (length tree1) (postincf isubnode1) 1)))) - (add-subnode idx (set-tree-with subnode val))) + (let ((subnode (ch-set-node-subnode tree1 (postincf isubnode1)))) + (add-subnode idx (subtree-with subnode val))) (add-entry idx val)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) - (add-subnode idx (rec (svref tree1 (- (length tree1) (postincf isubnode1) 1)) - (svref tree2 (- (length tree2) (postincf isubnode2) 1)) + (add-subnode idx (rec (ch-set-node-subnode tree1 (postincf isubnode1)) + (ch-set-node-subnode tree2 (postincf isubnode2)) (1+ depth)))) ((logbitp idx subnodes1) - (add-subnode idx (svref tree1 (- (length tree1) (postincf isubnode1) 1)))) + (add-subnode idx (ch-set-node-subnode tree1 (postincf isubnode1)))) ((logbitp idx subnodes2) - (add-subnode idx (svref tree2 (- (length tree2) (postincf isubnode2) 1)))) + (add-subnode idx (ch-set-node-subnode tree2 (postincf isubnode2)))) (t (error "Bug in 'ch-set-tree-union'"))))) res-n)))))) @@ -770,17 +773,10 @@ (defstruct (ch-set-node (cond ((or (null tree1) (null tree2)) nil) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((result (wb-set-tree-intersect (cdr tree1) (cdr tree2) compare-fn)) - (chash 0)) - (do-wb-set-tree-members (v result) - (mix-hashf chash (hash-to-fixnum v hash-fn))) - (case (wb-set-tree-size result) - (0 nil) - (1 (ch-set-tree-with nil (wb-set-tree-arb result) hash-fn compare-fn depth)) - (t (cons chash result))) - (cons chash result))) + (let ((result (wb-set-tree-intersect (cdr tree1) (cdr tree2) compare-fn))) + (ch-set-node-from-wb result hash-fn compare-fn depth))) ((or (consp tree1) (consp tree2)) - (let ((collision-node normal-node (if (consp tree1) (values tree1 tree2) (values tree2 tree1))) + (let ((normal-node collision-node (swap-if (consp tree1) tree1 tree2)) (result nil)) ;; Garbagey, but nontrivial to improve on, AFAICS. (do-wb-set-tree-members (x (cdr collision-node)) @@ -794,38 +790,40 @@ (defstruct (ch-set-node (subnodes2 (ch-set-node-subnode-mask tree2)) ;; Unlike in the union case, where we can compute the size in advance, for the intersection ;; we can only compute an upper bound -- the result could even be empty. - ((new-len (min (length tree1) (length tree2))) - ((res-n (make-array new-len :initial-element 0))))) + ((res-len (min (length tree1) (length tree2))) + ((res-n (make-array res-len :initial-element 0)))) + (ientry1 0) + (isubnode1 0) + (ientry2 0) + (isubnode2 0)) (flet ((add-entry (idx val) - (ch-set-add-entry res-n idx val hash-fn)) + (ch-set-node-add-entry res-n idx val hash-fn)) (add-subnode (idx subnode) - (ch-set-add-subnode res-n idx subnode hash-fn)) + (ch-set-node-add-subnode res-n idx subnode hash-fn)) (subtree-contains? (tree val) (ch-set-tree-contains? tree val hash-fn compare-fn (1+ depth)))) (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) (logand entries1 subnodes2) (logand subnodes1 entries2))) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) - (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1)))) - (val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (let ((val1 (ch-set-node-entry tree1 (postincf ientry1))) + (val2 (ch-set-node-entry tree2 (postincf ientry2)))) (when (equal?-cmp val1 val2 compare-fn) (add-entry idx val1)))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) - (let ((val (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) - (when (subtree-contains? (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) - val) + (let ((val (ch-set-node-entry tree1 (postincf ientry1)))) + (when (subtree-contains? (ch-set-node-subnode tree2 (postincf isubnode2)) val) (add-entry idx val)))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) - (let ((val (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) - (when (subtree-contains? (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) - val) + (let ((val (ch-set-node-entry tree2 (postincf ientry2)))) + (when (subtree-contains? (ch-set-node-subnode tree1 (postincf isubnode1)) val) (add-entry idx val)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) - (add-subnode idx (rec (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) - (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) + (add-subnode idx (rec (ch-set-node-subnode tree1 (postincf isubnode1)) + (ch-set-node-subnode tree2 (postincf isubnode2)) (1+ depth))))))) (ch-set-compact-node res-n))))))) -(defun ch-set-tree-difference (tree1 tree2 hash-fn compare-fn) +(defun ch-set-tree-diff (tree1 tree2 hash-fn compare-fn) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) (cond ((null tree1) nil) @@ -833,24 +831,14 @@ (defstruct (ch-set-node ((eq tree1 tree2) nil) ((consp tree1) (if (consp tree2) - (let ((result (wb-set-tree-diff (cdr tree1) (cdr tree2) compare-fn)) - (chash 0)) - (do-wb-set-tree-members (v result) - (mix-hashf chash (hash-to-fixnum v hash-fn))) - (cons chash result)) - (let ((result (cdr tree1)) - (chash (car tree1))) + (let ((result (wb-set-tree-diff (cdr tree1) (cdr tree2) compare-fn))) + (ch-set-node-from-wb result hash-fn compare-fn depth)) + (let ((result (cdr tree1))) ;; This could be improved by comparing hashes, but collision nodes will be vanishingly ;; rare in practice anyway. Or should be... (do-ch-set-tree-members (v tree2) - (let ((tmp (wb-set-tree-less result v compare-fn))) - (unless (eq tmp result) - (setq result tmp) - (unmix-hashf chash (hash-to-fixnum v hash-fn))))) - (case (wb-set-tree-size result) - (0 nil) - (1 (ch-set-tree-with nil (wb-set-tree-arb result) hash-fn compare-fn depth)) - (t (cons chash result)))))) + (setq result (wb-set-tree-less result v compare-fn))) + (ch-set-node-from-wb result hash-fn compare-fn depth)))) ((consp tree2) (do-wb-set-tree-members (v (cdr tree2)) (setq tree1 (ch-set-tree-less tree1 v hash-fn compare-fn depth))) @@ -860,64 +848,61 @@ (defstruct (ch-set-node (entries2 (ch-set-node-entry-mask tree2)) (subnodes1 (ch-set-node-subnode-mask tree1)) (subnodes2 (ch-set-node-subnode-mask tree2)) - ((new-len (length (the simple-vector tree1))) ; upper bound - ((res-n (make-array new-len :initial-element 0))))) + ((res-len (length (the simple-vector tree1))) ; upper bound + ((res-n (make-array res-len :initial-element 0)))) + (ientry1 0) + (isubnode1 0) + (ientry2 0) + (isubnode2 0)) (flet ((add-entry (idx val) - (ch-set-add-entry res-n idx val hash-fn)) + (ch-set-node-add-entry res-n idx val hash-fn)) (add-subnode (idx subnode) - (ch-set-add-subnode res-n idx subnode hash-fn))) + (ch-set-node-add-subnode res-n idx subnode hash-fn)) + (subtree-less (subtree val) + (ch-set-tree-less subtree val hash-fn compare-fn (1+ depth))) + (subtree-contains? (subtree val) + (ch-set-tree-contains? subtree val hash-fn compare-fn (1+ depth)))) (do-bit-indices (idx (logior entries1 subnodes1)) (cond ((logbitp idx entries1) - (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) + (let ((val1 (ch-set-node-entry tree1 (postincf ientry1)))) (cond ((logbitp idx entries2) - (let ((val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (let ((val2 (ch-set-node-entry tree2 (postincf ientry2)))) (unless (equal?-cmp val1 val2 compare-fn) (add-entry idx val1)))) ((logbitp idx subnodes2) - (let ((subnode (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)))) - (unless (ch-set-tree-contains? subnode val1 hash-fn compare-fn (1+ depth)) + (let ((subnode (ch-set-node-subnode tree2 (postincf isubnode2)))) + (unless (subtree-contains? subnode val1) (add-entry idx val1)))) (t (add-entry idx val1))))) ((logbitp idx subnodes1) - (let ((subnode1 (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)))) + (let ((subnode1 (ch-set-node-subnode tree1 (postincf isubnode1)))) (cond ((logbitp idx subnodes2) - (let ((subnode2 (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)))) + (let ((subnode2 (ch-set-node-subnode tree2 (postincf isubnode2)))) (add-subnode idx (rec subnode1 subnode2 (1+ depth))))) ((logbitp idx entries2) - (let ((val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) - (add-subnode idx (ch-set-tree-less subnode1 val2 hash-fn compare-fn (1+ depth))))) + (let ((val2 (ch-set-node-entry tree2 (postincf ientry2)))) + (add-subnode idx (subtree-less subnode1 val2)))) (t (add-subnode idx subnode1)))))))) (ch-set-compact-node res-n))))))) -(defun ch-set-tree-difference-2 (tree1 tree2 hash-fn compare-fn) +(defun ch-set-tree-diff-2 (tree1 tree2 hash-fn compare-fn) (declare (optimize (debug 3))) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) (cond ((null tree1) (values nil tree2)) ((null tree2) (values tree1 nil)) + ((eq tree1 tree2) (values nil nil)) ((consp tree1) (if (consp tree2) - (let ((result1 result2 (wb-set-tree-diff-2 (cdr tree1) (cdr tree2) compare-fn)) - (chash1 0) - (chash2 0)) - (do-wb-set-tree-members (v result1) - (mix-hashf chash1 (hash-to-fixnum v hash-fn))) - (do-wb-set-tree-members (v result2) - (mix-hashf chash2 (hash-to-fixnum v hash-fn))) - (values (cons chash1 result1) (cons chash2 result2))) - (let ((result1 (cdr tree1)) - (chash1 (car tree1))) + (let ((result1 result2 (wb-set-tree-diff-2 (cdr tree1) (cdr tree2) compare-fn))) + (values (ch-set-node-from-wb result1 hash-fn compare-fn depth) + (ch-set-node-from-wb result2 hash-fn compare-fn depth))) + (let ((result1 (cdr tree1))) (do-ch-set-tree-members (v tree2) - (let ((tmp (wb-set-tree-less result1 v compare-fn))) - (unless (eq tmp result1) - (setq result1 tmp) - (unmix-hashf chash1 (hash-to-fixnum v hash-fn))))) + (setq result1 (wb-set-tree-less result1 v compare-fn))) (do-wb-set-tree-members (v (cdr tree1)) (setq tree2 (ch-set-tree-less tree2 v hash-fn compare-fn depth))) - (values (case (wb-set-tree-size result1) - (0 nil) - (1 (ch-set-tree-with nil (wb-set-tree-arb result1) hash-fn compare-fn depth)) - (t (cons chash1 result1))) + (values (ch-set-node-from-wb result1 hash-fn compare-fn depth) tree2)))) ((consp tree2) (let ((res2 res1 (rec tree2 tree1 depth))) @@ -927,52 +912,79 @@ (defstruct (ch-set-node (entries2 (ch-set-node-entry-mask tree2)) (subnodes1 (ch-set-node-subnode-mask tree1)) (subnodes2 (ch-set-node-subnode-mask tree2)) - ((new-len1 (length (the simple-vector tree1))) ; upper bound - ((res-n1 (make-array new-len1 :initial-element 0)))) - ((new-len2 (length (the simple-vector tree2))) - ((res-n2 (make-array new-len2 :initial-element 0))))) + ((res-len1 (length (the simple-vector tree1))) ; upper bound + ((res-n1 (make-array res-len1 :initial-element 0)))) + ((res-len2 (length (the simple-vector tree2))) + ((res-n2 (make-array res-len2 :initial-element 0)))) + (ientry1 0) + (isubnode1 0) + (ientry2 0) + (isubnode2 0)) (flet ((add-entry (n idx val) - (ch-set-add-entry n idx val hash-fn)) + (ch-set-node-add-entry n idx val hash-fn)) (add-subnode (n idx subnode) - (ch-set-add-subnode n idx subnode hash-fn)) + (ch-set-node-add-subnode n idx subnode hash-fn)) (subtree-less (subtree val) (ch-set-tree-less subtree val hash-fn compare-fn (1+ depth))) (subtree-contains? (subtree val) (ch-set-tree-contains? subtree val hash-fn compare-fn (1+ depth)))) (do-bit-indices (idx (logior entries1 subnodes1 entries2 subnodes2)) (cond ((logbitp idx entries1) - (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) + (let ((val1 (ch-set-node-entry tree1 (postincf ientry1)))) (cond ((logbitp idx entries2) - (let ((val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (let ((val2 (ch-set-node-entry tree2 (postincf ientry2)))) (unless (equal?-cmp val1 val2 compare-fn) (add-entry res-n1 idx val1) (add-entry res-n2 idx val2)))) ((logbitp idx subnodes2) - (let ((subnode2 (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)))) + (let ((subnode2 (ch-set-node-subnode tree2 (postincf isubnode2)))) (unless (subtree-contains? subnode2 val1) (add-entry res-n1 idx val1)) (add-subnode res-n2 idx (subtree-less subnode2 val1)))) (t (add-entry res-n1 idx val1))))) ((logbitp idx subnodes1) - (let ((subnode1 (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)))) + (let ((subnode1 (ch-set-node-subnode tree1 (postincf isubnode1)))) (cond ((logbitp idx subnodes2) - (let ((subnode2 (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1))) + (let ((subnode2 (ch-set-node-subnode tree2 (postincf isubnode2))) ((new-sn1 new-sn2 (rec subnode1 subnode2 (1+ depth))))) (add-subnode res-n1 idx new-sn1) (add-subnode res-n2 idx new-sn2))) ((logbitp idx entries2) - (let ((val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (let ((val2 (ch-set-node-entry tree2 (postincf ientry2)))) (add-subnode res-n1 idx (subtree-less subnode1 val2)) (unless (subtree-contains? subnode1 val2) (add-entry res-n2 idx val2)))) (t (add-subnode res-n1 idx subnode1))))) ((logbitp idx entries2) - (add-entry res-n2 idx (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (add-entry res-n2 idx (ch-set-node-entry tree2 (postincf ientry2)))) ((logbitp idx subnodes2) - (add-subnode res-n2 idx (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)))) - (t (error "Bug in ch-set-tree-difference-2"))))) + (add-subnode res-n2 idx (ch-set-node-subnode tree2 (postincf isubnode2)))) + (t (error "Bug in ch-set-tree-diff-2"))))) (values (ch-set-compact-node res-n1) (ch-set-compact-node res-n2)))))))) +(defun ch-set-node-from-wb (wb-set-tree hash-fn compare-fn depth) + (declare (optimize (speed 3)) + (type function hash-fn compare-fn)) + (case (wb-set-tree-size wb-set-tree) + (0 nil) + (1 (ch-set-tree-with nil (wb-set-tree-arb wb-set-tree) hash-fn compare-fn depth)) + ;; Since this is a collision node, all the hash values must be equal. + (t (cons (multiply-hash (hash-to-fixnum (wb-set-tree-arb wb-set-tree) hash-fn) (wb-set-tree-size wb-set-tree)) + wb-set-tree)))) + +(defun ch-set-compact-node (n) + (declare (optimize (speed 3))) + (let ((entries (ch-set-node-entry-mask n)) + (subnodes (ch-set-node-subnode-mask n))) + (and (or (/= entries 0) (/= subnodes 0)) + (let ((len (length (the simple-vector n))) + (n-entries (logcount entries)) + ((extra (- len ch-set-node-header-size n-entries (logcount subnodes))))) + (when (< extra 0) + (error "Bug! Not enough space allocated for ch-map-node")) + (if (= extra 0) n + (vector-remove-n-at n (+ ch-set-node-header-size n-entries) extra)))))) + (defun ch-set-tree-subset? (tree1 tree2 hash-fn compare-fn) (declare (optimize (debug 3))) (rlabels (rec tree1 tree2 0) @@ -994,26 +1006,29 @@ (defstruct (ch-set-node (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) (subnodes1 (ch-set-node-subnode-mask tree1)) - (subnodes2 (ch-set-node-subnode-mask tree2))) + (subnodes2 (ch-set-node-subnode-mask tree2)) + (ientry1 0) + (isubnode1 0) + (ientry2 0) + (isubnode2 0)) (do-bit-indices (idx (logior entries1 subnodes1) t) (cond ((logbitp idx entries1) (cond ((logbitp idx entries2) - (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1)))) - (val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (let ((val1 (ch-set-node-entry tree1 (postincf ientry1))) + (val2 (ch-set-node-entry tree2 (postincf ientry2)))) (unless (equal?-cmp val1 val2 compare-fn) (return nil)))) ((logbitp idx subnodes2) - (let ((val (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) - (unless (ch-set-tree-contains? (svref tree2 (- (length tree2) - (1-bits-below idx subnodes2) 1)) + (let ((val (ch-set-node-entry tree1 (postincf ientry1)))) + (unless (ch-set-tree-contains? (ch-set-node-subnode tree2 (postincf isubnode2)) val hash-fn compare-fn (1+ depth)) (return nil)))) (t (return nil)))) ((logbitp idx subnodes1) (cond ((logbitp idx subnodes2) - (unless (rec (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) - (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) + (unless (rec (ch-set-node-subnode tree1 (postincf isubnode1)) + (ch-set-node-subnode tree2 (postincf isubnode2)) (1+ depth)) (return nil))) (t (return nil)))))))))))) @@ -1036,27 +1051,31 @@ (defstruct (ch-set-node (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) (subnodes1 (ch-set-node-subnode-mask tree1)) - (subnodes2 (ch-set-node-subnode-mask tree2))) + (subnodes2 (ch-set-node-subnode-mask tree2)) + (ientry1 0) + (isubnode1 0) + (ientry2 0) + (isubnode2 0)) (do-bit-indices (idx (logand (logior entries1 subnodes1) (logior entries2 subnodes2)) t) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) - (let ((val1 (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1)))) - (val2 (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) + (let ((val1 (ch-set-node-entry tree1 (postincf ientry1))) + (val2 (ch-set-node-entry tree2 (postincf ientry2)))) (when (equal?-cmp val1 val2 compare-fn) (return nil)))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) - (let ((val (svref tree1 (+ ch-set-node-header-size (1-bits-below idx entries1))))) - (when (ch-set-tree-contains? (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) + (let ((val (ch-set-node-entry tree1 (postincf ientry1)))) + (when (ch-set-tree-contains? (ch-set-node-subnode tree2 (postincf isubnode2)) val hash-fn compare-fn (1+ depth)) (return nil)))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) - (let ((val (svref tree2 (+ ch-set-node-header-size (1-bits-below idx entries2))))) - (when (ch-set-tree-contains? (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) + (let ((val (ch-set-node-entry tree2 (postincf ientry2)))) + (when (ch-set-tree-contains? (ch-set-node-subnode tree1 (postincf isubnode1)) val hash-fn compare-fn (1+ depth)) (return nil)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) - (unless (rec (svref tree1 (- (length tree1) (1-bits-below idx subnodes1) 1)) - (svref tree2 (- (length tree2) (1-bits-below idx subnodes2) 1)) + (unless (rec (ch-set-node-subnode tree1 (postincf isubnode1)) + (ch-set-node-subnode tree2 (postincf isubnode2)) (1+ depth)) (return nil))))))))))) @@ -1065,7 +1084,8 @@ (defstruct (ch-set-node ;;; Verifier (defun ch-set-tree-verify (tree hash-fn) - (declare (optimize (debug 3))) + (declare (optimize (debug 3)) + (type function hash-fn)) (or (null tree) (rlabels (rec tree 0 0) (rec (node depth partial-hash) @@ -1105,6 +1125,10 @@ (defstruct (ch-set-node (let ((chash 0)) (do-wb-set-tree-members (v (cdr subnode)) (mix-hashf chash (hash-to-fixnum v hash-fn))) + (test (= chash + (multiply-hash (hash-to-fixnum (wb-set-tree-arb (cdr subnode)) + hash-fn) + (wb-set-tree-size (cdr subnode))))) (mix-hashf content-hash chash) (incf size (wb-set-tree-size (cdr subnode))) (test (= (car subnode) chash))) @@ -1145,6 +1169,8 @@ (defstruct (ch-set-node - add another `consp' check on the cdrs of collision nodes in the set code, to deal with the possibility of a map collision node (when building a new set node, may want to convert) +-- I have decided not to do all that. But I am still toying with separating the key hash from + the value hash. That would save rehashing in `domain'. ||# (defstruct (ch-map-node @@ -1155,12 +1181,15 @@ (defstruct (ch-map-node (hash-value 0 :type fixnum)) (defconstant ch-map-node-header-size 4) +(deftype ch-map-tree () + '(or null cons simple-vector)) + (defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0)) ;; &&& This would benefit from returning a hash delta, as in `ch-set-tree-less'. Ironically, ;; the technique is not actually needed in that function. (declare (optimize (speed 3) (safety 03)) (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) - (type (integer 0 1000) depth)) + (type (integer 0 64) depth)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) (declare (fixnum key-hash)) (rlabels (rec tree (ash key-hash (- (* champ-hash-bits-per-level depth))) depth) @@ -1307,6 +1336,8 @@ (defstruct (ch-map-node (setf (svref v (+ idx i 2)) (svref vec (+ idx i)))) v)) +(declaim (ftype (function (ch-map-tree) fixnum) ch-map-tree-size)) +(declaim (inline ch-map-tree-size)) (defun ch-map-tree-size (tree) (cond ((null tree) 0) ((consp tree) @@ -1318,67 +1349,70 @@ (defstruct (ch-map-node ((consp tree) (car tree)) (t (ch-map-node-hash-value tree)))) -(defun ch-map-tree-less (tree key key-hash-fn key-cmp-fn val-hash-fn) - (declare (optimize (speed 3) (safety 03)) - (type function key-hash-fn key-cmp-fn val-hash-fn)) +(defun ch-map-tree-arb-pair (tree) + (cond ((null tree) + (error "'ch-map-tree-arb' called on empty tree")) + ((consp tree) + (wb-map-tree-arb-pair (cdr tree))) + ((= 0 (ch-map-node-entry-mask tree)) + ;; If there are no entries, there must be at least one subnode + (ch-map-tree-arb-pair (svref tree (1- (length tree))))) + (t + (values (svref tree ch-map-node-header-size) (svref tree (1+ ch-map-node-header-size)))))) + +(defun ch-map-tree-less (tree key key-hash-fn key-cmp-fn val-hash-fn &optional (depth 0)) + (declare (optimize (speed 1) (safety 03) (debug 3)) + (type function key-hash-fn key-cmp-fn val-hash-fn) + (type (integer 0 64) depth)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) (declare (fixnum key-hash)) - (rlabels (rec tree key-hash) - (rec (node hash-shifted) - (declare (fixnum hash-shifted)) + (rlabels (rec tree (ash key-hash (- (* champ-hash-bits-per-level depth))) depth) + (rec (node hash-shifted depth) + (declare (fixnum hash-shifted) + (type (integer 0 64) depth)) (and node - (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) - (entry-mask (ch-map-node-entry-mask node)) - ((entry-raw-idx (1-bits-below hash-bits entry-mask)) - ((entry-idx (+ ch-map-node-header-size (* 2 entry-raw-idx))))) - (subnode-mask (ch-map-node-subnode-mask node))) - (if (logbitp hash-bits entry-mask) - (let ((ex-key (svref node entry-idx))) - (cond ((not (equal?-cmp ex-key key key-cmp-fn)) - (values node 0)) - ((and (= (logcount entry-mask) 1) (= 0 subnode-mask)) - ;; &&& Check that this happens only at the root - (values nil (mix-hash key-hash (hash-to-fixnum (svref node (1+ entry-idx)) val-hash-fn)))) - (t - (let ((n (vector-remove-2-at node entry-idx)) - (ex-value-hash (hash-to-fixnum (svref node (1+ entry-idx)) val-hash-fn))) - (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) - (decf (ch-map-node-size n)) - (let ((kv-hash (mix-hash key-hash ex-value-hash))) - (unmix-hashf (ch-map-node-hash-value n) kv-hash) - (values n kv-hash)))))) - (let ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) - ((subnode-idx (- (the fixnum (length node)) 1 subnode-raw-idx)))) - (declare (fixnum subnode-raw-idx subnode-idx)) - (if (not (logbitp hash-bits subnode-mask)) + (if (consp node) + (let ((new-wb-tree (wb-map-tree-less (cdr node) key key-cmp-fn))) + (if (eq new-wb-tree (cdr node)) (values node 0) - (let ((subnode (svref node subnode-idx))) - (if (consp subnode) - (let ((new-wb-tree (wb-map-tree-less (cdr subnode) key key-cmp-fn))) - (if (eq new-wb-tree (cdr subnode)) - (values node 0) - (let ((ig ex-value (wb-map-tree-lookup (cdr subnode) key key-cmp-fn)) - ((ex-value-hash (hash-to-fixnum ex-value val-hash-fn)))) - (declare (ignore ig)) - (if (= 1 (wb-map-tree-size new-wb-tree)) - ;; Removing next-to-last pair of collision node: turn remaining key/val into entry - (let ((rem-key rem-val (wb-map-tree-arb-pair new-wb-tree)) - ;; `entry-idx' is still valid from above; the hash bits must be the same - ((n (vector-ins-2-rem-1 node entry-idx rem-key rem-val subnode-idx)))) - (logiorf (ch-map-node-entry-mask n) (ash 1 hash-bits)) - (logandc2f (ch-map-node-subnode-mask n) (ash 1 hash-bits)) - (decf (ch-map-node-size n)) - (let ((kv-hash (mix-hash key-hash ex-value-hash))) - (unmix-hashf (ch-map-node-hash-value n) kv-hash) - (values n kv-hash))) - (let ((kv-hash (mix-hash key-hash ex-value-hash)) - ((n (vector-update node subnode-idx - (cons (unmix-hash (car subnode) kv-hash) new-wb-tree))))) - (decf (ch-map-node-size n)) - (unmix-hashf (ch-map-node-hash-value n) kv-hash) - (values n kv-hash)))))) + (let ((ig ex-value (wb-map-tree-lookup (cdr node) key key-cmp-fn)) + ((ex-value-hash (hash-to-fixnum ex-value val-hash-fn)) + ((kv-hash (mix-hash key-hash ex-value-hash))))) + (declare (ignore ig)) + (if (= 1 (wb-map-tree-size new-wb-tree)) + (let ((k v (wb-map-tree-arb-pair new-wb-tree))) + ;; We don't have `val-cmp-fn' handy, but it can't actually be called anyway. + (values (ch-map-tree-with nil k v key-hash-fn key-cmp-fn val-hash-fn (fn (_ _) nil) depth) + kv-hash)) + (values (cons (unmix-hash (car node) kv-hash) new-wb-tree) kv-hash))))) + (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) + (entry-mask (ch-map-node-entry-mask node)) + ((entry-raw-idx (1-bits-below hash-bits entry-mask)) + ((entry-idx (+ ch-map-node-header-size (* 2 entry-raw-idx))))) + (subnode-mask (ch-map-node-subnode-mask node))) + (if (logbitp hash-bits entry-mask) + (let ((ex-key (svref node entry-idx))) + (cond ((not (equal?-cmp ex-key key key-cmp-fn)) + (values node 0)) + ((and (= (logcount entry-mask) 1) (= 0 subnode-mask)) + ;; &&& Check that this happens only at the root + (values nil (mix-hash key-hash (hash-to-fixnum (svref node (1+ entry-idx)) val-hash-fn)))) + (t + (let ((n (vector-remove-2-at node entry-idx)) + (ex-value-hash (hash-to-fixnum (svref node (1+ entry-idx)) val-hash-fn))) + (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) + (decf (ch-map-node-size n)) + (let ((kv-hash (mix-hash key-hash ex-value-hash))) + (unmix-hashf (ch-map-node-hash-value n) kv-hash) + (values n kv-hash)))))) + (let ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) + ((subnode-idx (- (the fixnum (length node)) 1 subnode-raw-idx)))) + (declare (fixnum subnode-raw-idx subnode-idx)) + (if (not (logbitp hash-bits subnode-mask)) + (values node 0) + (let ((subnode (svref node subnode-idx))) (let ((new-subnode content-hash-delta - (rec subnode (ash hash-shifted (- champ-hash-bits-per-level))))) + (rec subnode (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth)))) (declare (fixnum content-hash-delta)) (if (eq new-subnode subnode) (values node 0) @@ -1386,6 +1420,8 @@ (defstruct (ch-map-node (let ((n (vector-remove-at node subnode-idx))) (logandc2f (ch-map-node-subnode-mask n) (ash 1 hash-bits)) n)) + ((consp new-subnode) + (vector-update node subnode-idx new-subnode)) ((and (= 1 (logcount (ch-map-node-entry-mask new-subnode))) (= 0 (ch-map-node-subnode-mask new-subnode))) ;; New subnode contains only a single entry: pull it up into this node @@ -1470,6 +1506,36 @@ (defstruct (ch-map-node ((subnode (svref node subnode-idx)))) (rec subnode key (ash hash-shifted (- champ-hash-bits-per-level)))))))))))))) +(defun ch-map-tree-index (tree key key-hash-fn key-cmp-fn) + (declare (optimize (debug 3))) + (let ((key-hash (hash-to-fixnum key key-hash-fn))) + (declare (fixnum key-hash)) + (rlabels (rec tree key 0 key-hash) + (rec (node key base hash-shifted) + (declare (fixnum base hash-shifted)) + (and node + (if (consp node) + (let ((found? idx (wb-map-tree-rank (cdr node) key key-cmp-fn))) + (and found? (+ idx base))) + (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) + (entry-mask (ch-map-node-entry-mask node))) + (if (logbitp hash-bits entry-mask) + (let ((ientry (1-bits-below hash-bits entry-mask)) + ((entry-idx (+ ch-map-node-header-size (* 2 ientry))) + ((ex-key (svref node entry-idx))))) + (and (equal?-cmp ex-key key key-cmp-fn) + (+ base ientry))) + (let ((subnode-mask (ch-map-node-subnode-mask node))) + (incf base (logcount entry-mask)) + (and (logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + (len (length (the simple-vector node))) + ((subnode-idx (- len 1 isubnode)) + ((subnode (svref node subnode-idx))))) + (dotimes (i isubnode) + (incf base (ch-map-tree-size (svref node (- len 1 i))))) + (rec subnode key base (ash hash-shifted (- champ-hash-bits-per-level)))))))))))))) + (defun ch-map-tree-index-pair (tree index) (rlabels (rec tree index) (rec (tree index) @@ -1490,6 +1556,170 @@ (defstruct (ch-map-node (return (rec subnode index))) (decf index subnode-size)))))))))) +(defun ch-map-tree-domain (tree key-hash-fn) + (if (null tree) nil + (rlabels (rec tree) + (rec (node) + (if (consp node) + (let ((wb-dom (wb-map-tree-domain (cdr node))) + (hash 0)) + (do-wb-set-tree-members (x wb-dom) + (mix-hashf hash (hash-to-fixnum x key-hash-fn))) + (cons hash wb-dom)) + (let ((len (length (the simple-vector node))) + (entry-mask (ch-map-node-entry-mask node)) + ((nentries (logcount entry-mask)) + ((n (make-array (- len nentries))))) + (hash 0)) + (setf (ch-set-node-entry-mask n) entry-mask) + (setf (ch-set-node-subnode-mask n) (ch-map-node-subnode-mask node)) + (setf (ch-set-node-size n) (ch-map-node-size node)) + (dotimes (i nentries) + (let ((x (svref node (+ ch-map-node-header-size (* 2 i))))) + (setf (svref n (+ ch-set-node-header-size i)) x) + (mix-hashf hash (hash-to-fixnum x key-hash-fn)))) + (dotimes (i (- len (* 2 nentries) ch-map-node-header-size)) + (let ((new-subnode (rec (svref node (- len i 1))))) + (setf (svref n (- len nentries i 1)) new-subnode) + (mix-hashf hash (ch-set-tree-hash-value new-subnode)))) + (setf (ch-set-node-hash-value n) hash) + n)))))) + +(defun ch-map-tree-compare (tree1 tree2 key-cmp-fn val-cmp-fn) + (if (eq tree1 tree2) ':equal + (let ((size1 (ch-map-tree-size tree1)) + (size2 (ch-map-tree-size tree2))) + (cond ((< size1 size2) ':less) + ((> size1 size2) ':greater) + (t + (let ((hash1 (ch-map-tree-hash-value tree1)) + (hash2 (ch-map-tree-hash-value tree2))) + (cond ((< hash1 hash2) ':less) + ((> hash1 hash2) ':greater) + ((consp tree1) + (if (consp tree2) (wb-map-tree-compare (cdr tree1) (cdr tree2) key-cmp-fn val-cmp-fn) + ':less)) + ((consp tree2) ':greater) + (t + (let ((entries1 (ch-map-node-entry-mask tree1)) + (entries2 (ch-map-node-entry-mask tree2)) + (subnodes1 (ch-map-node-subnode-mask tree1)) + (subnodes2 (ch-map-node-subnode-mask tree2))) + (cond ((< entries1 entries2) ':less) + ((> entries1 entries2) ':greater) + ((< subnodes1 subnodes2) ':less) + ((> subnodes1 subnodes2) ':greater) + (t + ;; It's astronomically unlikely that we'll get here unless the trees are actually + ;; equal... but we still have to check. + (let ((default ':equal) + (len (length (the simple-vector tree1)))) + (dotimes (i (logcount entries1)) + (let ((k1 (svref tree1 (+ ch-map-node-header-size (* 2 i)))) + (v1 (svref tree1 (+ ch-map-node-header-size (1+ (* 2 i))))) + (k2 (svref tree2 (+ ch-map-node-header-size (* 2 i)))) + (v2 (svref tree2 (+ ch-map-node-header-size (1+ (* 2 i))))) + ((key-cmp (funcall key-cmp-fn k1 k2)))) + (when (member key-cmp '(:less :greater)) + (return-from ch-map-tree-compare key-cmp)) + (when (eq key-cmp ':unequal) + (setq default ':unequal)) + (let ((val-cmp (funcall val-cmp-fn v1 v2))) + (when (member val-cmp '(:less :greater)) + (return-from ch-map-tree-compare val-cmp)) + (when (eq val-cmp ':unequal) + (setq default ':unequal))))) + (dotimes (i (logcount subnodes1)) + (let ((cmp (ch-map-tree-compare (svref tree1 (- len i 1)) (svref tree2 (- len i 1)) + key-cmp-fn val-cmp-fn))) + (ecase cmp + (:equal) + (:unequal + (setq default ':unequal)) + ((:less :greater) + (return-from ch-map-tree-compare cmp))))) + default)))))))))))) + + +(defmacro do-ch-map-tree-pairs ((key-var value-var tree-form &optional value-form) + &body body) + (let ((body-fn (gensymx #:body-)) + (recur-fn (gensymx #:recur-))) + `(block nil + (labels ((,body-fn (,key-var ,value-var) + . ,body) + (,recur-fn (tree) + (when tree + (if (consp tree) + (do-wb-map-tree-pairs (,key-var ,value-var (cdr tree)) + (,body-fn ,key-var ,value-var)) + (let ((len (the fixnum (length (the simple-vector tree))))) + (dotimes (i (logcount (ch-map-node-entry-mask tree))) + (let ((idx (+ (* 2 i) ch-map-node-header-size))) + (,body-fn (svref tree idx) (svref tree (1+ idx))))) + (dotimes (i (logcount (ch-map-node-subnode-mask tree))) + (,recur-fn (svref tree (- len 1 i))))))))) + (declare (inline ,body-fn)) + (,recur-fn ,tree-form)) + ,value-form))) + + +;;; -------------------------------- +;;; Union, intersection, set-difference, subset?, disjoint? + +(declaim (inline ch-map-node-entry)) +(defun ch-map-node-entry (n ientry) + (declare (optimize (speed 3)) + (type simple-vector n) + (type champ-entry-index ientry)) + (let ((entry-idx (+ ch-map-node-header-size (* 2 ientry)))) + (values (svref n entry-idx) (svref n (1+ entry-idx))))) + +(declaim (inline ch-map-node-subnode)) +(defun ch-map-node-subnode (n isubnode) + (declare (optimize (speed 3)) + (type simple-vector n) + (type champ-subnode-index isubnode)) + (svref n (- (length n) isubnode 1))) + +(declaim (inline ch-map-node-add-entry)) +(defun ch-map-node-add-entry (n idx key val key-hash-fn val-hash-fn) + (declare (optimize (speed 3)) + (type champ-bit-index idx) + (type function key-hash-fn val-hash-fn)) + (let ((entry-idx (+ ch-map-node-header-size (* 2 (logcount (ch-map-node-entry-mask n)))))) + (setf (svref n entry-idx) key) + (setf (svref n (1+ entry-idx)) val)) + (logiorf (ch-map-node-entry-mask n) (ash 1 idx)) + (incf (ch-map-node-size n)) + (mix-hashf (ch-map-node-hash-value n) (hash-to-fixnum key key-hash-fn) (hash-to-fixnum val val-hash-fn))) + +(declaim (inline ch-map-node-add-subnode)) +(defun ch-map-node-add-subnode (n idx subnode key-hash-fn val-hash-fn) + (declare (optimize (speed 3)) + (type champ-bit-index idx) + (type function key-hash-fn val-hash-fn)) + (when subnode + (if (and (not (consp subnode)) + (= 1 (logcount (ch-map-node-entry-mask subnode))) + (= 0 (ch-map-node-subnode-mask subnode))) + ;; `subnode' contains only an entry -- pull it up. + (ch-map-node-add-entry n idx (svref subnode ch-map-node-header-size) + (svref subnode (1+ ch-map-node-header-size)) key-hash-fn val-hash-fn) + (progn + (when (and (not (consp subnode)) + (= 0 (ch-map-node-entry-mask subnode)) + (= 1 (logcount (ch-map-node-subnode-mask subnode))) + (consp (svref subnode (1- (length subnode))))) + ;; `subnode' contains only a collision subnode -- pull it up. + (setq subnode (svref subnode (1- (length subnode))))) + (setf (svref n (- (length (the simple-vector n)) + (logcount (ch-map-node-subnode-mask n)) 1)) + subnode) + (logiorf (ch-map-node-subnode-mask n) (ash 1 idx)) + (incf (ch-map-node-size n) (ch-map-tree-size subnode)) + (mix-hashf (ch-map-node-hash-value n) (ch-map-tree-hash-value subnode)))))) + (defun ch-map-tree-union (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (declare (optimize (debug 3)) (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) @@ -1500,11 +1730,10 @@ (defstruct (ch-map-node ((null tree2) tree1) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn)) - (chash 0)) - (do-wb-map-tree-pairs (k v result) - (mix-hashf chash (hash-to-fixnum k key-hash-fn) (hash-to-fixnum v val-hash-fn))) - (cons chash result))) + ;; &&& Heh -- the mere fact that we've reached two collision nodes doesn't entail that they + ;; collide with each other. + (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) + (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) ((consp tree1) (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) @@ -1527,112 +1756,237 @@ (defstruct (ch-map-node ((everything (logior all-entries all-subnodes)) ;; Entry collisions can change to subnodes, but they can't then collide with existing subnodes. ;; But we do have to subtract out entry/subnode collisions. - ((new-len (+ ch-map-node-header-size + ((res-len (+ ch-map-node-header-size (* 2 (- (logcount all-entries) (logcount (logand entries1 subnodes2)) (logcount (logand entries2 subnodes1)))) (logcount all-subnodes))) - ((res-n (make-array new-len :initial-element 0)))))) + ((res-n (make-array res-len :initial-element 0)))))) (ientry1 0) (isubnode1 0) (ientry2 0) - (isubnode2 0) - (res-entries 0) - (res-subnodes 0) - (res-ientry 0) - (res-isubnode 0) - (res-size 0) - (res-content-hash 0)) + (isubnode2 0)) (flet ((add-entry (idx key val) - (setf (svref res-n (+ ch-map-node-header-size (* 2 res-ientry))) key) - (setf (svref res-n (+ ch-map-node-header-size (1+ (* 2 res-ientry)))) val) - (incf res-ientry) - (logiorf res-entries (ash 1 idx)) - (incf res-size) - (mix-hashf res-content-hash (hash-to-fixnum key key-hash-fn) (hash-to-fixnum val val-hash-fn))) + (ch-map-node-add-entry res-n idx key val key-hash-fn val-hash-fn)) (add-subnode (idx subnode) - ;; It's possible for `subnode' to contain only a collision subnode -- we must pull it up. - (when (and (not (consp subnode)) - (= 0 (ch-map-node-entry-mask subnode)) - (= 1 (logcount (ch-map-node-subnode-mask subnode))) - (consp (svref subnode (1- (length subnode))))) - (setq subnode (svref subnode (1- (length subnode))))) - (setf (svref res-n (- new-len (postincf res-isubnode) 1)) subnode) - (logiorf res-subnodes (ash 1 idx)) - (incf res-size (ch-map-tree-size subnode)) - (mix-hashf res-content-hash (ch-map-tree-hash-value subnode))) - (map-tree-with (tree key value depth) - (ch-map-tree-with tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) + (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn)) + (subtree-lookup (tree key) + (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn (1+ depth))) + (subtree-with (subtree key value) + (ch-map-tree-with subtree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn + (1+ depth)))) (do-bit-indices (idx everything) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) - (let ((key1 (svref tree1 (+ ch-map-node-header-size (* 2 ientry1)))) - (key2 (svref tree2 (+ ch-map-node-header-size (* 2 ientry2)))) - ((val1 (svref tree1 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry1)))))) - (val2 (svref tree2 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry2)))))))) + (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1))) + (key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) (if (equal?-cmp key1 key2 key-cmp-fn) (add-entry idx key1 (funcall val-fn val1 val2)) - (add-subnode idx (map-tree-with (map-tree-with nil key1 val1 (1+ depth)) - key2 val2 (1+ depth)))))) + (add-subnode idx (subtree-with (subtree-with nil key1 val1) key2 val2))))) ((logbitp idx entries1) - (let ((key (svref tree1 (+ ch-map-node-header-size (* 2 ientry1)))) - ((val (svref tree1 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry1)))))))) + (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1)))) (if (logbitp idx subnodes2) - (let ((subnode (svref tree2 (- (length tree2) (postincf isubnode2) 1))) - ((val2? val2 (ch-map-tree-lookup tree2 key key-hash-fn key-cmp-fn depth)))) - (add-subnode idx (map-tree-with subnode key (if val2? (funcall val-fn val val2) val) - (1+ depth)))) - (add-entry idx key val)))) + (let ((subnode2 (ch-map-node-subnode tree2 (postincf isubnode2))) + ((val2? val2 (subtree-lookup subnode2 key1)))) + (add-subnode idx (subtree-with subnode2 key1 + (if val2? (funcall val-fn val1 val2) val1)))) + (add-entry idx key1 val1)))) ((logbitp idx entries2) - (let ((key (svref tree2 (+ ch-map-node-header-size (* 2 ientry2)))) - ((val (svref tree2 (+ ch-map-node-header-size (1+ (* 2 (postincf ientry2)))))))) + (let ((key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) (if (logbitp idx subnodes1) - (let ((subnode (svref tree1 (- (length tree1) (postincf isubnode1) 1))) - ((val1? val1 (ch-map-tree-lookup subnode key key-hash-fn key-cmp-fn depth)))) - (add-subnode idx (map-tree-with subnode key (if val1? (funcall val-fn val1 val) val) - (1+ depth)))) - (add-entry idx key val)))) + (let ((subnode1 (ch-map-node-subnode tree1 (postincf isubnode1))) + ((val1? val1 (subtree-lookup subnode1 key2)))) + (add-subnode idx (subtree-with subnode1 key2 + (if val1? (funcall val-fn val1 val2) val2)))) + (add-entry idx key2 val2)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) - (add-subnode idx (rec (svref tree1 (- (length tree1) (postincf isubnode1) 1)) - (svref tree2 (- (length tree2) (postincf isubnode2) 1)) + (add-subnode idx (rec (ch-map-node-subnode tree1 (postincf isubnode1)) + (ch-map-node-subnode tree2 (postincf isubnode2)) (1+ depth)))) ((logbitp idx subnodes1) - (add-subnode idx (svref tree1 (- (length tree1) (postincf isubnode1) 1)))) + (add-subnode idx (ch-map-node-subnode tree1 (postincf isubnode1)))) ((logbitp idx subnodes2) - (add-subnode idx (svref tree2 (- (length tree2) (postincf isubnode2) 1)))) + (add-subnode idx (ch-map-node-subnode tree2 (postincf isubnode2)))) (t (error "Bug in 'ch-map-tree-union'"))))) - ;; When two entries meet and become a subnode, we no longer need the value slot. Compact. - (let ((len-needed (+ ch-map-node-header-size (* 2 res-ientry) res-isubnode))) - (assert (>= new-len len-needed)) - (let ((extra (- new-len len-needed)) - ((res-n (if (= 0 extra) res-n - (vector-remove-n-at res-n (+ ch-map-node-header-size (* 2 res-ientry)) extra))))) - (setf (ch-map-node-entry-mask res-n) res-entries) - (setf (ch-map-node-subnode-mask res-n) res-subnodes) - (setf (ch-map-node-size res-n) res-size) - (setf (ch-map-node-hash-value res-n) res-content-hash) - res-n)))))))) + ;; When two entries meet and become a subnode, we no longer need the value slot. + (ch-map-compact-node res-n))))))) -(defmacro do-ch-map-tree-pairs ((key-var value-var tree-form &optional value-form) - &body body) - (let ((body-fn (gensymx #:body-)) - (recur-fn (gensymx #:recur-))) - `(block nil - (labels ((,body-fn (,key-var ,value-var) - . ,body) - (,recur-fn (tree) - (when tree - (if (consp tree) - (do-wb-map-tree-pairs (,key-var ,value-var (cdr tree)) - (,body-fn ,key-var ,value-var)) - (let ((len (the fixnum (length (the simple-vector tree))))) - (dotimes (i (logcount (ch-map-node-entry-mask tree))) - (let ((idx (+ (* 2 i) ch-map-node-header-size))) - (,body-fn (svref tree idx) (svref tree (1+ idx))))) - (dotimes (i (logcount (ch-map-node-subnode-mask tree))) - (,recur-fn (svref tree (- len 1 i))))))))) - (declare (inline ,body-fn)) - (,recur-fn ,tree-form)) - ,value-form))) +(defun ch-map-tree-intersection (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) + (declare (optimize (debug 3))) + (rlabels (rec tree1 tree2 0) + (rec (tree1 tree2 depth) + (cond ((or (null tree1) (null tree2)) nil) + ((eq tree1 tree2) tree1) + ((and (consp tree1) (consp tree2)) + (let ((result (wb-map-tree-intersect (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) + (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) + ((or (consp tree1) (consp tree2)) + (let ((normal-node collision-node (swap-if (consp tree1) tree1 tree2)) + (result nil)) + (do-wb-map-tree-pairs (k v (cdr collision-node)) + (when (ch-map-tree-lookup normal-node k key-hash-fn key-cmp-fn depth) + (setq result (ch-map-tree-with result k v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth)))) + result)) + (t + (let ((entries1 (ch-map-node-entry-mask tree1)) + (entries2 (ch-map-node-entry-mask tree2)) + (subnodes1 (ch-map-node-subnode-mask tree1)) + (subnodes2 (ch-map-node-subnode-mask tree2)) + ;; The result can be longer than either input, because the intersection of two subnodes + ;; could be an entry. + ((res-len (+ ch-map-node-header-size + (* 2 (+ (logcount (logand entries1 entries2)) + (logcount (logand subnodes1 subnodes2)))))) + ((res-n (make-array res-len :initial-element 0)))) + (ientry1 0) + (isubnode1 0) + (ientry2 0) + (isubnode2 0)) + (flet ((add-entry (idx key val) + (ch-map-node-add-entry res-n idx key val key-hash-fn val-hash-fn)) + (add-subnode (idx subnode) + (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn)) + (lookup (tree key depth) + (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn depth))) + (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) + (logand entries1 subnodes2) (logand subnodes1 entries2))) + (cond ((and (logbitp idx entries1) (logbitp idx entries2)) + (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1))) + (key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) + (when (equal?-cmp key1 key2 key-cmp-fn) + (add-entry idx key1 (funcall val-fn val1 val2))))) + ((and (logbitp idx entries1) (logbitp idx subnodes2)) + (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1))) + (subnode2 (ch-map-node-subnode tree2 (postincf isubnode2))) + ((val2? val2 (lookup subnode2 key1 (1+ depth))))) + (when val2? + (add-entry idx key1 (funcall val-fn val1 val2))))) + ((and (logbitp idx subnodes1) (logbitp idx entries2)) + (let ((key2 val2 (ch-map-node-entry tree2 (postincf ientry2))) + (subnode1 (ch-map-node-subnode tree1 (postincf isubnode1))) + ((val1? val1 (lookup subnode1 key2 (1+ depth))))) + (when val1? + (add-entry idx key2 (funcall val-fn val2 val1))))) + ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) + (add-subnode idx (rec (ch-map-node-subnode tree1 (postincf isubnode1)) + (ch-map-node-subnode tree2 (postincf isubnode2)) + (1+ depth)))))) + (ch-map-compact-node res-n)))))))) + +(defun ch-map-tree-diff-2 (tree1 tree2 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) + (rlabels (rec tree1 tree2 0) + (rec (tree1 tree2 depth) + (cond ((null tree1) (values nil tree2)) + ((null tree2) (values tree1 nil)) + ((eq tree1 tree2) (values nil nil)) + ((consp tree1) + (if (consp tree2) + (let ((result1 result2 (wb-map-tree-diff-2 (cdr tree1) (cdr tree2) key-cmp-fn val-cmp-fn))) + (values (ch-map-node-from-wb result1 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth) + (ch-map-node-from-wb result2 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) + (let ((result1 nil) + (result2 nil)) + (do-wb-map-tree-pairs (k v1 (cdr tree1)) + (let ((v2? v2 (ch-map-tree-lookup tree2 k key-hash-fn key-cmp-fn depth))) + (unless (and v2? (equal?-cmp v1 v2 val-cmp-fn)) + (setq result1 (wb-map-tree-with result1 k v1 key-cmp-fn val-cmp-fn))))) + (do-ch-map-tree-pairs (k v2 tree2) + (let ((v1? v1 (wb-map-tree-lookup (cdr tree1) k key-cmp-fn))) + (unless (and v1? (equal?-cmp v1 v2 val-cmp-fn)) + (setq result2 (ch-map-tree-with result2 k v2 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn + depth))))) + (values (ch-map-node-from-wb result1 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth) + result2)))) + ((consp tree2) + (let ((res2 res1 (rec tree2 tree1 depth))) + (values res1 res2))) + (t + (let ((entries1 (ch-map-node-entry-mask tree1)) + (entries2 (ch-map-node-entry-mask tree2)) + (subnodes1 (ch-map-node-subnode-mask tree1)) + (subnodes2 (ch-map-node-subnode-mask tree2)) + ((res-len1 (+ ch-map-node-header-size + (* 2 (+ (logcount entries1) (logcount subnodes1))))) + ((res-n1 (make-array res-len1 :initial-element 0)))) + ((res-len2 (+ ch-map-node-header-size + (* 2 (+ (logcount entries2) (logcount subnodes2))))) + ((res-n2 (make-array res-len2 :initial-element 0)))) + (ientry1 0) + (isubnode1 0) + (ientry2 0) + (isubnode2 0)) + (flet ((add-entry (n idx key val) + (ch-map-node-add-entry n idx key val key-hash-fn val-hash-fn)) + (add-subnode (n idx subnode) + (ch-map-node-add-subnode n idx subnode key-hash-fn val-hash-fn)) + (subtree-less (subtree key) + (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth))) + (subtree-lookup (subtree key) + (ch-map-tree-lookup subtree key key-hash-fn key-cmp-fn (1+ depth)))) + (do-bit-indices (idx (logior entries1 subnodes1 entries2 subnodes2)) + (cond ((logbitp idx entries1) + (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1)))) + (cond ((logbitp idx entries2) + (let ((key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) + (unless (and (equal?-cmp key1 key2 key-cmp-fn) (equal?-cmp val1 val2 val-cmp-fn)) + (add-entry res-n1 idx key1 val1) + (add-entry res-n2 idx key2 val2)))) + ((logbitp idx subnodes2) + (let ((subnode2 (ch-map-node-subnode tree2 (postincf isubnode2))) + ((val2? val2 (subtree-lookup subnode2 key1)))) + (if (and val2? (equal?-cmp val1 val2 val-cmp-fn)) + (add-subnode res-n2 idx (subtree-less subnode2 key1)) + (progn + (add-entry res-n1 idx key1 val1) + (add-subnode res-n2 idx subnode2))))) + (t (add-entry res-n1 idx key1 val1))))) + ((logbitp idx subnodes1) + (let ((subnode1 (ch-map-node-subnode tree1 (postincf isubnode1)))) + (cond ((logbitp idx subnodes2) + (let ((subnode2 (ch-map-node-subnode tree2 (postincf isubnode2))) + ((new-sn1 new-sn2 (rec subnode1 subnode2 (1+ depth))))) + (add-subnode res-n1 idx new-sn1) + (add-subnode res-n2 idx new-sn2))) + ((logbitp idx entries2) + (let ((key2 val2 (ch-map-node-entry tree2 (postincf ientry2))) + ((val1? val1 (subtree-lookup subnode1 key2)))) + (if (and val1? (equal?-cmp val1 val2 val-cmp-fn)) + (add-subnode res-n1 idx (subtree-less subnode1 key2)) + (progn + (add-subnode res-n1 idx subnode1) + (add-entry res-n2 idx key2 val2))))) + (t (add-subnode res-n1 idx subnode1))))) + ((logbitp idx entries2) + (let ((key val (ch-map-node-entry tree2 (postincf ientry2)))) + (add-entry res-n2 idx key val))) + ((logbitp idx subnodes2) + (add-subnode res-n2 idx (ch-map-node-subnode tree2 (postincf isubnode2)))) + (t (error "Bug in ch-map-tree-diff"))))) + (values (ch-map-compact-node res-n1) (ch-map-compact-node res-n2)))))))) + +(defun ch-map-node-from-wb (wb-map-tree key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth) + (declare (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) + (case (wb-map-tree-size wb-map-tree) + (0 nil) + (1 (let ((k v (wb-map-tree-arb-pair wb-map-tree))) + (ch-map-tree-with nil k v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) + (t (let ((chash (multiply-hash (hash-to-fixnum (wb-map-tree-arb-pair wb-map-tree) key-hash-fn) + (wb-map-tree-size wb-map-tree)))) + (do-wb-map-tree-pairs (k v wb-map-tree) + (declare (ignore k)) + (mix-hashf chash (hash-to-fixnum v val-hash-fn))) + (cons chash wb-map-tree))))) + +(defun ch-map-compact-node (n) + (let ((entries (ch-map-node-entry-mask n)) + (subnodes (ch-map-node-subnode-mask n))) + (and (or (/= entries 0) (/= subnodes 0)) + (let ((len (length (the simple-vector n))) + (n-entries (logcount entries)) + ((extra (- len ch-map-node-header-size (* 2 n-entries) (logcount subnodes))))) + (when (< extra 0) + (error "Bug! Not enough space allocated for ch-map-node")) + (if (= extra 0) n + (vector-remove-n-at n (+ ch-map-node-header-size (* 2 n-entries)) extra)))))) (defun ch-map-tree-verify (tree key-hash-fn val-hash-fn) (declare (optimize (debug 3)) @@ -1665,8 +2019,7 @@ (defstruct (ch-map-node (let ((key (svref node (+ ch-map-node-header-size (* 2 key-idx)))) ((key-hash (hash-to-fixnum key key-hash-fn))) (value (svref node (+ ch-map-node-header-size (1+ (* 2 key-idx)))))) - (setq content-hash (mix-hash content-hash key-hash - (hash-to-fixnum value val-hash-fn))) + (mix-hashf content-hash key-hash (hash-to-fixnum value val-hash-fn)) (test (= (ldb (byte (* champ-hash-bits-per-level (1+ depth)) 0) key-hash) (new-partial-hash hash-bits depth partial-hash))))) @@ -1677,10 +2030,11 @@ (defstruct (ch-map-node (let ((subnode (svref node (- (length node) 1 subnode-idx)))) (if (consp subnode) (let ((chash 0)) + (test (> (wb-map-tree-size (cdr subnode)) 1)) (do-wb-map-tree-pairs (k v (cdr subnode)) - (setf chash (mix-hash chash (hash-to-fixnum k key-hash-fn) - (hash-to-fixnum v val-hash-fn)))) - (setf content-hash (mix-hash content-hash chash)) + (mix-hashf chash (hash-to-fixnum k key-hash-fn) + (hash-to-fixnum v val-hash-fn))) + (mix-hashf content-hash chash) (incf size (wb-map-tree-size (cdr subnode))) (test (= (car subnode) chash))) (and (rec subnode (1+ depth) (new-partial-hash hash-bits depth partial-hash)) diff --git a/Code/fset.lisp b/Code/fset.lisp index 6aa3d59..00bfcbd 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -187,23 +187,23 @@ (defgeneric split-from (collection value) (:documentation - "Defined on tree \(WB\) collections only. Returns the subcollection with -elements/keys greater than or equal to `value'.")) + "Defined on tree \(WB\) sets, maps, and bags only. Returns the +subcollection with elements/keys greater than or equal to `value'.")) (defgeneric split-above (collection value) (:documentation - "Defined on tree \(WB\) collections only. Returns the subcollection with -elements/keys greater than `value'.")) + "Defined on tree \(WB\) sets, maps, and bags only. Returns the +subcollection with elements/keys greater than `value'.")) (defgeneric split-through (collection value) (:documentation - "Defined on tree \(WB\) collections only. Returns the subcollection with -elements/keys less than or equal to `value'.")) + "Defined on tree \(WB\) sets, maps, and bags only. Returns the +subcollection with elements/keys less than or equal to `value'.")) (defgeneric split-below (collection value) (:documentation - "Defined on tree \(WB\) collections only. Returns the subcollection with -elements/keys less than `value'.")) + "Defined on tree \(WB\) sets, maps, and bags only. Returns the +subcollection with elements/keys less than `value'.")) (defgeneric union (set-or-bag1 set-or-bag2 &key) (:documentation @@ -2288,25 +2288,25 @@ (defmethod intersection ((s1 ch-set) (s2 ch-set) &key) (defmethod set-difference ((s1 ch-set) (s2 ch-set) &key) (if-same-ch-set-orgs (s1 s2 hsorg) - (make-ch-set (ch-set-tree-difference (ch-set-contents s1) (ch-set-contents s2) - (hash-set-org-hash-fn hsorg) - (hash-set-org-compare-fn hsorg)) + (make-ch-set (ch-set-tree-diff (ch-set-contents s1) (ch-set-contents s2) + (hash-set-org-hash-fn hsorg) + (hash-set-org-compare-fn hsorg)) hsorg) (call-next-method))) (defmethod set-difference-rev ((s1 ch-set) (s2 ch-set)) (if-same-ch-set-orgs (s1 s2 hsorg) - (make-ch-set (ch-set-tree-difference (ch-set-contents s1) (ch-set-contents s2) - (hash-set-org-hash-fn hsorg) - (hash-set-org-compare-fn hsorg)) + (make-ch-set (ch-set-tree-diff (ch-set-contents s1) (ch-set-contents s2) + (hash-set-org-hash-fn hsorg) + (hash-set-org-compare-fn hsorg)) hsorg) (call-next-method))) (defmethod set-difference-2 ((s1 ch-set) (s2 ch-set)) (if-same-ch-set-orgs (s1 s2 hsorg) - (let ((s1-diff-s2 s2-diff-s1 (ch-set-tree-difference-2 (ch-set-contents s1) (ch-set-contents s2) - (hash-set-org-hash-fn hsorg) - (hash-set-org-compare-fn hsorg)))) + (let ((s1-diff-s2 s2-diff-s1 (ch-set-tree-diff-2 (ch-set-contents s1) (ch-set-contents s2) + (hash-set-org-hash-fn hsorg) + (hash-set-org-compare-fn hsorg)))) (values (make-ch-set s1-diff-s2 hsorg) (make-ch-set s2-diff-s1 hsorg))) (call-next-method))) @@ -3765,7 +3765,7 @@ (defmethod map-intersection ((map1 wb-map) (map2 wb-map) (make-wb-map (WB-Map-Tree-Intersect (wb-map-contents map1) (wb-map-contents map2) (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg)) tmorg (let ((def1 (map-default map1)) - (def2 (map-default map2))) + (def2 (map-default map2))) (and (or def1 def2) (funcall val-fn def1 def2)))) (call-next-method))) @@ -4275,9 +4275,23 @@ (defmethod with-default ((m ch-map) new-default) (defmethod empty? ((m ch-map)) (null (ch-map-contents m))) +(defmethod arb ((m ch-map)) + (let ((tree (ch-map-contents m))) + (if tree + (let ((key val (ch-map-tree-arb-pair tree))) + (values key val t)) + (values nil nil nil)))) + (defmethod size ((m ch-map)) (ch-map-tree-size (ch-map-contents m))) +(defmethod contains? ((m ch-map) x &optional (y nil y?)) + (check-three-arguments y? 'contains? 'wb-map) + (let ((hmorg (ch-map-org m)) + ((val? val (ch-map-tree-lookup (ch-map-contents m) x + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg))))) + (and val? (equal?-cmp val y (hash-map-org-val-compare-fn hmorg))))) + (defmethod with ((m ch-map) key &optional (value nil value?)) (check-three-arguments value? 'with 'ch-map) (let ((contents (ch-map-contents m)) @@ -4307,6 +4321,11 @@ (defmethod lookup ((m ch-map) key) ;; Our internal convention is the reverse of the external one. (values (if val? val (map-default m)) val?))) +(defmethod index ((m ch-map) key) + (declare (optimize (debug 3))) + (let ((hmorg (ch-map-org m))) + (ch-map-tree-index (ch-map-contents m) key (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg)))) + (defmethod at-index ((m ch-map) index) (let ((contents (ch-map-contents m)) ((size (ch-map-tree-size contents)))) @@ -4316,10 +4335,55 @@ (defmethod at-index ((m ch-map) index) :format-arguments (list index m))) (ch-map-tree-index-pair contents index))) +(defmethod domain ((m ch-map)) + (let ((hmorg (ch-map-org m)) + ((set-prototype (empty-ch-set (hash-map-org-key-compare-fn-name hmorg))))) + (make-ch-set (ch-map-tree-domain (ch-map-contents m) (hash-map-org-key-hash-fn hmorg)) + (ch-set-org set-prototype)))) + +(defmethod range ((m ch-map)) + (let ((hmorg (ch-map-org m)) + ((set-prototype (empty-ch-set (hash-map-org-val-compare-fn-name hmorg))) + (val-hash-fn (hash-map-org-val-hash-fn hmorg)) + (val-compare-fn (hash-map-org-val-compare-fn hmorg))) + (result nil)) + (do-map (key val m) + (declare (ignore key)) + (setq result (ch-set-tree-with result val val-hash-fn val-compare-fn))) + (make-ch-set result (ch-set-org set-prototype)))) + (defmethod domain-contains? ((m ch-map) x) (let ((hmorg (ch-map-org m))) (ch-map-tree-lookup (ch-map-contents m) x (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg)))) +(defmethod compare ((map1 ch-map) (map2 ch-map)) + (if-same-ch-map-orgs (map1 map2 hmorg) + (let ((val-compare-fn (hash-map-org-val-compare-fn hmorg)) + ((comp (ch-map-tree-compare (ch-map-contents map1) (ch-map-contents map2) + (hash-map-org-key-compare-fn hmorg) val-compare-fn)))) + (if (member comp '(:less :greater)) + comp + (let ((def-comp (funcall val-compare-fn (map-default map1) (map-default map2)))) + (if (member def-comp '(:less :greater)) + def-comp + (if (or (eq comp ':unequal) (eq def-comp ':unequal)) + ':unequal + ':equal))))) + ;; See `define-wb-set-methods compare' above. + (let ((m1-kcfn-name (hash-map-org-key-compare-fn-name (ch-map-org map1))) + (m1-vcfn-name (hash-map-org-val-compare-fn-name (ch-map-org map1))) + (m2-kcfn-name (hash-map-org-key-compare-fn-name (ch-map-org map2))) + (m2-vcfn-name (hash-map-org-val-compare-fn-name (ch-map-org map2))) + ((name-comp (compare (list m1-kcfn-name m1-vcfn-name) (list m2-kcfn-name m2-vcfn-name))))) + (ecase name-comp + ((:less :greater) + name-comp) + (:equal + (compare (convert 'wb-map map1 :key-compare-fn-name m1-kcfn-name :val-compare-fn-name m1-vcfn-name) + (convert 'wb-map map2 :key-compare-fn-name m1-kcfn-name :val-compare-fn-name m1-vcfn-name))) + (:unequal + (error "Can't compare wb-maps with uninterned compare-fn-names with same symbol-name")))))) + (defmethod map-union ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2))) (if-same-ch-map-orgs (m1 m2 hmorg) (make-ch-map (ch-map-tree-union (ch-map-contents m1) (ch-map-contents m2) @@ -4331,6 +4395,26 @@ (defmethod map-union ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2) (and (or def1 def2) (funcall val-fn def1 def2)))) (call-next-method))) +(defmethod map-intersection ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2))) + (if-same-ch-map-orgs (m1 m2 hmorg) + (make-ch-map (ch-map-tree-intersection (ch-map-contents m1) (ch-map-contents m2) + (coerce val-fn 'function) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)) + hmorg (let ((def1 (map-default m1)) + (def2 (map-default m2))) + (and (or def1 def2) (funcall val-fn def1 def2)))) + (call-next-method))) + +(defmethod map-difference-2 ((map1 ch-map) (map2 ch-map)) + (if-same-ch-map-orgs (map1 map2 hmorg) + (let ((newc1 newc2 (ch-map-tree-diff-2 (ch-map-contents map1) (ch-map-contents map2) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)))) + (values (make-ch-map newc1 hmorg (map-default map1)) + (make-ch-map newc2 hmorg (map-default map2)))) + (call-next-method))) + (defmethod internal-do-map ((m ch-map) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) diff --git a/Code/hash.lisp b/Code/hash.lisp index ef6fdaf..7d207b3 100644 --- a/Code/hash.lisp +++ b/Code/hash.lisp @@ -20,34 +20,32 @@ (define-hash-function compare hash-value) ;;; "depthoid"). Maybe I should too. (defmethod hash-value ((x identity-equality-mixin)) - ;; &&& Seems to work in SBCL - (logxor (sxhash (class-of x)) (slot-value x 'serial-number))) + (mix-hash (sxhash (class-of x)) (slot-value x 'serial-number))) (defmethod hash-value ((x identity-ordering-mixin)) - ;; &&& Seems to work in SBCL - (logxor (sxhash (class-of x)) (slot-value x 'serial-number))) + (mix-hash (sxhash (class-of x)) (slot-value x 'serial-number))) (defmethod hash-value ((x real)) (sxhash x)) (defmethod hash-value ((x integer)) - ;; &&& This will make the tree structure sensitive to powers of 32, but seems like any reasonably - ;; simple bit-twiddling will risk causing some such artifact. Still, have a look at - ;; `sxhash-fixnum-xform' in the SBCL sources, for example. - x) + (logxor (ash x 3) x)) (defmethod hash-value ((x character)) - (sxhash x)) ; I guess + (sxhash x)) (defmethod hash-value ((x symbol)) - ;; None of SBCL, CCL, Allegro, LispWorks, or CLASP include the package in the hash. Of these, - ;; only on SBCL is the hash of a symbol different from that of its `symbol-name'. + ;; None of SBCL, CCL, ABCL, Allegro, LispWorks, or CLASP include the package in the hash. (Of these, + ;; only on SBCL is the hash of a symbol different from that of its `symbol-name'.) We _could_ mix + ;; in the hash of the package, but how often does one really use symbols from multiple packages in + ;; one set or map? We'll leave that problem for `compare' — it handles it well. (sxhash x)) (defmethod hash-value ((x string)) (sxhash x)) (defmethod hash-value ((x list)) + ;; &&& Needs length/depth-limiting. (logxor (hash-value (car x)) (logand most-positive-fixnum (* 11 (hash-value (cdr x)))))) (defmethod hash-value ((x vector)) diff --git a/Code/macros.lisp b/Code/macros.lisp index 4c6bd18..2d3ac33 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -21,7 +21,7 @@ (defmacro postincf (place &optional (delta 1)) ;; I used to do the `get-setf-expansion' thing and save the value in a local, but this - ;; seems to give better code, at least on SBCL. + ;; seems to give better code, at least on SBCL on AMD64. `(1- (incf ,place ,delta))) diff --git a/Code/port.lisp b/Code/port.lisp index 428f642..2897340 100644 --- a/Code/port.lisp +++ b/Code/port.lisp @@ -404,6 +404,15 @@ `(locally (declare (optimize (speed 3) (safety 0))) (the fixnum (logxor (the fixnum ,hash) . ,(mapcar (fn (x) `(the fixnum ,x)) to-unmix))))) +(defmacro multiply-hash (hash integer) + "Returns `hash' mixed with itself `integer' times." + #+(or sbcl ccl allegro lispworks) + `(locally (declare (optimize (speed 3) (safety 0))) + (the fixnum (* (the fixnum ,hash) (the fixnum ,integer)))) + #-(or sbcl ccl allegro lispworks) + `(locally (declare (optimize (speed 3) (safety 0))) + (the fixnum (* (the fixnum ,hash) (logand 1 (the fixnum ,integer)))))) + (define-modify-macro mix-hashf (&rest args) mix-hash) (define-modify-macro unmix-hashf (hash &rest to-unmix) @@ -454,3 +463,7 @@ (define-modify-macro unmix-hashf (hash &rest to-unmix) (defun eqv (a b &rest more) (and (or (eq a b) (and a b)) (gmap (:result and) #'eqv (:arg constant a) (:arg list more)))) + +(defun swap-if (pred x y) + (if pred (values y x) + (values x y))) diff --git a/Code/testing.lisp b/Code/testing.lisp index dd6afc9..871b99a 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -3825,7 +3825,7 @@ (defmethod verify ((br wb-2-relation)) (defmethod hash-value ((x my-integer)) ;; Drop the two low-order bits to force collisions, and spread the bits out to force more levels - ;; to be created. Also, values equal mod 256 will have the same hash. + ;; to be created. Also, values equal mod 1024 will have the same hash. (let ((val (ash (my-integer-value x) -2))) (dpb (ldb (byte 2 6) val) (byte 2 15) @@ -3853,6 +3853,7 @@ (defmethod verify ((s ch-set)) (prev-wbs wbs) (prev-chs chs)) (test (eqv (contains? chs mi) (contains? wbs mi))) + (test (or (empty? chs) (contains? chs (arb chs)))) (if (< (random 100) 20) (progn (excludef wbs mi) @@ -3911,7 +3912,6 @@ (defmethod verify ((s ch-set)) (test (equal? (reverse (convert 'seq chs)) (gmap (:result seq) nil (:arg fun-sequence chs :from-end? t))))))) (when saved-chs - (test (eqv (disjoint? chs saved-chs) (disjoint? wbs saved-wbs))) (let ((chs-union (union chs saved-chs))) (test (verify chs-union)) (test (equal? (convert 'wb-set chs-union) (union wbs saved-wbs)))) @@ -3926,6 +3926,14 @@ (defmethod verify ((s ch-set)) (test (verify chs-diff-2b)) (test (equal? chs-diff-2a chs-diff)) (test (equal? chs-diff-2b (set-difference saved-chs chs)))))) + ;; To get a good test for `disjoint?', we need different statistics -- choosing 256 out of 1024, + ;; disjointness is astronomically unlikely. Choosing 55 out of 4096 gives roughly 50% odds. + ;; (Why so few? The Birthday Paradox.) + (let ((wbs0 (gmap (:result wb-set) (fn (_i) (make-my-integer (random 4096))) (:arg index 0 55))) + (wbs1 (gmap (:result wb-set) (fn (_i) (make-my-integer (random 4096))) (:arg index 0 55))) + ((chs0 (convert 'ch-set wbs0)) + (chs1 (convert 'ch-set wbs1)))) + (test (eqv (disjoint? chs0 chs1) (disjoint? wbs0 wbs1)))) (setq saved-wbs wbs) (setq saved-chs chs)))))) @@ -3937,46 +3945,92 @@ (defmethod verify ((m ch-map)) (defun test-champ-maps (n) (declare (optimize (speed 0) (debug 3))) - (let ((saved-wbm nil) - (saved-chm nil)) - (dotimes (i n) - (let ((wbm (wb-map)) - (chm (ch-map))) - (setq *champ-map-test-pairs* (seq)) - (dotimes (j 256) - (let ((mi (make-my-integer (random 1024))) - (val (random 65536)) - (prev-wbm wbm) - (prev-chm chm)) - (unless (eql (lookup chm mi) (lookup wbm mi)) - (error "ch-map lookup failed")) - (if (< (random 100) 20) + (macrolet ((test (form) + `(unless ,form + (error "Test failed: ~S" ',form)))) + (let ((saved-wbm nil) + (saved-chm nil)) + (dotimes (i n) + (let ((wbm (wb-map)) + (chm (ch-map))) + (setq *champ-map-test-pairs* (seq)) + (dotimes (j 256) + (let ((mi (make-my-integer (random 1024))) + (val (random 65536)) + (prev-wbm wbm) + (prev-chm chm)) + (test (eql (lookup chm mi) (lookup wbm mi))) + (test (or (empty? chm) (let ((k v (arb chm))) + (equal? v (lookup chm k))))) + (if (< (random 100) 20) + (progn + (push-last *champ-map-test-pairs* (list '- mi val)) + (excludef wbm mi) + (excludef chm mi) + (test (or (domain-contains? prev-wbm mi) + (eq chm prev-chm)))) (progn - (push-last *champ-map-test-pairs* (list '- mi val)) - (excludef wbm mi) - (excludef chm mi) - (unless (or (domain-contains? prev-wbm mi) - (eq chm prev-chm)) - (error "ch-map less failed to detect no change"))) - (progn - (push-last *champ-map-test-pairs* (list '+ mi val)) - (setf (@ wbm mi) val) - (setf (@ chm mi) val))) - (unless (verify chm) - (error "Verification failed on ~A; prev ~A" chm prev-chm)) - (let ((wbm-from-ch (convert 'wb-map chm))) - (unless (equal? wbm wbm-from-ch) - (error "ch-map equal? failed on ~A~%vs. ~A:~%diffs ~A~%prev ~A" wbm chm - (multiple-value-list (map-difference-2 wbm wbm-from-ch)) prev-chm))))) - (when saved-chm - (let ((chm-union (map-union chm saved-chm))) - (unless (verify chm-union) - (error "ch-map union verification failed")) - (let ((wbm-union (map-union wbm saved-wbm)) - ((chm-union-as-wbm (convert 'wb-map chm-union)))) - (unless (equal? chm-union-as-wbm wbm-union) - (let ((ch-only wb-only (map-difference-2 chm-union-as-wbm wbm-union))) - (error "ch-map union failed: ~A, ~A" ch-only wb-only)))))) - (setq saved-wbm wbm) - (setq saved-chm chm))))) + (push-last *champ-map-test-pairs* (list '+ mi val)) + (setf (@ wbm mi) val) + (setf (@ chm mi) val))) + (test (verify chm)) + (when (let ((quot rem (floor j 32))) + (and (= 0 rem) (>= quot 1))) + (let ((wbm-from-ch (convert 'wb-map chm))) + (unless (equal? wbm wbm-from-ch) + (error "ch-map equal? failed on ~A~%vs. ~A:~%diffs ~A~%prev ~A" wbm chm + (multiple-value-list (map-difference-2 wbm wbm-from-ch)) prev-chm))) + (let ((ch-dom (domain chm))) + (test (verify ch-dom)) + (test (equal? (convert 'wb-set ch-dom) (domain wbm)))) + (let ((idx (random (size chm))) + ((elt (at-index chm idx)) + ((tmp-chm (with (less chm elt) + ;; Adding 4096 doesn't change the hash value. + (make-my-integer (+ (my-integer-value elt) 4096)) + (@ chm elt)))))) + ;; `ch-set-tree-compare' is tough to test thoroughly. This at least checks the case that is + ;; least obviously correct by inspection, where all the hash values are the same but two elements + ;; nonetheless differ. + (test (eq (compare chm tmp-chm) ':less)) + (test (eq (compare tmp-chm chm) ':greater))) + (let ((k 0) + #+(or)(it (iterator chs)) + #+(or)(f-it (fun-iterator chs))) + (do-map (x y chm) + (let ((idxx idxy (at-index chm k))) + (test (and (equal? x idxx) (equal? y idxy)))) + #+(or)(test (funcall it ':more?)) + #+(or)(test (not (funcall f-it ':empty?))) + #+(or) + (let ((itval (funcall it ':get)) + (f-itval (funcall f-it ':first))) + (test (equal? x itval)) + (test (equal? x f-itval))) + (test (= (index chm x) k)) + (incf k) + #+(or)(setq f-it (funcall f-it ':rest))) + #+(or)(test (funcall it ':done?)) + #+(or)(test (funcall f-it ':empty?)))))) + (when saved-chm + (let ((chm-union (map-union chm saved-chm))) + (test (verify chm-union)) + (let ((wbm-union (map-union wbm saved-wbm)) + ((chm-union-as-wbm (convert 'wb-map chm-union)))) + (unless (equal? chm-union-as-wbm wbm-union) + (let ((ch-only wb-only (map-difference-2 chm-union-as-wbm wbm-union))) + (error "ch-map union failed: ~A, ~A" ch-only wb-only))))) + (let ((chm-intersection (map-intersection chm saved-chm))) + (test (verify chm-intersection)) + (let ((wbm-intersection (map-intersection wbm saved-wbm)) + ((chm-int-as-wbm (convert 'wb-map chm-intersection)))) + (test (equal? chm-int-as-wbm wbm-intersection)))) + (let ((chm-diff-2a chm-diff-2b (map-difference-2 chm saved-chm)) + (wbm-diff-2a wbm-diff-2b (map-difference-2 wbm saved-wbm))) + (test (verify chm-diff-2a)) + (test (verify chm-diff-2b)) + (test (equal? (convert 'wb-map chm-diff-2a) wbm-diff-2a)) + (test (equal? (convert 'wb-map chm-diff-2b) wbm-diff-2b)))) + (setq saved-wbm wbm) + (setq saved-chm chm)))))) -- GitLab From 28a3b5eb2f4470b36f142b9017ce17373fbff4dc Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Mon, 8 Sep 2025 17:41:40 -0700 Subject: [PATCH 09/16] Another checkpoint. Getting there! --- Code/champ.lisp | 407 ++++++++++++++++++++++++++++++++-------------- Code/fset.lisp | 33 ++++ Code/port.lisp | 4 +- Code/testing.lisp | 14 +- 4 files changed, 333 insertions(+), 125 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index e40bb00..6d67cff 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -42,6 +42,11 @@ (deftype champ-entry-index () `(integer 0 ,(1- champ-node-radix))) (deftype champ-subnode-index () `(integer 0 ,(1- champ-node-radix))) +(declaim (inline champ-hash-bits)) +(defun champ-hash-bits (hash depth) + (ldb (byte champ-hash-bits-per-level (* depth champ-hash-bits-per-level)) + hash)) + (declaim (inline 1-bits-below)) (defun 1-bits-below (idx mask) "The number of 1 bits in `mask' at bit positions (strictly) less than `idx'." @@ -705,8 +710,23 @@ (defstruct (ch-set-node ((null tree2) tree1) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((result (wb-set-tree-union (cdr tree1) (cdr tree2) compare-fn))) - (ch-set-node-from-wb result hash-fn compare-fn depth))) + (let ((hash1 (hash-to-fixnum (wb-set-tree-arb (cdr tree1)) hash-fn)) + (hash2 (hash-to-fixnum (wb-set-tree-arb (cdr tree2)) hash-fn))) + (if (= hash1 hash2) + (let ((result (wb-set-tree-union (cdr tree1) (cdr tree2) compare-fn))) + (ch-set-node-from-wb result hash-fn depth)) + (let ((size (+ (wb-set-tree-size (cdr tree1)) (wb-set-tree-size (cdr tree2))))) + (declare (fixnum size)) + (rlabels (build depth) + (build (depth) + (declare (type (integer 0 64) depth)) + (let ((bits1 (champ-hash-bits hash1 depth)) + (bits2 (champ-hash-bits hash2 depth)) + (chash (mix-hash (car tree1) (car tree2)))) + (if (= bits1 bits2) + (vector 0 (ash 1 bits1) size chash (build (1+ depth))) + (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) + (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0)))))))))) ((or (consp tree1) (consp tree2)) (let ((normal-node collision-node (if (consp tree1) (values tree2 tree1) (values tree1 tree2)))) ;; Garbagey, but nontrivial to improve on, AFAICS. @@ -729,7 +749,7 @@ (defstruct (ch-set-node (isubnode1 0) (ientry2 0) (isubnode2 0)) - (declare (type (integer 0 64) ientry1 isubnode1 ientry2 isubnode2)) + (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) (flet ((add-entry (idx val) (ch-set-node-add-entry res-n idx val hash-fn)) (add-subnode (idx subnode) @@ -773,8 +793,10 @@ (defstruct (ch-set-node (cond ((or (null tree1) (null tree2)) nil) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((result (wb-set-tree-intersect (cdr tree1) (cdr tree2) compare-fn))) - (ch-set-node-from-wb result hash-fn compare-fn depth))) + (and (= (hash-to-fixnum (wb-set-tree-arb (cdr tree1)) hash-fn) + (hash-to-fixnum (wb-set-tree-arb (cdr tree2)) hash-fn)) + (let ((result (wb-set-tree-intersect (cdr tree1) (cdr tree2) compare-fn))) + (ch-set-node-from-wb result hash-fn depth)))) ((or (consp tree1) (consp tree2)) (let ((normal-node collision-node (swap-if (consp tree1) tree1 tree2)) (result nil)) @@ -791,11 +813,7 @@ (defstruct (ch-set-node ;; Unlike in the union case, where we can compute the size in advance, for the intersection ;; we can only compute an upper bound -- the result could even be empty. ((res-len (min (length tree1) (length tree2))) - ((res-n (make-array res-len :initial-element 0)))) - (ientry1 0) - (isubnode1 0) - (ientry2 0) - (isubnode2 0)) + ((res-n (make-array res-len :initial-element 0))))) (flet ((add-entry (idx val) (ch-set-node-add-entry res-n idx val hash-fn)) (add-subnode (idx subnode) @@ -804,22 +822,24 @@ (defstruct (ch-set-node (ch-set-tree-contains? tree val hash-fn compare-fn (1+ depth)))) (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) (logand entries1 subnodes2) (logand subnodes1 entries2))) + ;; Here and in the other algorithms that don't look at every bit in the OR of + ;; the masks, we have to use `1-bits-below' instead of counters to get the indices. (cond ((and (logbitp idx entries1) (logbitp idx entries2)) - (let ((val1 (ch-set-node-entry tree1 (postincf ientry1))) - (val2 (ch-set-node-entry tree2 (postincf ientry2)))) + (let ((val1 (ch-set-node-entry tree1 (1-bits-below idx entries1))) + (val2 (ch-set-node-entry tree2 (1-bits-below idx entries2)))) (when (equal?-cmp val1 val2 compare-fn) (add-entry idx val1)))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) - (let ((val (ch-set-node-entry tree1 (postincf ientry1)))) - (when (subtree-contains? (ch-set-node-subnode tree2 (postincf isubnode2)) val) + (let ((val (ch-set-node-entry tree1 (1-bits-below idx entries1)))) + (when (subtree-contains? (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) val) (add-entry idx val)))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) - (let ((val (ch-set-node-entry tree2 (postincf ientry2)))) - (when (subtree-contains? (ch-set-node-subnode tree1 (postincf isubnode1)) val) + (let ((val (ch-set-node-entry tree2 (1-bits-below idx entries2)))) + (when (subtree-contains? (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) val) (add-entry idx val)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) - (add-subnode idx (rec (ch-set-node-subnode tree1 (postincf isubnode1)) - (ch-set-node-subnode tree2 (postincf isubnode2)) + (add-subnode idx (rec (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) + (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) (1+ depth))))))) (ch-set-compact-node res-n))))))) @@ -831,14 +851,17 @@ (defstruct (ch-set-node ((eq tree1 tree2) nil) ((consp tree1) (if (consp tree2) - (let ((result (wb-set-tree-diff (cdr tree1) (cdr tree2) compare-fn))) - (ch-set-node-from-wb result hash-fn compare-fn depth)) - (let ((result (cdr tree1))) - ;; This could be improved by comparing hashes, but collision nodes will be vanishingly - ;; rare in practice anyway. Or should be... - (do-ch-set-tree-members (v tree2) - (setq result (wb-set-tree-less result v compare-fn))) - (ch-set-node-from-wb result hash-fn compare-fn depth)))) + (if (= (hash-to-fixnum (wb-set-tree-arb (cdr tree1)) hash-fn) + (hash-to-fixnum (wb-set-tree-arb (cdr tree2)) hash-fn)) + (let ((result (wb-set-tree-diff (cdr tree1) (cdr tree2) compare-fn))) + (ch-set-node-from-wb result hash-fn depth)) + tree1) + (let ((result nil)) + ;; Assuming the collision subtree is likely to be much smaller than the regular one. + (do-wb-set-tree-members (v (cdr tree1)) + (unless (ch-set-tree-contains? tree2 v hash-fn compare-fn depth) + (setq result (wb-set-tree-with result v compare-fn)))) + (ch-set-node-from-wb result hash-fn depth)))) ((consp tree2) (do-wb-set-tree-members (v (cdr tree2)) (setq tree1 (ch-set-tree-less tree1 v hash-fn compare-fn depth))) @@ -849,11 +872,7 @@ (defstruct (ch-set-node (subnodes1 (ch-set-node-subnode-mask tree1)) (subnodes2 (ch-set-node-subnode-mask tree2)) ((res-len (length (the simple-vector tree1))) ; upper bound - ((res-n (make-array res-len :initial-element 0)))) - (ientry1 0) - (isubnode1 0) - (ientry2 0) - (isubnode2 0)) + ((res-n (make-array res-len :initial-element 0))))) (flet ((add-entry (idx val) (ch-set-node-add-entry res-n idx val hash-fn)) (add-subnode (idx subnode) @@ -864,24 +883,24 @@ (defstruct (ch-set-node (ch-set-tree-contains? subtree val hash-fn compare-fn (1+ depth)))) (do-bit-indices (idx (logior entries1 subnodes1)) (cond ((logbitp idx entries1) - (let ((val1 (ch-set-node-entry tree1 (postincf ientry1)))) + (let ((val1 (ch-set-node-entry tree1 (1-bits-below idx entries1)))) (cond ((logbitp idx entries2) - (let ((val2 (ch-set-node-entry tree2 (postincf ientry2)))) + (let ((val2 (ch-set-node-entry tree2 (1-bits-below idx entries2)))) (unless (equal?-cmp val1 val2 compare-fn) (add-entry idx val1)))) ((logbitp idx subnodes2) - (let ((subnode (ch-set-node-subnode tree2 (postincf isubnode2)))) + (let ((subnode (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)))) (unless (subtree-contains? subnode val1) (add-entry idx val1)))) (t (add-entry idx val1))))) ((logbitp idx subnodes1) - (let ((subnode1 (ch-set-node-subnode tree1 (postincf isubnode1)))) - (cond ((logbitp idx subnodes2) - (let ((subnode2 (ch-set-node-subnode tree2 (postincf isubnode2)))) - (add-subnode idx (rec subnode1 subnode2 (1+ depth))))) - ((logbitp idx entries2) - (let ((val2 (ch-set-node-entry tree2 (postincf ientry2)))) + (let ((subnode1 (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)))) + (cond ((logbitp idx entries2) + (let ((val2 (ch-set-node-entry tree2 (1-bits-below idx entries2)))) (add-subnode idx (subtree-less subnode1 val2)))) + ((logbitp idx subnodes2) + (let ((subnode2 (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)))) + (add-subnode idx (rec subnode1 subnode2 (1+ depth))))) (t (add-subnode idx subnode1)))))))) (ch-set-compact-node res-n))))))) @@ -894,15 +913,18 @@ (defstruct (ch-set-node ((eq tree1 tree2) (values nil nil)) ((consp tree1) (if (consp tree2) - (let ((result1 result2 (wb-set-tree-diff-2 (cdr tree1) (cdr tree2) compare-fn))) - (values (ch-set-node-from-wb result1 hash-fn compare-fn depth) - (ch-set-node-from-wb result2 hash-fn compare-fn depth))) + (if (= (hash-to-fixnum (wb-set-tree-arb (cdr tree1)) hash-fn) + (hash-to-fixnum (wb-set-tree-arb (cdr tree2)) hash-fn)) + (let ((result1 result2 (wb-set-tree-diff-2 (cdr tree1) (cdr tree2) compare-fn))) + (values (ch-set-node-from-wb result1 hash-fn depth) + (ch-set-node-from-wb result2 hash-fn depth))) + (values tree1 tree2)) (let ((result1 (cdr tree1))) (do-ch-set-tree-members (v tree2) (setq result1 (wb-set-tree-less result1 v compare-fn))) (do-wb-set-tree-members (v (cdr tree1)) (setq tree2 (ch-set-tree-less tree2 v hash-fn compare-fn depth))) - (values (ch-set-node-from-wb result1 hash-fn compare-fn depth) + (values (ch-set-node-from-wb result1 hash-fn depth) tree2)))) ((consp tree2) (let ((res2 res1 (rec tree2 tree1 depth))) @@ -962,12 +984,13 @@ (defstruct (ch-set-node (t (error "Bug in ch-set-tree-diff-2"))))) (values (ch-set-compact-node res-n1) (ch-set-compact-node res-n2)))))))) -(defun ch-set-node-from-wb (wb-set-tree hash-fn compare-fn depth) +(defun ch-set-node-from-wb (wb-set-tree hash-fn depth) (declare (optimize (speed 3)) - (type function hash-fn compare-fn)) + (type function hash-fn)) (case (wb-set-tree-size wb-set-tree) (0 nil) - (1 (ch-set-tree-with nil (wb-set-tree-arb wb-set-tree) hash-fn compare-fn depth)) + ;; `compare-fn' can't be called in this case. + (1 (ch-set-tree-with nil (wb-set-tree-arb wb-set-tree) hash-fn (fn (_ _)) depth)) ;; Since this is a collision node, all the hash values must be equal. (t (cons (multiply-hash (hash-to-fixnum (wb-set-tree-arb wb-set-tree) hash-fn) (wb-set-tree-size wb-set-tree)) wb-set-tree)))) @@ -1006,29 +1029,25 @@ (defstruct (ch-set-node (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) (subnodes1 (ch-set-node-subnode-mask tree1)) - (subnodes2 (ch-set-node-subnode-mask tree2)) - (ientry1 0) - (isubnode1 0) - (ientry2 0) - (isubnode2 0)) + (subnodes2 (ch-set-node-subnode-mask tree2))) (do-bit-indices (idx (logior entries1 subnodes1) t) (cond ((logbitp idx entries1) (cond ((logbitp idx entries2) - (let ((val1 (ch-set-node-entry tree1 (postincf ientry1))) - (val2 (ch-set-node-entry tree2 (postincf ientry2)))) + (let ((val1 (ch-set-node-entry tree1 (1-bits-below idx entries1))) + (val2 (ch-set-node-entry tree2 (1-bits-below idx entries2)))) (unless (equal?-cmp val1 val2 compare-fn) (return nil)))) ((logbitp idx subnodes2) - (let ((val (ch-set-node-entry tree1 (postincf ientry1)))) - (unless (ch-set-tree-contains? (ch-set-node-subnode tree2 (postincf isubnode2)) + (let ((val (ch-set-node-entry tree1 (1-bits-below idx entries1)))) + (unless (ch-set-tree-contains? (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) val hash-fn compare-fn (1+ depth)) (return nil)))) (t (return nil)))) ((logbitp idx subnodes1) (cond ((logbitp idx subnodes2) - (unless (rec (ch-set-node-subnode tree1 (postincf isubnode1)) - (ch-set-node-subnode tree2 (postincf isubnode2)) + (unless (rec (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) + (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) (1+ depth)) (return nil))) (t (return nil)))))))))))) @@ -1051,31 +1070,27 @@ (defstruct (ch-set-node (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) (subnodes1 (ch-set-node-subnode-mask tree1)) - (subnodes2 (ch-set-node-subnode-mask tree2)) - (ientry1 0) - (isubnode1 0) - (ientry2 0) - (isubnode2 0)) + (subnodes2 (ch-set-node-subnode-mask tree2))) (do-bit-indices (idx (logand (logior entries1 subnodes1) (logior entries2 subnodes2)) t) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) - (let ((val1 (ch-set-node-entry tree1 (postincf ientry1))) - (val2 (ch-set-node-entry tree2 (postincf ientry2)))) + (let ((val1 (ch-set-node-entry tree1 (1-bits-below idx entries1))) + (val2 (ch-set-node-entry tree2 (1-bits-below idx entries2)))) (when (equal?-cmp val1 val2 compare-fn) (return nil)))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) - (let ((val (ch-set-node-entry tree1 (postincf ientry1)))) - (when (ch-set-tree-contains? (ch-set-node-subnode tree2 (postincf isubnode2)) + (let ((val (ch-set-node-entry tree1 (1-bits-below idx entries1)))) + (when (ch-set-tree-contains? (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) val hash-fn compare-fn (1+ depth)) (return nil)))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) - (let ((val (ch-set-node-entry tree2 (postincf ientry2)))) - (when (ch-set-tree-contains? (ch-set-node-subnode tree1 (postincf isubnode1)) + (let ((val (ch-set-node-entry tree2 (1-bits-below idx entries2)))) + (when (ch-set-tree-contains? (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) val hash-fn compare-fn (1+ depth)) (return nil)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) - (unless (rec (ch-set-node-subnode tree1 (postincf isubnode1)) - (ch-set-node-subnode tree2 (postincf isubnode2)) + (unless (rec (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) + (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) (1+ depth)) (return nil))))))))))) @@ -1122,9 +1137,13 @@ (defstruct (ch-set-node (gmap :and (fn (subnode-idx hash-bits) (let ((subnode (svref node (- (length node) 1 subnode-idx)))) (if (consp subnode) - (let ((chash 0)) + (let ((chash 0) + (elt-hash (hash-to-fixnum (wb-set-tree-arb (cdr subnode)) hash-fn))) + (test (> (wb-set-tree-size (cdr subnode)) 1)) (do-wb-set-tree-members (v (cdr subnode)) - (mix-hashf chash (hash-to-fixnum v hash-fn))) + (let ((vh (hash-to-fixnum v hash-fn))) + (test (= vh elt-hash)) + (mix-hashf chash vh))) (test (= chash (multiply-hash (hash-to-fixnum (wb-set-tree-arb (cdr subnode)) hash-fn) @@ -1382,7 +1401,7 @@ (defstruct (ch-map-node (if (= 1 (wb-map-tree-size new-wb-tree)) (let ((k v (wb-map-tree-arb-pair new-wb-tree))) ;; We don't have `val-cmp-fn' handy, but it can't actually be called anyway. - (values (ch-map-tree-with nil k v key-hash-fn key-cmp-fn val-hash-fn (fn (_ _) nil) depth) + (values (ch-map-tree-with nil k v key-hash-fn key-cmp-fn val-hash-fn (fn (_ _)) depth) kv-hash)) (values (cons (unmix-hash (car node) kv-hash) new-wb-tree) kv-hash))))) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) @@ -1721,7 +1740,7 @@ (defstruct (ch-map-node (mix-hashf (ch-map-node-hash-value n) (ch-map-tree-hash-value subnode)))))) (defun ch-map-tree-union (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) - (declare (optimize (debug 3)) + (declare (optimize (speed 3)) (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) @@ -1730,10 +1749,23 @@ (defstruct (ch-map-node ((null tree2) tree1) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - ;; &&& Heh -- the mere fact that we've reached two collision nodes doesn't entail that they - ;; collide with each other. - (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) - (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) + (let ((hash1 (hash-to-fixnum (wb-map-tree-arb-pair (cdr tree1)) key-hash-fn)) + (hash2 (hash-to-fixnum (wb-map-tree-arb-pair (cdr tree2)) key-hash-fn))) + (if (= hash1 hash2) + (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) + (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth)) + (let ((size (+ (wb-map-tree-size (cdr tree1)) (wb-map-tree-size (cdr tree2))))) + (declare (fixnum size)) + (rlabels (build depth) + (build (depth) + (declare (type (integer 0 64) depth)) + (let ((bits1 (champ-hash-bits hash1 depth)) + (bits2 (champ-hash-bits hash2 depth)) + (chash (mix-hash (car tree1) (car tree2)))) + (if (= bits1 bits2) + (vector 0 (ash 1 bits1) size chash (build (1+ depth))) + (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) + (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0)))))))))) ((consp tree1) (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) @@ -1766,10 +1798,12 @@ (defstruct (ch-map-node (isubnode1 0) (ientry2 0) (isubnode2 0)) + (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) (flet ((add-entry (idx key val) (ch-map-node-add-entry res-n idx key val key-hash-fn val-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn)) + (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn) + nil) ; hush, SBCL (subtree-lookup (tree key) (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn (1+ depth))) (subtree-with (subtree key value) @@ -1818,57 +1852,54 @@ (defstruct (ch-map-node ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) (let ((result (wb-map-tree-intersect (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) - (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) + (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth))) ((or (consp tree1) (consp tree2)) (let ((normal-node collision-node (swap-if (consp tree1) tree1 tree2)) (result nil)) - (do-wb-map-tree-pairs (k v (cdr collision-node)) - (when (ch-map-tree-lookup normal-node k key-hash-fn key-cmp-fn depth) - (setq result (ch-map-tree-with result k v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth)))) + (do-wb-map-tree-pairs (k cv (cdr collision-node)) + (let ((nv? nv (ch-map-tree-lookup normal-node k key-hash-fn key-cmp-fn depth))) + (when nv? + (setq result (ch-map-tree-with result k (if (consp tree1) (funcall val-fn cv nv) + (funcall val-fn nv cv)) + key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))))) result)) (t (let ((entries1 (ch-map-node-entry-mask tree1)) (entries2 (ch-map-node-entry-mask tree2)) (subnodes1 (ch-map-node-subnode-mask tree1)) (subnodes2 (ch-map-node-subnode-mask tree2)) - ;; The result can be longer than either input, because the intersection of two subnodes - ;; could be an entry. - ((res-len (+ ch-map-node-header-size - (* 2 (+ (logcount (logand entries1 entries2)) - (logcount (logand subnodes1 subnodes2)))))) - ((res-n (make-array res-len :initial-element 0)))) - (ientry1 0) - (isubnode1 0) - (ientry2 0) - (isubnode2 0)) + ((combined-mask (logand (logior entries1 subnodes1) (logior entries2 subnodes2))) + ;; The result can be longer than either input, because the intersection of two subnodes + ;; could be an entry. + ((res-len (+ ch-map-node-header-size (* 2 (logcount combined-mask)))) + ((res-n (make-array res-len :initial-element 0)))))) (flet ((add-entry (idx key val) (ch-map-node-add-entry res-n idx key val key-hash-fn val-hash-fn)) (add-subnode (idx subnode) (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn)) - (lookup (tree key depth) - (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn depth))) - (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) - (logand entries1 subnodes2) (logand subnodes1 entries2))) + (subtree-lookup (tree key) + (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn (1+ depth)))) + (do-bit-indices (idx combined-mask) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) - (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1))) - (key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) + (let ((key1 val1 (ch-map-node-entry tree1 (1-bits-below idx entries1))) + (key2 val2 (ch-map-node-entry tree2 (1-bits-below idx entries2)))) (when (equal?-cmp key1 key2 key-cmp-fn) (add-entry idx key1 (funcall val-fn val1 val2))))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) - (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1))) - (subnode2 (ch-map-node-subnode tree2 (postincf isubnode2))) - ((val2? val2 (lookup subnode2 key1 (1+ depth))))) + (let ((key1 val1 (ch-map-node-entry tree1 (1-bits-below idx entries1))) + (subnode2 (ch-map-node-subnode tree2 (1-bits-below idx subnodes2))) + ((val2? val2 (subtree-lookup subnode2 key1)))) (when val2? (add-entry idx key1 (funcall val-fn val1 val2))))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) - (let ((key2 val2 (ch-map-node-entry tree2 (postincf ientry2))) - (subnode1 (ch-map-node-subnode tree1 (postincf isubnode1))) - ((val1? val1 (lookup subnode1 key2 (1+ depth))))) + (let ((key2 val2 (ch-map-node-entry tree2 (1-bits-below idx entries2))) + (subnode1 (ch-map-node-subnode tree1 (1-bits-below idx subnodes1))) + ((val1? val1 (subtree-lookup subnode1 key2)))) (when val1? - (add-entry idx key2 (funcall val-fn val2 val1))))) + (add-entry idx key2 (funcall val-fn val1 val2))))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) - (add-subnode idx (rec (ch-map-node-subnode tree1 (postincf isubnode1)) - (ch-map-node-subnode tree2 (postincf isubnode2)) + (add-subnode idx (rec (ch-map-node-subnode tree1 (1-bits-below idx subnodes1)) + (ch-map-node-subnode tree2 (1-bits-below idx subnodes2)) (1+ depth)))))) (ch-map-compact-node res-n)))))))) @@ -1881,8 +1912,8 @@ (defstruct (ch-map-node ((consp tree1) (if (consp tree2) (let ((result1 result2 (wb-map-tree-diff-2 (cdr tree1) (cdr tree2) key-cmp-fn val-cmp-fn))) - (values (ch-map-node-from-wb result1 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth) - (ch-map-node-from-wb result2 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) + (values (ch-map-node-from-wb result1 key-hash-fn key-cmp-fn val-hash-fn depth) + (ch-map-node-from-wb result2 key-hash-fn key-cmp-fn val-hash-fn depth))) (let ((result1 nil) (result2 nil)) (do-wb-map-tree-pairs (k v1 (cdr tree1)) @@ -1894,7 +1925,7 @@ (defstruct (ch-map-node (unless (and v1? (equal?-cmp v1 v2 val-cmp-fn)) (setq result2 (ch-map-tree-with result2 k v2 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))))) - (values (ch-map-node-from-wb result1 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth) + (values (ch-map-node-from-wb result1 key-hash-fn key-cmp-fn val-hash-fn depth) result2)))) ((consp tree2) (let ((res2 res1 (rec tree2 tree1 depth))) @@ -1904,11 +1935,9 @@ (defstruct (ch-map-node (entries2 (ch-map-node-entry-mask tree2)) (subnodes1 (ch-map-node-subnode-mask tree1)) (subnodes2 (ch-map-node-subnode-mask tree2)) - ((res-len1 (+ ch-map-node-header-size - (* 2 (+ (logcount entries1) (logcount subnodes1))))) + ((res-len1 (+ ch-map-node-header-size (* 2 (logcount (logior entries1 subnodes1))))) ((res-n1 (make-array res-len1 :initial-element 0)))) - ((res-len2 (+ ch-map-node-header-size - (* 2 (+ (logcount entries2) (logcount subnodes2))))) + ((res-len2 (+ ch-map-node-header-size (* 2 (logcount (logior entries2 subnodes2))))) ((res-n2 (make-array res-len2 :initial-element 0)))) (ientry1 0) (isubnode1 0) @@ -1963,12 +1992,143 @@ (defstruct (ch-map-node (t (error "Bug in ch-map-tree-diff"))))) (values (ch-map-compact-node res-n1) (ch-map-compact-node res-n2)))))))) -(defun ch-map-node-from-wb (wb-map-tree key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth) - (declare (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) +(defun ch-map-tree-restrict (map-tree set-tree key-hash-fn key-cmp-fn val-hash-fn) + (declare (optimize (debug 3))) + (rlabels (rec map-tree set-tree 0) + (rec (map-tree set-tree depth) + (cond ((or (null map-tree) (null set-tree)) nil) + ((and (consp map-tree) (consp set-tree)) + (let ((m-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr map-tree)) key-hash-fn)) + (s-hash (hash-to-fixnum (wb-set-tree-arb (cdr set-tree)) key-hash-fn))) + (and (= m-hash s-hash) + (let ((result (wb-map-tree-restrict (cdr map-tree) (cdr set-tree) key-cmp-fn))) + (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth))))) + ;; I figure the collision nodes are probably the smaller of the two. + ((consp map-tree) + (let ((result nil)) + (do-wb-map-tree-pairs (k v (cdr map-tree)) + (when (ch-set-tree-contains? set-tree k key-hash-fn key-cmp-fn depth) + (setq result (ch-map-tree-with result k v key-hash-fn key-cmp-fn val-hash-fn (fn (_ _)) depth)))) + result)) + ((consp set-tree) + (let ((result nil)) + (do-wb-set-tree-members (k (cdr set-tree)) + (let ((v? v (ch-map-tree-lookup map-tree k key-hash-fn key-cmp-fn depth))) + (when v? + (setq result (ch-map-tree-with result k v key-hash-fn key-cmp-fn val-hash-fn (fn (_ _)) + depth))))) + result)) + (t + (let ((entries1 (ch-map-node-entry-mask map-tree)) + (entries2 (ch-set-node-entry-mask set-tree)) + (subnodes1 (ch-map-node-subnode-mask map-tree)) + (subnodes2 (ch-set-node-subnode-mask set-tree)) + ((combined-mask (logand (logior entries1 subnodes1) (logior entries2 subnodes2))) + ;; The result can be longer than either input, because the restriction of two subnodes + ;; could be an entry. + ((res-len (+ ch-map-node-header-size (* 2 (logcount combined-mask)))) + ((res-n (make-array res-len :initial-element 0)))))) + (flet ((add-entry (idx key val) + (ch-map-node-add-entry res-n idx key val key-hash-fn val-hash-fn)) + (add-subnode (idx subnode) + (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn)) + (map-lookup (map-subtree key) + (ch-map-tree-lookup map-subtree key key-hash-fn key-cmp-fn (1+ depth))) + (set-contains? (set-subtree key) + (ch-set-tree-contains? set-subtree key key-hash-fn key-cmp-fn (1+ depth)))) + (do-bit-indices (idx combined-mask) + (cond ((and (logbitp idx entries1) (logbitp idx entries2)) + (let ((key1 val1 (ch-map-node-entry map-tree (1-bits-below idx entries1))) + (key2 (ch-set-node-entry set-tree (1-bits-below idx entries2)))) + (when (equal?-cmp key1 key2 key-cmp-fn) + (add-entry idx key1 val1)))) + ((and (logbitp idx entries1) (logbitp idx subnodes2)) + (let ((key1 val1 (ch-map-node-entry map-tree (1-bits-below idx entries1))) + (subnode2 (ch-set-node-subnode set-tree (1-bits-below idx subnodes2)))) + (when (set-contains? subnode2 key1) + (add-entry idx key1 val1)))) + ((and (logbitp idx subnodes1) (logbitp idx entries2)) + (let ((subnode1 (ch-map-node-subnode map-tree (1-bits-below idx subnodes1))) + (key2 (ch-set-node-entry set-tree (1-bits-below idx entries2))) + ((val1? val1 (map-lookup subnode1 key2)))) + (when val1? + (add-entry idx key2 val1)))) + ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) + (add-subnode idx (rec (ch-map-node-subnode map-tree (1-bits-below idx subnodes1)) + (ch-map-node-subnode set-tree (1-bits-below idx subnodes2)) + (1+ depth)))))) + (ch-map-compact-node res-n)))))))) + +(defun ch-map-tree-restrict-not (map-tree set-tree key-hash-fn key-cmp-fn val-hash-fn) + (declare (optimize (debug 3))) + (rlabels (rec map-tree set-tree 0) + (rec (map-tree set-tree depth) + (cond ((or (null map-tree) (null set-tree)) nil) + ((and (consp map-tree) (consp set-tree)) + (let ((m-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr map-tree)) key-hash-fn)) + (s-hash (hash-to-fixnum (wb-set-tree-arb (cdr set-tree)) key-hash-fn))) + (if (= m-hash s-hash) + (let ((result (wb-map-tree-restrict-not (cdr map-tree) (cdr set-tree) key-cmp-fn))) + (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth)) + map-tree))) + ((consp map-tree) + (let ((result nil)) + (do-wb-map-tree-pairs (k v (cdr map-tree)) + (unless (ch-set-tree-contains? set-tree k key-hash-fn key-cmp-fn depth) + (setq result (wb-map-tree-with result k v key-cmp-fn (fn (_ _)))))) + (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth))) + ((consp set-tree) + (do-wb-set-tree-members (k (cdr set-tree)) + (setq map-tree (ch-map-tree-less map-tree k key-hash-fn key-cmp-fn val-hash-fn depth))) + map-tree) + (t + (let ((entries1 (ch-map-node-entry-mask map-tree)) + (entries2 (ch-set-node-entry-mask set-tree)) + (subnodes1 (ch-map-node-subnode-mask map-tree)) + (subnodes2 (ch-set-node-subnode-mask set-tree)) + ;; The result can be longer than `map-tree', because the restriction of two subnodes + ;; could be an entry. + ((res-len (+ ch-map-node-header-size + (* 2 (+ (logcount entries1) (logcount subnodes1))))) + ((res-n (make-array res-len :initial-element 0))))) + (flet ((add-entry (idx key val) + (ch-map-node-add-entry res-n idx key val key-hash-fn val-hash-fn)) + (add-subnode (idx subnode) + (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn)) + (map-subtree-less (subtree key) + (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth))) + (set-contains? (set-subtree key) + (ch-set-tree-contains? set-subtree key key-hash-fn key-cmp-fn (1+ depth)))) + (do-bit-indices (idx (logior entries1 subnodes1)) + (cond ((logbitp idx entries1) + (let ((key1 val1 (ch-map-node-entry map-tree (1-bits-below idx entries1)))) + (cond ((logbitp idx entries2) + (let ((key2 (ch-set-node-entry set-tree (1-bits-below idx entries2)))) + (unless (equal?-cmp key1 key2 key-cmp-fn) + (add-entry idx key1 val1)))) + ((logbitp idx subnodes2) + (let ((subnode2 (ch-set-node-subnode set-tree (1-bits-below idx subnodes2)))) + (unless (set-contains? subnode2 key1) + (add-entry idx key1 val1)))) + (t (add-entry idx key1 val1))))) + ((logbitp idx subnodes1) + (let ((subnode1 (ch-map-node-subnode map-tree (1-bits-below idx subnodes1)))) + (cond ((logbitp idx entries2) + (let ((key2 (ch-set-node-entry set-tree (1-bits-below idx entries2)))) + (add-subnode idx (map-subtree-less subnode1 key2)))) + ((logbitp idx subnodes2) + (let ((subnode2 (ch-set-node-subnode set-tree (1-bits-below idx subnodes2)))) + (add-subnode idx (rec subnode1 subnode2 (1+ depth))))) + (t (add-subnode idx subnode1))))))) + (ch-map-compact-node res-n)))))))) + +(defun ch-map-node-from-wb (wb-map-tree key-hash-fn key-cmp-fn val-hash-fn depth) + (declare (type function key-hash-fn key-cmp-fn val-hash-fn)) (case (wb-map-tree-size wb-map-tree) (0 nil) (1 (let ((k v (wb-map-tree-arb-pair wb-map-tree))) - (ch-map-tree-with nil k v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))) + ;; `val-cmp-fn' can't be called in this case. + (ch-map-tree-with nil k v key-hash-fn key-cmp-fn val-hash-fn (fn (_ _)) depth))) (t (let ((chash (multiply-hash (hash-to-fixnum (wb-map-tree-arb-pair wb-map-tree) key-hash-fn) (wb-map-tree-size wb-map-tree)))) (do-wb-map-tree-pairs (k v wb-map-tree) @@ -2029,11 +2189,14 @@ (defstruct (ch-map-node (gmap :and (fn (subnode-idx hash-bits) (let ((subnode (svref node (- (length node) 1 subnode-idx)))) (if (consp subnode) - (let ((chash 0)) + (let ((chash 0) + (key-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr subnode)) + key-hash-fn))) (test (> (wb-map-tree-size (cdr subnode)) 1)) (do-wb-map-tree-pairs (k v (cdr subnode)) - (mix-hashf chash (hash-to-fixnum k key-hash-fn) - (hash-to-fixnum v val-hash-fn))) + (let ((kh (hash-to-fixnum k key-hash-fn))) + (test (= kh key-hash)) + (mix-hashf chash kh (hash-to-fixnum v val-hash-fn)))) (mix-hashf content-hash chash) (incf size (wb-map-tree-size (cdr subnode))) (test (= (car subnode) chash))) diff --git a/Code/fset.lisp b/Code/fset.lisp index 00bfcbd..22af998 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -579,6 +579,7 @@ (defmethod last ((s sequence)) wb-map hash-table 16 hash-table map 8 wb-map ch-map 16 + ch-map wb-map 16 seq seq 0 wb-seq wb-seq 0 @@ -4415,6 +4416,26 @@ (defmethod map-difference-2 ((map1 ch-map) (map2 ch-map)) (make-ch-map newc2 hmorg (map-default map2)))) (call-next-method))) +(defmethod restrict ((m ch-map) (s ch-set)) + (let ((hmorg (ch-map-org m)) + (hsorg (ch-set-org s))) + (if (eq (hash-map-org-key-compare-fn hmorg) (hash-set-org-compare-fn hsorg)) + (make-ch-map (ch-map-tree-restrict (ch-map-contents m) (ch-set-contents s) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg)) + hmorg (map-default m)) + (call-next-method)))) + +(defmethod restrict-not ((m ch-map) (s ch-set)) + (let ((hmorg (ch-map-org m)) + (hsorg (ch-set-org s))) + (if (eq (hash-map-org-key-compare-fn hmorg) (hash-set-org-compare-fn hsorg)) + (make-ch-map (ch-map-tree-restrict-not (ch-map-contents m) (ch-set-contents s) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg)) + hmorg (map-default m)) + (call-next-method)))) + (defmethod internal-do-map ((m ch-map) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) @@ -4427,6 +4448,18 @@ (defmethod convert ((to-type (eql 'wb-map)) (m ch-map) &key key-compare-fn-name (do-ch-map-tree-pairs (k v (ch-map-contents m) tree) (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn)))))) +(defmethod convert ((to-type (eql 'ch-map)) (m wb-map) &key key-compare-fn-name val-compare-fn-name) + (let ((prototype (empty-ch-map nil key-compare-fn-name val-compare-fn-name)) + ((hmorg (ch-map-org prototype)) + ((key-hash-fn (hash-map-org-key-hash-fn hmorg)) + (key-compare-fn (hash-map-org-key-compare-fn hmorg)) + (val-hash-fn (hash-map-org-val-hash-fn hmorg)) + (val-compare-fn (hash-map-org-val-compare-fn hmorg)))) + (result nil)) + (do-wb-map-tree-pairs (k v (wb-map-contents m)) + (setq result (ch-map-tree-with result k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) + (make-ch-map result hmorg (map-default m)))) + (defun print-ch-map (map stream level) (declare (ignore level)) (pprint-logical-block (stream nil :prefix "##{|" diff --git a/Code/port.lisp b/Code/port.lisp index 2897340..903cba9 100644 --- a/Code/port.lisp +++ b/Code/port.lisp @@ -461,8 +461,10 @@ (define-modify-macro unmix-hashf (hash &rest to-unmix) ;;; Miscellaneous utilities (defun eqv (a b &rest more) + "True if `b' and all of `more' are boolean-equal to `a`, i.e., all null or +all nonnull. (Not the even-parity function.)" (and (or (eq a b) (and a b)) - (gmap (:result and) #'eqv (:arg constant a) (:arg list more)))) + (gmap (:result and) (fn (x) (or (eq x a) (and x a))) (:arg list more)))) (defun swap-if (pred x y) (if pred (values y x) diff --git a/Code/testing.lisp b/Code/testing.lisp index 871b99a..6588abc 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -4030,7 +4030,17 @@ (defmethod verify ((m ch-map)) (test (verify chm-diff-2a)) (test (verify chm-diff-2b)) (test (equal? (convert 'wb-map chm-diff-2a) wbm-diff-2a)) - (test (equal? (convert 'wb-map chm-diff-2b) wbm-diff-2b)))) + (test (equal? (convert 'wb-map chm-diff-2b) wbm-diff-2b))) + ;; &&& `restrict' and `restrict-not' + (let ((saved-chm-dom (domain saved-chm)) + (saved-wbm-dom (domain saved-wbm)) + ((ch-pos (restrict chm saved-chm-dom)) + (ch-neg (restrict-not chm saved-chm-dom)) + (wb-pos (restrict wbm saved-wbm-dom)) + (wb-neg (restrict-not wbm saved-wbm-dom)))) + (test (verify ch-pos)) + (test (verify ch-neg)) + (test (equal? (convert 'wb-map ch-pos) wb-pos)) + (test (equal? (convert 'wb-map ch-neg) wb-neg)))) (setq saved-wbm wbm) (setq saved-chm chm)))))) - -- GitLab From 922f727a01701749410bb7e767b24e9089084d1e Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 11 Sep 2025 01:28:24 -0700 Subject: [PATCH 10/16] W00t! Maps might be done! --- Code/champ.lisp | 192 ++++++++++++++++++++++++++++++++++++++-- Code/fset.lisp | 211 +++++++++++++++++++++++++++++++------------- Code/macros.lisp | 13 +++ Code/relations.lisp | 10 +-- Code/testing.lisp | 23 +++-- Code/wb-trees.lisp | 24 ++--- 6 files changed, 374 insertions(+), 99 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index 6d67cff..c20591d 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -1203,6 +1203,14 @@ (defstruct (ch-map-node (deftype ch-map-tree () '(or null cons simple-vector)) +(declaim (ftype (function (ch-map-tree) fixnum) ch-map-tree-size)) +(declaim (inline ch-map-tree-size)) +(defun ch-map-tree-size (tree) + (cond ((null tree) 0) + ((consp tree) + (wb-map-tree-size (cdr tree))) + (t (ch-map-node-size tree)))) + (defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0)) ;; &&& This would benefit from returning a hash delta, as in `ch-set-tree-less'. Ironically, ;; the technique is not actually needed in that function. @@ -1308,6 +1316,7 @@ (defstruct (ch-map-node node ; no change ;; New subnode (let ((n (vector-update node subnode-idx new-subnode))) + ;; If only a value was updated, the subnode won't have changed size. (setf (ch-map-node-size n) (the fixnum (+ (ch-map-node-size n) (- (the fixnum (ch-map-tree-size new-subnode)) (the fixnum (ch-map-tree-size subnode)))))) @@ -1355,14 +1364,6 @@ (defstruct (ch-map-node (setf (svref v (+ idx i 2)) (svref vec (+ idx i)))) v)) -(declaim (ftype (function (ch-map-tree) fixnum) ch-map-tree-size)) -(declaim (inline ch-map-tree-size)) -(defun ch-map-tree-size (tree) - (cond ((null tree) 0) - ((consp tree) - (wb-map-tree-size (cdr tree))) - (t (ch-map-node-size tree)))) - (defun ch-map-tree-hash-value (tree) (cond ((null tree) 0) ((consp tree) (car tree)) @@ -1660,6 +1661,9 @@ (defstruct (ch-map-node default)))))))))))) +;;; -------------------------------- +;;; Iteration primitives + (defmacro do-ch-map-tree-pairs ((key-var value-var tree-form &optional value-form) &body body) (let ((body-fn (gensymx #:body-)) @@ -1682,6 +1686,152 @@ (defstruct (ch-map-node (,recur-fn ,tree-form)) ,value-form))) +;;; ---------------- +;;; Stateful iterator + +(defun make-ch-map-tree-iterator (tree) + (let ((iter (make-ch-map-tree-iterator-internal tree))) + (lambda (op) + (ecase op + (:get (ch-map-tree-iterator-get iter)) + (:done? (ch-map-tree-iterator-done? iter)) + (:more? (not (ch-map-tree-iterator-done? iter))))))) + +(defun make-ch-map-tree-iterator-internal (tree) + (let ((iter (make-array (+ 1 (* 2 (ceiling (integer-length most-positive-fixnum) champ-hash-bits-per-level)))))) + (if (null tree) + (setf (svref iter 0) -1) + (progn + (setf (svref iter 0) 1) ; the stack pointer + (setf (svref iter 1) tree) + (setf (svref iter 2) 0) + (ch-map-tree-iterator-canonicalize iter))) + iter)) + +(defun ch-map-tree-iterator-canonicalize (iter) + (declare (optimize (speed 3) (safety 03))) + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (type (or null fixnum) idx)) + (when (if (null idx) + (wb-map-tree-iterator-done? (svref iter sp)) + (= idx (logcount (logior (ch-map-node-entry-mask node) (ch-map-node-subnode-mask node))))) + (decf sp 2) + (unless (< sp 0) + (setq node (svref iter sp)) + (setq idx (svref iter (1+ sp))))) + (unless (< sp 0) + (loop + (when (null idx) + (return)) + (let ((n-entries (logcount (ch-map-node-entry-mask node))) + (n-subnodes (logcount (ch-map-node-subnode-mask node)))) + (when (< idx n-entries) + (return)) + (let ((len (length (the simple-vector node)))) + (setq node (svref node (- len (- idx n-entries) 1))) + (incf idx) + (unless (= idx (+ n-entries n-subnodes)) ; TCO + (setf (svref iter (1+ sp)) idx) + (incf sp 2)) + (if (consp node) + (setq node (make-wb-map-tree-iterator-internal (cdr node)) + idx nil) + (setq idx 0)) + (setf (svref iter sp) node) + (setf (svref iter (1+ sp)) idx))))) + (setf (svref iter 0) sp))) + +(defun ch-map-tree-iterator-done? (iter) + (declare (optimize (speed 3) (safety 03))) + (< (the fixnum (svref iter 0)) 0)) + +(defun ch-map-tree-iterator-get (iter) + (declare (optimize (speed 3) (safety 03))) + (let ((sp (svref iter 0))) + (declare (fixnum sp)) + (and (> sp 0) + (let ((node (svref iter sp)) + (idx (svref iter (1+ sp)))) + (declare (type (or null fixnum) idx)) + (if (null idx) + (let ((key val (wb-map-tree-iterator-get node))) + (ch-map-tree-iterator-canonicalize iter) + (values key val t)) + (let ((entry-idx (+ ch-map-node-header-size (the fixnum (* 2 idx))))) + (setf (svref iter (1+ sp)) (1+ idx)) + (ch-map-tree-iterator-canonicalize iter) + (values (svref node entry-idx) (svref node (1+ entry-idx)) + t))))))) + +;;; ---------------- +;;; Functional iterator + +(defun ch-map-tree-fun-iter (tree) + (declare (optimize (speed 3) (safety 03))) + (rlabels (walk tree (lambda (op) + (ecase op + (:first (values nil nil)) + (:empty? t) + (:more? nil)))) + (walk (node cont) + (if (consp node) + (wb-map-tree-fun-iter (cdr node) cont) + (let ((n-entries (logcount (ch-map-node-entry-mask node))) + (n-subnodes (logcount (ch-map-node-subnode-mask node)))) + (rlabels (entry 0) + (entry (i) + (declare (fixnum i)) + (if (< i n-entries) + (lambda (op) + (ecase op + (:first (let ((entry-idx (+ ch-map-node-header-size (the fixnum (* 2 i))))) + (values (svref node entry-idx) (svref node (1+ entry-idx)) t))) + (:rest (entry (1+ i))) + (:empty? nil) + (:more? t))) + (subnode 0))) + (subnode (i) + (declare (fixnum i)) + (if (< i n-subnodes) + (walk (svref node (- (+ ch-map-node-header-size (* 2 n-entries) n-subnodes) + i 1)) + (lambda (op) (funcall (the function (subnode (1+ i))) op))) + cont)))))))) + +(defun ch-map-tree-rev-fun-iter (tree) + (declare (optimize (speed 3) (safety 03))) + (rlabels (walk tree (lambda (op) + (ecase op + (:first (values nil nil)) + (:empty? t) + (:more? nil)))) + (walk (node cont) + (if (consp node) + (wb-map-tree-rev-fun-iter (cdr node) cont) + (let ((n-entries (logcount (ch-map-node-entry-mask node))) + (n-subnodes (logcount (ch-map-node-subnode-mask node)))) + (rlabels (subnode (1- n-subnodes)) + (entry (i) + (declare (fixnum i)) + (if (>= i 0) + (lambda (op) + (ecase op + (:first (let ((entry-idx (+ ch-map-node-header-size (the fixnum (* 2 i))))) + (values (svref node entry-idx) (svref node (1+ entry-idx)) t))) + (:rest (entry (1- i))) + (:empty? nil) + (:more? t))) + cont)) + (subnode (i) + (declare (fixnum i)) + (if (>= i 0) + (walk (svref node (- (+ ch-map-node-header-size (* 2 n-entries) n-subnodes) + i 1)) + (lambda (op) (funcall (the function (subnode (1- i))) op))) + (entry (1- n-entries)))))))))) + ;;; -------------------------------- ;;; Union, intersection, set-difference, subset?, disjoint? @@ -2148,6 +2298,32 @@ (defstruct (ch-map-node (if (= extra 0) n (vector-remove-n-at n (+ ch-map-node-header-size (* 2 n-entries)) extra)))))) +(defun ch-map-tree-compose (tree fn val1-hash-fn val2-hash-fn) + (declare (type function fn val1-hash-fn val2-hash-fn)) + (cond ((null tree) nil) + ((consp tree) + (wb-map-tree-compose tree fn)) + (t + (let ((n (make-array (length (the simple-vector tree)) :initial-element 0)) + (chash (ch-map-tree-hash-value tree))) + (dotimes (i (logcount (ch-map-node-entry-mask tree))) + (let ((entry-idx (+ ch-map-node-header-size (* 2 i)))) + (setf (svref n entry-idx) (svref tree entry-idx)) + (let ((val (svref tree (1+ entry-idx))) + ((new-val (funcall fn val)))) + (setf (svref n (1+ entry-idx)) new-val) + (mix-hashf chash (unmix-hash (hash-to-fixnum new-val val2-hash-fn) + (hash-to-fixnum val val1-hash-fn)))))) + (dotimes (i (logcount (ch-map-node-subnode-mask tree))) + (let ((subnode-idx (- (length (the simple-vector tree)) i 1))) + (setf (svref n subnode-idx) + (ch-map-tree-compose (svref tree subnode-idx) fn val1-hash-fn val2-hash-fn)))) + (setf (ch-map-node-entry-mask n) (ch-map-node-entry-mask tree)) + (setf (ch-map-node-subnode-mask n) (ch-map-node-subnode-mask tree)) + (setf (ch-map-node-size n) (ch-map-node-size tree)) + (setf (ch-map-node-hash-value n) chash) + n)))) + (defun ch-map-tree-verify (tree key-hash-fn val-hash-fn) (declare (optimize (debug 3)) (type function key-hash-fn val-hash-fn)) diff --git a/Code/fset.lisp b/Code/fset.lisp index 22af998..f75c27e 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -432,7 +432,7 @@ (defmethod reduce (fn (s sequence) &rest keyword-args "Returns a map containing only those pairs of `map' whose keys are not in `set'.")) -(defgeneric compose (map1 map2-or-fn) +(defgeneric compose (map1 map2-or-fn &key) (:documentation "Returns a new map with the same domain as `map1', which maps each member of that domain to the result of applying first `map1' to it, then applying @@ -579,7 +579,12 @@ (defmethod last ((s sequence)) wb-map hash-table 16 hash-table map 8 wb-map ch-map 16 - ch-map wb-map 16 + ch-map ch-map 0, 16 + ch-map map 16 + ch-map list 6, 7, 16 + ch-map seq 6, 7, 16 + ch-map sequence 6, 7, 16 + ch-map hash-table 16 seq seq 0 wb-seq wb-seq 0 @@ -2446,20 +2451,23 @@ (defmethod convert ((to-type (eql 'ch-set)) (s ch-set) &key compare-fn-name) (defmethod convert ((to-type (eql 'ch-set)) (l list) &key compare-fn-name) (convert-to-ch-set l nil (let ((tree nil)) - (dolist (x l tree) - (setq tree (ch-set-tree-with tree x hash-fn compare-fn)))))) + (dolist (x l) + (setq tree (ch-set-tree-with tree x hash-fn compare-fn))) + tree))) (defmethod convert ((to-type (eql 'ch-set)) (s seq) &key compare-fn-name) (convert-to-ch-set s nil (let ((tree nil)) - (do-seq (x s :value tree) - (setq tree (ch-set-tree-with tree x hash-fn compare-fn)))))) + (do-seq (x s) + (setq tree (ch-set-tree-with tree x hash-fn compare-fn))) + tree))) (defmethod convert ((to-type (eql 'ch-set)) (s sequence) &key compare-fn-name) (convert-to-ch-set s nil (let ((tree nil)) - (dotimes (i (length s) tree) - (setq tree (ch-set-tree-with tree (elt s i) hash-fn compare-fn)))))) + (dotimes (i (length s)) + (setq tree (ch-set-tree-with tree (elt s i) hash-fn compare-fn))) + tree))) (defun print-ch-set (set stream level) (declare (ignore level)) @@ -3836,65 +3844,45 @@ (defmethod restrict-not ((m wb-map) (s wb-set)) (defun compose-functions (f1 f2) (lambda (&rest args) (multiple-value-call f2 (apply f1 args)))) -(defmethod compose ((f1 function) (f2 function)) +(defmethod compose ((f1 function) (f2 function) &key) (compose-functions f1 f2)) -(defmethod compose ((f1 symbol) (f2 function)) - (compose-functions f1 f2)) +(defmethod compose ((f1 symbol) (f2 function) &key) + (compose-functions (symbol-function f1) f2)) -(defmethod compose ((f1 function) (f2 symbol)) - (compose-functions f1 f2)) +(defmethod compose ((f1 function) (f2 symbol) &key) + (compose-functions f1 (symbol-function f2))) -(defmethod compose ((f1 symbol) (f2 symbol)) - (compose-functions f1 f2)) +(defmethod compose ((f1 symbol) (f2 symbol) &key) + (compose-functions (symbol-function f1) (symbol-function f2))) -(defmethod compose ((m1 map) (m2 map)) - "Fallback method for mixed implementations." - (let ((result (empty-map-like m1))) - (do-map (k v1 m1) - (setf (lookup result k) (lookup m2 v1))) - result)) +;;; I've removed the fallback method for `compose', as it's not needed -- the maps +;;; don't need to match anyway. -(defmethod compose ((map1 wb-map) (map2 wb-map)) - (let ((tree2 (wb-map-contents map2)) - (kcf2 (tree-map-org-key-compare-fn (wb-map-org map2)))) - (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1) - #'(lambda (x) - (let ((val2? val2 (WB-Map-Tree-Lookup tree2 x kcf2))) - (if val2? val2 (map-default map2))))) - (wb-map-org map1) - (let ((new-default? new-default - (WB-Map-Tree-Lookup tree2 (map-default map1) kcf2))) - (if new-default? new-default (map-default map2)))))) +(defmethod compose ((map1 wb-map) (map2 map) &key val-compare-fn-name) + "The returned map's `val-compare-fn-name' can be specified; it defaults +to `compare'." + (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1) + (fn (x) + (let ((val2 val2? (lookup map2 x))) + (if val2? val2 (map-default map2))))) + (wb-map-org (empty-wb-map nil (key-compare-fn-name map1) val-compare-fn-name)) + (let ((new-default new-default? (lookup map2 (map-default map1)))) + (if new-default? new-default (map-default map2))))) -(defmethod compose ((m map) (fn function)) - (map-fn-compose m fn)) +(defmethod compose ((m wb-map) (fn function) &key val-compare-fn-name) + (wb-map-fn-compose m fn val-compare-fn-name)) -(defmethod compose ((m map) (fn symbol)) - (map-fn-compose m (coerce-to-function fn))) +(defmethod compose ((m wb-map) (fn symbol) &key val-compare-fn-name) + (wb-map-fn-compose m (symbol-function fn) val-compare-fn-name)) -(defmethod compose ((m map) (s seq)) - (map-fn-compose m (fn (x) (lookup s x)))) +(defmethod compose ((m wb-map) (s seq) &key val-compare-fn-name) + (wb-map-fn-compose m (fn (x) (lookup s x)) val-compare-fn-name)) -(defun map-fn-compose (m fn) +(defun wb-map-fn-compose (m fn val-compare-fn-name) (declare (type function fn)) - (let ((result (empty-map-like m))) - (do-map (k v m) - (setf (lookup result k) (funcall fn v))) - result)) - -(defmethod compose ((m wb-map) (fn function)) - (wb-map-fn-compose m fn)) - -(defmethod compose ((m wb-map) (fn symbol)) - (wb-map-fn-compose m (coerce-to-function fn))) - -(defmethod compose ((m wb-map) (s seq)) - (wb-map-fn-compose m (fn (x) (lookup s x)))) - -(defun wb-map-fn-compose (m fn) - (declare (type function fn)) - (make-wb-map (WB-Map-Tree-Compose (wb-map-contents m) fn) (wb-map-org m) + (make-wb-map (WB-Map-Tree-Compose (wb-map-contents m) fn) + (wb-map-org (empty-wb-map nil (key-compare-fn-name m) val-compare-fn-name)) (funcall fn (map-default m)))) (defmethod convert ((to-type (eql 'map)) (m map) &key) @@ -4270,6 +4258,12 @@ (defmethod key-compare-fn-name ((m ch-map)) (defmethod val-compare-fn-name ((m ch-map)) (hash-map-org-val-compare-fn-name (ch-map-org m))) +(defmethod key-hash-fn ((m ch-map)) + (hash-map-org-key-hash-fn (ch-map-org m))) + +(defmethod val-hash-fn ((m ch-map)) + (hash-map-org-val-hash-fn (ch-map-org m))) + (defmethod with-default ((m ch-map) new-default) (make-ch-map (ch-map-contents m) (ch-map-org m) new-default)) @@ -4436,19 +4430,55 @@ (defmethod restrict-not ((m ch-map) (s ch-set)) hmorg (map-default m)) (call-next-method)))) +(defmethod compose ((map1 ch-map) (map2 map) &key val-compare-fn-name) + (let ((prototype (empty-ch-map nil (key-compare-fn-name map1) val-compare-fn-name))) + (make-ch-map (ch-map-tree-compose (ch-map-contents map1) + (fn (x) + (let ((val2 val2? (lookup map2 x))) + (if val2? val2 (map-default map2)))) + (val-hash-fn map1) (val-hash-fn prototype)) + (ch-map-org prototype) + (let ((new-default? new-default + (lookup map2 (map-default map1)))) + (if new-default? new-default (map-default map2)))))) + +(defmethod compose ((m ch-map) (fn function) &key val-compare-fn-name) + (ch-map-fn-compose m fn val-compare-fn-name)) + +(defmethod compose ((m ch-map) (fn symbol) &key val-compare-fn-name) + (ch-map-fn-compose m (symbol-function fn) val-compare-fn-name)) + +(defmethod compose ((m ch-map) (s seq) &key val-compare-fn-name) + (ch-map-fn-compose m (fn (x) (lookup s x)) val-compare-fn-name)) + +(defun ch-map-fn-compose (m fn val-compare-fn-name) + (declare (type function fn)) + (let ((prototype (empty-ch-map nil (key-compare-fn-name m) val-compare-fn-name))) + (make-ch-map (ch-map-tree-compose (ch-map-contents m) fn (val-hash-fn m) (val-hash-fn prototype)) + (ch-map-org prototype) + (funcall fn (map-default m))))) + (defmethod internal-do-map ((m ch-map) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) (do-ch-map-tree-pairs (x y (ch-map-contents m) (funcall value-fn)) (funcall elt-fn x y))) +(defmethod iterator ((m ch-map) &key) + (make-ch-map-tree-iterator (ch-map-contents m))) + +(defmethod fun-iterator ((s ch-map) &key from-end?) + (if from-end? + (ch-map-tree-rev-fun-iter (ch-map-contents s)) + (ch-map-tree-fun-iter (ch-map-contents s)))) + (defmethod convert ((to-type (eql 'wb-map)) (m ch-map) &key key-compare-fn-name val-compare-fn-name) (convert-to-wb-map m nil nil (let ((tree nil)) (do-ch-map-tree-pairs (k v (ch-map-contents m) tree) (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn)))))) -(defmethod convert ((to-type (eql 'ch-map)) (m wb-map) &key key-compare-fn-name val-compare-fn-name) +(defmethod convert ((to-type (eql 'ch-map)) (m map) &key key-compare-fn-name val-compare-fn-name) (let ((prototype (empty-ch-map nil key-compare-fn-name val-compare-fn-name)) ((hmorg (ch-map-org prototype)) ((key-hash-fn (hash-map-org-key-hash-fn hmorg)) @@ -4456,10 +4486,67 @@ (defmethod convert ((to-type (eql 'ch-map)) (m wb-map) &key key-compare-fn-name (val-hash-fn (hash-map-org-val-hash-fn hmorg)) (val-compare-fn (hash-map-org-val-compare-fn hmorg)))) (result nil)) - (do-wb-map-tree-pairs (k v (wb-map-contents m)) + (do-map (k v m) (setq result (ch-map-tree-with result k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) (make-ch-map result hmorg (map-default m)))) +(defmethod convert ((to-type (eql 'ch-map)) (m ch-map) + &key (default nil default?) key-compare-fn-name val-compare-fn-name) + "The result uses `default' if supplied, otherwise has the same default as `m'." + (convert-to-ch-map m (if default? default (map-default m)) + (let ((m-hmorg (ch-map-org m))) + (or (eq m-hmorg hmorg) + (and (eq key-hash-fn (hash-map-org-key-hash-fn m-hmorg)) + (eq key-compare-fn (hash-map-org-key-compare-fn m-hmorg)) + (eq val-hash-fn (hash-map-org-val-hash-fn m-hmorg)) + (eq val-compare-fn (hash-map-org-val-compare-fn m-hmorg))))) + (let ((tree nil)) + (do-ch-map-tree-pairs (k v (ch-map-contents m)) + (setq tree (ch-map-tree-with tree k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) + tree))) + +(defmethod convert ((to-type (eql 'ch-map)) (l list) + &key (key-fn #'car) (value-fn #'cdr) + key-compare-fn-name val-compare-fn-name) + (declare (type function key-fn value-fn)) + (convert-to-ch-map l nil nil + (let ((tree nil)) + (dolist (x l) + (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) + key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) + tree))) + +(defmethod convert ((to-type (eql 'ch-map)) (s seq) + &key (key-fn #'car) (value-fn #'cdr) + key-compare-fn-name val-compare-fn-name) + (declare (type function key-fn value-fn)) + (convert-to-ch-map l nil nil + (let ((tree nil)) + (do-seq (x s) + (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) + key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) + tree))) + +(defmethod convert ((to-type (eql 'ch-map)) (s sequence) + &key (key-fn #'car) (value-fn #'cdr) + key-compare-fn-name val-compare-fn-name) + (declare (type function key-fn value-fn)) + (convert-to-ch-map l nil nil + (let ((tree nil)) + (dotimes (i (length s)) + (let ((x (elt s i))) + (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) + key-hash-fn key-compare-fn val-hash-fn val-compare-fn)))) + tree))) + +(defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn-name val-compare-fn-name) + (convert-to-ch-map ht nil nil + (let ((tree nil)) + (maphash (lambda (k v) + (setq tree (ch-map-tree-with tree k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) + ht) + tree))) + (defun print-ch-map (map stream level) (declare (ignore level)) (pprint-logical-block (stream nil :prefix "##{|" @@ -5257,16 +5344,16 @@ (defmethod convert ((to-type (eql 'vector)) (s sequence) &key) (defun compose-with-key-fn (fn collection) (lambda (key) (lookup collection (funcall fn key)))) -(defmethod compose ((fn function) (m wb-map)) +(defmethod compose ((fn function) (m map) &key) (compose-with-key-fn fn m)) -(defmethod compose ((fn symbol) (m wb-map)) +(defmethod compose ((fn symbol) (m map) &key) (compose-with-key-fn fn m)) -(defmethod compose ((fn function) (s seq)) +(defmethod compose ((fn function) (s seq) &key) (compose-with-key-fn fn s)) -(defmethod compose ((fn symbol) (s seq)) +(defmethod compose ((fn symbol) (s seq) &key) (compose-with-key-fn fn s)) diff --git a/Code/macros.lisp b/Code/macros.lisp index 2d3ac33..073cba2 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -883,3 +883,16 @@ (defmethod ,name ,(mod-param-list 'wb-custom-set) ,(if identity-test `(if ,identity-test ,coll ,body) body)))) + +(defmacro convert-to-ch-map (coll default identity-test &body contents-forms) + (let ((body `(let ((tree (progn . ,contents-forms))) + (make-ch-map tree hmorg ,default)))) + `(let ((prototype (empty-ch-map nil key-compare-fn-name val-compare-fn-name)) + ((hmorg (ch-map-org prototype)) + ((key-hash-fn (hash-map-org-key-hash-fn hmorg)) + (key-compare-fn (hash-map-org-key-compare-fn hmorg)) + (val-hash-fn (hash-map-org-val-hash-fn hmorg)) + (val-compare-fn (hash-map-org-val-compare-fn hmorg))))) + ,(if identity-test + `(if ,identity-test ,coll ,body) + body)))) diff --git a/Code/relations.lisp b/Code/relations.lisp index 03c4c45..305d1f9 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -286,19 +286,19 @@ (defmethod join ((bra wb-2-relation) cola (brb wb-2-relation) colb) (make-wb-2-relation new-size new-map0 new-map1))) -(defmethod compose ((rel wb-2-relation) (fn function)) +(defmethod compose ((rel wb-2-relation) (fn function) &key) (2-relation-fn-compose rel fn)) -(defmethod compose ((rel wb-2-relation) (fn symbol)) +(defmethod compose ((rel wb-2-relation) (fn symbol) &key) (2-relation-fn-compose rel (coerce fn 'function))) -(defmethod compose ((rel wb-2-relation) (fn map)) +(defmethod compose ((rel wb-2-relation) (fn map) &key) (2-relation-fn-compose rel fn)) -(defmethod compose ((rel wb-2-relation) (fn seq)) +(defmethod compose ((rel wb-2-relation) (fn seq) &key) (2-relation-fn-compose rel fn)) -(defmethod compose ((rel1 wb-2-relation) (rel2 wb-2-relation)) +(defmethod compose ((rel1 wb-2-relation) (rel2 wb-2-relation) &key) (join rel1 1 rel2 0)) (defun 2-relation-fn-compose (rel fn) diff --git a/Code/testing.lisp b/Code/testing.lisp index 6588abc..8d71102 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -88,10 +88,8 @@ (define-hash-function erapmoc hash-value-negated) (Test-Bag-Operations i) (Test-Seq-Operations i) (Test-Tuple-Operations i)) - ;; These take longer. - (progn - (test-champ-sets (max 2 (floor n-iterations 3))) - (test-champ-maps (max 2 (floor n-iterations 3)))))) + (test-champ-sets n-iterations) + (test-champ-maps n-iterations))) (defun Test-Misc-0 () @@ -3995,23 +3993,24 @@ (defmethod verify ((m ch-map)) (test (eq (compare chm tmp-chm) ':less)) (test (eq (compare tmp-chm chm) ':greater))) (let ((k 0) - #+(or)(it (iterator chs)) - #+(or)(f-it (fun-iterator chs))) + (it (iterator chm)) + (f-it (fun-iterator chm))) (do-map (x y chm) (let ((idxx idxy (at-index chm k))) (test (and (equal? x idxx) (equal? y idxy)))) - #+(or)(test (funcall it ':more?)) - #+(or)(test (not (funcall f-it ':empty?))) - #+(or) + (test (funcall it ':more?)) + (test (not (funcall f-it ':empty?))) (let ((itval (funcall it ':get)) (f-itval (funcall f-it ':first))) (test (equal? x itval)) (test (equal? x f-itval))) (test (= (index chm x) k)) (incf k) - #+(or)(setq f-it (funcall f-it ':rest))) - #+(or)(test (funcall it ':done?)) - #+(or)(test (funcall f-it ':empty?)))))) + (setq f-it (funcall f-it ':rest))) + (test (funcall it ':done?)) + (test (funcall f-it ':empty?))) + (test (equal? (reverse (convert 'seq chm)) + (gmap (:result seq) #'cons (:arg fun-map chm :from-end? t))))))) (when saved-chm (let ((chm-union (map-union chm saved-chm))) (test (verify chm-union)) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index 3b604e0..ee37c42 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -5718,13 +5718,13 @@ (defstruct (WB-Map-Tree-Node ;;; ---------------- ;;; Functional iterators. Fun!!! -(defun WB-Map-Tree-Fun-Iter (tree) +(defun WB-Map-Tree-Fun-Iter (tree &optional (cont (lambda (op) + (ecase op + (:first (values nil nil nil)) + (:empty? t) + (:more? nil))))) (declare (optimize (speed 3) (safety 0))) - (rlabels (walk tree (lambda (op) - (ecase op - (:first (values nil nil nil)) - (:empty? t) - (:more? nil)))) + (rlabels (walk tree cont) (walk (node cont) (cond ((null node) cont) @@ -5762,13 +5762,13 @@ (defstruct (WB-Map-Tree-Node (:empty? nil) (:more? t))))))))))) -(defun WB-Map-Tree-Rev-Fun-Iter (tree) +(defun WB-Map-Tree-Rev-Fun-Iter (tree &optional (cont (lambda (op) + (ecase op + (:first (values nil nil nil)) + (:empty? t) + (:more? nil))))) (declare (optimize (speed 3) (safety 0))) - (rlabels (walk tree (lambda (op) - (ecase op - (:first (values nil nil nil)) - (:empty? t) - (:more? nil)))) + (rlabels (walk tree cont) (walk (node cont) (cond ((null node) cont) -- GitLab From 43d4b39df020158b54a9842e0dc1626c232f71e7 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 11 Sep 2025 18:45:58 -0700 Subject: [PATCH 11/16] Minor cleanup of internals. --- Code/champ.lisp | 122 ++++++++++++++++++++++-------------------------- 1 file changed, 55 insertions(+), 67 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index c20591d..92c6399 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -129,18 +129,20 @@ (defstruct (ch-set-node (let ((value-hash (hash-to-fixnum value hash-fn))) (declare (fixnum value-hash)) (rlabels (rec tree (ash value-hash (- (* champ-hash-bits-per-level depth))) depth) - (rec (node hash-shifted depth) + (rec (node hash-shifted depth &optional node-hash) (declare (fixnum hash-shifted) - (type (integer 0 64) depth)) + (type (integer 0 64) depth) + (type (or null fixnum) node-hash)) (let ((hash-bits (logand hash-shifted champ-hash-level-mask))) (if (null node) (vector (ash 1 hash-bits) 0 1 value-hash value) (if (consp node) ;; We can create collision nodes at any level (see below). -- Well, not at the root. But ;; this is called from elsewhere (e.g. `-union') on subtrees, which might be collision nodes. - (let ((wb-hash-shifted (ash (hash-to-fixnum (wb-set-tree-arb (cdr node)) hash-fn) - (- (* champ-hash-bits-per-level depth)))) - (size (1+ (wb-set-tree-size (cdr node))))) + (let ((node-hash (or node-hash (hash-to-fixnum (wb-set-tree-arb (cdr node)) hash-fn))) + ((wb-hash-shifted (ash node-hash (- (* champ-hash-bits-per-level depth))))) + (size (1+ (wb-set-tree-size (cdr node)))) + (content-hash (mix-hash (car node) value-hash))) (declare (fixnum wb-hash-shifted hash-shifted size)) (if (= hash-shifted wb-hash-shifted) ;; Update the collision node. @@ -148,20 +150,14 @@ (defstruct (ch-set-node (if (eq new-wb-tree (cdr node)) node ;; New entry in collision node - (cons (mix-hash (car node) value-hash) new-wb-tree))) - ;; Oh, this is fun. We add enough levels to get to where the hashes differ. - (rlabels (build hash-shifted wb-hash-shifted) - (build (hash-shifted wb-hash-shifted) - (declare (fixnum hash-shifted wb-hash-shifted)) - (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) - (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask)) - (content-hash (mix-hash (car node) value-hash))) - (if (= hash-bits wb-hash-bits) - (vector 0 (ash 1 hash-bits) size content-hash - (build (ash hash-shifted (- champ-hash-bits-per-level)) - (ash wb-hash-shifted (- champ-hash-bits-per-level)))) - (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size content-hash - value node))))))) + (cons content-hash new-wb-tree))) + (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) + (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask))) + (if (= hash-bits wb-hash-bits) + (vector 0 (ash 1 hash-bits) size content-hash + (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth) node-hash)) + (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size content-hash + value node))))) ;; Normal case (let ((entry-mask (ch-set-node-entry-mask node)) ((entry-raw-idx (1-bits-below hash-bits entry-mask)) @@ -482,6 +478,7 @@ (defstruct (ch-set-node ;;; This ordering has the slight downside that it can seem unstable; adding or removing an element ;;; can cause a different element to change places (because an entry becomes a subnode or conversely). ;;; But doing it hash-wise is noticeably slower, like a factor of 2 on a straightforward micro-benchmark. +;;; And one of the selling points of CHAMP was supposed to be its better iteration performance. (defmacro do-ch-set-tree-members ((value-var tree-form &optional value-form) &body body) (let ((body-fn (gensymx #:body-)) @@ -704,29 +701,27 @@ (defstruct (ch-set-node (declare (optimize (speed 3) (safety 03)) (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) - (rec (tree1 tree2 depth) - (declare (type (integer 0 64) depth)) + (rec (tree1 tree2 depth &optional hash1 hash2) + (declare (type (integer 0 64) depth) + (type (or null fixnum) hash1 hash2)) (cond ((null tree1) tree2) ((null tree2) tree1) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((hash1 (hash-to-fixnum (wb-set-tree-arb (cdr tree1)) hash-fn)) - (hash2 (hash-to-fixnum (wb-set-tree-arb (cdr tree2)) hash-fn))) + (let ((hash1 (or hash1 (hash-to-fixnum (wb-set-tree-arb (cdr tree1)) hash-fn))) + (hash2 (or hash2 (hash-to-fixnum (wb-set-tree-arb (cdr tree2)) hash-fn)))) (if (= hash1 hash2) (let ((result (wb-set-tree-union (cdr tree1) (cdr tree2) compare-fn))) (ch-set-node-from-wb result hash-fn depth)) - (let ((size (+ (wb-set-tree-size (cdr tree1)) (wb-set-tree-size (cdr tree2))))) + (let ((size (+ (wb-set-tree-size (cdr tree1)) (wb-set-tree-size (cdr tree2)))) + (bits1 (champ-hash-bits hash1 depth)) + (bits2 (champ-hash-bits hash2 depth)) + (chash (mix-hash (car tree1) (car tree2)))) (declare (fixnum size)) - (rlabels (build depth) - (build (depth) - (declare (type (integer 0 64) depth)) - (let ((bits1 (champ-hash-bits hash1 depth)) - (bits2 (champ-hash-bits hash2 depth)) - (chash (mix-hash (car tree1) (car tree2)))) - (if (= bits1 bits2) - (vector 0 (ash 1 bits1) size chash (build (1+ depth))) - (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) - (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0)))))))))) + (if (= bits1 bits2) + (vector 0 (ash 1 bits1) size chash (rec tree1 tree2 (1+ depth) hash1 hash2)) + (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) + (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0))))))) ((or (consp tree1) (consp tree2)) (let ((normal-node collision-node (if (consp tree1) (values tree2 tree1) (values tree1 tree2)))) ;; Garbagey, but nontrivial to improve on, AFAICS. @@ -1220,18 +1215,18 @@ (defstruct (ch-map-node (let ((key-hash (hash-to-fixnum key key-hash-fn))) (declare (fixnum key-hash)) (rlabels (rec tree (ash key-hash (- (* champ-hash-bits-per-level depth))) depth) - (rec (node hash-shifted depth) + (rec (node hash-shifted depth &optional node-hash) (declare (fixnum hash-shifted) - (type (integer 0 64) depth)) + (type (integer 0 64) depth) + (type (or null fixnum) node-hash)) (let ((hash-bits (logand hash-shifted champ-hash-level-mask))) (if (null node) (vector (ash 1 hash-bits) 0 1 (mix-hash key-hash (hash-to-fixnum value val-hash-fn)) key value) (if (consp node) ;; Collision node. - (let ((wb-hash-shifted - (ash (hash-to-fixnum (wb-map-tree-arb-pair (cdr node)) key-hash-fn) - (* (- champ-hash-bits-per-level) depth))) + (let ((node-hash (or node-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr node)) key-hash-fn))) + ((wb-hash-shifted (ash node-hash (* (- champ-hash-bits-per-level) depth)))) (size (1+ (wb-map-tree-size (cdr node))))) (declare (fixnum wb-hash-shifted hash-shifted size)) (if (= hash-shifted wb-hash-shifted) @@ -1250,19 +1245,14 @@ (defstruct (ch-map-node (t ; New entry in collision node (cons (mix-hash (car node) key-hash (hash-to-fixnum value val-hash-fn)) new-wb-tree)))) - ;; Oh, this is fun. We add enough levels to get to where the hashes differ. - (rlabels (build hash-shifted wb-hash-shifted) - (build (hash-shifted wb-hash-shifted) - (declare (fixnum hash-shifted wb-hash-shifted)) - (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) - (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask)) - (content-hash (mix-hash (car node) key-hash (hash-to-fixnum value val-hash-fn)))) - (if (= hash-bits wb-hash-bits) - (vector 0 (ash 1 hash-bits) size content-hash - (build (ash hash-shifted (- champ-hash-bits-per-level)) - (ash wb-hash-shifted (- champ-hash-bits-per-level)))) - (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size content-hash - key value node))))))) + (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) + (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask)) + (content-hash (mix-hash (car node) key-hash (hash-to-fixnum value val-hash-fn)))) + (if (= hash-bits wb-hash-bits) + (vector 0 (ash 1 hash-bits) size content-hash + (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth) node-hash)) + (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size content-hash + key value node))))) ;; Normal case. (let ((entry-mask (ch-map-node-entry-mask node)) ((entry-raw-idx (1-bits-below hash-bits entry-mask)) @@ -1893,29 +1883,27 @@ (defstruct (ch-map-node (declare (optimize (speed 3)) (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) (rlabels (rec tree1 tree2 0) - (rec (tree1 tree2 depth) - (declare (type (integer 0 64) depth)) + (rec (tree1 tree2 depth &optional hash1 hash2) + (declare (type (integer 0 64) depth) + (type (or null fixnum) hash1 hash2)) (cond ((null tree1) tree2) ((null tree2) tree1) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((hash1 (hash-to-fixnum (wb-map-tree-arb-pair (cdr tree1)) key-hash-fn)) - (hash2 (hash-to-fixnum (wb-map-tree-arb-pair (cdr tree2)) key-hash-fn))) + (let ((hash1 (or hash1 (hash-to-fixnum (wb-map-tree-arb-pair (cdr tree1)) key-hash-fn))) + (hash2 (or hash2 (hash-to-fixnum (wb-map-tree-arb-pair (cdr tree2)) key-hash-fn)))) (if (= hash1 hash2) (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth)) - (let ((size (+ (wb-map-tree-size (cdr tree1)) (wb-map-tree-size (cdr tree2))))) + (let ((bits1 (champ-hash-bits hash1 depth)) + (bits2 (champ-hash-bits hash2 depth)) + (size (+ (wb-map-tree-size (cdr tree1)) (wb-map-tree-size (cdr tree2)))) + (chash (mix-hash (car tree1) (car tree2)))) (declare (fixnum size)) - (rlabels (build depth) - (build (depth) - (declare (type (integer 0 64) depth)) - (let ((bits1 (champ-hash-bits hash1 depth)) - (bits2 (champ-hash-bits hash2 depth)) - (chash (mix-hash (car tree1) (car tree2)))) - (if (= bits1 bits2) - (vector 0 (ash 1 bits1) size chash (build (1+ depth))) - (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) - (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0)))))))))) + (if (= bits1 bits2) + (vector 0 (ash 1 bits1) size chash (rec tree1 tree2 (1+ depth) hash1 hash2)) + (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) + (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0))))))) ((consp tree1) (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) -- GitLab From 455d7740b46bae2681d93b1cc906688f24b44c41 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sat, 13 Sep 2025 17:08:52 -0700 Subject: [PATCH 12/16] Internal improvements: - Split map hash into key and value parts - Compute the value hash only on demand - Key (element) hash of collision node is now just that of one key (element) - Map 'less' now returns the deleted range value, if any - Other minor cleanups --- Code/champ.lisp | 662 ++++++++++++++++++++++++--------------------- Code/fset.lisp | 23 +- Code/hash.lisp | 4 +- Code/port.lisp | 21 +- Code/testing.lisp | 30 +- Code/wb-trees.lisp | 45 +-- 6 files changed, 422 insertions(+), 363 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index d7727ae..4eeaafc 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -88,7 +88,7 @@ (fixnum-len (integer-length most-positive-fixnum)) (fh 0)) (dotimes (i (ceiling len fixnum-len)) - (mix-hashf fh (ldb (byte fixnum-len (* fixnum-len i)) h))) + (hash-mixf fh (ldb (byte fixnum-len (* fixnum-len i)) h))) (if (< h 0) (- fh) fh))) (declaim (ftype (function (t) fixnum) squash-bignum-hash)) @@ -141,8 +141,7 @@ (defstruct (ch-set-node ;; this is called from elsewhere (e.g. `-union') on subtrees, which might be collision nodes. (let ((node-hash (or node-hash (hash-to-fixnum (wb-set-tree-arb (cdr node)) hash-fn))) ((wb-hash-shifted (ash node-hash (- (* champ-hash-bits-per-level depth))))) - (size (1+ (wb-set-tree-size (cdr node)))) - (content-hash (mix-hash (car node) value-hash))) + (size (1+ (wb-set-tree-size (cdr node))))) (declare (fixnum wb-hash-shifted hash-shifted size)) (if (= hash-shifted wb-hash-shifted) ;; Update the collision node. @@ -150,9 +149,10 @@ (defstruct (ch-set-node (if (eq new-wb-tree (cdr node)) node ;; New entry in collision node - (cons content-hash new-wb-tree))) + (cons (car node) new-wb-tree))) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) - (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask))) + (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask)) + (content-hash (hash-mix (car node) value-hash))) (if (= hash-bits wb-hash-bits) (vector 0 (ash 1 hash-bits) size content-hash (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth) node-hash)) @@ -177,9 +177,8 @@ (defstruct (ch-set-node ((ex-value-hash-shifted (ash ex-value-hash (* (- champ-hash-bits-per-level) (1+ depth)))) ((n2 (if (= hash-shifted ex-value-hash-shifted) ;; Collision! Fall back to WB-tree. - (cons (mix-hash value-hash ex-value-hash) - (wb-set-tree-with (wb-set-tree-with nil ex-value compare-fn) - value compare-fn)) + (cons value-hash (wb-set-tree-with (wb-set-tree-with nil ex-value compare-fn) + value compare-fn)) ;; Creates a little garbage; &&& hand-integrate later. (rec (vector (ash 1 (logand ex-value-hash-shifted champ-hash-level-mask)) 0 1 ex-value-hash ex-value) @@ -190,7 +189,8 @@ (defstruct (ch-set-node (logandc2f (ch-set-node-entry-mask n) (ash 1 hash-bits)) (logiorf (ch-set-node-subnode-mask n) (ash 1 hash-bits)) (incf (ch-set-node-size n)) - (mix-hashf (ch-set-node-hash-value n) value-hash) + (unless (consp n2) + (hash-mixf (ch-set-node-hash-value n) value-hash)) n))) ;; No entry found: check for subnode (if (logbitp hash-bits subnode-mask) @@ -204,14 +204,14 @@ (defstruct (ch-set-node (setf (ch-set-node-size n) (the fixnum (+ (ch-set-node-size n) (- (the fixnum (ch-set-tree-size new-subnode)) (the fixnum (ch-set-tree-size subnode)))))) - (mix-hashf (ch-set-node-hash-value n) (unmix-hash (ch-set-tree-hash-value new-subnode) + (hash-mixf (ch-set-node-hash-value n) (hash-unmix (ch-set-tree-hash-value new-subnode) (ch-set-tree-hash-value subnode))) n))) ;; Neither entry nor subnode found: make new entry (let ((n (vector-insert node entry-idx value))) (logiorf (ch-set-node-entry-mask n) (ash 1 hash-bits)) (incf (ch-set-node-size n)) - (mix-hashf (ch-set-node-hash-value n) value-hash) + (hash-mixf (ch-set-node-hash-value n) value-hash) n))))))))))) (defun vector-rem-1-ins-1 (vec rem-idx ins-idx ins-val) @@ -244,14 +244,13 @@ (defstruct (ch-set-node (if (consp node) (let ((new-wb-tree (wb-set-tree-less (cdr node) value compare-fn))) (if (eq new-wb-tree (cdr node)) - (values node 0) + node (if (= 1 (wb-set-tree-size new-wb-tree)) ;; Removing next-to-last entry of collision node: turn remaining value into entry (let ((rem-val (wb-set-tree-arb new-wb-tree)) (hash-bits (logand hash-shifted champ-hash-level-mask))) - (values (vector (ash 1 hash-bits) 0 1 value-hash rem-val) value-hash)) - (values (cons (unmix-hash (car node) value-hash) new-wb-tree) - value-hash)))) + (vector (ash 1 hash-bits) 0 1 value-hash rem-val)) + (cons (car node) new-wb-tree)))) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (entry-mask (ch-set-node-entry-mask node)) ((entry-raw-idx (1-bits-below hash-bits entry-mask)) @@ -260,30 +259,25 @@ (defstruct (ch-set-node (if (logbitp hash-bits entry-mask) (let ((ex-value (svref node entry-idx))) (cond ((not (equal?-cmp ex-value value compare-fn)) - (values node 0)) + node) ((and (= (logcount entry-mask) 1) (= 0 subnode-mask)) - (values nil value-hash)) + (assert (= depth 0)) + nil) (t (let ((n (vector-remove-at node entry-idx))) (logandc2f (ch-set-node-entry-mask n) (ash 1 hash-bits)) (decf (ch-set-node-size n)) - (unmix-hashf (ch-set-node-hash-value n) value-hash) - (values n value-hash))))) + (hash-unmixf (ch-set-node-hash-value n) value-hash) + n)))) (let ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) ((subnode-idx (- (length node) 1 subnode-raw-idx)))) (if (not (logbitp hash-bits subnode-mask)) - (values node 0) + node (let ((subnode (svref node subnode-idx)) - ((new-subnode content-hash-delta - (rec subnode (ash hash-shifted (- champ-hash-bits-per-level)))))) - (declare (fixnum content-hash-delta)) + ((new-subnode (rec subnode (ash hash-shifted (- champ-hash-bits-per-level)))))) (if (eq new-subnode subnode) - (values node 0) - (let ((n (cond ((null new-subnode) - (let ((n (vector-remove-at node subnode-idx))) - (logandc2f (ch-set-node-subnode-mask n) (ash 1 hash-bits)) - n)) - ((consp new-subnode) + node + (let ((n (cond ((consp new-subnode) (vector-update node subnode-idx new-subnode)) ((and (= 1 (logcount (ch-set-node-entry-mask new-subnode))) (= 0 (ch-set-node-subnode-mask new-subnode))) @@ -304,8 +298,9 @@ (defstruct (ch-set-node (svref new-subnode ch-set-node-header-size))) (t (vector-update node subnode-idx new-subnode))))) (decf (ch-set-node-size n)) - (unmix-hashf (ch-set-node-hash-value n) content-hash-delta) - (values n content-hash-delta)))))))))))))) + (hash-mixf (ch-set-node-hash-value n) (hash-unmix (ch-set-tree-hash-value new-subnode) + (ch-set-tree-hash-value subnode))) + n))))))))))))) (defun vector-ins-1-rem-1 (vec ins-idx ins-val rem-idx) (declare ;(optimize (speed 3) (safety 03)) @@ -670,7 +665,7 @@ (defstruct (ch-set-node (setf (svref n (+ ch-set-node-header-size (logcount (ch-set-node-entry-mask n)))) val) (logiorf (ch-set-node-entry-mask n) (ash 1 idx)) (incf (ch-set-node-size n)) - (mix-hashf (ch-set-node-hash-value n) (hash-to-fixnum val hash-fn))) + (hash-mixf (ch-set-node-hash-value n) (hash-to-fixnum val hash-fn))) (declaim (inline ch-set-node-add-subnode)) (defun ch-set-node-add-subnode (n idx subnode hash-fn) @@ -695,31 +690,30 @@ (defstruct (ch-set-node subnode) (logiorf (ch-set-node-subnode-mask n) (ash 1 idx)) (incf (ch-set-node-size n) (ch-set-tree-size subnode)) - (mix-hashf (ch-set-node-hash-value n) (ch-set-tree-hash-value subnode)))))) + (hash-mixf (ch-set-node-hash-value n) (ch-set-tree-hash-value subnode)))))) (defun ch-set-tree-union (tree1 tree2 hash-fn compare-fn) (declare (optimize (speed 3) (safety 03)) (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) - (rec (tree1 tree2 depth &optional hash1 hash2) - (declare (type (integer 0 64) depth) - (type (or null fixnum) hash1 hash2)) + (rec (tree1 tree2 depth) + (declare (type (integer 0 64) depth)) (cond ((null tree1) tree2) ((null tree2) tree1) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((hash1 (or hash1 (hash-to-fixnum (wb-set-tree-arb (cdr tree1)) hash-fn))) - (hash2 (or hash2 (hash-to-fixnum (wb-set-tree-arb (cdr tree2)) hash-fn)))) + (let ((hash1 (the fixnum (car tree1))) + (hash2 (the fixnum (car tree2)))) (if (= hash1 hash2) (let ((result (wb-set-tree-union (cdr tree1) (cdr tree2) compare-fn))) - (ch-set-node-from-wb result hash-fn depth)) + (ch-set-node-from-wb result hash1 depth)) (let ((size (+ (wb-set-tree-size (cdr tree1)) (wb-set-tree-size (cdr tree2)))) (bits1 (champ-hash-bits hash1 depth)) (bits2 (champ-hash-bits hash2 depth)) - (chash (mix-hash (car tree1) (car tree2)))) + (chash (hash-mix (car tree1) (car tree2)))) (declare (fixnum size)) (if (= bits1 bits2) - (vector 0 (ash 1 bits1) size chash (rec tree1 tree2 (1+ depth) hash1 hash2)) + (vector 0 (ash 1 bits1) size chash (rec tree1 tree2 (1+ depth))) (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0))))))) ((or (consp tree1) (consp tree2)) @@ -788,10 +782,9 @@ (defstruct (ch-set-node (cond ((or (null tree1) (null tree2)) nil) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (and (= (hash-to-fixnum (wb-set-tree-arb (cdr tree1)) hash-fn) - (hash-to-fixnum (wb-set-tree-arb (cdr tree2)) hash-fn)) + (and (= (the fixnum (car tree1)) (the fixnum (car tree2))) (let ((result (wb-set-tree-intersect (cdr tree1) (cdr tree2) compare-fn))) - (ch-set-node-from-wb result hash-fn depth)))) + (ch-set-node-from-wb result (car tree1) depth)))) ((or (consp tree1) (consp tree2)) (let ((normal-node collision-node (swap-if (consp tree1) tree1 tree2)) (result nil)) @@ -846,17 +839,16 @@ (defstruct (ch-set-node ((eq tree1 tree2) nil) ((consp tree1) (if (consp tree2) - (if (= (hash-to-fixnum (wb-set-tree-arb (cdr tree1)) hash-fn) - (hash-to-fixnum (wb-set-tree-arb (cdr tree2)) hash-fn)) + (if (= (the fixnum (car tree1)) (the fixnum (car tree2))) (let ((result (wb-set-tree-diff (cdr tree1) (cdr tree2) compare-fn))) - (ch-set-node-from-wb result hash-fn depth)) + (ch-set-node-from-wb result (car tree1) depth)) tree1) (let ((result nil)) ;; Assuming the collision subtree is likely to be much smaller than the regular one. (do-wb-set-tree-members (v (cdr tree1)) (unless (ch-set-tree-contains? tree2 v hash-fn compare-fn depth) (setq result (wb-set-tree-with result v compare-fn)))) - (ch-set-node-from-wb result hash-fn depth)))) + (ch-set-node-from-wb result (car tree1) depth)))) ((consp tree2) (do-wb-set-tree-members (v (cdr tree2)) (setq tree1 (ch-set-tree-less tree1 v hash-fn compare-fn depth))) @@ -908,18 +900,17 @@ (defstruct (ch-set-node ((eq tree1 tree2) (values nil nil)) ((consp tree1) (if (consp tree2) - (if (= (hash-to-fixnum (wb-set-tree-arb (cdr tree1)) hash-fn) - (hash-to-fixnum (wb-set-tree-arb (cdr tree2)) hash-fn)) + (if (= (the fixnum (car tree1)) (the fixnum (car tree2))) (let ((result1 result2 (wb-set-tree-diff-2 (cdr tree1) (cdr tree2) compare-fn))) - (values (ch-set-node-from-wb result1 hash-fn depth) - (ch-set-node-from-wb result2 hash-fn depth))) + (values (ch-set-node-from-wb result1 (car tree1) depth) + (ch-set-node-from-wb result2 (car tree2) depth))) (values tree1 tree2)) (let ((result1 (cdr tree1))) (do-ch-set-tree-members (v tree2) (setq result1 (wb-set-tree-less result1 v compare-fn))) (do-wb-set-tree-members (v (cdr tree1)) (setq tree2 (ch-set-tree-less tree2 v hash-fn compare-fn depth))) - (values (ch-set-node-from-wb result1 hash-fn depth) + (values (ch-set-node-from-wb result1 (car tree1) depth) tree2)))) ((consp tree2) (let ((res2 res1 (rec tree2 tree1 depth))) @@ -979,16 +970,14 @@ (defstruct (ch-set-node (t (error "Bug in ch-set-tree-diff-2"))))) (values (ch-set-compact-node res-n1) (ch-set-compact-node res-n2)))))))) -(defun ch-set-node-from-wb (wb-set-tree hash-fn depth) +(defun ch-set-node-from-wb (wb-set-tree hash depth) (declare (optimize (speed 3)) - (type function hash-fn)) + (fixnum hash) + (type (integer 0 64) depth)) (case (wb-set-tree-size wb-set-tree) (0 nil) - ;; `compare-fn' can't be called in this case. - (1 (ch-set-tree-with nil (wb-set-tree-arb wb-set-tree) hash-fn (fn (_ _)) depth)) - ;; Since this is a collision node, all the hash values must be equal. - (t (cons (multiply-hash (hash-to-fixnum (wb-set-tree-arb wb-set-tree) hash-fn) (wb-set-tree-size wb-set-tree)) - wb-set-tree)))) + (1 (vector (ash 1 (champ-hash-bits hash depth)) 0 1 hash (wb-set-tree-arb wb-set-tree))) + (t (cons hash wb-set-tree)))) (defun ch-set-compact-node (n) (declare (optimize (speed 3))) @@ -1101,7 +1090,10 @@ (defstruct (ch-set-node (rec (node depth partial-hash) (macrolet ((test (form) `(or ,form - (error "Test failed at ~:A: ~S" (path depth partial-hash) ',form)))) + (progn + (cerror "Ignore and proceed." + "Test failed at ~:A: ~S" (path depth partial-hash) ',form) + nil)))) (let ((entry-mask (ch-set-node-entry-mask node)) (subnode-mask (ch-set-node-subnode-mask node)) ((entry-bits (bit-indices entry-mask)) @@ -1116,13 +1108,13 @@ (defstruct (ch-set-node (test (not (and (> depth 0) (= 0 entry-mask) (= 1 (logcount subnode-mask)) (consp (svref node (1- (length node))))))) (let ((size (logcount entry-mask)) - (content-hash 0)) + (node-hash 0)) (and ;; Check entry value hashes (gmap :and (fn (value-idx hash-bits) (let ((value (svref node (+ ch-set-node-header-size value-idx))) ((value-hash (hash-to-fixnum value hash-fn)))) - (mix-hashf content-hash value-hash) + (hash-mixf node-hash value-hash) (test (= (ldb (byte (* champ-hash-bits-per-level (1+ depth)) 0) value-hash) (new-partial-hash hash-bits depth partial-hash))))) @@ -1132,30 +1124,23 @@ (defstruct (ch-set-node (gmap :and (fn (subnode-idx hash-bits) (let ((subnode (svref node (- (length node) 1 subnode-idx)))) (if (consp subnode) - (let ((chash 0) - (elt-hash (hash-to-fixnum (wb-set-tree-arb (cdr subnode)) hash-fn))) + (let ((elt-hash (hash-to-fixnum (wb-set-tree-arb (cdr subnode)) hash-fn))) (test (> (wb-set-tree-size (cdr subnode)) 1)) (do-wb-set-tree-members (v (cdr subnode)) - (let ((vh (hash-to-fixnum v hash-fn))) - (test (= vh elt-hash)) - (mix-hashf chash vh))) - (test (= chash - (multiply-hash (hash-to-fixnum (wb-set-tree-arb (cdr subnode)) - hash-fn) - (wb-set-tree-size (cdr subnode))))) - (mix-hashf content-hash chash) + (test (= (hash-to-fixnum v hash-fn) elt-hash))) + (hash-mixf node-hash elt-hash) (incf size (wb-set-tree-size (cdr subnode))) - (test (= (car subnode) chash))) + (test (= (car subnode) elt-hash))) (and (rec subnode (1+ depth) (new-partial-hash hash-bits depth partial-hash)) (progn (incf size (ch-set-node-size subnode)) - (mix-hashf content-hash (ch-set-node-hash-value subnode)) + (hash-mixf node-hash (ch-set-node-hash-value subnode)) t))))) (:arg index 0) (:arg list subnode-bits)) ;; Finally, check size and hash (test (= (ch-set-node-size node) size)) - (test (= (ch-set-node-hash-value node) content-hash)))))))) + (test (= (ch-set-node-hash-value node) node-hash)))))))) (new-partial-hash (hash-bits depth partial-hash) (dpb hash-bits (byte champ-hash-bits-per-level (* champ-hash-bits-per-level depth)) partial-hash)) @@ -1192,9 +1177,17 @@ (defstruct (ch-map-node (entry-mask 0 :type fixnum) (subnode-mask 0 :type fixnum) (size 0 :type fixnum) ; total number of pairs at or below this node - (hash-value 0 :type fixnum)) -(defconstant ch-map-node-header-size 4) - + (key-hash 0 :type fixnum) + ;; This slot is used in two different ways. For maps, it is a lazily populated cache of + ;; the hashes of the values. For bags, it is the total count (multiplicity). + (value-hash nil :type (or null integer))) +(defmacro ch-map-node-bag-count (x) + `(ch-map-node-value-hash ,x)) +(defconstant ch-map-node-header-size 5) + +;;; A collision node has the form ((key-hash . value-hash) . wb-tree), where `key-hash' is the hash +;;; value of any key -- they're all equal -- and `value-hash', if nonnull, is the mixed hash of all +;;; the values. (deftype ch-map-tree () '(or null cons simple-vector)) @@ -1206,9 +1199,23 @@ (defstruct (ch-map-node (wb-map-tree-size (cdr tree))) (t (ch-map-node-size tree)))) +(declaim (inline ch-map-node-entry)) +(defun ch-map-node-entry (node ientry) + (declare (optimize (speed 3)) + (type simple-vector node) + (type champ-entry-index ientry)) + (let ((entry-idx (+ ch-map-node-header-size (* 2 ientry)))) + (values (svref node entry-idx) (svref node (1+ entry-idx))))) + +(declaim (inline ch-map-node-subnode)) +(defun ch-map-node-subnode (node isubnode) + (declare (optimize (speed 3)) + (type simple-vector node) + (type champ-subnode-index isubnode)) + (svref node (- (length node) isubnode 1))) + (defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0)) - ;; &&& This would benefit from returning a hash delta, as in `ch-set-tree-less'. Ironically, - ;; the technique is not actually needed in that function. + ;; &&& This would benefit from returning a hash delta, as in `ch-set-tree-less'. (declare (optimize (speed 3) (safety 03)) (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (type (integer 0 64) depth)) @@ -1221,8 +1228,7 @@ (defstruct (ch-map-node (type (or null fixnum) node-hash)) (let ((hash-bits (logand hash-shifted champ-hash-level-mask))) (if (null node) - (vector (ash 1 hash-bits) 0 1 (mix-hash key-hash (hash-to-fixnum value val-hash-fn)) - key value) + (vector (ash 1 hash-bits) 0 1 key-hash nil key value) (if (consp node) ;; Collision node. (let ((node-hash (or node-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr node)) key-hash-fn))) @@ -1231,35 +1237,35 @@ (defstruct (ch-map-node (declare (fixnum wb-hash-shifted hash-shifted size)) (if (= hash-shifted wb-hash-shifted) ;; Update the collision node. - (let ((new-wb-tree - (wb-map-tree-with (cdr node) key value key-cmp-fn val-cmp-fn))) - (cond ((eq new-wb-tree (cdr node)) - node) - ((= (wb-map-tree-size new-wb-tree) (wb-map-tree-size (cdr node))) - ;; The key was already present, but the value was updated. - (let ((ig old-value (wb-map-tree-lookup (cdr node) key key-cmp-fn))) - (declare (ignore ig)) - (cons (mix-hash (car node) (unmix-hash (hash-to-fixnum value val-hash-fn) - (hash-to-fixnum old-value val-hash-fn))) - new-wb-tree))) - (t ; New entry in collision node - (cons (mix-hash (car node) key-hash (hash-to-fixnum value val-hash-fn)) - new-wb-tree)))) + (let ((new-wb-tree (wb-map-tree-with (cdr node) key value key-cmp-fn val-cmp-fn))) + (if (eq new-wb-tree (cdr node)) + node + (let ((value-hash (and (cdar node) + (hash-mix (cdar node) (hash-to-fixnum value val-hash-fn))))) + (if (= (wb-map-tree-size new-wb-tree) (wb-map-tree-size (cdr node))) + ;; The key was already present, but the value was updated. + (let ((ig old-value (wb-map-tree-lookup (cdr node) key key-cmp-fn))) + (declare (ignore ig)) + (cons (cons (caar node) + (and value-hash + (hash-unmix value-hash (hash-to-fixnum old-value val-hash-fn)))) + new-wb-tree)) + ;; New entry in collision node + (cons (cons (caar node) value-hash) new-wb-tree))))) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (wb-hash-bits (logand wb-hash-shifted champ-hash-level-mask)) - (content-hash (mix-hash (car node) key-hash (hash-to-fixnum value val-hash-fn)))) + (key-hash (hash-mix (caar node) key-hash)) + (value-hash (and (cdar node) (hash-mix (cdar node) (hash-to-fixnum value val-hash-fn))))) (if (= hash-bits wb-hash-bits) - (vector 0 (ash 1 hash-bits) size content-hash + (vector 0 (ash 1 hash-bits) size key-hash value-hash (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth) node-hash)) - (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size content-hash + (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size key-hash value-hash key value node))))) ;; Normal case. (let ((entry-mask (ch-map-node-entry-mask node)) - ((entry-raw-idx (1-bits-below hash-bits entry-mask)) - ((entry-idx (+ ch-map-node-header-size (* 2 entry-raw-idx))))) + ((entry-idx (+ ch-map-node-header-size (* 2 (1-bits-below hash-bits entry-mask))))) (subnode-mask (ch-map-node-subnode-mask node)) - ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) - ((subnode-idx (- (length node) 1 subnode-raw-idx))))) + ((subnode-idx (- (length node) 1 (1-bits-below hash-bits subnode-mask))))) (if (logbitp hash-bits entry-mask) ;; Entry found (let ((ex-key (svref node entry-idx)) @@ -1269,8 +1275,9 @@ (defstruct (ch-map-node node ; Key found, value equal: nothing to do ;; Key found, value differs: just update value (let ((n (vector-update node (+ entry-idx 1) value))) - (mix-hashf (ch-map-node-hash-value n) (unmix-hash (hash-to-fixnum value val-hash-fn) - (hash-to-fixnum ex-val val-hash-fn))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) (hash-unmix (hash-to-fixnum value val-hash-fn) + (hash-to-fixnum ex-val val-hash-fn)))) n)) ;; Entry with different key found: make a subnode (let ((hash-shifted (ash hash-shifted (- champ-hash-bits-per-level))) @@ -1278,15 +1285,13 @@ (defstruct (ch-map-node ((ex-key-hash-shifted (ash ex-key-hash (* (- champ-hash-bits-per-level) (1+ depth)))) ((n2 (if (= hash-shifted ex-key-hash-shifted) ;; Collision! Fall back to WB-tree. - (cons (mix-hash key-hash (hash-to-fixnum value val-hash-fn) - ex-key-hash (hash-to-fixnum ex-val val-hash-fn)) + (cons (cons key-hash nil) (wb-map-tree-with (wb-map-tree-with nil ex-key ex-val key-cmp-fn val-cmp-fn) key value key-cmp-fn val-cmp-fn)) ;; Creates a little garbage; &&& hand-integrate later. (rec (vector (ash 1 (logand ex-key-hash-shifted champ-hash-level-mask)) - 0 1 (mix-hash ex-key-hash (hash-to-fixnum ex-val val-hash-fn)) - ex-key ex-val) + 0 1 ex-key-hash nil ex-key ex-val) hash-shifted (1+ depth)))) ;; The `1+' is because we're inserting _after_ `subnode-idx', because the subnodes ;; are in reverse order. @@ -1294,7 +1299,12 @@ (defstruct (ch-map-node (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) (logiorf (ch-map-node-subnode-mask n) (ash 1 hash-bits)) (incf (ch-map-node-size n)) - (mix-hashf (ch-map-node-hash-value n) key-hash (hash-to-fixnum value val-hash-fn)) + (unless (consp n2) + (hash-mixf (ch-map-node-key-hash n) key-hash)) + (when (ch-map-node-value-hash n) + ;; `ex-val' is now included in `n2'; we mustn't double-count it. + (hash-unmixf (ch-map-node-value-hash n) (hash-to-fixnum ex-val val-hash-fn)) + (hash-mixf (ch-map-node-value-hash n) (ch-map-tree-value-hash n2 val-hash-fn))) n))) ;; No entry found: check for subnode (if (logbitp hash-bits subnode-mask) @@ -1310,14 +1320,20 @@ (defstruct (ch-map-node (setf (ch-map-node-size n) (the fixnum (+ (ch-map-node-size n) (- (the fixnum (ch-map-tree-size new-subnode)) (the fixnum (ch-map-tree-size subnode)))))) - (mix-hashf (ch-map-node-hash-value n) (unmix-hash (ch-map-tree-hash-value new-subnode) - (ch-map-tree-hash-value subnode))) + (hash-mixf (ch-map-node-key-hash n) (hash-unmix (ch-map-tree-key-hash new-subnode) + (ch-map-tree-key-hash subnode))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (hash-unmix (ch-map-tree-value-hash new-subnode val-hash-fn) + (ch-map-tree-value-hash subnode val-hash-fn)))) n))) ;; Neither entry nor subnode found: make new entry (let ((n (vector-insert-2 node entry-idx key value))) (logiorf (ch-map-node-entry-mask n) (ash 1 hash-bits)) (incf (ch-map-node-size n)) - (mix-hashf (ch-map-node-hash-value n) key-hash (hash-to-fixnum value val-hash-fn)) + (hash-mixf (ch-map-node-key-hash n) key-hash) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) (hash-to-fixnum value val-hash-fn))) n))))))))))) (defun vector-rem-2-ins-1 (vec rem-idx ins-idx ins-val) @@ -1354,10 +1370,35 @@ (defstruct (ch-map-node (setf (svref v (+ idx i 2)) (svref vec (+ idx i)))) v)) -(defun ch-map-tree-hash-value (tree) +(defun ch-map-tree-key-hash (tree) + (cond ((null tree) 0) + ((consp tree) (caar tree)) + (t (ch-map-node-key-hash tree)))) + +(defun ch-map-tree-value-hash (tree val-hash-fn) + (declare (optimize (speed 3)) + (type function val-hash-fn)) (cond ((null tree) 0) - ((consp tree) (car tree)) - (t (ch-map-node-hash-value tree)))) + ((consp tree) + (or (cdar tree) + (setf (cdar tree) + (let ((vhash 0)) + (do-wb-map-tree-pairs (k v (cdr tree)) + (declare (ignore k)) + (hash-mixf vhash (hash-to-fixnum v val-hash-fn))) + vhash)))) + (t + (or (ch-map-node-value-hash tree) + ;; Could happen in multiple threads, but they'll compute the same result. + (setf (ch-map-node-value-hash tree) + (let ((vhash 0)) + (dotimes (i (logcount (ch-map-node-entry-mask tree))) + (let ((k v (ch-map-node-entry tree i))) + (declare (ignore k)) + (hash-mixf vhash (hash-to-fixnum v val-hash-fn)))) + (dotimes (i (logcount (ch-map-node-subnode-mask tree))) + (hash-mixf vhash (ch-map-tree-value-hash (ch-map-node-subnode tree i) val-hash-fn))) + vhash)))))) (defun ch-map-tree-arb-pair (tree) (cond ((null tree) @@ -1382,19 +1423,20 @@ (defstruct (ch-map-node (type (integer 0 64) depth)) (and node (if (consp node) - (let ((new-wb-tree (wb-map-tree-less (cdr node) key key-cmp-fn))) - (if (eq new-wb-tree (cdr node)) - (values node 0) - (let ((ig ex-value (wb-map-tree-lookup (cdr node) key key-cmp-fn)) - ((ex-value-hash (hash-to-fixnum ex-value val-hash-fn)) - ((kv-hash (mix-hash key-hash ex-value-hash))))) - (declare (ignore ig)) - (if (= 1 (wb-map-tree-size new-wb-tree)) - (let ((k v (wb-map-tree-arb-pair new-wb-tree))) - ;; We don't have `val-cmp-fn' handy, but it can't actually be called anyway. - (values (ch-map-tree-with nil k v key-hash-fn key-cmp-fn val-hash-fn (fn (_ _)) depth) - kv-hash)) - (values (cons (unmix-hash (car node) kv-hash) new-wb-tree) kv-hash))))) + (if (/= (the fixnum (caar node)) key-hash) + (values node nil) + (let ((new-wb-tree ex-value (wb-map-tree-less (cdr node) key key-cmp-fn))) + (if (eq new-wb-tree (cdr node)) + (values node nil) + (let ((value-hash (and (cdar node) + (hash-unmix (cdar node) (hash-to-fixnum ex-value val-hash-fn))))) + (if (= 1 (wb-map-tree-size new-wb-tree)) + (let ((k v (wb-map-tree-arb-pair new-wb-tree))) + (values (vector (ash 1 (logcount (logand hash-shifted champ-hash-level-mask))) + 0 1 key-hash value-hash k v) + ex-value)) + (values (cons (cons (caar node) value-hash) new-wb-tree) + ex-value)))))) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (entry-mask (ch-map-node-entry-mask node)) ((entry-raw-idx (1-bits-below hash-bits entry-mask)) @@ -1403,34 +1445,30 @@ (defstruct (ch-map-node (if (logbitp hash-bits entry-mask) (let ((ex-key (svref node entry-idx))) (cond ((not (equal?-cmp ex-key key key-cmp-fn)) - (values node 0)) + (values node nil)) ((and (= (logcount entry-mask) 1) (= 0 subnode-mask)) - ;; &&& Check that this happens only at the root - (values nil (mix-hash key-hash (hash-to-fixnum (svref node (1+ entry-idx)) val-hash-fn)))) + (assert (= depth 0)) + (values nil (svref node (1+ entry-idx)))) (t - (let ((n (vector-remove-2-at node entry-idx)) - (ex-value-hash (hash-to-fixnum (svref node (1+ entry-idx)) val-hash-fn))) + (let ((n (vector-remove-2-at node entry-idx))) (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) (decf (ch-map-node-size n)) - (let ((kv-hash (mix-hash key-hash ex-value-hash))) - (unmix-hashf (ch-map-node-hash-value n) kv-hash) - (values n kv-hash)))))) + (hash-unmixf (ch-map-node-key-hash n) key-hash) + (when (ch-map-node-value-hash n) + (hash-unmixf (ch-map-node-value-hash n) + (hash-to-fixnum (svref node (1+ entry-idx)) val-hash-fn))) + (values n (svref node (1+ entry-idx))))))) (let ((subnode-raw-idx (1-bits-below hash-bits subnode-mask)) ((subnode-idx (- (the fixnum (length node)) 1 subnode-raw-idx)))) (declare (fixnum subnode-raw-idx subnode-idx)) (if (not (logbitp hash-bits subnode-mask)) (values node 0) (let ((subnode (svref node subnode-idx))) - (let ((new-subnode content-hash-delta + (let ((new-subnode lookup-val (rec subnode (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth)))) - (declare (fixnum content-hash-delta)) (if (eq new-subnode subnode) (values node 0) - (let ((n (cond ((null new-subnode) - (let ((n (vector-remove-at node subnode-idx))) - (logandc2f (ch-map-node-subnode-mask n) (ash 1 hash-bits)) - n)) - ((consp new-subnode) + (let ((n (cond ((consp new-subnode) (vector-update node subnode-idx new-subnode)) ((and (= 1 (logcount (ch-map-node-entry-mask new-subnode))) (= 0 (ch-map-node-subnode-mask new-subnode))) @@ -1453,8 +1491,13 @@ (defstruct (ch-map-node (svref new-subnode ch-map-node-header-size))) (t (vector-update node subnode-idx new-subnode))))) (decf (ch-map-node-size n)) - (unmix-hashf (ch-map-node-hash-value n) content-hash-delta) - (values n content-hash-delta))))))))))))))) + (hash-mixf (ch-map-node-key-hash n) (hash-unmix (ch-map-tree-key-hash new-subnode) + (ch-map-tree-key-hash subnode))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (hash-unmix (ch-map-tree-value-hash new-subnode val-hash-fn) + (ch-map-tree-value-hash subnode val-hash-fn)))) + (values n lookup-val))))))))))))))) (defun vector-remove-2-at (vec idx) (declare (optimize (speed 3) (safety 03)) @@ -1571,84 +1614,92 @@ (defstruct (ch-map-node (rlabels (rec tree) (rec (node) (if (consp node) - (let ((wb-dom (wb-map-tree-domain (cdr node))) - (hash 0)) - (do-wb-set-tree-members (x wb-dom) - (mix-hashf hash (hash-to-fixnum x key-hash-fn))) - (cons hash wb-dom)) + (let ((wb-dom (wb-map-tree-domain (cdr node)))) + (cons (hash-to-fixnum (wb-set-tree-arb wb-dom) key-hash-fn) wb-dom)) (let ((len (length (the simple-vector node))) (entry-mask (ch-map-node-entry-mask node)) + (subnode-mask (ch-map-node-subnode-mask node)) ((nentries (logcount entry-mask)) - ((n (make-array (- len nentries))))) + (nsubnodes (logcount subnode-mask)) + ((res-len (+ ch-set-node-header-size nentries nsubnodes)) + ((n (make-array res-len))))) (hash 0)) (setf (ch-set-node-entry-mask n) entry-mask) - (setf (ch-set-node-subnode-mask n) (ch-map-node-subnode-mask node)) + (setf (ch-set-node-subnode-mask n) subnode-mask) (setf (ch-set-node-size n) (ch-map-node-size node)) (dotimes (i nentries) (let ((x (svref node (+ ch-map-node-header-size (* 2 i))))) (setf (svref n (+ ch-set-node-header-size i)) x) - (mix-hashf hash (hash-to-fixnum x key-hash-fn)))) - (dotimes (i (- len (* 2 nentries) ch-map-node-header-size)) + (hash-mixf hash (hash-to-fixnum x key-hash-fn)))) + (dotimes (i nsubnodes) (let ((new-subnode (rec (svref node (- len i 1))))) - (setf (svref n (- len nentries i 1)) new-subnode) - (mix-hashf hash (ch-set-tree-hash-value new-subnode)))) + (setf (svref n (- res-len i 1)) new-subnode) + (hash-mixf hash (ch-set-tree-hash-value new-subnode)))) (setf (ch-set-node-hash-value n) hash) n)))))) -(defun ch-map-tree-compare (tree1 tree2 key-cmp-fn val-cmp-fn) +(defun ch-map-tree-compare (tree1 tree2 key-cmp-fn val-hash-fn val-cmp-fn) (if (eq tree1 tree2) ':equal (let ((size1 (ch-map-tree-size tree1)) (size2 (ch-map-tree-size tree2))) - (cond ((< size1 size2) ':less) - ((> size1 size2) ':greater) - (t - (let ((hash1 (ch-map-tree-hash-value tree1)) - (hash2 (ch-map-tree-hash-value tree2))) - (cond ((< hash1 hash2) ':less) - ((> hash1 hash2) ':greater) - ((consp tree1) - (if (consp tree2) (wb-map-tree-compare (cdr tree1) (cdr tree2) key-cmp-fn val-cmp-fn) - ':less)) - ((consp tree2) ':greater) - (t - (let ((entries1 (ch-map-node-entry-mask tree1)) - (entries2 (ch-map-node-entry-mask tree2)) - (subnodes1 (ch-map-node-subnode-mask tree1)) - (subnodes2 (ch-map-node-subnode-mask tree2))) - (cond ((< entries1 entries2) ':less) - ((> entries1 entries2) ':greater) - ((< subnodes1 subnodes2) ':less) - ((> subnodes1 subnodes2) ':greater) - (t - ;; It's astronomically unlikely that we'll get here unless the trees are actually - ;; equal... but we still have to check. - (let ((default ':equal) - (len (length (the simple-vector tree1)))) - (dotimes (i (logcount entries1)) - (let ((k1 (svref tree1 (+ ch-map-node-header-size (* 2 i)))) - (v1 (svref tree1 (+ ch-map-node-header-size (1+ (* 2 i))))) - (k2 (svref tree2 (+ ch-map-node-header-size (* 2 i)))) - (v2 (svref tree2 (+ ch-map-node-header-size (1+ (* 2 i))))) - ((key-cmp (funcall key-cmp-fn k1 k2)))) - (when (member key-cmp '(:less :greater)) - (return-from ch-map-tree-compare key-cmp)) - (when (eq key-cmp ':unequal) - (setq default ':unequal)) - (let ((val-cmp (funcall val-cmp-fn v1 v2))) - (when (member val-cmp '(:less :greater)) - (return-from ch-map-tree-compare val-cmp)) - (when (eq val-cmp ':unequal) - (setq default ':unequal))))) - (dotimes (i (logcount subnodes1)) - (let ((cmp (ch-map-tree-compare (svref tree1 (- len i 1)) (svref tree2 (- len i 1)) - key-cmp-fn val-cmp-fn))) - (ecase cmp - (:equal) - (:unequal - (setq default ':unequal)) - ((:less :greater) - (return-from ch-map-tree-compare cmp))))) - default)))))))))))) + (cond + ((< size1 size2) ':less) + ((> size1 size2) ':greater) + (t + (let ((khash1 (ch-map-tree-key-hash tree1)) + (khash2 (ch-map-tree-key-hash tree2))) + (cond + ((< khash1 khash2) ':less) + ((> khash1 khash2) ':greater) + (t + (let ((vhash1 (ch-map-tree-value-hash tree1 val-hash-fn)) + (vhash2 (ch-map-tree-value-hash tree2 val-hash-fn))) + (cond + ((< vhash1 vhash2) ':less) + ((> vhash1 vhash2) ':greater) + ((consp tree1) + (if (consp tree2) (wb-map-tree-compare (cdr tree1) (cdr tree2) key-cmp-fn val-cmp-fn) + ':less)) + ((consp tree2) ':greater) + (t + (let ((entries1 (ch-map-node-entry-mask tree1)) + (entries2 (ch-map-node-entry-mask tree2)) + (subnodes1 (ch-map-node-subnode-mask tree1)) + (subnodes2 (ch-map-node-subnode-mask tree2))) + (cond ((< entries1 entries2) ':less) + ((> entries1 entries2) ':greater) + ((< subnodes1 subnodes2) ':less) + ((> subnodes1 subnodes2) ':greater) + (t + ;; It's astronomically unlikely that we'll get here unless the trees are actually + ;; equal... but we still have to check. + (let ((default ':equal) + (len (length (the simple-vector tree1)))) + (dotimes (i (logcount entries1)) + (let ((k1 (svref tree1 (+ ch-map-node-header-size (* 2 i)))) + (v1 (svref tree1 (+ ch-map-node-header-size (1+ (* 2 i))))) + (k2 (svref tree2 (+ ch-map-node-header-size (* 2 i)))) + (v2 (svref tree2 (+ ch-map-node-header-size (1+ (* 2 i))))) + ((key-cmp (funcall key-cmp-fn k1 k2)))) + (when (member key-cmp '(:less :greater)) + (return-from ch-map-tree-compare key-cmp)) + (when (eq key-cmp ':unequal) + (setq default ':unequal)) + (let ((val-cmp (funcall val-cmp-fn v1 v2))) + (when (member val-cmp '(:less :greater)) + (return-from ch-map-tree-compare val-cmp)) + (when (eq val-cmp ':unequal) + (setq default ':unequal))))) + (dotimes (i (logcount subnodes1)) + (let ((cmp (ch-map-tree-compare (svref tree1 (- len i 1)) (svref tree2 (- len i 1)) + key-cmp-fn val-hash-fn val-cmp-fn))) + (ecase cmp + (:equal) + (:unequal + (setq default ':unequal)) + ((:less :greater) + (return-from ch-map-tree-compare cmp))))) + default))))))))))))))) ;;; -------------------------------- @@ -1826,45 +1877,30 @@ (defstruct (ch-map-node ;;; -------------------------------- ;;; Union, intersection, set-difference, subset?, disjoint? -(declaim (inline ch-map-node-entry)) -(defun ch-map-node-entry (n ientry) - (declare (optimize (speed 3)) - (type simple-vector n) - (type champ-entry-index ientry)) - (let ((entry-idx (+ ch-map-node-header-size (* 2 ientry)))) - (values (svref n entry-idx) (svref n (1+ entry-idx))))) - -(declaim (inline ch-map-node-subnode)) -(defun ch-map-node-subnode (n isubnode) - (declare (optimize (speed 3)) - (type simple-vector n) - (type champ-subnode-index isubnode)) - (svref n (- (length n) isubnode 1))) - (declaim (inline ch-map-node-add-entry)) -(defun ch-map-node-add-entry (n idx key val key-hash-fn val-hash-fn) +(defun ch-map-node-add-entry (n idx key val key-hash-fn) (declare (optimize (speed 3)) (type champ-bit-index idx) - (type function key-hash-fn val-hash-fn)) + (type function key-hash-fn)) (let ((entry-idx (+ ch-map-node-header-size (* 2 (logcount (ch-map-node-entry-mask n)))))) (setf (svref n entry-idx) key) (setf (svref n (1+ entry-idx)) val)) (logiorf (ch-map-node-entry-mask n) (ash 1 idx)) (incf (ch-map-node-size n)) - (mix-hashf (ch-map-node-hash-value n) (hash-to-fixnum key key-hash-fn) (hash-to-fixnum val val-hash-fn))) + (hash-mixf (ch-map-node-key-hash n) (hash-to-fixnum key key-hash-fn))) (declaim (inline ch-map-node-add-subnode)) -(defun ch-map-node-add-subnode (n idx subnode key-hash-fn val-hash-fn) +(defun ch-map-node-add-subnode (n idx subnode key-hash-fn) (declare (optimize (speed 3)) (type champ-bit-index idx) - (type function key-hash-fn val-hash-fn)) + (type function key-hash-fn)) (when subnode (if (and (not (consp subnode)) (= 1 (logcount (ch-map-node-entry-mask subnode))) (= 0 (ch-map-node-subnode-mask subnode))) ;; `subnode' contains only an entry -- pull it up. (ch-map-node-add-entry n idx (svref subnode ch-map-node-header-size) - (svref subnode (1+ ch-map-node-header-size)) key-hash-fn val-hash-fn) + (svref subnode (1+ ch-map-node-header-size)) key-hash-fn) (progn (when (and (not (consp subnode)) (= 0 (ch-map-node-entry-mask subnode)) @@ -1877,33 +1913,30 @@ (defstruct (ch-map-node subnode) (logiorf (ch-map-node-subnode-mask n) (ash 1 idx)) (incf (ch-map-node-size n) (ch-map-tree-size subnode)) - (mix-hashf (ch-map-node-hash-value n) (ch-map-tree-hash-value subnode)))))) + (hash-mixf (ch-map-node-key-hash n) (ch-map-tree-key-hash subnode)))))) (defun ch-map-tree-union (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (declare (optimize (speed 3)) (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) (rlabels (rec tree1 tree2 0) - (rec (tree1 tree2 depth &optional hash1 hash2) - (declare (type (integer 0 64) depth) - (type (or null fixnum) hash1 hash2)) + (rec (tree1 tree2 depth) + (declare (type (integer 0 64) depth)) (cond ((null tree1) tree2) ((null tree2) tree1) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((hash1 (or hash1 (hash-to-fixnum (wb-map-tree-arb-pair (cdr tree1)) key-hash-fn))) - (hash2 (or hash2 (hash-to-fixnum (wb-map-tree-arb-pair (cdr tree2)) key-hash-fn)))) - (if (= hash1 hash2) - (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) - (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth)) - (let ((bits1 (champ-hash-bits hash1 depth)) - (bits2 (champ-hash-bits hash2 depth)) - (size (+ (wb-map-tree-size (cdr tree1)) (wb-map-tree-size (cdr tree2)))) - (chash (mix-hash (car tree1) (car tree2)))) - (declare (fixnum size)) - (if (= bits1 bits2) - (vector 0 (ash 1 bits1) size chash (rec tree1 tree2 (1+ depth) hash1 hash2)) - (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) - (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0))))))) + (if (= (the fixnum (caar tree1)) (the fixnum (caar tree2))) + (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) + (ch-map-node-from-wb result (caar tree1) depth)) + (let ((bits1 (champ-hash-bits (the fixnum (caar tree1)) depth)) + (bits2 (champ-hash-bits (the fixnum (caar tree2)) depth)) + (size (+ (wb-map-tree-size (cdr tree1)) (wb-map-tree-size (cdr tree2)))) + (key-hash (hash-mix (caar tree1) (caar tree2)))) + (declare (fixnum size)) + (if (= bits1 bits2) + (vector 0 (ash 1 bits1) size key-hash nil (rec tree1 tree2 (1+ depth))) + (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) + (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size key-hash nil subnode1 subnode0)))))) ((consp tree1) (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) @@ -1937,10 +1970,11 @@ (defstruct (ch-map-node (ientry2 0) (isubnode2 0)) (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) + (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn val-hash-fn)) + (ch-map-node-add-entry res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn) + (ch-map-node-add-subnode res-n idx subnode key-hash-fn) nil) ; hush, SBCL (subtree-lookup (tree key) (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn (1+ depth))) @@ -1989,8 +2023,9 @@ (defstruct (ch-map-node (cond ((or (null tree1) (null tree2)) nil) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (let ((result (wb-map-tree-intersect (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) - (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth))) + (and (= (caar tree1) (caar tree2)) + (let ((result (wb-map-tree-intersect (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) + (ch-map-node-from-wb result (caar tree1) depth)))) ((or (consp tree1) (consp tree2)) (let ((normal-node collision-node (swap-if (consp tree1) tree1 tree2)) (result nil)) @@ -2011,10 +2046,11 @@ (defstruct (ch-map-node ;; could be an entry. ((res-len (+ ch-map-node-header-size (* 2 (logcount combined-mask)))) ((res-n (make-array res-len :initial-element 0)))))) + (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn val-hash-fn)) + (ch-map-node-add-entry res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn)) + (ch-map-node-add-subnode res-n idx subnode key-hash-fn)) (subtree-lookup (tree key) (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn (1+ depth)))) (do-bit-indices (idx combined-mask) @@ -2049,9 +2085,11 @@ (defstruct (ch-map-node ((eq tree1 tree2) (values nil nil)) ((consp tree1) (if (consp tree2) - (let ((result1 result2 (wb-map-tree-diff-2 (cdr tree1) (cdr tree2) key-cmp-fn val-cmp-fn))) - (values (ch-map-node-from-wb result1 key-hash-fn key-cmp-fn val-hash-fn depth) - (ch-map-node-from-wb result2 key-hash-fn key-cmp-fn val-hash-fn depth))) + (if (= (caar tree1) (caar tree2)) + (let ((result1 result2 (wb-map-tree-diff-2 (cdr tree1) (cdr tree2) key-cmp-fn val-cmp-fn))) + (values (ch-map-node-from-wb result1 (caar tree1) depth) + (ch-map-node-from-wb result2 (caar tree2) depth))) + (values tree1 tree2)) (let ((result1 nil) (result2 nil)) (do-wb-map-tree-pairs (k v1 (cdr tree1)) @@ -2063,7 +2101,7 @@ (defstruct (ch-map-node (unless (and v1? (equal?-cmp v1 v2 val-cmp-fn)) (setq result2 (ch-map-tree-with result2 k v2 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))))) - (values (ch-map-node-from-wb result1 key-hash-fn key-cmp-fn val-hash-fn depth) + (values (ch-map-node-from-wb result1 (caar tree1) depth) result2)))) ((consp tree2) (let ((res2 res1 (rec tree2 tree1 depth))) @@ -2081,10 +2119,12 @@ (defstruct (ch-map-node (isubnode1 0) (ientry2 0) (isubnode2 0)) + (setf (ch-map-node-value-hash res-n1) nil) + (setf (ch-map-node-value-hash res-n2) nil) (flet ((add-entry (n idx key val) - (ch-map-node-add-entry n idx key val key-hash-fn val-hash-fn)) + (ch-map-node-add-entry n idx key val key-hash-fn)) (add-subnode (n idx subnode) - (ch-map-node-add-subnode n idx subnode key-hash-fn val-hash-fn)) + (ch-map-node-add-subnode n idx subnode key-hash-fn)) (subtree-less (subtree key) (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth))) (subtree-lookup (subtree key) @@ -2136,11 +2176,9 @@ (defstruct (ch-map-node (rec (map-tree set-tree depth) (cond ((or (null map-tree) (null set-tree)) nil) ((and (consp map-tree) (consp set-tree)) - (let ((m-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr map-tree)) key-hash-fn)) - (s-hash (hash-to-fixnum (wb-set-tree-arb (cdr set-tree)) key-hash-fn))) - (and (= m-hash s-hash) - (let ((result (wb-map-tree-restrict (cdr map-tree) (cdr set-tree) key-cmp-fn))) - (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth))))) + (and (= (caar map-tree) (car set-tree)) + (let ((result (wb-map-tree-restrict (cdr map-tree) (cdr set-tree) key-cmp-fn))) + (ch-map-node-from-wb result (car set-tree) depth)))) ;; I figure the collision nodes are probably the smaller of the two. ((consp map-tree) (let ((result nil)) @@ -2166,10 +2204,11 @@ (defstruct (ch-map-node ;; could be an entry. ((res-len (+ ch-map-node-header-size (* 2 (logcount combined-mask)))) ((res-n (make-array res-len :initial-element 0)))))) + (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn val-hash-fn)) + (ch-map-node-add-entry res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn)) + (ch-map-node-add-subnode res-n idx subnode key-hash-fn)) (map-lookup (map-subtree key) (ch-map-tree-lookup map-subtree key key-hash-fn key-cmp-fn (1+ depth))) (set-contains? (set-subtree key) @@ -2203,18 +2242,16 @@ (defstruct (ch-map-node (rec (map-tree set-tree depth) (cond ((or (null map-tree) (null set-tree)) nil) ((and (consp map-tree) (consp set-tree)) - (let ((m-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr map-tree)) key-hash-fn)) - (s-hash (hash-to-fixnum (wb-set-tree-arb (cdr set-tree)) key-hash-fn))) - (if (= m-hash s-hash) - (let ((result (wb-map-tree-restrict-not (cdr map-tree) (cdr set-tree) key-cmp-fn))) - (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth)) - map-tree))) + (if (= (caar map-tree) (car set-tree)) + (let ((result (wb-map-tree-restrict-not (cdr map-tree) (cdr set-tree) key-cmp-fn))) + (ch-map-node-from-wb result (car set-tree) depth)) + map-tree)) ((consp map-tree) (let ((result nil)) (do-wb-map-tree-pairs (k v (cdr map-tree)) (unless (ch-set-tree-contains? set-tree k key-hash-fn key-cmp-fn depth) (setq result (wb-map-tree-with result k v key-cmp-fn (fn (_ _)))))) - (ch-map-node-from-wb result key-hash-fn key-cmp-fn val-hash-fn depth))) + (ch-map-node-from-wb result (caar map-tree) depth))) ((consp set-tree) (do-wb-set-tree-members (k (cdr set-tree)) (setq map-tree (ch-map-tree-less map-tree k key-hash-fn key-cmp-fn val-hash-fn depth))) @@ -2229,10 +2266,11 @@ (defstruct (ch-map-node ((res-len (+ ch-map-node-header-size (* 2 (+ (logcount entries1) (logcount subnodes1))))) ((res-n (make-array res-len :initial-element 0))))) + (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn val-hash-fn)) + (ch-map-node-add-entry res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn val-hash-fn)) + (ch-map-node-add-subnode res-n idx subnode key-hash-fn)) (map-subtree-less (subtree key) (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth))) (set-contains? (set-subtree key) @@ -2260,19 +2298,13 @@ (defstruct (ch-map-node (t (add-subnode idx subnode1))))))) (ch-map-compact-node res-n)))))))) -(defun ch-map-node-from-wb (wb-map-tree key-hash-fn key-cmp-fn val-hash-fn depth) - (declare (type function key-hash-fn key-cmp-fn val-hash-fn)) +(defun ch-map-node-from-wb (wb-map-tree key-hash depth) (case (wb-map-tree-size wb-map-tree) (0 nil) (1 (let ((k v (wb-map-tree-arb-pair wb-map-tree))) - ;; `val-cmp-fn' can't be called in this case. - (ch-map-tree-with nil k v key-hash-fn key-cmp-fn val-hash-fn (fn (_ _)) depth))) - (t (let ((chash (multiply-hash (hash-to-fixnum (wb-map-tree-arb-pair wb-map-tree) key-hash-fn) - (wb-map-tree-size wb-map-tree)))) - (do-wb-map-tree-pairs (k v wb-map-tree) - (declare (ignore k)) - (mix-hashf chash (hash-to-fixnum v val-hash-fn))) - (cons chash wb-map-tree))))) + (vector (ash 1 (champ-hash-bits key-hash depth)) + 0 1 key-hash nil k v))) + (t (cons (cons key-hash nil) wb-map-tree)))) (defun ch-map-compact-node (n) (let ((entries (ch-map-node-entry-mask n)) @@ -2286,30 +2318,26 @@ (defstruct (ch-map-node (if (= extra 0) n (vector-remove-n-at n (+ ch-map-node-header-size (* 2 n-entries)) extra)))))) -(defun ch-map-tree-compose (tree fn val1-hash-fn val2-hash-fn) - (declare (type function fn val1-hash-fn val2-hash-fn)) +(defun ch-map-tree-compose (tree fn) + (declare (type function fn)) (cond ((null tree) nil) ((consp tree) (wb-map-tree-compose tree fn)) (t - (let ((n (make-array (length (the simple-vector tree)) :initial-element 0)) - (chash (ch-map-tree-hash-value tree))) + (let ((n (make-array (length (the simple-vector tree)) :initial-element 0))) (dotimes (i (logcount (ch-map-node-entry-mask tree))) (let ((entry-idx (+ ch-map-node-header-size (* 2 i)))) (setf (svref n entry-idx) (svref tree entry-idx)) - (let ((val (svref tree (1+ entry-idx))) - ((new-val (funcall fn val)))) - (setf (svref n (1+ entry-idx)) new-val) - (mix-hashf chash (unmix-hash (hash-to-fixnum new-val val2-hash-fn) - (hash-to-fixnum val val1-hash-fn)))))) + (setf (svref n (1+ entry-idx)) (funcall fn (svref tree (1+ entry-idx)))))) (dotimes (i (logcount (ch-map-node-subnode-mask tree))) (let ((subnode-idx (- (length (the simple-vector tree)) i 1))) (setf (svref n subnode-idx) - (ch-map-tree-compose (svref tree subnode-idx) fn val1-hash-fn val2-hash-fn)))) + (ch-map-tree-compose (svref tree subnode-idx) fn)))) (setf (ch-map-node-entry-mask n) (ch-map-node-entry-mask tree)) (setf (ch-map-node-subnode-mask n) (ch-map-node-subnode-mask tree)) (setf (ch-map-node-size n) (ch-map-node-size tree)) - (setf (ch-map-node-hash-value n) chash) + (setf (ch-map-node-key-hash n) (ch-map-node-key-hash tree)) + (setf (ch-map-node-value-hash n) nil) n)))) (defun ch-map-tree-verify (tree key-hash-fn val-hash-fn) @@ -2320,7 +2348,10 @@ (defstruct (ch-map-node (rec (node depth partial-hash) (macrolet ((test (form) `(or ,form - (error "Test failed at ~:A: ~S" (path depth partial-hash) ',form)))) + (progn + (cerror "Ignore and proceed." + "Verification check failed at ~:A: ~S" (path depth partial-hash) ',form) + nil)))) (let ((entry-mask (ch-map-node-entry-mask node)) (subnode-mask (ch-map-node-subnode-mask node)) ((entry-bits (bit-indices entry-mask)) @@ -2336,14 +2367,17 @@ (defstruct (ch-map-node (test (not (and (> depth 0) (= 0 entry-mask) (= 1 (logcount subnode-mask)) (consp (svref node (1- (length node))))))) (let ((size (logcount entry-mask)) - (content-hash 0)) + (node-key-hash 0) + (node-value-hash 0)) (and ;; Check entry key hashes (gmap :and (fn (key-idx hash-bits) (let ((key (svref node (+ ch-map-node-header-size (* 2 key-idx)))) ((key-hash (hash-to-fixnum key key-hash-fn))) (value (svref node (+ ch-map-node-header-size (1+ (* 2 key-idx)))))) - (mix-hashf content-hash key-hash (hash-to-fixnum value val-hash-fn)) + (hash-mixf node-key-hash key-hash) + (when (ch-map-node-value-hash node) + (hash-mixf node-value-hash (hash-to-fixnum value val-hash-fn))) (test (= (ldb (byte (* champ-hash-bits-per-level (1+ depth)) 0) key-hash) (new-partial-hash hash-bits depth partial-hash))))) @@ -2353,27 +2387,36 @@ (defstruct (ch-map-node (gmap :and (fn (subnode-idx hash-bits) (let ((subnode (svref node (- (length node) 1 subnode-idx)))) (if (consp subnode) - (let ((chash 0) - (key-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr subnode)) - key-hash-fn))) + (let ((key-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr subnode)) + key-hash-fn)) + (vhash 0)) + (test (consp (car subnode))) (test (> (wb-map-tree-size (cdr subnode)) 1)) (do-wb-map-tree-pairs (k v (cdr subnode)) (let ((kh (hash-to-fixnum k key-hash-fn))) (test (= kh key-hash)) - (mix-hashf chash kh (hash-to-fixnum v val-hash-fn)))) - (mix-hashf content-hash chash) + (when (cdar subnode) + (hash-mixf vhash (hash-to-fixnum v val-hash-fn))))) + (hash-mixf node-key-hash key-hash) (incf size (wb-map-tree-size (cdr subnode))) - (test (= (car subnode) chash))) + (when (cdar subnode) + (test (= (cdar subnode) vhash)) + (hash-mixf node-value-hash vhash)) + (test (= (caar subnode) key-hash))) (and (rec subnode (1+ depth) (new-partial-hash hash-bits depth partial-hash)) (progn (incf size (ch-map-node-size subnode)) - (mix-hashf content-hash (ch-map-node-hash-value subnode)) + (hash-mixf node-key-hash (ch-map-node-key-hash subnode)) + (when (ch-map-node-value-hash node) + (hash-mixf node-value-hash (ch-map-node-value-hash subnode))) t))))) (:arg index 0) (:arg list subnode-bits)) - ;; Finally, check size and hash + ;; Finally, check size and hashes (test (= (ch-map-node-size node) size)) - (test (= (ch-map-node-hash-value node) content-hash)))))))) + (test (= (ch-map-node-key-hash node) node-key-hash)) + (or (null (ch-map-node-value-hash node)) + (test (= (ch-map-node-value-hash node) node-value-hash))))))))) (new-partial-hash (hash-bits depth partial-hash) (dpb hash-bits (byte champ-hash-bits-per-level (* champ-hash-bits-per-level depth)) partial-hash)) @@ -2385,3 +2428,4 @@ (defstruct (ch-map-node path)) (nreverse path)))))) + diff --git a/Code/fset.lisp b/Code/fset.lisp index 269051a..49a3cf0 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -3577,10 +3577,10 @@ (defmethod less ((m wb-map) key &optional (arg2 nil arg2?)) (check-two-arguments arg2? 'less 'wb-map) (let ((contents (wb-map-contents m)) (tmorg (wb-map-org m)) - ((new-contents (WB-Map-Tree-Less contents key (tree-map-org-key-compare-fn tmorg))))) + ((new-contents range-val (WB-Map-Tree-Less contents key (tree-map-org-key-compare-fn tmorg))))) (if (eq new-contents contents) m - (make-wb-map new-contents tmorg (map-default m))))) + (values (make-wb-map new-contents tmorg (map-default m)) range-val)))) (defmethod split-from ((m wb-map) key) (let ((tmorg (wb-map-org m)) @@ -4324,11 +4324,12 @@ (defmethod less ((m ch-map) key &optional (arg2 nil arg2?)) (check-two-arguments arg2? 'less 'ch-map) (let ((contents (ch-map-contents m)) (hmorg (ch-map-org m)) - ((new-contents (ch-map-tree-less contents key (hash-map-org-key-hash-fn hmorg) - (hash-map-org-key-compare-fn hmorg) (hash-map-org-val-hash-fn hmorg))))) + ((new-contents range-val + (ch-map-tree-less contents key (hash-map-org-key-hash-fn hmorg) + (hash-map-org-key-compare-fn hmorg) (hash-map-org-val-hash-fn hmorg))))) (if (eq new-contents contents) m - (make-ch-map new-contents hmorg (map-default m))))) + (values (make-ch-map new-contents hmorg (map-default m)) range-val)))) (defmethod lookup ((m ch-map) key) (let ((hmorg (ch-map-org m)) @@ -4376,7 +4377,8 @@ (defmethod compare ((map1 ch-map) (map2 ch-map)) (if-same-ch-map-orgs (map1 map2 hmorg) (let ((val-compare-fn (hash-map-org-val-compare-fn hmorg)) ((comp (ch-map-tree-compare (ch-map-contents map1) (ch-map-contents map2) - (hash-map-org-key-compare-fn hmorg) val-compare-fn)))) + (hash-map-org-key-compare-fn hmorg) (hash-map-org-val-hash-fn hmorg) + val-compare-fn)))) (if (member comp '(:less :greater)) comp (let ((def-comp (funcall val-compare-fn (map-default map1) (map-default map2)))) @@ -4400,6 +4402,10 @@ (defmethod compare ((map1 ch-map) (map2 ch-map)) (:unequal (error "Can't compare wb-maps with uninterned compare-fn-names with same symbol-name")))))) +(defmethod hash-value ((m ch-map)) + (let ((tree (ch-map-contents m))) + (hash-mix (ch-map-tree-key-hash tree) (ch-map-tree-value-hash tree (hash-map-org-val-hash-fn (ch-map-org m)))))) + (defmethod map-union ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2))) (if-same-ch-map-orgs (m1 m2 hmorg) (make-ch-map (ch-map-tree-union (ch-map-contents m1) (ch-map-contents m2) @@ -4456,8 +4462,7 @@ (defmethod compose ((map1 ch-map) (map2 map) &key val-compare-fn-name) (make-ch-map (ch-map-tree-compose (ch-map-contents map1) (fn (x) (let ((val2 val2? (lookup map2 x))) - (if val2? val2 (map-default map2)))) - (val-hash-fn map1) (val-hash-fn prototype)) + (if val2? val2 (map-default map2))))) (ch-map-org prototype) (let ((new-default? new-default (lookup map2 (map-default map1)))) @@ -4475,7 +4480,7 @@ (defmethod compose ((m ch-map) (s seq) &key val-compare-fn-name) (defun ch-map-fn-compose (m fn val-compare-fn-name) (declare (type function fn)) (let ((prototype (empty-ch-map nil (key-compare-fn-name m) val-compare-fn-name))) - (make-ch-map (ch-map-tree-compose (ch-map-contents m) fn (val-hash-fn m) (val-hash-fn prototype)) + (make-ch-map (ch-map-tree-compose (ch-map-contents m) fn) (ch-map-org prototype) (funcall fn (map-default m))))) diff --git a/Code/hash.lisp b/Code/hash.lisp index 6a248d8..78ab8fa 100644 --- a/Code/hash.lisp +++ b/Code/hash.lisp @@ -20,10 +20,10 @@ (define-hash-function compare hash-value) ;;; "depthoid"). Maybe I should too. (defmethod hash-value ((x identity-equality-mixin)) - (mix-hash (sxhash (class-of x)) (slot-value x 'serial-number))) + (hash-mix (sxhash (class-of x)) (slot-value x 'serial-number))) (defmethod hash-value ((x identity-ordering-mixin)) - (mix-hash (sxhash (class-of x)) (slot-value x 'serial-number))) + (hash-mix (sxhash (class-of x)) (slot-value x 'serial-number))) (defmethod hash-value ((x real)) (sxhash x)) diff --git a/Code/port.lisp b/Code/port.lisp index e736e97..739d6a1 100644 --- a/Code/port.lisp +++ b/Code/port.lisp @@ -374,7 +374,7 @@ ;;; ---------------- -(defmacro mix-hash (&rest args) +(defmacro hash-mix (&rest args) ;; On implementations where we can reliably get fixnum addition and subtraction without ;; overflow checks at speed-3 safety-0, using them will give us better distributional properties. ;; On other implementations, we fall back to XOR. @@ -392,7 +392,7 @@ `(locally (declare (optimize (speed 3) (safety 0))) (the fixnum (logxor . ,(mapcar (fn (x) `(the fixnum ,x)) args))))) -(defmacro unmix-hash (hash &rest to-unmix) +(defmacro hash-unmix (hash &rest to-unmix) ;; As above. #+(or sbcl ccl allegro lispworks) (labels ((build (fn expr args) @@ -404,19 +404,10 @@ `(locally (declare (optimize (speed 3) (safety 0))) (the fixnum (logxor (the fixnum ,hash) . ,(mapcar (fn (x) `(the fixnum ,x)) to-unmix))))) -(defmacro multiply-hash (hash integer) - "Returns `hash' mixed with itself `integer' times." - #+(or sbcl ccl allegro lispworks) - `(locally (declare (optimize (speed 3) (safety 0))) - (the fixnum (* (the fixnum ,hash) (the fixnum ,integer)))) - #-(or sbcl ccl allegro lispworks) - `(locally (declare (optimize (speed 3) (safety 0))) - (the fixnum (* (the fixnum ,hash) (logand 1 (the fixnum ,integer)))))) - -(define-modify-macro mix-hashf (&rest args) - mix-hash) -(define-modify-macro unmix-hashf (hash &rest to-unmix) - unmix-hash) +(define-modify-macro hash-mixf (&rest args) + hash-mix) +(define-modify-macro hash-unmixf (hash &rest to-unmix) + hash-unmix) ;;; ---------------- diff --git a/Code/testing.lisp b/Code/testing.lisp index 3713ee0..be98ef9 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -85,6 +85,8 @@ (define-hash-function erapmoc hash-value-negated) (Test-List-Relations) (let ((*random-state* (make-random-state random-seed))) ; for repeatability. (dotimes (i n-iterations) + (when (zerop (mod i 10)) + (format t ".")) (Test-Map-Operations i (Test-Set-Operations i)) (Test-Bag-Operations i) (Test-Seq-Operations i) @@ -2148,10 +2150,10 @@ (define-hash-function erapmoc hash-value-negated) (setf (gethash 'b ht) 31) (test (equal? (convert 'map ht) (map ('a 17) ('b 31))))) ;; Check that our hash mixing operations do NOT check for overflow. - (test (= (mix-hash-func most-negative-fixnum most-negative-fixnum) 0)))) + (test (= (hash-mix-func most-negative-fixnum most-negative-fixnum) 0)))) -(defun mix-hash-func (a b) - (mix-hash a b)) +(defun hash-mix-func (a b) + (hash-mix a b)) (defun Test-Reader () (macrolet ((test (str form) @@ -2632,7 +2634,9 @@ (define-hash-function erapmoc hash-value-negated) (let ((r (Make-My-Integer (random 100)))) (unless (eql (lookup fm0 r) (cdr (assoc r m0 :test #'equal?))) (error "Map lookup failed (fm0) on iteration ~D: ~A, ~A, ~A" i fm0 m0 r)) - (let ((tmp (less fm0 r))) + (let ((tmp tval (less fm0 r))) + (unless (or (equal? tmp fm0) (equal? tval (@ fm0 r))) + (error "Map `less' failed to return value on iteration ~D" i)) (setq m0 (Alist-Remove m0 r)) (unless (verify tmp) (error "Map verify failed (fm0) on iteration ~D, removing ~A" i r)) @@ -3864,6 +3868,8 @@ (defmethod verify ((s ch-set)) (let ((saved-wbs nil) (saved-chs nil)) (dotimes (i n) + (when (zerop (mod i 10)) + (format t ".")) (let ((wbs (wb-set)) (chs (ch-set))) (dotimes (j 256) @@ -3969,6 +3975,8 @@ (defmethod verify ((m ch-map)) (let ((saved-wbm nil) (saved-chm nil)) (dotimes (i n) + (when (zerop (mod i 10)) + (format t ".")) (let ((wbm (wb-map)) (chm (ch-map))) (setq *champ-map-test-pairs* (seq)) @@ -4003,11 +4011,15 @@ (defmethod verify ((m ch-map)) (test (equal? (convert 'wb-set ch-dom) (domain wbm)))) (let ((idx (random (size chm))) ((elt (at-index chm idx)) - ((tmp-chm (with (less chm elt) - ;; Adding 4096 doesn't change the hash value. - (make-my-integer (+ (my-integer-value elt) 4096)) - (@ chm elt)))))) - ;; `ch-set-tree-compare' is tough to test thoroughly. This at least checks the case that is + ((chm-less-elt tval (less chm elt)) + ((tmp-chm (with chm-less-elt + ;; Adding 4096 doesn't change the hash value. + (make-my-integer (+ (my-integer-value elt) 4096)) + (@ chm elt))))))) + (test (verify chm-less-elt)) + (test (equal? tval (@ chm elt))) + (test (verify tmp-chm)) + ;; `ch-map-tree-compare' is tough to test thoroughly. This at least checks the case that is ;; least obviously correct by inspection, where all the hash values are the same but two elements ;; nonetheless differ. (test (eq (compare chm tmp-chm) ':less)) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index 142aa74..a7cb975 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -4498,7 +4498,8 @@ (defstruct (WB-Map-Tree-Node ;;; Map-less (defun WB-Map-Tree-Less (tree key key-cmp-fn) - "Returns a new tree like `tree', but with any entry for `key' removed." + "Returns a new tree like `tree', but with any entry for `key' removed. +If such an entry was found, returns the associated value as a second value." (declare (optimize (speed 3) (safety 0)) (type WB-Map-Tree tree) (type function key-cmp-fn)) @@ -4506,9 +4507,10 @@ (defstruct (WB-Map-Tree-Node ((consp tree) (let ((found? idx (Vector-Set-Binary-Search (car tree) key key-cmp-fn))) (if (eq found? ':equal) - (and (> (length (the simple-vector (car tree))) 1) - (cons (Vector-Remove-At (car tree) idx) - (Vector-Remove-At (cdr tree) idx))) + (values (and (> (length (the simple-vector (car tree))) 1) + (cons (Vector-Remove-At (car tree) idx) + (Vector-Remove-At (cdr tree) idx))) + (svref (cdr tree) idx)) tree))) (t (let ((node-key (WB-Map-Tree-Node-Key tree)) @@ -4518,27 +4520,31 @@ (defstruct (WB-Map-Tree-Node (if (not (Equivalent-Node? node-key)) (if (eq comp ':unequal) tree - (WB-Map-Tree-Join (WB-Map-Tree-Node-Left tree) - (WB-Map-Tree-Node-Right tree) key-cmp-fn)) - (let ((key val (Equivalent-Map-Less node-key key key-cmp-fn))) - (if (eq key node-key) + (values (WB-Map-Tree-Join (WB-Map-Tree-Node-Left tree) + (WB-Map-Tree-Node-Right tree) key-cmp-fn) + (WB-Map-Tree-Node-Value tree))) + (let ((less-key less-val range-val (Equivalent-Map-Less node-key key key-cmp-fn))) + (if (eq less-key node-key) tree - (WB-Map-Tree-Build-Node key val (WB-Map-Tree-Node-Left tree) - (WB-Map-Tree-Node-Right tree)))))) + (values (WB-Map-Tree-Build-Node less-key less-val (WB-Map-Tree-Node-Left tree) + (WB-Map-Tree-Node-Right tree)) + range-val))))) ((:less) (let ((left (WB-Map-Tree-Node-Left tree)) - ((new-left (WB-Map-Tree-Less left key key-cmp-fn)))) + ((new-left range-val (WB-Map-Tree-Less left key key-cmp-fn)))) (if (eq new-left left) tree - (WB-Map-Tree-Build-Node node-key (WB-Map-Tree-Node-Value tree) - new-left (WB-Map-Tree-Node-Right tree))))) + (values (WB-Map-Tree-Build-Node node-key (WB-Map-Tree-Node-Value tree) + new-left (WB-Map-Tree-Node-Right tree)) + range-val)))) ((:greater) (let ((right (WB-Map-Tree-Node-Right tree)) - ((new-right (WB-Map-Tree-Less right key key-cmp-fn)))) + ((new-right range-val (WB-Map-Tree-Less right key key-cmp-fn)))) (if (eq new-right right) tree - (WB-Map-Tree-Build-Node node-key (WB-Map-Tree-Node-Value tree) - (WB-Map-Tree-Node-Left tree) new-right))))))))) + (values (WB-Map-Tree-Build-Node node-key (WB-Map-Tree-Node-Value tree) + (WB-Map-Tree-Node-Left tree) new-right) + range-val))))))))) (defun WB-Map-Tree-Minimum-Pair (tree) @@ -5987,7 +5993,8 @@ (defstruct (WB-Map-Tree-Node (defun Equivalent-Map-Less (eqvm key key-cmp-fn) "Removes the pair associated with `key' from `eqvm', an `Equivalent-Map'. If the result is a single pair, it's returned as two values; otherwise one value -is returned, which is an `Equivalent-Map'." +is returned, which is an `Equivalent-Map'. If a pair is removed, its value is +returned as the third value." (declare (optimize (speed 3) (safety 0)) (type function key-cmp-fn)) (let ((alist (Equivalent-Node-List eqvm)) @@ -5996,8 +6003,8 @@ (defstruct (WB-Map-Tree-Node (let ((result (cl:remove pr alist))) (declare (type list result)) (if (= (length result) 1) - (values (caar result) (cdar result)) - (Make-Equivalent-Map result))) + (values (caar result) (cdar result) (cdr pr)) + (values (Make-Equivalent-Map result) nil (cdr pr)))) eqvm))) (defun Equivalent-Map-Restrict (key val set-elt key-cmp-fn) -- GitLab From 9d755e3936fa8da7601fbcf06a9cb1405eafc159 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sat, 13 Sep 2025 17:14:17 -0700 Subject: [PATCH 13/16] Comment cleanup. --- Code/champ.lisp | 21 ++------------------- 1 file changed, 2 insertions(+), 19 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index 4eeaafc..3a6c186 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -179,7 +179,7 @@ (defstruct (ch-set-node ;; Collision! Fall back to WB-tree. (cons value-hash (wb-set-tree-with (wb-set-tree-with nil ex-value compare-fn) value compare-fn)) - ;; Creates a little garbage; &&& hand-integrate later. + ;; Turn the entry into a subnode and recur. (rec (vector (ash 1 (logand ex-value-hash-shifted champ-hash-level-mask)) 0 1 ex-value-hash ex-value) hash-shifted (1+ depth)))) @@ -1156,22 +1156,6 @@ (defstruct (ch-set-node ;;; ================================================================================ ;;; Maps -#|| - -It occurs to me that with a little tweaking, we could arrange for `domain' to be O(1): - -- split the map node hash value into a key part and a value part -- move the value part of the hash, along with the values, to the region in between the keys and subnodes, - so a node looks like (key-mask subnode-mask size key-hash keys... value-hash values... ...subnodes) - (note, the key-hash and value-hash have to include resp. the key-hashes and value-hashes of the subnodes) -- for collision nodes, make them (key-hash value-hash . wb-tree) -- add another `consp' check on the cdrs of collision nodes in the set code, to deal with - the possibility of a map collision node (when building a new set node, may want to convert) - --- I have decided not to do all that. But I am still toying with separating the key hash from - the value hash. That would save rehashing in `domain'. -||# - (defstruct (ch-map-node (:type vector)) (entry-mask 0 :type fixnum) @@ -1215,7 +1199,6 @@ (defstruct (ch-map-node (svref node (- (length node) isubnode 1))) (defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0)) - ;; &&& This would benefit from returning a hash delta, as in `ch-set-tree-less'. (declare (optimize (speed 3) (safety 03)) (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (type (integer 0 64) depth)) @@ -1289,7 +1272,7 @@ (defstruct (ch-map-node (wb-map-tree-with (wb-map-tree-with nil ex-key ex-val key-cmp-fn val-cmp-fn) key value key-cmp-fn val-cmp-fn)) - ;; Creates a little garbage; &&& hand-integrate later. + ;; Turn the entry into a subnode and recur. (rec (vector (ash 1 (logand ex-key-hash-shifted champ-hash-level-mask)) 0 1 ex-key-hash nil ex-key ex-val) hash-shifted (1+ depth)))) -- GitLab From 10bd10d84fc9e76886adc892bb63b8c908865afe Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Mon, 15 Sep 2025 16:41:44 -0700 Subject: [PATCH 14/16] Hashing improvements; missing features; damn the torpedoes! --- Code/champ.lisp | 327 +++++++++++++++++++++++++++------------------- Code/fset.lisp | 58 +++++++- Code/hash.lisp | 75 +++++++++-- Code/port.lisp | 19 +++ Code/testing.lisp | 92 ++++++++----- fset.asd | 2 +- 6 files changed, 395 insertions(+), 178 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index 3a6c186..7268fad 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -42,7 +42,8 @@ (deftype champ-entry-index () `(integer 0 ,(1- champ-node-radix))) (deftype champ-subnode-index () `(integer 0 ,(1- champ-node-radix))) -(declaim (inline champ-hash-bits)) +(declaim (inline champ-hash-bits) + (ftype (function (fixnum fixnum) champ-bit-index) champ-hash-bits)) (defun champ-hash-bits (hash depth) (ldb (byte champ-hash-bits-per-level (* depth champ-hash-bits-per-level)) hash)) @@ -123,7 +124,7 @@ (defstruct (ch-set-node (t (ch-set-node-hash-value tree)))) (defun ch-set-tree-with (tree value hash-fn compare-fn &optional (depth 0)) - (declare (optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (type function hash-fn compare-fn) (type (integer 0 64) depth)) (let ((value-hash (hash-to-fixnum value hash-fn))) @@ -215,7 +216,7 @@ (defstruct (ch-set-node n))))))))))) (defun vector-rem-1-ins-1 (vec rem-idx ins-idx ins-val) - (declare ;(optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (simple-vector vec) (fixnum rem-idx ins-idx)) (assert (<= rem-idx (the fixnum (1- ins-idx)))) @@ -234,7 +235,9 @@ (defstruct (ch-set-node v)) (defun ch-set-tree-less (tree value hash-fn compare-fn &optional (depth 0)) - ;(declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0)) + (type function hash-fn compare-fn) + (type (integer 0 64) depth)) (let ((value-hash (hash-to-fixnum value hash-fn))) (declare (fixnum value-hash)) (rlabels (rec tree (ash value-hash (- (* champ-hash-bits-per-level depth)))) @@ -303,7 +306,7 @@ (defstruct (ch-set-node n))))))))))))) (defun vector-ins-1-rem-1 (vec ins-idx ins-val rem-idx) - (declare ;(optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (simple-vector vec) (fixnum ins-idx rem-idx)) (assert (<= ins-idx rem-idx)) @@ -319,6 +322,7 @@ (defstruct (ch-set-node v)) (defun ch-set-tree-arb (tree) + (declare (optimize (speed 3) (safety 0))) (cond ((null tree) (error "'ch-set-tree-arb' called on empty tree")) ((consp tree) @@ -330,7 +334,9 @@ (defstruct (ch-set-node (svref tree ch-set-node-header-size)))) (defun ch-set-tree-contains? (tree value hash-fn compare-fn &optional (depth 0)) - ;(declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0)) + (type function hash-fn compare-fn) + (type (integer 0 64) depth)) (let ((value-hash (hash-to-fixnum value hash-fn))) (declare (fixnum value-hash)) (rlabels (rec tree value (ash value-hash (- (* champ-hash-bits-per-level depth)))) @@ -353,6 +359,8 @@ (defstruct (ch-set-node (rec subnode value (ash hash-shifted (- champ-hash-bits-per-level)))))))))))))) (defun ch-set-tree-compare (tree1 tree2 compare-fn) + (declare (optimize (speed 3) (safety 0)) + (type function compare-fn)) (if (eq tree1 tree2) ':equal (let ((size1 (ch-set-tree-size tree1)) (size2 (ch-set-tree-size tree2))) @@ -404,6 +412,8 @@ (defstruct (ch-set-node default)))))))))))) (defun ch-set-tree-index (tree value hash-fn compare-fn) + (declare (optimize (speed 3) (safety 0)) + (type function hash-fn compare-fn)) (let ((value-hash (hash-to-fixnum value hash-fn))) (declare (fixnum value-hash)) (rlabels (rec tree value 0 value-hash) @@ -412,7 +422,7 @@ (defstruct (ch-set-node (and node (if (consp node) (let ((found? idx (wb-set-tree-rank (cdr node) value compare-fn))) - (and found? (+ idx base))) + (and found? (the fixnum (+ (the fixnum idx) base)))) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (entry-mask (ch-set-node-entry-mask node))) (if (logbitp hash-bits entry-mask) @@ -420,7 +430,7 @@ (defstruct (ch-set-node ((entry-idx (+ ch-set-node-header-size ientry)) ((ex-value (svref node entry-idx))))) (and (equal?-cmp ex-value value compare-fn) - (+ base ientry))) + (the fixnum (+ base ientry)))) (let ((subnode-mask (ch-set-node-subnode-mask node))) (incf base (logcount entry-mask)) (and (logbitp hash-bits subnode-mask) @@ -434,12 +444,13 @@ (defstruct (ch-set-node (ash hash-shifted (- champ-hash-bits-per-level)))))))))))))) (defun ch-set-tree-index-element (tree index) - (declare (optimize (debug 3))) + (declare (optimize (speed 3) (safety 0))) (rlabels (rec tree index) (rec (tree index) + (declare (fixnum index)) (if (consp tree) (wb-set-tree-rank-element (cdr tree) index) - (let ((len (length tree)) + (let ((len (length (the simple-vector tree))) (entry-mask (ch-set-node-entry-mask tree)) ((n-entries (logcount entry-mask)))) (if (< index n-entries) @@ -454,7 +465,7 @@ (defstruct (ch-set-node (decf index subnode-size)))))))))) (defun vector-remove-n-at (vec idx n) - (declare (optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (type simple-vector vec) (type (unsigned-byte 24) idx n)) (let ((len (length vec))) @@ -507,6 +518,7 @@ (defstruct (ch-set-node (:more? (not (ch-set-tree-iterator-done? iter))))))) (defun make-ch-set-tree-iterator-internal (tree) + (declare (optimize (speed 3) (safety 0))) ;; Unlike with the WB-trees, the maximum depth here is not a function of the set size. (let ((iter (make-array (+ 1 (* 2 (ceiling (integer-length most-positive-fixnum) champ-hash-bits-per-level)))))) (if (null tree) @@ -519,7 +531,7 @@ (defstruct (ch-set-node iter)) (defun ch-set-tree-iterator-canonicalize (iter) - (declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0))) (let ((sp (svref iter 0)) ((node (svref iter sp)) (idx (svref iter (1+ sp))))) @@ -553,11 +565,11 @@ (defstruct (ch-set-node (setf (svref iter 0) sp))) (defun ch-set-tree-iterator-done? (iter) - (declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0))) (< (the fixnum (svref iter 0)) 0)) (defun ch-set-tree-iterator-get (iter) - (declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0))) (let ((sp (svref iter 0))) (declare (fixnum sp)) (and (> sp 0) @@ -578,7 +590,7 @@ (defstruct (ch-set-node ;;; Functional iterator (defun ch-set-tree-fun-iter (tree) - (declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0))) (rlabels (walk tree (lambda (op) (ecase op (:first (values nil nil)) @@ -609,7 +621,7 @@ (defstruct (ch-set-node cont)))))))) (defun ch-set-tree-rev-fun-iter (tree) - (declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0))) (rlabels (walk tree (lambda (op) (ecase op (:first (values nil nil)) @@ -645,21 +657,21 @@ (defstruct (ch-set-node (declaim (inline ch-set-node-entry)) (defun ch-set-node-entry (n ientry) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (type simple-vector n) (type champ-entry-index ientry)) (svref n (+ ch-set-node-header-size ientry))) (declaim (inline ch-set-node-subnode)) (defun ch-set-node-subnode (n isubnode) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (type simple-vector n) (type champ-subnode-index isubnode)) (svref n (- (length n) isubnode 1))) (declaim (inline ch-set-node-add-entry)) (defun ch-set-node-add-entry (n idx val hash-fn) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function hash-fn)) (setf (svref n (+ ch-set-node-header-size (logcount (ch-set-node-entry-mask n)))) val) @@ -669,7 +681,7 @@ (defstruct (ch-set-node (declaim (inline ch-set-node-add-subnode)) (defun ch-set-node-add-subnode (n idx subnode hash-fn) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function hash-fn)) (when subnode @@ -693,7 +705,7 @@ (defstruct (ch-set-node (hash-mixf (ch-set-node-hash-value n) (ch-set-tree-hash-value subnode)))))) (defun ch-set-tree-union (tree1 tree2 hash-fn compare-fn) - (declare (optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) @@ -716,12 +728,12 @@ (defstruct (ch-set-node (vector 0 (ash 1 bits1) size chash (rec tree1 tree2 (1+ depth))) (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0))))))) - ((or (consp tree1) (consp tree2)) - (let ((normal-node collision-node (if (consp tree1) (values tree2 tree1) (values tree1 tree2)))) - ;; Garbagey, but nontrivial to improve on, AFAICS. - (do-wb-set-tree-members (x (cdr collision-node)) - (setq normal-node (ch-set-tree-with normal-node x hash-fn compare-fn depth))) - normal-node)) + ((consp tree1) + (do-wb-set-tree-members (x (cdr tree1)) + (setq tree2 (ch-set-tree-with tree2 x hash-fn compare-fn depth))) + tree2) + ((consp tree2) + (rec tree2 tree1 depth)) (t (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) @@ -776,23 +788,25 @@ (defstruct (ch-set-node res-n)))))) (defun ch-set-tree-intersection (tree1 tree2 hash-fn compare-fn) - (declare (optimize (debug 3))) + (declare (optimize (speed 3) (safety 0)) + (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) + (declare (type (integer 0 64) depth)) (cond ((or (null tree1) (null tree2)) nil) ((eq tree1 tree2) tree1) - ((and (consp tree1) (consp tree2)) - (and (= (the fixnum (car tree1)) (the fixnum (car tree2))) - (let ((result (wb-set-tree-intersect (cdr tree1) (cdr tree2) compare-fn))) - (ch-set-node-from-wb result (car tree1) depth)))) - ((or (consp tree1) (consp tree2)) - (let ((normal-node collision-node (swap-if (consp tree1) tree1 tree2)) - (result nil)) - ;; Garbagey, but nontrivial to improve on, AFAICS. - (do-wb-set-tree-members (x (cdr collision-node)) - (when (ch-set-tree-contains? normal-node x hash-fn compare-fn depth) - (setq result (ch-set-tree-with result x hash-fn compare-fn depth)))) - result)) + ((consp tree1) + (if (consp tree2) + (and (= (the fixnum (car tree1)) (the fixnum (car tree2))) + (let ((result (wb-set-tree-intersect (cdr tree1) (cdr tree2) compare-fn))) + (ch-set-node-from-wb result (car tree1) depth))) + (let ((result nil)) + (do-wb-set-tree-members (x (cdr tree1)) + (when (ch-set-tree-contains? tree2 x hash-fn compare-fn depth) + (setq result (ch-set-tree-with result x hash-fn compare-fn depth)))) + result))) + ((consp tree2) + (rec tree2 tree1 depth)) (t (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) @@ -832,8 +846,11 @@ (defstruct (ch-set-node (ch-set-compact-node res-n))))))) (defun ch-set-tree-diff (tree1 tree2 hash-fn compare-fn) + (declare (optimize (speed 3) (safety 0)) + (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) + (declare (type (integer 0 64) depth)) (cond ((null tree1) nil) ((null tree2) tree1) ((eq tree1 tree2) nil) @@ -892,9 +909,11 @@ (defstruct (ch-set-node (ch-set-compact-node res-n))))))) (defun ch-set-tree-diff-2 (tree1 tree2 hash-fn compare-fn) - (declare (optimize (debug 3))) + (declare (optimize (speed 3) (safety 0)) + (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) + (declare (type (integer 0 64) depth)) (cond ((null tree1) (values nil tree2)) ((null tree2) (values tree1 nil)) ((eq tree1 tree2) (values nil nil)) @@ -928,6 +947,7 @@ (defstruct (ch-set-node (isubnode1 0) (ientry2 0) (isubnode2 0)) + (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) (flet ((add-entry (n idx val) (ch-set-node-add-entry n idx val hash-fn)) (add-subnode (n idx subnode) @@ -971,7 +991,7 @@ (defstruct (ch-set-node (values (ch-set-compact-node res-n1) (ch-set-compact-node res-n2)))))))) (defun ch-set-node-from-wb (wb-set-tree hash depth) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (fixnum hash) (type (integer 0 64) depth)) (case (wb-set-tree-size wb-set-tree) @@ -980,7 +1000,7 @@ (defstruct (ch-set-node (t (cons hash wb-set-tree)))) (defun ch-set-compact-node (n) - (declare (optimize (speed 3))) + (declare (optimize (speed 3) (safety 0))) (let ((entries (ch-set-node-entry-mask n)) (subnodes (ch-set-node-subnode-mask n))) (and (or (/= entries 0) (/= subnodes 0)) @@ -993,18 +1013,20 @@ (defstruct (ch-set-node (vector-remove-n-at n (+ ch-set-node-header-size n-entries) extra)))))) (defun ch-set-tree-subset? (tree1 tree2 hash-fn compare-fn) - (declare (optimize (debug 3))) + (declare (optimize (speed 3) (safety 0)) + (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) + (declare (type (integer 0 64) depth)) (cond ((null tree1) t) ((null tree2) nil) ((eq tree1 tree2) t) - ((and (consp tree1) (consp tree2)) - (wb-set-tree-subset? (cdr tree1) (cdr tree2) compare-fn)) ((consp tree1) - (do-wb-set-tree-members (x (cdr tree1) t) - (unless (ch-set-tree-contains? tree2 x hash-fn compare-fn depth) - (return nil)))) + (if (consp tree2) + (wb-set-tree-subset? (cdr tree1) (cdr tree2) compare-fn) + (do-wb-set-tree-members (x (cdr tree1) t) + (unless (ch-set-tree-contains? tree2 x hash-fn compare-fn depth) + (return nil))))) ((consp tree2) (do-ch-set-tree-members (x tree1 t) (unless (wb-set-tree-contains? (cdr tree2) x compare-fn) @@ -1037,19 +1059,21 @@ (defstruct (ch-set-node (t (return nil)))))))))))) (defun ch-set-tree-disjoint? (tree1 tree2 hash-fn compare-fn) - (declare (optimize (debug 3))) + (declare (optimize (speed 3) (safety 0)) + (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) + (declare (type (integer 0 64) depth)) (cond ((or (null tree1) (null tree2)) t) ((eq tree1 tree2) nil) - ((and (consp tree1) (consp tree2)) - (wb-set-tree-disjoint? (cdr tree1) (cdr tree2) compare-fn)) - ((or (consp tree1) (consp tree2)) - (let ((collision-node normal-node (if (consp tree1) (values tree1 tree2) (values tree2 tree1)))) - (do-wb-set-tree-members (x (cdr collision-node) - t) - (when (ch-set-tree-contains? normal-node x hash-fn compare-fn depth) + ((consp tree1) + (if (consp tree2) + (wb-set-tree-disjoint? (cdr tree1) (cdr tree2) compare-fn) + (do-wb-set-tree-members (x (cdr tree1) t) + (when (ch-set-tree-contains? tree2 x hash-fn compare-fn depth) (return nil))))) + ((consp tree2) + (rec tree2 tree1 depth)) (t (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) @@ -1083,8 +1107,6 @@ (defstruct (ch-set-node ;;; Verifier (defun ch-set-tree-verify (tree hash-fn) - (declare (optimize (debug 3)) - (type function hash-fn)) (or (null tree) (rlabels (rec tree 0 0) (rec (node depth partial-hash) @@ -1178,6 +1200,7 @@ (defstruct (ch-map-node (declaim (ftype (function (ch-map-tree) fixnum) ch-map-tree-size)) (declaim (inline ch-map-tree-size)) (defun ch-map-tree-size (tree) + (declare (optimize (speed 3) (safety 0))) (cond ((null tree) 0) ((consp tree) (wb-map-tree-size (cdr tree))) @@ -1185,7 +1208,7 @@ (defstruct (ch-map-node (declaim (inline ch-map-node-entry)) (defun ch-map-node-entry (node ientry) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (type simple-vector node) (type champ-entry-index ientry)) (let ((entry-idx (+ ch-map-node-header-size (* 2 ientry)))) @@ -1193,13 +1216,13 @@ (defstruct (ch-map-node (declaim (inline ch-map-node-subnode)) (defun ch-map-node-subnode (node isubnode) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (type simple-vector node) (type champ-subnode-index isubnode)) (svref node (- (length node) isubnode 1))) (defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0)) - (declare (optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (type (integer 0 64) depth)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) @@ -1320,7 +1343,7 @@ (defstruct (ch-map-node n))))))))))) (defun vector-rem-2-ins-1 (vec rem-idx ins-idx ins-val) - (declare (optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (simple-vector vec) (fixnum rem-idx ins-idx)) (assert (<= rem-idx (the fixnum (- ins-idx 2)))) @@ -1339,7 +1362,7 @@ (defstruct (ch-map-node v)) (defun vector-insert-2 (vec idx ins-0 ins-1) - (declare (optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (simple-vector vec) (fixnum idx)) (let ((len (length vec)) @@ -1353,13 +1376,16 @@ (defstruct (ch-map-node (setf (svref v (+ idx i 2)) (svref vec (+ idx i)))) v)) +(declaim (ftype (function (ch-map-tree) fixnum) ch-map-tree-key-hash)) (defun ch-map-tree-key-hash (tree) + (declare (optimize (speed 3) (safety 0))) (cond ((null tree) 0) ((consp tree) (caar tree)) (t (ch-map-node-key-hash tree)))) +(declaim (ftype (function (ch-map-tree function) fixnum) ch-map-tree-value-hash)) (defun ch-map-tree-value-hash (tree val-hash-fn) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (type function val-hash-fn)) (cond ((null tree) 0) ((consp tree) @@ -1384,6 +1410,7 @@ (defstruct (ch-map-node vhash)))))) (defun ch-map-tree-arb-pair (tree) + (declare (optimize (speed 3) (safety 0))) (cond ((null tree) (error "'ch-map-tree-arb' called on empty tree")) ((consp tree) @@ -1395,7 +1422,7 @@ (defstruct (ch-map-node (values (svref tree ch-map-node-header-size) (svref tree (1+ ch-map-node-header-size)))))) (defun ch-map-tree-less (tree key key-hash-fn key-cmp-fn val-hash-fn &optional (depth 0)) - (declare (optimize (speed 1) (safety 03) (debug 3)) + (declare (optimize (speed 1) (safety 0)) (type function key-hash-fn key-cmp-fn val-hash-fn) (type (integer 0 64) depth)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) @@ -1483,7 +1510,7 @@ (defstruct (ch-map-node (values n lookup-val))))))))))))))) (defun vector-remove-2-at (vec idx) - (declare (optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (simple-vector vec) (fixnum idx)) (let ((len (length vec)) @@ -1497,7 +1524,7 @@ (defstruct (ch-map-node v)) (defun vector-ins-2-rem-1 (vec ins-idx ins-0 ins-1 rem-idx) - (declare (optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (simple-vector vec) (fixnum ins-idx rem-idx)) (assert (<= ins-idx rem-idx)) @@ -1516,7 +1543,7 @@ (defstruct (ch-map-node v)) (defun ch-map-tree-lookup (tree key key-hash-fn key-cmp-fn &optional (depth 0)) - (declare (optimize (speed 3) (safety 03)) + (declare (optimize (speed 3) (safety 0)) (type function key-hash-fn key-cmp-fn) (type (integer 0 64) depth)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) @@ -1543,7 +1570,8 @@ (defstruct (ch-map-node (rec subnode key (ash hash-shifted (- champ-hash-bits-per-level)))))))))))))) (defun ch-map-tree-index (tree key key-hash-fn key-cmp-fn) - (declare (optimize (debug 3))) + (declare (optimize (speed 3) (safety 0)) + (type function key-hash-fn key-cmp-fn)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) (declare (fixnum key-hash)) (rlabels (rec tree key 0 key-hash) @@ -1552,7 +1580,7 @@ (defstruct (ch-map-node (and node (if (consp node) (let ((found? idx (wb-map-tree-rank (cdr node) key key-cmp-fn))) - (and found? (+ idx base))) + (and found? (the fixnum (+ (the fixnum idx) base)))) (let ((hash-bits (logand hash-shifted champ-hash-level-mask)) (entry-mask (ch-map-node-entry-mask node))) (if (logbitp hash-bits entry-mask) @@ -1560,7 +1588,7 @@ (defstruct (ch-map-node ((entry-idx (+ ch-map-node-header-size (* 2 ientry))) ((ex-key (svref node entry-idx))))) (and (equal?-cmp ex-key key key-cmp-fn) - (+ base ientry))) + (the fixnum (+ base ientry)))) (let ((subnode-mask (ch-map-node-subnode-mask node))) (incf base (logcount entry-mask)) (and (logbitp hash-bits subnode-mask) @@ -1573,11 +1601,13 @@ (defstruct (ch-map-node (rec subnode key base (ash hash-shifted (- champ-hash-bits-per-level)))))))))))))) (defun ch-map-tree-index-pair (tree index) + (declare (optimize (speed 3) (safety 0))) (rlabels (rec tree index) (rec (tree index) + (declare (fixnum index)) (if (consp tree) (wb-map-tree-rank-pair (cdr tree) index) - (let ((len (length tree)) + (let ((len (length (the simple-vector tree))) (entry-mask (ch-map-node-entry-mask tree)) ((n-entries (logcount entry-mask)))) (if (< index n-entries) @@ -1593,6 +1623,8 @@ (defstruct (ch-map-node (decf index subnode-size)))))))))) (defun ch-map-tree-domain (tree key-hash-fn) + (declare (optimize (speed 3) (safety 0)) + (type function key-hash-fn)) (if (null tree) nil (rlabels (rec tree) (rec (node) @@ -1622,6 +1654,8 @@ (defstruct (ch-map-node n)))))) (defun ch-map-tree-compare (tree1 tree2 key-cmp-fn val-hash-fn val-cmp-fn) + (declare (optimize (speed 3) (safety 0)) + (type function key-cmp-fn val-hash-fn val-cmp-fn)) (if (eq tree1 tree2) ':equal (let ((size1 (ch-map-tree-size tree1)) (size2 (ch-map-tree-size tree2))) @@ -1722,6 +1756,7 @@ (defstruct (ch-map-node (:more? (not (ch-map-tree-iterator-done? iter))))))) (defun make-ch-map-tree-iterator-internal (tree) + (declare (optimize (speed 3) (safety 0))) (let ((iter (make-array (+ 1 (* 2 (ceiling (integer-length most-positive-fixnum) champ-hash-bits-per-level)))))) (if (null tree) (setf (svref iter 0) -1) @@ -1733,7 +1768,7 @@ (defstruct (ch-map-node iter)) (defun ch-map-tree-iterator-canonicalize (iter) - (declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0))) (let ((sp (svref iter 0)) ((node (svref iter sp)) (idx (svref iter (1+ sp))))) @@ -1768,11 +1803,11 @@ (defstruct (ch-map-node (setf (svref iter 0) sp))) (defun ch-map-tree-iterator-done? (iter) - (declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0))) (< (the fixnum (svref iter 0)) 0)) (defun ch-map-tree-iterator-get (iter) - (declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0))) (let ((sp (svref iter 0))) (declare (fixnum sp)) (and (> sp 0) @@ -1793,7 +1828,7 @@ (defstruct (ch-map-node ;;; Functional iterator (defun ch-map-tree-fun-iter (tree) - (declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0))) (rlabels (walk tree (lambda (op) (ecase op (:first (values nil nil)) @@ -1825,7 +1860,7 @@ (defstruct (ch-map-node cont)))))))) (defun ch-map-tree-rev-fun-iter (tree) - (declare (optimize (speed 3) (safety 03))) + (declare (optimize (speed 3) (safety 0))) (rlabels (walk tree (lambda (op) (ecase op (:first (values nil nil)) @@ -1862,7 +1897,7 @@ (defstruct (ch-map-node (declaim (inline ch-map-node-add-entry)) (defun ch-map-node-add-entry (n idx key val key-hash-fn) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function key-hash-fn)) (let ((entry-idx (+ ch-map-node-header-size (* 2 (logcount (ch-map-node-entry-mask n)))))) @@ -1874,7 +1909,7 @@ (defstruct (ch-map-node (declaim (inline ch-map-node-add-subnode)) (defun ch-map-node-add-subnode (n idx subnode key-hash-fn) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function key-hash-fn)) (when subnode @@ -1899,11 +1934,12 @@ (defstruct (ch-map-node (hash-mixf (ch-map-node-key-hash n) (ch-map-tree-key-hash subnode)))))) (defun ch-map-tree-union (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) - (declare (optimize (speed 3)) + (declare (optimize (speed 3) (safety 0)) (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) - (rlabels (rec tree1 tree2 0) - (rec (tree1 tree2 depth) - (declare (type (integer 0 64) depth)) + (rlabels (rec tree1 tree2 val-fn 0) + (rec (tree1 tree2 val-fn depth) + (declare (type (integer 0 64) depth) + (type function val-fn)) (cond ((null tree1) tree2) ((null tree2) tree1) ((eq tree1 tree2) tree1) @@ -1917,21 +1953,22 @@ (defstruct (ch-map-node (key-hash (hash-mix (caar tree1) (caar tree2)))) (declare (fixnum size)) (if (= bits1 bits2) - (vector 0 (ash 1 bits1) size key-hash nil (rec tree1 tree2 (1+ depth))) + (vector 0 (ash 1 bits1) size key-hash nil (rec tree1 tree2 val-fn (1+ depth))) (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size key-hash nil subnode1 subnode0)))))) ((consp tree1) (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) - (setq tree2 (ch-map-tree-with tree2 k1 (if v2? (funcall val-fn v1 v2) v1) - key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth)))) + (if v2? + (let ((new-v second-val (funcall val-fn v1 v2))) + (if (eq second-val ':no-value) + (setq tree2 (ch-map-tree-less tree2 k1 key-hash-fn key-cmp-fn val-hash-fn depth)) + (setq tree2 (ch-map-tree-with tree2 k1 new-v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn + depth)))) + (setq tree2 (ch-map-tree-with tree2 k1 v1 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))))) tree2) ((consp tree2) - (do-wb-map-tree-pairs (k2 v2 (cdr tree2)) - (let ((v1? v1 (ch-map-tree-lookup tree1 k2 key-hash-fn key-cmp-fn depth))) - (setq tree1 (ch-map-tree-with tree1 k2 (if v1? (funcall val-fn v1 v2) v2) - key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth)))) - tree1) + (rec tree2 tree1 (fn (x y) (funcall val-fn y x)) depth)) (t (let ((entries1 (ch-map-node-entry-mask tree1)) (entries2 (ch-map-node-entry-mask tree2)) @@ -1940,13 +1977,9 @@ (defstruct (ch-map-node ((all-entries (logior entries1 entries2)) (all-subnodes (logior subnodes1 subnodes2)) ((everything (logior all-entries all-subnodes)) - ;; Entry collisions can change to subnodes, but they can't then collide with existing subnodes. - ;; But we do have to subtract out entry/subnode collisions. - ((res-len (+ ch-map-node-header-size - (* 2 (- (logcount all-entries) - (logcount (logand entries1 subnodes2)) - (logcount (logand entries2 subnodes1)))) - (logcount all-subnodes))) + ;; The `:no-value' feature creates the possibility that a subnode, on one or both sides, + ;; will change to an entry; in the worst case, this could happen to all of them. + ((res-len (+ ch-map-node-header-size (* 2 (logcount everything)))) ((res-n (make-array res-len :initial-element 0)))))) (ientry1 0) (isubnode1 0) @@ -1963,34 +1996,46 @@ (defstruct (ch-map-node (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn (1+ depth))) (subtree-with (subtree key value) (ch-map-tree-with subtree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn - (1+ depth)))) + (1+ depth))) + (subtree-less (subtree key) + (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth)))) (do-bit-indices (idx everything) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1))) (key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) (if (equal?-cmp key1 key2 key-cmp-fn) - (add-entry idx key1 (funcall val-fn val1 val2)) + (let ((new-val second-val (funcall val-fn val1 val2))) + (unless (eq second-val ':no-value) + (add-entry idx key1 new-val))) (add-subnode idx (subtree-with (subtree-with nil key1 val1) key2 val2))))) ((logbitp idx entries1) (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1)))) (if (logbitp idx subnodes2) (let ((subnode2 (ch-map-node-subnode tree2 (postincf isubnode2))) ((val2? val2 (subtree-lookup subnode2 key1)))) - (add-subnode idx (subtree-with subnode2 key1 - (if val2? (funcall val-fn val1 val2) val1)))) + (if val2? + (let ((new-val second-val (funcall val-fn val1 val2))) + (if (eq second-val ':no-value) + (add-subnode idx (subtree-less subnode2 key1)) + (add-subnode idx (subtree-with subnode2 key1 new-val)))) + (add-subnode idx (subtree-with subnode2 key1 val1)))) (add-entry idx key1 val1)))) ((logbitp idx entries2) (let ((key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) (if (logbitp idx subnodes1) (let ((subnode1 (ch-map-node-subnode tree1 (postincf isubnode1))) ((val1? val1 (subtree-lookup subnode1 key2)))) - (add-subnode idx (subtree-with subnode1 key2 - (if val1? (funcall val-fn val1 val2) val2)))) + (if val1? + (let ((new-val second-val (funcall val-fn val1 val2))) + (if (eq second-val ':no-value) + (add-subnode idx (subtree-less subnode1 key2)) + (add-subnode idx (subtree-with subnode1 key2 new-val)))) + (add-subnode idx (subtree-with subnode1 key2 val2)))) (add-entry idx key2 val2)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) (add-subnode idx (rec (ch-map-node-subnode tree1 (postincf isubnode1)) (ch-map-node-subnode tree2 (postincf isubnode2)) - (1+ depth)))) + val-fn (1+ depth)))) ((logbitp idx subnodes1) (add-subnode idx (ch-map-node-subnode tree1 (postincf isubnode1)))) ((logbitp idx subnodes2) @@ -2000,25 +2045,30 @@ (defstruct (ch-map-node (ch-map-compact-node res-n))))))) (defun ch-map-tree-intersection (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) - (declare (optimize (debug 3))) - (rlabels (rec tree1 tree2 0) - (rec (tree1 tree2 depth) + (declare (optimize (speed 3) (safety 0)) + (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) + (rlabels (rec tree1 tree2 val-fn 0) + (rec (tree1 tree2 val-fn depth) + (declare (type (integer 0 64) depth) + (type function val-fn)) (cond ((or (null tree1) (null tree2)) nil) ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) - (and (= (caar tree1) (caar tree2)) + (and (= (the fixnum (caar tree1)) (the fixnum (caar tree2))) (let ((result (wb-map-tree-intersect (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) (ch-map-node-from-wb result (caar tree1) depth)))) - ((or (consp tree1) (consp tree2)) - (let ((normal-node collision-node (swap-if (consp tree1) tree1 tree2)) - (result nil)) - (do-wb-map-tree-pairs (k cv (cdr collision-node)) - (let ((nv? nv (ch-map-tree-lookup normal-node k key-hash-fn key-cmp-fn depth))) - (when nv? - (setq result (ch-map-tree-with result k (if (consp tree1) (funcall val-fn cv nv) - (funcall val-fn nv cv)) - key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))))) + ((consp tree1) + (let ((result nil)) + (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) + (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) + (when v2? + (let ((new-v second-val (funcall val-fn v1 v2))) + (unless (eq second-val ':no-value) + (setq result (ch-map-tree-with result k1 new-v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn + depth))))))) result)) + ((consp tree2) + (rec tree2 tree1 (fn (x y) (funcall val-fn y x)) depth)) (t (let ((entries1 (ch-map-node-entry-mask tree1)) (entries2 (ch-map-node-entry-mask tree2)) @@ -2041,34 +2091,43 @@ (defstruct (ch-map-node (let ((key1 val1 (ch-map-node-entry tree1 (1-bits-below idx entries1))) (key2 val2 (ch-map-node-entry tree2 (1-bits-below idx entries2)))) (when (equal?-cmp key1 key2 key-cmp-fn) - (add-entry idx key1 (funcall val-fn val1 val2))))) + (let ((new-val second-val (funcall val-fn val1 val2))) + (unless (eq second-val ':no-value) + (add-entry idx key1 new-val)))))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) (let ((key1 val1 (ch-map-node-entry tree1 (1-bits-below idx entries1))) (subnode2 (ch-map-node-subnode tree2 (1-bits-below idx subnodes2))) ((val2? val2 (subtree-lookup subnode2 key1)))) (when val2? - (add-entry idx key1 (funcall val-fn val1 val2))))) + (let ((new-val second-val (funcall val-fn val1 val2))) + (unless (eq second-val ':no-value) + (add-entry idx key1 new-val)))))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) (let ((key2 val2 (ch-map-node-entry tree2 (1-bits-below idx entries2))) (subnode1 (ch-map-node-subnode tree1 (1-bits-below idx subnodes1))) ((val1? val1 (subtree-lookup subnode1 key2)))) (when val1? - (add-entry idx key2 (funcall val-fn val1 val2))))) + (let ((new-val second-val (funcall val-fn val1 val2))) + (unless (eq second-val ':no-value) + (add-entry idx key2 new-val)))))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) (add-subnode idx (rec (ch-map-node-subnode tree1 (1-bits-below idx subnodes1)) (ch-map-node-subnode tree2 (1-bits-below idx subnodes2)) - (1+ depth)))))) + val-fn (1+ depth)))))) (ch-map-compact-node res-n)))))))) (defun ch-map-tree-diff-2 (tree1 tree2 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) + (declare (optimize (speed 3) (safety 0)) + (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) + (declare (type (integer 0 64) depth)) (cond ((null tree1) (values nil tree2)) ((null tree2) (values tree1 nil)) ((eq tree1 tree2) (values nil nil)) ((consp tree1) (if (consp tree2) - (if (= (caar tree1) (caar tree2)) + (if (= (the fixnum (caar tree1)) (the fixnum (caar tree2))) (let ((result1 result2 (wb-map-tree-diff-2 (cdr tree1) (cdr tree2) key-cmp-fn val-cmp-fn))) (values (ch-map-node-from-wb result1 (caar tree1) depth) (ch-map-node-from-wb result2 (caar tree2) depth))) @@ -2102,6 +2161,7 @@ (defstruct (ch-map-node (isubnode1 0) (ientry2 0) (isubnode2 0)) + (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) (setf (ch-map-node-value-hash res-n1) nil) (setf (ch-map-node-value-hash res-n2) nil) (flet ((add-entry (n idx key val) @@ -2154,12 +2214,14 @@ (defstruct (ch-map-node (values (ch-map-compact-node res-n1) (ch-map-compact-node res-n2)))))))) (defun ch-map-tree-restrict (map-tree set-tree key-hash-fn key-cmp-fn val-hash-fn) - (declare (optimize (debug 3))) + (declare (optimize (speed 3) (safety 0)) + (type function key-hash-fn key-cmp-fn val-hash-fn)) (rlabels (rec map-tree set-tree 0) (rec (map-tree set-tree depth) + (declare (type (integer 0 64) depth)) (cond ((or (null map-tree) (null set-tree)) nil) ((and (consp map-tree) (consp set-tree)) - (and (= (caar map-tree) (car set-tree)) + (and (= (the fixnum (caar map-tree)) (the fixnum (car set-tree))) (let ((result (wb-map-tree-restrict (cdr map-tree) (cdr set-tree) key-cmp-fn))) (ch-map-node-from-wb result (car set-tree) depth)))) ;; I figure the collision nodes are probably the smaller of the two. @@ -2220,12 +2282,14 @@ (defstruct (ch-map-node (ch-map-compact-node res-n)))))))) (defun ch-map-tree-restrict-not (map-tree set-tree key-hash-fn key-cmp-fn val-hash-fn) - (declare (optimize (debug 3))) + (declare (optimize (speed 3) (safety 0)) + (type function key-hash-fn key-cmp-fn val-hash-fn)) (rlabels (rec map-tree set-tree 0) (rec (map-tree set-tree depth) + (declare (type (integer 0 64) depth)) (cond ((or (null map-tree) (null set-tree)) nil) ((and (consp map-tree) (consp set-tree)) - (if (= (caar map-tree) (car set-tree)) + (if (= (the fixnum (caar map-tree)) (the fixnum (car set-tree))) (let ((result (wb-map-tree-restrict-not (cdr map-tree) (cdr set-tree) key-cmp-fn))) (ch-map-node-from-wb result (car set-tree) depth)) map-tree)) @@ -2282,6 +2346,7 @@ (defstruct (ch-map-node (ch-map-compact-node res-n)))))))) (defun ch-map-node-from-wb (wb-map-tree key-hash depth) + (declare (optimize (speed 3) (safety 0))) (case (wb-map-tree-size wb-map-tree) (0 nil) (1 (let ((k v (wb-map-tree-arb-pair wb-map-tree))) @@ -2290,6 +2355,7 @@ (defstruct (ch-map-node (t (cons (cons key-hash nil) wb-map-tree)))) (defun ch-map-compact-node (n) + (declare (optimize (speed 3) (safety 0))) (let ((entries (ch-map-node-entry-mask n)) (subnodes (ch-map-node-subnode-mask n))) (and (or (/= entries 0) (/= subnodes 0)) @@ -2302,7 +2368,8 @@ (defstruct (ch-map-node (vector-remove-n-at n (+ ch-map-node-header-size (* 2 n-entries)) extra)))))) (defun ch-map-tree-compose (tree fn) - (declare (type function fn)) + (declare (optimize (speed 3) (safety 0)) + (type function fn)) (cond ((null tree) nil) ((consp tree) (wb-map-tree-compose tree fn)) @@ -2324,8 +2391,6 @@ (defstruct (ch-map-node n)))) (defun ch-map-tree-verify (tree key-hash-fn val-hash-fn) - (declare (optimize (debug 3)) - (type function key-hash-fn val-hash-fn)) (or (null tree) (rlabels (rec tree 0 0) (rec (node depth partial-hash) diff --git a/Code/fset.lisp b/Code/fset.lisp index 49a3cf0..fa5c391 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -1837,6 +1837,20 @@ (define-wb-set-methods compare ((s1 wb-set) (s2 wb-set)) ;; Shouldn't be possible, since we check the symbol-package in `empty-wb-custom-set'. (error "Can't compare wb-sets with uninterned compare-fn-names with same symbol-name")))))) +(define-wb-set-methods hash-value ((s wb-set)) + ;; I expect this to be rarely used, so I don't want to make everybody pay the cost of a + ;; cache slot (I already went to a lot of trouble not to make everybody pay the cost of + ;; a compare-fn slot). So instead, I bound the number of elements to hash ... let's say 32. + (let ((result 0) + (i 0) + (mult 1)) + (do-wb-set-tree-members (x (contents s)) + (hash-mixf result (logand most-positive-fixnum (* mult (hash-value x)))) + (setq mult (logand most-positive-fixnum (* mult 13))) + (when (= (incf i) 32) + (return))) + result)) + (defgeneric internal-do-set (set elt-fn value-fn) (:documentation "Calls `elt-fn' on successive elements of the set; when done, calls `value-fn' @@ -2419,9 +2433,6 @@ (defmethod image ((fn bag) (s ch-set)) (hash-set-org-compare-fn hsorg)))) (make-ch-set result hsorg))) -(defmethod hash-value ((s ch-set)) - (ch-set-tree-hash-value (ch-set-contents s))) - (defmethod compare ((s1 ch-set) (s2 ch-set)) (if-same-ch-set-orgs (s1 s2 hsorg) (ch-set-tree-compare (ch-set-contents s1) (ch-set-contents s2) @@ -2439,6 +2450,9 @@ (defmethod compare ((s1 ch-set) (s2 ch-set)) (:unequal (error "Can't compare ch-sets with uninterned compare-fn-names with same symbol-name")))))) +(defmethod hash-value ((s ch-set)) + (ch-set-tree-hash-value (ch-set-contents s))) + (defmethod internal-do-set ((s ch-set) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) @@ -3022,6 +3036,19 @@ (defmethod compare ((b1 wb-bag) (b2 wb-bag)) (:unequal (error "Can't compare wb-bags with uninterned compare-fn-names with same symbol-name")))))) +(defmethod hash-value ((b wb-bag)) + ;; I expect this to be rarely used, so I don't want to make everybody pay the cost of a + ;; cache slot. So instead, I bound the number of elements to hash ... let's say 32. + (let ((result 0) + (i 0) + (mult 1)) + (do-wb-bag-tree-pairs (x n (wb-bag-contents b)) + (hash-mixf result (logand most-positive-fixnum (* n mult (hash-value x)))) + (setq mult (logand most-positive-fixnum (* mult 13))) + (when (= (incf i) 32) + (return))) + result)) + (defgeneric internal-do-bag-pairs (bag elt-fn value-fn) (:documentation "Calls `elt-fn' on successive pairs of the bag (the second argument is @@ -3645,6 +3672,20 @@ (defmethod compare ((map1 wb-map) (map2 wb-map)) (:unequal (error "Can't compare wb-maps with uninterned compare-fn-names with same symbol-name")))))) +(defmethod hash-value ((m wb-map)) + ;; I expect this to be rarely used, so I don't want to make everybody pay the cost of a + ;; cache slot. So instead, I bound the number of pairs to hash ... let's say 32. + (let ((result 0) + (i 0) + (mult 1)) + (do-wb-map-tree-pairs (k v (wb-map-contents m)) + (hash-mixf result (logand most-positive-fixnum (* mult (hash-value k))) + (logand most-positive-fixnum (* mult (hash-value v)))) + (setq mult (logand most-positive-fixnum (* mult 13))) + (when (= (incf i) 32) + (return))) + result)) + (defgeneric internal-do-map (map elt-fn value-fn) (:documentation "Calls `elt-fn' on successive pairs of the map (as two arguments); when done, @@ -4593,6 +4634,12 @@ (defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn- (let (#+sbcl (sb-pretty:*pprint-quote-with-syntactic-sugar* nil)) (write (list x y) :stream stream))))) +(gmap:def-gmap-arg-type ch-map (map) + "Yields each pair of `map', as two values." + `((make-ch-map-tree-iterator-internal (ch-map-contents ,map)) + #'ch-map-tree-iterator-done? + (:values 2 #'ch-map-tree-iterator-get))) + (gmap:def-gmap-res-type ch-map (&key filterp default key-compare-fn-name val-compare-fn-name) "Consumes two values from the mapped function; returns a wb-map of the pairs. Note that `filterp', if supplied, must take two arguments." @@ -4610,6 +4657,11 @@ (defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn- (,vhf-var (hash-map-org-val-hash-fn ,org-var)) (,vcf-var (hash-map-org-val-compare-fn ,org-var))))))) +(defmethod make-load-form ((m ch-map) &optional environment) + (declare (ignore environment)) + `(convert 'ch-map ',(convert 'list m) :key-compare-fn-name ',(hash-map-org-key-compare-fn-name (ch-map-org m)) + :val-compare-fn-name ',(hash-map-org-val-compare-fn-name (ch-map-org m)))) + ;;; ================================================================================ ;;; Seqs diff --git a/Code/hash.lisp b/Code/hash.lisp index 78ab8fa..8b68696 100644 --- a/Code/hash.lisp +++ b/Code/hash.lisp @@ -20,16 +20,23 @@ (define-hash-function compare hash-value) ;;; "depthoid"). Maybe I should too. (defmethod hash-value ((x identity-equality-mixin)) - (hash-mix (sxhash (class-of x)) (slot-value x 'serial-number))) + (hash-mix (class-hash-value x) (slot-value x 'serial-number))) (defmethod hash-value ((x identity-ordering-mixin)) - (hash-mix (sxhash (class-of x)) (slot-value x 'serial-number))) + (hash-mix (class-hash-value x) (slot-value x 'serial-number))) + +(defmethod hash-value ((s null)) + #32Rnil) ; = 24149. (defmethod hash-value ((x real)) (sxhash x)) (defmethod hash-value ((x integer)) - (logxor (ash x 3) x)) + ;; It's fine if `x' is negative, or a bignum. + x) + +(defmethod hash-value ((x complex)) + (sxhash x)) (defmethod hash-value ((x character)) (sxhash x)) @@ -39,28 +46,72 @@ (defmethod hash-value ((x symbol)) ;; only on SBCL is the hash of a symbol different from that of its `symbol-name'.) We _could_ mix ;; in the hash of the package, but how often does one really use symbols from multiple packages in ;; one set or map? We'll leave that problem for `compare' — it handles it well. - (sxhash x)) + (symbol-hash-value x)) (defmethod hash-value ((x string)) + ;; We could, of course, do our own string hashing (using maybe SipHash? plenty to choose from: + ;; https://en.wikipedia.org/wiki/List_of_hash_functions). But the built-in string hash should + ;; be well optimized for the implementation. Let's go with it for now. (sxhash x)) (defmethod hash-value ((x list)) - ;; &&& Needs length/depth-limiting. - (logxor (hash-value (car x)) (logand most-positive-fixnum (* 11 (hash-value (cdr x)))))) + ;; We assume that the list is longer (cdr-wise) than it is deep (car-wise). + (list-hash-value x 4 12)) + +(defun list-hash-value (ls car-depth cdr-depth) + ;; Since lists can be trees, they can have an arbitrary amount of stuff beneath them. + ;; We bound the maximum depth to keep hashing effort from becoming excessive. + (if (<= car-depth 0) + 0 + (do ((ls ls (cdr ls)) + (result 0) + (mult 1 (logand most-positive-fixnum (* mult 13))) + (cdrs 0 (1+ cdrs))) + ((or (not (consp ls)) (>= cdrs cdr-depth)) + (when (not (null ls)) + (hash-mixf result (hash-value ls))) + result) + (let ((x (car ls)) + ((x-hash (if (consp x) + (list-hash-value x (1- car-depth) (- cdr-depth 3)) + (hash-value x))))) + (hash-mixf result (logand most-positive-fixnum (* mult x-hash))))))) (defmethod hash-value ((x vector)) (if (simple-vector-p x) - (do ((result 0 (logxor result (logand most-positive-fixnum (* mult (hash-value (svref x i)))))) - (mult 1 (* mult 13)) + (do ((len (length x)) (i 0 (1+ i)) - (len (length x))) + (mult 1 (logand most-positive-fixnum (* mult 13))) + (result 0 (let ((hash (* mult (hash-value (svref x i))))) + (hash-mix result (logand most-positive-fixnum hash))))) ((= i len) result)) - (do ((result 0 (logxor result (logand most-positive-fixnum (* mult (hash-value (aref x i)))))) - (mult 1 (* mult 13)) + (do ((len (length x)) (i 0 (1+ i)) - (len (length x))) + (mult 1 (logand most-positive-fixnum (* mult 13))) + (result 0 (let ((hash (* mult (hash-value (aref x i))))) + (hash-mix result (logand most-positive-fixnum hash))))) ((= i len) result)))) +(defmethod hash-value ((x pathname)) + (sxhash x)) + +;;; Arrays (that aren't vectors) +(defmethod hash-value ((x array)) + (do ((len (array-total-size x)) + (i 0 (1+ i)) + (mult 1 (logand most-positive-fixnum (* mult 13))) + (result 0 (let ((hash (* mult (hash-value (row-major-aref x i))))) + (hash-mix result (logand most-positive-fixnum hash))))) + ((= i len) result))) + +;;; Fallback for generic sequences +(defmethod hash-value ((x sequence)) + (do ((len (length x)) + (i 0 (1+ i)) + (mult 1 (logand most-positive-fixnum (* mult 13))) + (result 0 (let ((hash (* mult (hash-value (elt x i))))) ; hush, SBCL + (hash-mix result (logand most-positive-fixnum hash))))) + ((= i len) result))) (defun zero (x) (declare (ignore x)) diff --git a/Code/port.lisp b/Code/port.lisp index 739d6a1..77f375e 100644 --- a/Code/port.lisp +++ b/Code/port.lisp @@ -409,6 +409,25 @@ (define-modify-macro hash-mixf (&rest args) (define-modify-macro hash-unmixf (hash &rest to-unmix) hash-unmix) +(declaim (inline symbol-hash-value)) +(defun symbol-hash-value (sym) + #-(or ccl allegro lispworks) + (sxhash sym) + ;; Some CLs don't cache the hash, AFAICT. So we use a plist slot. Of course, this works best if + ;; the plist is otherwise empty; but it usually is. + #+(or ccl allegro lispworks) + (or (get sym 'hash-value) + (setf (get sym 'hash-value) (sxhash sym)))) + +(declaim (inline class-hash-value)) +(defun class-hash-value (x) + #-(or ccl lispworks) + (symbol-hash-value (class-of x)) + #+ccl + (symbol-hash-value (slot-value (class-of x) 'ccl::name)) + #+lispworks + (symbol-hash-value (slot-value (class-of x) 'clos::name))) + ;;; ---------------- diff --git a/Code/testing.lisp b/Code/testing.lisp index be98ef9..b668cf0 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -2071,6 +2071,7 @@ (define-hash-function erapmoc hash-value-negated) (ch-set 19 7 'c '(eek)) (wb-bag 7 2 3 'd 2 9 4 2 7 'd) (wb-map ('a 'foo) (7 14) ('(yow) '(x y zzy))) + (ch-map ('a 'baz) (7 42) ('(yow!) '(y zzy x))) (wb-seq 21 #\q 19 'zot '(urgh) 17.2d0 'glitch) (dyn-tuple (+k0+ 27) (+k1+ 'foo) (+k2+ -21.3) (+k4+ '(fizz buzz))))) (test (equal? x (eval (make-load-form x)))))))) @@ -2130,6 +2131,10 @@ (define-hash-function erapmoc hash-value-negated) '((b . 4) (a . 3)))) (let ((m (wb-custom-map 'erapmoc nil ('a 7) ('b 42)))) (test (eq m (convert 'wb-map m :key-compare-fn-name 'erapmoc)))) + (let ((m (ch-custom-map 'erapmoc nil ('a 7) ('b 42)))) + (test (eq m (convert 'ch-map m :key-compare-fn-name 'erapmoc)))) + (let ((m (wb-map ('a 3) ('b 42)))) + (test (equal? m (gmap (:result wb-map) nil (:arg wb-map m))))) (test (equal (convert 'list (convert 'map '((a . 3) (b . 4)))) '((a . 3) (b . 4)))) (test (equal (convert 'list (convert 'wb-map '((a . 3) (b . 4)) :key-compare-fn-name 'erapmoc)) @@ -2145,13 +2150,33 @@ (define-hash-function erapmoc hash-value-negated) '((b . 4) (a . 3)))) (test (equal? (convert 'wb-map (bag 1 2 2 3)) (map (1 1) (2 2) (3 1)))) + (test (equal? (convert 'list (convert 'ch-map (wb-map (3 'a) (4 'b)))) + '((3 . a) (4 . b)))) + (test (equal? (convert 'list (convert 'ch-map (wb-map (3 'a) (4 'b)) :key-compare-fn-name 'erapmoc)) + '((4 . b) (3 . a)))) + (test (equal? (convert 'list (convert 'ch-map (seq '(3 . a) '(4 . b)))) + '((3 . a) (4 . b)))) + (test (equal? (convert 'list (convert 'ch-map (seq '(3 . a) '(4 . b)) :key-compare-fn-name 'erapmoc)) + '((4 . b) (3 . a)))) + (test (equal? (convert 'list (convert 'ch-map (list '(3 . a) '(4 . b)))) + '((3 . a) (4 . b)))) + (test (equal? (convert 'list (convert 'ch-map (list '(3 . a) '(4 . b)) :key-compare-fn-name 'erapmoc)) + '((4 . b) (3 . a)))) + (test (equal? (convert 'list (convert 'ch-map #((3 . a) (4 . b)))) + '((3 . a) (4 . b)))) + (test (equal? (convert 'list (convert 'ch-map #((3 . a) (4 . b)) :key-compare-fn-name 'erapmoc)) + '((4 . b) (3 . a)))) (let ((ht (make-hash-table))) (setf (gethash 'a ht) 17) (setf (gethash 'b ht) 31) - (test (equal? (convert 'map ht) (map ('a 17) ('b 31))))) + (test (equal? (convert 'wb-map ht) (wb-map ('a 17) ('b 31)))) + (test (equal? (convert 'ch-map ht) (ch-map ('a 17) ('b 31))))) + (let ((m (ch-map ('a 3) ('b 42)))) + (test (equal? m (gmap (:result ch-map) nil (:arg ch-map m))))) ;; Check that our hash mixing operations do NOT check for overflow. (test (= (hash-mix-func most-negative-fixnum most-negative-fixnum) 0)))) +;;; Outlined so SBCL constant propagation doesn't do the test at compile time. (defun hash-mix-func (a b) (hash-mix a b)) @@ -4043,35 +4068,40 @@ (defmethod verify ((m ch-map)) (test (funcall f-it ':empty?))) (test (equal? (reverse (convert 'seq chm)) (gmap (:result seq) #'cons (:arg fun-map chm :from-end? t))))))) - (when saved-chm - (let ((chm-union (map-union chm saved-chm))) - (test (verify chm-union)) - (let ((wbm-union (map-union wbm saved-wbm)) - ((chm-union-as-wbm (convert 'wb-map chm-union)))) - (unless (equal? chm-union-as-wbm wbm-union) - (let ((ch-only wb-only (map-difference-2 chm-union-as-wbm wbm-union))) - (error "ch-map union failed: ~A, ~A" ch-only wb-only))))) - (let ((chm-intersection (map-intersection chm saved-chm))) - (test (verify chm-intersection)) - (let ((wbm-intersection (map-intersection wbm saved-wbm)) - ((chm-int-as-wbm (convert 'wb-map chm-intersection)))) - (test (equal? chm-int-as-wbm wbm-intersection)))) - (let ((chm-diff-2a chm-diff-2b (map-difference-2 chm saved-chm)) - (wbm-diff-2a wbm-diff-2b (map-difference-2 wbm saved-wbm))) - (test (verify chm-diff-2a)) - (test (verify chm-diff-2b)) - (test (equal? (convert 'wb-map chm-diff-2a) wbm-diff-2a)) - (test (equal? (convert 'wb-map chm-diff-2b) wbm-diff-2b))) - ;; &&& `restrict' and `restrict-not' - (let ((saved-chm-dom (domain saved-chm)) - (saved-wbm-dom (domain saved-wbm)) - ((ch-pos (restrict chm saved-chm-dom)) - (ch-neg (restrict-not chm saved-chm-dom)) - (wb-pos (restrict wbm saved-wbm-dom)) - (wb-neg (restrict-not wbm saved-wbm-dom)))) - (test (verify ch-pos)) - (test (verify ch-neg)) - (test (equal? (convert 'wb-map ch-pos) wb-pos)) - (test (equal? (convert 'wb-map ch-neg) wb-neg)))) + (flet ((filter-mod-20 (x y) + (declare (ignore x)) + (if (zerop (mod y 20)) + (values nil ':no-value) + y))) + (when saved-chm + (let ((chm-union (map-union chm saved-chm #'filter-mod-20))) + (test (verify chm-union)) + (let ((wbm-union (map-union wbm saved-wbm #'filter-mod-20)) + ((chm-union-as-wbm (convert 'wb-map chm-union)))) + (unless (equal? chm-union-as-wbm wbm-union) + (let ((ch-only wb-only (map-difference-2 chm-union-as-wbm wbm-union))) + (error "ch-map union failed: ~A, ~A" ch-only wb-only))))) + (let ((chm-intersection (map-intersection chm saved-chm #'filter-mod-20))) + (test (verify chm-intersection)) + (let ((wbm-intersection (map-intersection wbm saved-wbm #'filter-mod-20)) + ((chm-int-as-wbm (convert 'wb-map chm-intersection)))) + (test (equal? chm-int-as-wbm wbm-intersection)))) + (let ((chm-diff-2a chm-diff-2b (map-difference-2 chm saved-chm)) + (wbm-diff-2a wbm-diff-2b (map-difference-2 wbm saved-wbm))) + (test (verify chm-diff-2a)) + (test (verify chm-diff-2b)) + (test (equal? (convert 'wb-map chm-diff-2a) wbm-diff-2a)) + (test (equal? (convert 'wb-map chm-diff-2b) wbm-diff-2b))) + ;; &&& `restrict' and `restrict-not' + (let ((saved-chm-dom (domain saved-chm)) + (saved-wbm-dom (domain saved-wbm)) + ((ch-pos (restrict chm saved-chm-dom)) + (ch-neg (restrict-not chm saved-chm-dom)) + (wb-pos (restrict wbm saved-wbm-dom)) + (wb-neg (restrict-not wbm saved-wbm-dom)))) + (test (verify ch-pos)) + (test (verify ch-neg)) + (test (equal? (convert 'wb-map ch-pos) wb-pos)) + (test (equal? (convert 'wb-map ch-neg) wb-neg))))) (setq saved-wbm wbm) (setq saved-chm chm)))))) diff --git a/fset.asd b/fset.asd index 5a61b44..da96bc7 100644 --- a/fset.asd +++ b/fset.asd @@ -13,7 +13,7 @@ See: https://gitlab.common-lisp.net/fset/fset/-/wikis/home " :author "Scott L. Burson " - :version "1.5.2" + :version "1.6.0" :homepage "https://gitlab.common-lisp.net/fset/fset/-/wikis/home" :source-control "https://github.com/slburson/fset" :license "BSD-2-Clause" -- GitLab From bb3760424d9e20fcdd809ff012e9b425f266f20a Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 18 Sep 2025 15:20:28 -0700 Subject: [PATCH 15/16] Finishing touches on review. - Improved 'hash-value' methods, and added some - Improved API for hashing - Tuples now use CHAMP maps internally --- Code/champ.lisp | 14 ++---- Code/complement-sets.lisp | 5 +++ Code/defs.lisp | 4 +- Code/fset.lisp | 26 ++++++++--- Code/hash.lisp | 69 +++++++++++++++++++---------- Code/iterate.lisp | 3 +- Code/macros.lisp | 6 +-- Code/port.lisp | 20 ++++++++- Code/relations.lisp | 18 ++++++++ Code/replay.lisp | 11 +++++ Code/tuples.lisp | 92 ++++++++++++++++++++++++++++----------- 11 files changed, 195 insertions(+), 73 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index 7268fad..97b4a6f 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -78,20 +78,14 @@ (push i result)))) +;;; Although we tell people that the hash function must return a fixnum, we +;;; have no way to enforce that, so just to be sure, we check the return value. +;;; A fixnum test is pretty cheap on most platforms. (defmacro hash-to-fixnum (val hash-fn) `(let ((h (funcall ,hash-fn ,val))) (if (typep h 'fixnum) h - (squash-bignum-hash h)))) - -(defun squash-bignum-hash (h) - (let ((len (integer-length h)) - (fixnum-len (integer-length most-positive-fixnum)) - (fh 0)) - (dotimes (i (ceiling len fixnum-len)) - (hash-mixf fh (ldb (byte fixnum-len (* fixnum-len i)) h))) - (if (< h 0) (- fh) fh))) -(declaim (ftype (function (t) fixnum) squash-bignum-hash)) + (the fixnum (squash-bignum-hash h))))) ;;; ================================================================================ diff --git a/Code/complement-sets.lisp b/Code/complement-sets.lisp index 2464dd7..a897b98 100644 --- a/Code/complement-sets.lisp +++ b/Code/complement-sets.lisp @@ -140,6 +140,11 @@ (defmethod compare ((cs complement-set) (s set)) (defmethod compare ((s set) (cs complement-set)) ':less) +(defmethod hash-value ((cs complement-set)) + ;; Using one's complement instead of two's, so the full set has a different hash (-1) + ;; from the empty set (0). + (logxor -1 (hash-value-fixnum (complement-set-complement cs)))) + (defmethod make-load-form ((cs complement-set) &optional environment) (declare (ignore environment)) `(complement ',(complement-set-complement cs))) diff --git a/Code/defs.lisp b/Code/defs.lisp index fa7e34c..1d5d573 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -47,7 +47,7 @@ #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:eql-compare #:define-equality-slots #:define-comparison-slots #:define-hash-function #:unwrap-equivalent-node ; custom comparison functions may have to call this - #:hash-value #:zero + #:hash-value #:hash-value-fixnum #:zero #:hash-mix #:hash-mixf #:hash-multiply #:identity-equality-mixin #:identity-ordering-mixin #:define-cross-type-compare-methods #:compare-lexicographically @@ -166,7 +166,7 @@ #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:eql-compare #:define-equality-slots #:define-comparison-slots #:define-hash-function #:unwrap-equivalent-node ; custom comparison functions may have to call this - #:hash-value #:zero + #:hash-value #:hash-value-fixnum #:zero #:hash-mix #:hash-mixf #:hash-multiply #:identity-equality-mixin #:identity-ordering-mixin #:define-cross-type-compare-methods #:compare-lexicographically diff --git a/Code/fset.lisp b/Code/fset.lisp index fa5c391..99ccc45 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -1845,8 +1845,8 @@ (define-wb-set-methods hash-value ((s wb-set)) (i 0) (mult 1)) (do-wb-set-tree-members (x (contents s)) - (hash-mixf result (logand most-positive-fixnum (* mult (hash-value x)))) - (setq mult (logand most-positive-fixnum (* mult 13))) + (hash-mixf result (hash-multiply mult (hash-value-fixnum x))) + (setq mult (hash-multiply mult 13)) (when (= (incf i) 32) (return))) result)) @@ -3043,8 +3043,8 @@ (defmethod hash-value ((b wb-bag)) (i 0) (mult 1)) (do-wb-bag-tree-pairs (x n (wb-bag-contents b)) - (hash-mixf result (logand most-positive-fixnum (* n mult (hash-value x)))) - (setq mult (logand most-positive-fixnum (* mult 13))) + (hash-mixf result (hash-multiply (hash-multiply n mult) (hash-value-fixnum x))) + (setq mult (hash-multiply mult 13)) (when (= (incf i) 32) (return))) result)) @@ -3679,9 +3679,8 @@ (defmethod hash-value ((m wb-map)) (i 0) (mult 1)) (do-wb-map-tree-pairs (k v (wb-map-contents m)) - (hash-mixf result (logand most-positive-fixnum (* mult (hash-value k))) - (logand most-positive-fixnum (* mult (hash-value v)))) - (setq mult (logand most-positive-fixnum (* mult 13))) + (hash-mixf result (hash-multiply mult (hash-mix (hash-value-fixnum k) (hash-value-fixnum v)))) + (setq mult (hash-multiply mult 13)) (when (= (incf i) 32) (return))) result)) @@ -4925,6 +4924,19 @@ (defmethod compare ((s1 wb-seq) (s2 wb-seq)) ':unequal ':equal)))))) +(defmethod hash-value ((s wb-seq)) + ;; Currently doing bounded hashing, but &&& am considering changing it to do caching + ;; with incremental update. + (let ((result 0) + (i 0) + (mult 1)) + (do-wb-seq-tree-members (x (wb-seq-contents s)) + (hash-mixf result (hash-multiply mult (hash-value-fixnum x))) + (setq mult (hash-multiply mult 13)) + (when (= (incf i) 32) + (return))) + result)) + (defmethod compare-lexicographically ((s1 wb-seq) (s2 wb-seq) &key (val-compare-fn #'compare)) (WB-Seq-Tree-Compare-Lexicographically (wb-seq-contents s1) (wb-seq-contents s2) val-compare-fn)) diff --git a/Code/hash.lisp b/Code/hash.lisp index 8b68696..8f6f6fe 100644 --- a/Code/hash.lisp +++ b/Code/hash.lisp @@ -9,15 +9,38 @@ (in-package :fset) -(defgeneric hash-value (x)) +(defgeneric hash-value (x) + (:documentation + "Returns a fixnum providing an encoding of the contents of `x'. The +result can be negative. For best performance, it is recommended to use +fixnum arithmetic and return a fixnum; however, Common Lisp gives us no +way to enforce this constraint, so callers should use `hash-value-fixnum' +instead. + +When writing methods for this generic function, in order to force fixnum +arithmetic, you may find `hash-mix', `hash-mixf', and `hash-multiply' useful. + +This generic function is used in combination with `compare', so it is +important that for any two objects on which `compare' returns `:equal' +or `:unequal', this function returns the same hash value.")) (define-hash-function compare hash-value) -;;; As of this writing, these methods are tentative. They should be gone over for performance -;;; and hash quality (well-distributed-ness) in the major Lisp implementations. +(declaim (inline hash-value-fixnum)) +(defun hash-value-fixnum (x) + "Returns the `hash-value' of `x', ensuring that the result is a fixnum." + (let ((h (hash-value x))) + (if (typep h 'fixnum) h + (the fixnum (squash-bignum-hash h))))) + +(defun squash-bignum-hash (h) + (let ((len (integer-length h)) + (fixnum-len (integer-length most-positive-fixnum)) + (fh 0)) + (dotimes (i (ceiling len fixnum-len)) + (hash-mixf fh (ldb (byte fixnum-len (* fixnum-len i)) h))) + (the fixnum (if (< h 0) (- fh) fh)))) -;;; Oh, this is interesting: SBCL limits length/depth when hashing list structure (search for -;;; "depthoid"). Maybe I should too. (defmethod hash-value ((x identity-equality-mixin)) (hash-mix (class-hash-value x) (slot-value x 'serial-number))) @@ -32,8 +55,9 @@ (defmethod hash-value ((x real)) (sxhash x)) (defmethod hash-value ((x integer)) - ;; It's fine if `x' is negative, or a bignum. - x) + ;; It's fine if `x' is negative. + (if (typep x 'fixnum) x + (squash-bignum-hash x))) (defmethod hash-value ((x complex)) (sxhash x)) @@ -65,31 +89,30 @@ (defmethod hash-value ((x list)) 0 (do ((ls ls (cdr ls)) (result 0) - (mult 1 (logand most-positive-fixnum (* mult 13))) + (mult 1 (hash-multiply mult 13)) (cdrs 0 (1+ cdrs))) ((or (not (consp ls)) (>= cdrs cdr-depth)) (when (not (null ls)) - (hash-mixf result (hash-value ls))) + (hash-mixf result (hash-value-fixnum ls))) ; defensive squashing result) (let ((x (car ls)) ((x-hash (if (consp x) (list-hash-value x (1- car-depth) (- cdr-depth 3)) - (hash-value x))))) - (hash-mixf result (logand most-positive-fixnum (* mult x-hash))))))) + (hash-value-fixnum x))))) + (hash-mixf result (hash-multiply mult x-hash)))))) (defmethod hash-value ((x vector)) + (declare #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) (if (simple-vector-p x) (do ((len (length x)) (i 0 (1+ i)) - (mult 1 (logand most-positive-fixnum (* mult 13))) - (result 0 (let ((hash (* mult (hash-value (svref x i))))) - (hash-mix result (logand most-positive-fixnum hash))))) + (mult 1 (hash-multiply mult 13)) + (result 0 (hash-mix result (hash-multiply mult (hash-value-fixnum (svref x i)))))) ((= i len) result)) (do ((len (length x)) (i 0 (1+ i)) - (mult 1 (logand most-positive-fixnum (* mult 13))) - (result 0 (let ((hash (* mult (hash-value (aref x i))))) - (hash-mix result (logand most-positive-fixnum hash))))) + (mult 1 (hash-multiply mult 13)) + (result 0 (hash-mix result (hash-multiply mult (hash-value-fixnum (aref x i)))))) ((= i len) result)))) (defmethod hash-value ((x pathname)) @@ -97,20 +120,20 @@ (defmethod hash-value ((x pathname)) ;;; Arrays (that aren't vectors) (defmethod hash-value ((x array)) + (declare #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) (do ((len (array-total-size x)) (i 0 (1+ i)) - (mult 1 (logand most-positive-fixnum (* mult 13))) - (result 0 (let ((hash (* mult (hash-value (row-major-aref x i))))) - (hash-mix result (logand most-positive-fixnum hash))))) + (mult 1 (hash-multiply mult 13)) + (result 0 (hash-mix result (hash-multiply mult (hash-value-fixnum (row-major-aref x i)))))) ((= i len) result))) ;;; Fallback for generic sequences (defmethod hash-value ((x sequence)) + (declare #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) (do ((len (length x)) (i 0 (1+ i)) - (mult 1 (logand most-positive-fixnum (* mult 13))) - (result 0 (let ((hash (* mult (hash-value (elt x i))))) ; hush, SBCL - (hash-mix result (logand most-positive-fixnum hash))))) + (mult 1 (hash-multiply mult 13)) + (result 0 (hash-mix result (hash-multiply mult (hash-value-fixnum (elt x i)))))) ((= i len) result))) (defun zero (x) diff --git a/Code/iterate.lisp b/Code/iterate.lisp index e8e4f2c..ccb8317 100644 --- a/Code/iterate.lisp +++ b/Code/iterate.lisp @@ -162,7 +162,6 @@ (make-accum-var-binding var-spec init-val nil :type nil) (return-code :body `((setq ,var ,op-expr))))) -;;; The arrow (or some keyword, anyway) is required by Iterate. Be glad I didn't use Unicode `→' :-) (defclause (collect-map key*val &optional initial-value init-val into var-spec) "Collects key/value pairs into a map, by default a `wb-map' ordered by `compare'. Use `initial-value' to construct a different kind of map. @@ -179,7 +178,7 @@ (defclause (collect-map-to-sets key*val &optional initial-value init-val into var-spec) "Collects key/value pairs into a map, collecting values for each key into a set. `key*val' must be a list of two expressions, for key and value. By -default, the result a `wb-map' ordered by `compare', and the value sets are +default, the result is a `wb-map' ordered by `compare', and the value sets are `wb-sets' ordered by `compare'. Use `initial-value' to construct a different kind of map; the map's default must be a set \(or bag\)." (unless (and (listp key*val) (= (length key*val) 2)) diff --git a/Code/macros.lisp b/Code/macros.lisp index ae32ff0..f145b04 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -267,11 +267,11 @@ (defmethod hash-value ((x ,class)) (error "At least one slot/accessor must be supplied")) (let ((x-var (gensymx #:x-))) (rlabels `(let ((,x-var ,obj)) - ,(rec `(hash-value ,(call (car slots/accessors) x-var)) (cdr slots/accessors))) + ,(rec `(hash-value-fixnum ,(call (car slots/accessors) x-var)) (cdr slots/accessors))) (rec (value accs) (if (null accs) value - (rec `(logxor (logand most-positive-fixnum (* 17 ,value)) - (hash-value ,(call (car accs) x-var))) + (rec `(hash-mix (hash-multiply 17 ,value) + (hash-value-fixnum ,(call (car accs) x-var))) (cdr accs)))) (call (fn arg) ;; Makes the expansion more readable, if nothing else diff --git a/Code/port.lisp b/Code/port.lisp index 77f375e..3010b3e 100644 --- a/Code/port.lisp +++ b/Code/port.lisp @@ -374,7 +374,11 @@ ;;; ---------------- +;;; These are macros because Allegro (still!) doesn't inline user functions. (defmacro hash-mix (&rest args) + "Returns the \"mix\" of the values, where \"mix\" is a commutative and +associative operation with an inverse. All values MUST be fixnums; the +result is a fixnum." ;; On implementations where we can reliably get fixnum addition and subtraction without ;; overflow checks at speed-3 safety-0, using them will give us better distributional properties. ;; On other implementations, we fall back to XOR. @@ -393,6 +397,8 @@ (the fixnum (logxor . ,(mapcar (fn (x) `(the fixnum ,x)) args))))) (defmacro hash-unmix (hash &rest to-unmix) + "Returns the result of \"unmixing\" each of `to-unmix' from `hash'. All +values MUST be fixnums; the result is a fixnum." ;; As above. #+(or sbcl ccl allegro lispworks) (labels ((build (fn expr args) @@ -404,6 +410,18 @@ `(locally (declare (optimize (speed 3) (safety 0))) (the fixnum (logxor (the fixnum ,hash) . ,(mapcar (fn (x) `(the fixnum ,x)) to-unmix))))) +(defmacro hash-multiply (ha hb) + "Returns the product of `ha' and `hb' modulo 2^fixnum_length. Both MUST be +fixnums; the result is a fixnum." + #+(or sbcl ccl allegro lispworks) + `(locally (declare (optimize (speed 3) (safety 0))) + (the fixnum (* (the fixnum ,ha) (the fixnum ,hb)))) + #-(or sbcl ccl allegro lispworks) + `(locally (declare (optimize (speed 3) (safety 0))) + (let ((prod (* (the fixnum ,ha) (the fixnum ,hb))) + ((fprod (the fixnum (logand most-positive-fixnum prod))))) + (if (< prod 0) (- fprod) fprod)))) + (define-modify-macro hash-mixf (&rest args) hash-mix) (define-modify-macro hash-unmixf (hash &rest to-unmix) @@ -422,7 +440,7 @@ (define-modify-macro hash-unmixf (hash &rest to-unmix) (declaim (inline class-hash-value)) (defun class-hash-value (x) #-(or ccl lispworks) - (symbol-hash-value (class-of x)) + (sxhash (class-of x)) #+ccl (symbol-hash-value (slot-value (class-of x) 'ccl::name)) #+lispworks diff --git a/Code/relations.lisp b/Code/relations.lisp index 03a9890..1561a8e 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -540,6 +540,24 @@ (defmethod compare ((a wb-2-relation) (b wb-2-relation)) (WB-Map-Tree-Compare (wb-2-relation-map0 a) (wb-2-relation-map0 b) #'compare (fn (a b) (WB-Set-Tree-Compare a b #'compare))))))) +(defmethod hash-value ((rel wb-2-relation)) + ;; As with the other WB types, we do bounded-effort hashing without caching. + (let ((result 0) + (i 0) + (mult 1)) + (Do-WB-Map-Tree-Pairs (x ys (wb-2-relation-map0 rel)) + (hash-mixf result (hash-multiply mult (hash-value-fixnum x))) + (setq mult (hash-multiply mult 13)) + (let ((j 0)) + (Do-WB-Set-Tree-Members (y ys) + (hash-mixf result (hash-multiply mult (hash-value-fixnum y))) + (setq mult (hash-multiply mult 3)) + (when (= (incf j) 8) + (return)))) + (when (= (incf i) 8) + (return))) + result)) + (defgeneric transitive-closure (2-relation set) (:documentation diff --git a/Code/replay.lisp b/Code/replay.lisp index 7249217..d1c0001 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -155,6 +155,17 @@ (defmethod compare ((set1 wb-replay-set) (set2 wb-replay-set)) ':equal))))) (call-next-method)))) +(defmethod hash-value ((rs wb-replay-set)) + (let ((result 0) + (i 0) + (mult 1)) + (do-wb-seq-tree-members (x (wb-replay-set-ordering rs)) + (hash-mixf result (hash-multiply mult (hash-value-fixnum x))) + (setq mult (hash-multiply mult 13)) + (when (= (incf i) 32) + (return))) + result)) + (defmethod convert ((to-type (eql 'list)) (s wb-replay-set) &key) (convert 'list (convert 'seq s))) (defmethod convert ((to-type (eql 'vector)) (s wb-replay-set) &key) diff --git a/Code/tuples.lisp b/Code/tuples.lisp index f15e5dc..c53581c 100644 --- a/Code/tuples.lisp +++ b/Code/tuples.lisp @@ -102,7 +102,7 @@ (defstruct (dyn-tuple (:include tuple) - (:constructor make-dyn-tuple (descriptor contents)) + (:constructor make-dyn-tuple (descriptor contents &optional hash-value)) (:predicate dyn-tuple?) (:print-function print-dyn-tuple) (:copier nil)) @@ -111,7 +111,9 @@ (defstruct (dyn-tuple ;; A `Tuple-Desc'. (descriptor nil :read-only t) ;; A vector of value chunks (vectors) (all these vectors being simple). - (contents nil :read-only t)) + (contents nil :read-only t) + ;; If nonnull, the cumulative `hash-value' of the keys and values. + (hash-value nil :type (or null fixnum))) (defstruct (tuple-key @@ -177,13 +179,24 @@ (defstruct (tuple-key (declare (ignore level)) (format stream "#" (tuple-key-name key))) -(defmethod compare ((key1 tuple-key) (key2 tuple-key)) - ;(compare (tuple-key-number key1) (tuple-key-number key2)) inlined... +(declaim (inline key-compare)) +(defun key-compare (key1 key2) (let ((n1 (tuple-key-number key1)) (n2 (tuple-key-number key2))) (cond ((< n1 n2) ':less) ((> n1 n2) ':greater) (t ':equal)))) +(defmethod compare ((key1 tuple-key) (key2 tuple-key)) + (key-compare key1 key2)) + +(declaim (inline key-hash-value)) +(defun key-hash-value (key) + (1+ (tuple-key-number key))) + +(defmethod hash-value ((key tuple-key)) + (key-hash-value key)) + +(define-hash-function key-compare key-hash-value) (defconstant Tuple-Value-Chunk-Bits 4) @@ -192,7 +205,7 @@ (defmethod compare ((key1 tuple-key) (key2 tuple-key)) (defstruct (Tuple-Desc (:constructor Make-Tuple-Desc-Internal (Key-Set Pairs Lock Serial-Number))) - ;; The set (as an FSet set) of `tuple-key's for which tuples using this index + ;; The set (as an FSet ch-set) of `tuple-key's for which tuples using this index ;; contain values. (Key-Set nil :read-only t) ;; The pair vector, which contains two copies of the pair sequence, each pair @@ -205,10 +218,10 @@ (defstruct (Tuple-Desc ;; reorder map is a list with one element for each chunk in the target; that ;; element is `nil' if the chunk is unchanged, else it is a vector of indices ;; into the source tuple (where an index of `nil' indicates an insertion). (mutable) - (Reorder-Map-Map (empty-map)) + (Reorder-Map-Map (empty-ch-map nil 'Tuple-Desc-Compare 'eql-compare)) ;; Cache used by `Tuple-With': for each key not in this descriptor but that has been ;; added to tuples with this descriptor, the descriptor for the new tuple. (mutable) - (Next-Desc-Map (empty-map)) + (Next-Desc-Map (empty-ch-map nil 'key-compare 'eql-compare)) ;; Serial number (used for `Reorder-Map-Map'). (Serial-Number 0 :type fixnum :read-only t)) @@ -222,15 +235,26 @@ (defstruct (Tuple-Desc (prog1 +Tuple-Desc-Next-Serial-Number+ (incf +Tuple-Desc-Next-Serial-Number+))))) -(deflex +Tuple-Descriptor-Map+ (empty-map)) +(deflex +Tuple-Descriptor-Map+ (empty-ch-map)) -(defmethod compare ((x Tuple-Desc) (y Tuple-Desc)) +(declaim (inline tuple-desc-compare)) +(defun tuple-desc-compare (x y) (if (eq x y) ':equal (let ((xser (Tuple-Desc-Serial-Number x)) (yser (Tuple-Desc-Serial-Number y))) (cond ((< xser yser) ':less) ((> xser yser) ':greater) (t ':equal))))) +(defmethod compare ((x Tuple-Desc) (y Tuple-Desc)) + (tuple-desc-compare x y)) + +(declaim (inline tuple-desc-hash-value)) +(defun tuple-desc-hash-value (td) + (Tuple-Desc-Serial-Number td)) +(defmethod hash-value ((td Tuple-Desc)) + (Tuple-Desc-Hash-Value td)) + +(define-hash-function tuple-desc-compare tuple-desc-hash-value) ;;; Urgh, Allegro 6 doesn't obey inline declarations, so we use a macro for this. ;;; This takes its argument doubled for the convenience of the common case (lookup). @@ -256,10 +280,10 @@ (defmethod domain ((tup dyn-tuple)) (defun empty-dyn-tuple () "Returns an empty dyn-tuple." - (let ((desc (lookup +Tuple-Descriptor-Map+ (empty-map)))) + (let ((desc (lookup +Tuple-Descriptor-Map+ (empty-ch-set)))) (unless desc - (setq desc (Make-Tuple-Desc (empty-set) (vector))) - (setf (lookup +Tuple-Descriptor-Map+ (empty-map)) desc)) + (setq desc (Make-Tuple-Desc (empty-ch-set) (vector))) + (setf (lookup +Tuple-Descriptor-Map+ (empty-ch-set)) desc)) (make-dyn-tuple desc (vector)))) (deflex +Tuple-Random-Value+ 0 @@ -375,13 +399,19 @@ (defmethod domain ((tup dyn-tuple)) (simple-vector pairs contents chunk)) (dotimes (i (length chunk)) (setf (svref new-chunk i) (svref chunk i))) - (setf (svref new-chunk val-idx) val) - (if single-chunk? (make-dyn-tuple desc new-chunk) - (progn - (dotimes (i (length contents)) - (setf (svref new-contents i) (svref contents i))) - (setf (svref new-contents ichunk) new-chunk) - (make-dyn-tuple desc new-contents))))) + (let ((prev-hash (dyn-tuple-hash-value tuple)) + ((new-hash (and prev-hash + (let ((prev-val (svref new-chunk val-idx))) + (hash-mix prev-hash + (hash-unmix (hash-value-fixnum val) + (hash-value-fixnum prev-val)))))))) + (setf (svref new-chunk val-idx) val) + (if single-chunk? (make-dyn-tuple desc new-chunk) + (progn + (dotimes (i (length contents)) + (setf (svref new-contents i) (svref contents i))) + (setf (svref new-contents ichunk) new-chunk) + (make-dyn-tuple desc new-contents new-hash)))))) (let ((old-desc (dyn-tuple-descriptor tuple))) (unless (< (the fixnum (size (Tuple-Desc-Key-Set old-desc))) (1- (ash 1 Tuple-Value-Index-Size))) @@ -453,9 +483,12 @@ (defmethod domain ((tup dyn-tuple)) (reorder-map reorder-map (cdr reorder-map)) (new-chunks nil)) ((<= n 0) - (if (cdr new-chunks) - (make-dyn-tuple new-desc (coerce (nreverse new-chunks) 'vector)) - (make-dyn-tuple new-desc (car new-chunks)))) + (let ((prev-hash (dyn-tuple-hash-value tuple)) + ((new-hash (and prev-hash (hash-mix prev-hash (key-hash-value key) + (hash-value-fixnum val)))))) + (if (cdr new-chunks) + (make-dyn-tuple new-desc (coerce (nreverse new-chunks) 'vector) new-hash) + (make-dyn-tuple new-desc (car new-chunks) new-hash)))) (declare (fixnum i n)) (if (null (car reorder-map)) (push (if (<= (1- nkeys) Tuple-Value-Chunk-Size) old-chunks @@ -521,8 +554,8 @@ (defmethod domain ((tup dyn-tuple)) #'(lambda (,key-var ,value-var) . ,body) #'(lambda () ,value)))) -(defmacro Do-Tuple-Internal ((key-var value-var tuple-form &optional value-form) - &body body) +(defmacro Do-Tuple-Pairs ((key-var value-var tuple-form &optional value-form) + &body body) (let ((tuple-var (gensymx #:tuple-)) (desc-var (gensymx #:desc-)) (contents-var (gensymx #:contents-)) @@ -551,7 +584,7 @@ (defmethod domain ((tup dyn-tuple)) (defmethod internal-do-tuple ((tup tuple) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) - (Do-Tuple-Internal (x y tup (funcall value-fn)) + (Do-Tuple-Pairs (x y tup (funcall value-fn)) (funcall elt-fn x y))) (defun print-dyn-tuple (tuple stream level) @@ -594,6 +627,15 @@ (defmethod compare ((tup1 tuple) (tup2 tuple)) (when (eq res ':unequal) (setq default ':unequal)))))))) +(defmethod hash-value ((tup tuple)) + (or (dyn-tuple-hash-value tup) + (let ((hash 0) + (mult 1)) + (Do-Tuple-Pairs (k v tup) + (hash-mixf hash (hash-multiply mult (hash-mix (key-hash-value k) (hash-value-fixnum v)))) + (setf mult (hash-multiply mult 13))) + (setf (dyn-tuple-hash-value tup) hash)))) + (defmethod with ((tuple tuple) (key tuple-key) &optional (value nil value?)) (check-three-arguments value? 'with 'tuple) -- GitLab From ba8c746502851029f730523ac19553604d1d5027 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 18 Sep 2025 16:30:08 -0700 Subject: [PATCH 16/16] Fix ECL support. --- Code/port.lisp | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/Code/port.lisp b/Code/port.lisp index 3010b3e..6bcabad 100644 --- a/Code/port.lisp +++ b/Code/port.lisp @@ -201,7 +201,7 @@ #+(and ecl threads) (progn (defun make-lock (&optional name) - (apply #'mp:make-lock (and name `(:name ,name)))) + (apply #'mp:make-lock :recursive t (and name `(:name ,name)))) (defmacro with-lock ((lock &key (wait? t)) &body body) (let ((lock-var (gensym "LOCK-")) (wait?-var (gensym "WAIT?-")) @@ -309,17 +309,15 @@ ;;; two bitfields to fit in a fixnum less the sign bit. ;;; These numbers are noncritical except possibly for small fixnums. -;;; Fixnum widths of known implementations: +;;; Fixnum widths of known implementations, exclusive of sign bit: ;;; SBCL >= 1.0.53, 64-bit: 62 ;;; ECL, 64-bit: 61 ;;; SBCL < 1.0.53, OpenMCL/Clozure CL, -;;; Scieneer CL, 64-bit 60 -;;; CLISP, 64-bit 48 -;;; Symbolics L-, I-machine; ABCL 31 +;;; Scieneer CL, Allegro, 64-bit: 60 +;;; Symbolics L-, I-machine; ABCL: 31 ;;; Allegro, CMUCL, SBCL, ECL -;;; LispWorks (most), 32-bit 29 -;;; CLISP, 32-bit; CADR, LMI Lambda 24 -;;; LispWorks 4 on Linux 23 +;;; LispWorks (most), 32-bit: 29 +;;; CADR, LMI Lambda: 24 (defconstant Tuple-Value-Index-Size (floor (+ 5 (integer-length most-positive-fixnum)) 3) -- GitLab