| 1 | ;;;-*- Mode: Lisp; Package: WOOD -*-
|
|---|
| 2 |
|
|---|
| 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 4 | ;;;
|
|---|
| 5 | ;;; btrees.lisp
|
|---|
| 6 | ;;; B* trees with variable length keys for pheaps.
|
|---|
| 7 | ;;;
|
|---|
| 8 | ;;; Copyright © 1996-1997 Digitool, Inc.
|
|---|
| 9 | ;;; Copyright © 1992-1995 Apple Computer, Inc.
|
|---|
| 10 | ;;; All rights reserved.
|
|---|
| 11 | ;;; Permission is given to use, copy, and modify this software provided
|
|---|
| 12 | ;;; that Digitool is given credit in all derivative works.
|
|---|
| 13 | ;;; This software is provided "as is". Digitool makes no warranty or
|
|---|
| 14 | ;;; representation, either express or implied, with respect to this software,
|
|---|
| 15 | ;;; its quality, accuracy, merchantability, or fitness for a particular
|
|---|
| 16 | ;;; purpose.
|
|---|
| 17 | ;;;
|
|---|
| 18 |
|
|---|
| 19 | ;;; Key size is limited to 127 bytes with longer keys
|
|---|
| 20 | ;;; being stored as strings (and requiring an extra disk access).
|
|---|
| 21 | ;;; (longer strings are not yet implemented).
|
|---|
| 22 |
|
|---|
| 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 24 | ;;;
|
|---|
| 25 | ;;; Modification History
|
|---|
| 26 | ;;;
|
|---|
| 27 | ;;; 03/26/97 bill check-btree-consistency avoids divide by zero errors.
|
|---|
| 28 | ;;; ------------- 0.96
|
|---|
| 29 | ;;; 08/27/96 bill Wrap an eval-when around the definition of *enable-debug-break* as
|
|---|
| 30 | ;;; suggested by Rainer Joswig.
|
|---|
| 31 | ;;; ------------- 0.95
|
|---|
| 32 | ;;; 05/13/96 bill mis-parenthesization of compare-string in %btree-search-node
|
|---|
| 33 | ;;; ------------- 0.94 = MCL-PPC 3.9
|
|---|
| 34 | ;;; 03/26/96 bill Don't use %schar in %btree-search-node, MCL-PPC type checks it.
|
|---|
| 35 | ;;; 03/21/96 bill Specify element-type of base-character to make-string calls
|
|---|
| 36 | ;;; Add an optional swap-space-in-k arg to time-btree-store & time-btree-read
|
|---|
| 37 | ;;; ------------- 0.93
|
|---|
| 38 | ;;; 08/10/95 bill p-do-btree macro is to a btree what dolist is to a list.
|
|---|
| 39 | ;;; 07/02/95 bill Fix fencepost in computation of fill-count in %shift-node-left
|
|---|
| 40 | ;;; Thanks to Horace Enea for providing the test case to track down this bug.
|
|---|
| 41 | ;;; 05/25/95 bill New parameter: *max-btree-node-size*.
|
|---|
| 42 | ;;; dc-cons-btree-node calls dc-allocate-new-btree-node instead of
|
|---|
| 43 | ;;; %dc-allocate-new-memory.
|
|---|
| 44 | ;;; New function: dc-allocate-new-btree-node, calls %dc-allocate-new-memory
|
|---|
| 45 | ;;; as before if the page size is <= *max-btree-node-size*. Otherwise, carves
|
|---|
| 46 | ;;; up a disk page into *max-btree-node-size* nodes, returns one of them, and
|
|---|
| 47 | ;;; adds the rest to the btree node free list.
|
|---|
| 48 | ;;; 04/11/95 bill new function: p-map-btree-keystrings.
|
|---|
| 49 | ;;; dc-map-btree uses compare-strings-function instead of string<
|
|---|
| 50 | ;;; for comparing with the TO arg.
|
|---|
| 51 | ;;; ------------- 0.9
|
|---|
| 52 | ;;; 02/06/95 bill Moon's idea to add binary search to %btree-search-node without
|
|---|
| 53 | ;;; changing the disk representation. That and doing the comparisons
|
|---|
| 54 | ;;; inline got speed improvement of a factor of 2.7 over the old linear
|
|---|
| 55 | ;;; search code.
|
|---|
| 56 | ;;; 12/16/94 bill Complete rewrite of the low-level insertion code.
|
|---|
| 57 | ;;; This fixes a bug found by Paul.Meurer@mi.uib.no and
|
|---|
| 58 | ;;; will make much easier the addition of binary search for nodes.
|
|---|
| 59 | ;;; 10/28/94 Moon Change without-interrupts to with-databases-locked.
|
|---|
| 60 | ;;; 10/25/94 bill (setf (p-btree-store ...) x) now returns x instead of its pptr.
|
|---|
| 61 | ;;; 09/21/94 bill without-interrupts as necessary for interlocking
|
|---|
| 62 | ;;; ------------- 0.8
|
|---|
| 63 | ;;; 07/31/93 bill %btree-insert-in-inner-node now goes out of line to
|
|---|
| 64 | ;;; %attempt-to-shift-left-inner-node & %attempt-to-shift-right-inner-node.
|
|---|
| 65 | ;;; %attempt-to-shift-right-inner-node is new code. I thought
|
|---|
| 66 | ;;; that I could get away with leaving it out, but I was wrong.
|
|---|
| 67 | ;;; 03/29/93 bill *forwarded-btree* in btree-find-leaf-node & dc-map-btree
|
|---|
| 68 | ;;; 03/25/93 bill %btree-split-inner-node - wrong page on one of the accessing-byte-array's
|
|---|
| 69 | ;;; Also, neglected to update last-middle-size when the parent entry went at the
|
|---|
| 70 | ;;; end of the new middle node. In this case, some of the copying was also extraneous.
|
|---|
| 71 | ;;; -------------- 0.6
|
|---|
| 72 | ;;; -------------- 0.5
|
|---|
| 73 | ;;; 07/28/92 bill make p-map-btree deal correctly with insertion or
|
|---|
| 74 | ;;; deletion while mapping.
|
|---|
| 75 | ;;; 07/27/92 bill p-clear-btree, p-map-btree
|
|---|
| 76 | ;;; 06/30/92 bill little bug in %split-btree-root
|
|---|
| 77 | ;;; 06/26/92 bill btree vector indices defs -> woodequ
|
|---|
| 78 | ;;; 06/23/92 bill Don't ignore type in p-make-btree
|
|---|
| 79 | ;;; -------------- 0.1
|
|---|
| 80 | ;;;
|
|---|
| 81 |
|
|---|
| 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 83 | ;;;
|
|---|
| 84 | ;;; To do:
|
|---|
| 85 | ;;;
|
|---|
| 86 | ;;; 1) Maybe.
|
|---|
| 87 | ;;; Replace the $btree_parent slot with $btree_mod-count for locking use.
|
|---|
| 88 | ;;; Updating parents at shift or split time is too expensive.
|
|---|
| 89 | ;;; Instead, pass around an ancestors list (stack-consed).
|
|---|
| 90 | ;;;
|
|---|
| 91 | ;;; 2) Implement keys longer than 127 bytes.
|
|---|
| 92 |
|
|---|
| 93 | (in-package :wood)
|
|---|
| 94 |
|
|---|
| 95 | (export '(p-make-btree p-make-string-equal-btree
|
|---|
| 96 | p-btree-lookup p-btree-store p-btree-delete
|
|---|
| 97 | dc-make-btree dc-btree-lookup dc-btree-store dc-btree-delete))
|
|---|
| 98 |
|
|---|
| 99 | ;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 100 | ;;;
|
|---|
| 101 | ;;; btree vector - subtype $v_btree
|
|---|
| 102 | ;;;
|
|---|
| 103 | ;;; This code belongs in woodequ.lisp
|
|---|
| 104 | ;;;
|
|---|
| 105 |
|
|---|
| 106 | ; So this will work as a patch file
|
|---|
| 107 | (eval-when (:compile-toplevel :execute :load-toplevel)
|
|---|
| 108 |
|
|---|
| 109 | (unless (boundp '$btree.max-key-size)
|
|---|
| 110 |
|
|---|
| 111 | (makunbound '$btree-size)
|
|---|
| 112 |
|
|---|
| 113 | ; Defined here so that this file can be distributed as a patch
|
|---|
| 114 | ; Real definition is in "woodequ.lisp"
|
|---|
| 115 | (def-indices
|
|---|
| 116 | $btree.root ; the root node
|
|---|
| 117 | $btree.count ; number of leaf entries
|
|---|
| 118 | $btree.depth ; 0 means only the root exists
|
|---|
| 119 | $btree.nodes ; total number of nodes
|
|---|
| 120 | $btree.first-leaf ; first leaf node. A constant
|
|---|
| 121 | $btree.type ; type bits
|
|---|
| 122 | $btree.max-key-size ; maximum size of a key
|
|---|
| 123 | $btree-size ; length of a $v_btree vector
|
|---|
| 124 | )
|
|---|
| 125 |
|
|---|
| 126 | )) ; End unless & compile-when
|
|---|
| 127 |
|
|---|
| 128 | ; This file is being distributed before the with-databases-locked macro
|
|---|
| 129 | ; is defined in "block-io-mcl.lisp"
|
|---|
| 130 | (eval-when (:compile-toplevel :execute :load-toplevel)
|
|---|
| 131 |
|
|---|
| 132 | (unless (fboundp 'with-databases-locked)
|
|---|
| 133 | (defmacro with-databases-locked (&body body)
|
|---|
| 134 | `(progn ,@body)))
|
|---|
| 135 |
|
|---|
| 136 | )
|
|---|
| 137 |
|
|---|
| 138 | ;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 139 | ;;;
|
|---|
| 140 | ;;; Node layout - subtype $v_btree-node
|
|---|
| 141 | ;;;
|
|---|
| 142 | ;;; -------------------
|
|---|
| 143 | ;;; | $vector-header |
|
|---|
| 144 | ;;; | subtype length |
|
|---|
| 145 | ;;; |-------------------|
|
|---|
| 146 | ;;; | link |
|
|---|
| 147 | ;;; | parent |
|
|---|
| 148 | ;;; | used free |
|
|---|
| 149 | ;;; | count flags |
|
|---|
| 150 | ;;; | pointer[0] |
|
|---|
| 151 | ;;; | len[0] key[0] ... |
|
|---|
| 152 | ;;; | pointer[1] |
|
|---|
| 153 | ;;; | len[1] key[1] ... |
|
|---|
| 154 | ;;; | ... |
|
|---|
| 155 | ;;; | pointer[m] |
|
|---|
| 156 | ;;; | len[m] key[m] ... |
|
|---|
| 157 | ;;; | pointer[m+1] |
|
|---|
| 158 | ;;; -------------------
|
|---|
| 159 |
|
|---|
| 160 | ;;; $vector-header is the standard vector header marker
|
|---|
| 161 | ;;; subtype is one byte, it's value is $v_btree-node
|
|---|
| 162 | ;;; length is the total length of the data portion of the block in bytes
|
|---|
| 163 | ;;; link is used by the GC so that it can walk btree nodes last.
|
|---|
| 164 | ;;; parent points at the parent node of this one, or at the btree
|
|---|
| 165 | ;;; uvector for the root.
|
|---|
| 166 | ;;; used is 16 bits: the number of bytes that are in use at $btree_data
|
|---|
| 167 | ;;; free is 16 bits: the number of free bytes at the end of the block.
|
|---|
| 168 | ;;; count is 16 bits: the number of entries in this node
|
|---|
| 169 | ;;; flags is 16 bits of flags.
|
|---|
| 170 | ;;; Bit 0 is set for a leaf page.
|
|---|
| 171 | ;;; Bit 1 is set for the root page.
|
|---|
| 172 | ;;; pointer[i] is 4 bytes aligned on a 4-byte boundary.
|
|---|
| 173 | ;;; For a leaf node, it points at the indexed data.
|
|---|
| 174 | ;;; For a non-leaf node, it points at another node in the tree
|
|---|
| 175 | ;;; This node is the branch of the tree containing all entries whose
|
|---|
| 176 | ;;; keys are <= key[i].
|
|---|
| 177 | ;;; pointer[m+1] for a leaf node points to the next leaf node.
|
|---|
| 178 | ;;; This makes a linked list of all the leaf nodes,
|
|---|
| 179 | ;;; which is useful for mapping over the entries.
|
|---|
| 180 | ;;; pointer[m+1] for a non-leaf node points at the branch of the tree
|
|---|
| 181 | ;;; containing entries whose keys are > key[m]
|
|---|
| 182 | ;;; len[i] is a byte giving the length of key[i]
|
|---|
| 183 | ;;; if len[i] is 255, then there are three unused bytes followed
|
|---|
| 184 | ;;; by a four byte pointer to a string containing the key.
|
|---|
| 185 | ;;; otherwise, len[i] will always be < 128
|
|---|
| 186 | ;;; (keys longer than 127 bytes are not yet implemented)
|
|---|
| 187 | ;;; key[i] is len[i] bytes of characters for the key followed
|
|---|
| 188 | ;;; by enough padding bytes to get to the next 4-byte boundary.
|
|---|
| 189 |
|
|---|
| 190 | (defconstant $btree_link $v_data)
|
|---|
| 191 | (defconstant $btree_parent (+ $btree_link 4))
|
|---|
| 192 | (defconstant $btree_used (+ $btree_parent 4))
|
|---|
| 193 | (defconstant $btree_free (+ $btree_used 2))
|
|---|
| 194 | (defconstant $btree_count (+ $btree_free 2))
|
|---|
| 195 | (defconstant $btree_flags (+ $btree_count 2))
|
|---|
| 196 | (defconstant $btree_data (+ $btree_flags 2))
|
|---|
| 197 |
|
|---|
| 198 | (defconstant $btree_flags.leaf-bit 0)
|
|---|
| 199 | (defconstant $btree_flags.root-bit 1)
|
|---|
| 200 |
|
|---|
| 201 | (defmacro with-simple-string ((var string) &body body)
|
|---|
| 202 | (let ((thunk (gensym)))
|
|---|
| 203 | `(let ((,thunk #'(lambda (,var) ,@body)))
|
|---|
| 204 | (declare (dynamic-extent ,thunk))
|
|---|
| 205 | (funcall-with-simple-string ,string ,thunk))))
|
|---|
| 206 |
|
|---|
| 207 | (defun funcall-with-simple-string (string thunk)
|
|---|
| 208 | (if (simple-string-p string)
|
|---|
| 209 | (funcall thunk string)
|
|---|
| 210 | (let* ((len (length string))
|
|---|
| 211 | (simple-string (make-string len :element-type 'base-character)))
|
|---|
| 212 | (declare (dynamic-extent simple-string))
|
|---|
| 213 | (multiple-value-bind (str offset) (array-data-and-offset string)
|
|---|
| 214 | (wood::%load-string str offset len simple-string))
|
|---|
| 215 | (funcall thunk simple-string))))
|
|---|
| 216 |
|
|---|
| 217 | ; Bound by the garbage collector. We won't type-check this
|
|---|
| 218 | ; btree as it's subtype has been overwritten with a forwarding pointer.
|
|---|
| 219 | (defvar *forwarded-btree* nil)
|
|---|
| 220 |
|
|---|
| 221 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 222 | ;;;
|
|---|
| 223 | ;;; The documented interface
|
|---|
| 224 | ;;;
|
|---|
| 225 |
|
|---|
| 226 | (defun p-make-btree (pheap &key area type)
|
|---|
| 227 | (pptr pheap
|
|---|
| 228 | (dc-make-btree (pheap-disk-cache pheap)
|
|---|
| 229 | (and area (pheap-pptr-pointer area pheap))
|
|---|
| 230 | (and type (require-type type 'fixnum)))))
|
|---|
| 231 |
|
|---|
| 232 | (defun p-make-string-equal-btree (pheap &key area)
|
|---|
| 233 | (p-make-btree pheap :area area :type $btree-type_string-equal))
|
|---|
| 234 |
|
|---|
| 235 | (defun p-btree-lookup (btree key-string &optional default)
|
|---|
| 236 | (let ((pheap (pptr-pheap btree)))
|
|---|
| 237 | (multiple-value-bind (pointer immediate? found?)
|
|---|
| 238 | (dc-btree-lookup
|
|---|
| 239 | (pheap-disk-cache pheap)
|
|---|
| 240 | (pptr-pointer btree)
|
|---|
| 241 | (if (stringp key-string)
|
|---|
| 242 | key-string
|
|---|
| 243 | (p-load key-string)))
|
|---|
| 244 | (if found?
|
|---|
| 245 | (values
|
|---|
| 246 | (if immediate?
|
|---|
| 247 | pointer
|
|---|
| 248 | (pptr pheap pointer))
|
|---|
| 249 | t)
|
|---|
| 250 | default))))
|
|---|
| 251 |
|
|---|
| 252 | (defun p-btree-store (btree key-string default &optional (value default))
|
|---|
| 253 | (let ((pheap (pptr-pheap btree)))
|
|---|
| 254 | (multiple-value-bind (pointer immediate?)
|
|---|
| 255 | (%p-store pheap value)
|
|---|
| 256 | (dc-btree-store
|
|---|
| 257 | (pheap-disk-cache pheap)
|
|---|
| 258 | (pptr-pointer btree)
|
|---|
| 259 | (if (stringp key-string)
|
|---|
| 260 | key-string
|
|---|
| 261 | (p-load key-string))
|
|---|
| 262 | pointer
|
|---|
| 263 | immediate?)
|
|---|
| 264 | (if immediate?
|
|---|
| 265 | pointer
|
|---|
| 266 | (pptr pheap pointer)))))
|
|---|
| 267 |
|
|---|
| 268 | (defun setf-p-btree-lookup (btree key-string default &optional (value default))
|
|---|
| 269 | (p-btree-store btree key-string default value)
|
|---|
| 270 | value)
|
|---|
| 271 |
|
|---|
| 272 | (defsetf p-btree-lookup setf-p-btree-lookup)
|
|---|
| 273 |
|
|---|
| 274 | (defun p-btree-delete (btree key-string)
|
|---|
| 275 | (dc-btree-delete
|
|---|
| 276 | (pptr-disk-cache btree)
|
|---|
| 277 | (pptr-pointer btree)
|
|---|
| 278 | (if (stringp key-string)
|
|---|
| 279 | key-string
|
|---|
| 280 | (p-load key-string))))
|
|---|
| 281 |
|
|---|
| 282 | (defun p-clear-btree (btree)
|
|---|
| 283 | (dc-clear-btree (pptr-disk-cache btree)
|
|---|
| 284 | (pptr-pointer btree))
|
|---|
| 285 | btree)
|
|---|
| 286 |
|
|---|
| 287 | (defmacro p-do-btree ((key value) (btree &optional from to) &body body)
|
|---|
| 288 | (let ((mapper (gensym)))
|
|---|
| 289 | `(let ((,mapper #'(lambda (,key ,value) ,@body)))
|
|---|
| 290 | (declare (dynamic-extent ,mapper))
|
|---|
| 291 | ,(if (or from to)
|
|---|
| 292 | `(p-map-btree ,btree ,mapper ,from ,to)
|
|---|
| 293 | `(p-map-btree ,btree ,mapper)))))
|
|---|
| 294 |
|
|---|
| 295 | (defun p-map-btree (btree function &optional from to)
|
|---|
| 296 | (let* ((pheap (pptr-pheap btree))
|
|---|
| 297 | (f #'(lambda (disk-cache key value imm?)
|
|---|
| 298 | (declare (ignore disk-cache))
|
|---|
| 299 | (funcall function key (if imm? value (pptr pheap value))))))
|
|---|
| 300 | (declare (dynamic-extent f))
|
|---|
| 301 | (dc-map-btree (pheap-disk-cache pheap)
|
|---|
| 302 | (pptr-pointer btree)
|
|---|
| 303 | f
|
|---|
| 304 | (if (or (null from) (stringp from))
|
|---|
| 305 | from
|
|---|
| 306 | (p-load from))
|
|---|
| 307 | (if (or (null to) (stringp to))
|
|---|
| 308 | to
|
|---|
| 309 | (p-load to)))))
|
|---|
| 310 |
|
|---|
| 311 | (defun p-map-btree-keystrings (btree function &optional from to)
|
|---|
| 312 | (let* ((pheap (pptr-pheap btree))
|
|---|
| 313 | (f #'(lambda (disk-cache key value imm?)
|
|---|
| 314 | (declare (ignore disk-cache value imm?))
|
|---|
| 315 | (funcall function key))))
|
|---|
| 316 | (declare (dynamic-extent f))
|
|---|
| 317 | (dc-map-btree (pheap-disk-cache pheap)
|
|---|
| 318 | (pptr-pointer btree)
|
|---|
| 319 | f
|
|---|
| 320 | (if (or (null from) (stringp from))
|
|---|
| 321 | from
|
|---|
| 322 | (p-load from))
|
|---|
| 323 | (if (or (null to) (stringp to))
|
|---|
| 324 | to
|
|---|
| 325 | (p-load to)))))
|
|---|
| 326 |
|
|---|
| 327 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 328 | ;;;
|
|---|
| 329 | ;;; disk-cache versions of the documented interface
|
|---|
| 330 | ;;;
|
|---|
| 331 |
|
|---|
| 332 | (defun dc-make-btree (disk-cache &optional area type)
|
|---|
| 333 | (with-databases-locked
|
|---|
| 334 | (let* ((btree (dc-make-uvector disk-cache $btree-size $v_btree area 0 t))
|
|---|
| 335 | (root (dc-cons-btree-node
|
|---|
| 336 | disk-cache btree btree
|
|---|
| 337 | (logior (ash 1 $btree_flags.leaf-bit) (ash 1 $btree_flags.root-bit)))))
|
|---|
| 338 | (accessing-disk-cache (disk-cache)
|
|---|
| 339 | (svset.p btree $btree.root root)
|
|---|
| 340 | (svset.p btree $btree.first-leaf root)
|
|---|
| 341 | (when type
|
|---|
| 342 | (svset.p btree $btree.type (require-type type 'fixnum) t))
|
|---|
| 343 | (svset.p btree $btree.max-key-size 0))
|
|---|
| 344 | btree)))
|
|---|
| 345 |
|
|---|
| 346 | (defun dc-btree-lookup (disk-cache btree key-string)
|
|---|
| 347 | (with-databases-locked
|
|---|
| 348 | (with-simple-string (key-string key-string)
|
|---|
| 349 | (multiple-value-bind (node offset eq)
|
|---|
| 350 | (btree-find-leaf-node disk-cache btree key-string)
|
|---|
| 351 | (when eq
|
|---|
| 352 | (multiple-value-bind (pointer immediate?)
|
|---|
| 353 | (read-pointer disk-cache (+ node offset))
|
|---|
| 354 | (values pointer immediate? t)))))))
|
|---|
| 355 |
|
|---|
| 356 | (defun dc-btree-store (disk-cache btree key-string value &optional
|
|---|
| 357 | value-imm?)
|
|---|
| 358 | (with-databases-locked
|
|---|
| 359 | (with-simple-string (key-string key-string)
|
|---|
| 360 | (when (> (length key-string) 127)
|
|---|
| 361 | #-gz(error "Keys longer than 127 bytes not supported yet.")
|
|---|
| 362 | #+gz(warn "Keys longer than 127 bytes not supported yet.")
|
|---|
| 363 | #+gz (setq key-string (subseq key-string 0 127)))
|
|---|
| 364 | (multiple-value-bind (node offset eq)
|
|---|
| 365 | (btree-find-leaf-node disk-cache btree key-string)
|
|---|
| 366 | (if eq
|
|---|
| 367 | (setf (read-pointer disk-cache (+ node offset) value-imm?)
|
|---|
| 368 | value)
|
|---|
| 369 | (progn
|
|---|
| 370 | (%btree-insert-in-node
|
|---|
| 371 | disk-cache btree node offset key-string value value-imm?)
|
|---|
| 372 | (accessing-disk-cache (disk-cache)
|
|---|
| 373 | (svset.p btree $btree.count (1+ (svref.p btree $btree.count)) t))
|
|---|
| 374 | (values value value-imm?)))))))
|
|---|
| 375 |
|
|---|
| 376 | (defun dc-btree-delete (disk-cache btree key-string)
|
|---|
| 377 | (with-databases-locked
|
|---|
| 378 | (with-simple-string (key-string key-string)
|
|---|
| 379 | (if (> (length key-string) 127)
|
|---|
| 380 | (error "Keys longer than 127 bytes not supported yet."))
|
|---|
| 381 | (multiple-value-bind (node offset eq)
|
|---|
| 382 | (btree-find-leaf-node disk-cache btree key-string)
|
|---|
| 383 | (when eq
|
|---|
| 384 | (%btree-delete-from-node disk-cache btree node offset t)
|
|---|
| 385 | (accessing-disk-cache (disk-cache)
|
|---|
| 386 | (svset.p btree $btree.count (1- (svref.p btree $btree.count)) t))
|
|---|
| 387 | t)))))
|
|---|
| 388 |
|
|---|
| 389 | (defun dc-clear-btree (disk-cache btree)
|
|---|
| 390 | (require-satisfies dc-vector-subtype-p disk-cache btree $v_btree)
|
|---|
| 391 | (let (root-node first-leaf)
|
|---|
| 392 | (with-databases-locked
|
|---|
| 393 | (setq root-node (dc-%svref disk-cache btree $btree.root)
|
|---|
| 394 | first-leaf (dc-%svref disk-cache btree $btree.first-leaf))
|
|---|
| 395 | (accessing-disk-cache (disk-cache first-leaf)
|
|---|
| 396 | (multiple-value-bind (node used free) (init-btree-node disk-cache first-leaf)
|
|---|
| 397 | (declare (ignore node))
|
|---|
| 398 | (fill.b (+ $btree_data used) 0 free))
|
|---|
| 399 | (store.l btree $btree_parent)
|
|---|
| 400 | (store.w (logior (ash 1 $btree_flags.root-bit)
|
|---|
| 401 | (ash 1 $btree_flags.leaf-bit)
|
|---|
| 402 | (load.w $btree_flags))
|
|---|
| 403 | $btree_flags))
|
|---|
| 404 | (dc-%svfill disk-cache btree
|
|---|
| 405 | $btree.root first-leaf
|
|---|
| 406 | ($btree.count t) 0
|
|---|
| 407 | ($btree.count t) 0
|
|---|
| 408 | ($btree.nodes t) 1)
|
|---|
| 409 | (when (> (dc-uvsize disk-cache btree) $btree.max-key-size) ; backward compatibility
|
|---|
| 410 | (setf (dc-%svref disk-cache btree $btree.max-key-size t) 0)))
|
|---|
| 411 | ; Eventually, rewrite dc-%clear-node to occasionally allow interrupts.
|
|---|
| 412 | (with-databases-locked
|
|---|
| 413 | (dc-%clear-node disk-cache root-node first-leaf)))
|
|---|
| 414 | btree)
|
|---|
| 415 |
|
|---|
| 416 | (defun dc-%clear-node (disk-cache node first-leaf)
|
|---|
| 417 | (require-satisfies dc-vector-subtype-p disk-cache node $v_btree-node)
|
|---|
| 418 | (unless (eql node first-leaf)
|
|---|
| 419 | (with-locked-page (disk-cache node nil buf offset)
|
|---|
| 420 | (accessing-byte-array (buf offset)
|
|---|
| 421 | (unless (logbitp $btree_flags.leaf-bit (load.w $btree_flags))
|
|---|
| 422 | (let ((p $btree_data))
|
|---|
| 423 | (declare (fixnum p))
|
|---|
| 424 | (dotimes (i (load.w $btree_count))
|
|---|
| 425 | (dc-%clear-node disk-cache (load.l p) first-leaf)
|
|---|
| 426 | (incf p 4)
|
|---|
| 427 | (incf p (normalize-size (1+ (load.b p)) 4)))
|
|---|
| 428 | (dc-%clear-node disk-cache (load.l p) first-leaf)))
|
|---|
| 429 | (dc-free-btree-node disk-cache nil node)))))
|
|---|
| 430 |
|
|---|
| 431 | ; This assumes that actions at event-processing level don't change the
|
|---|
| 432 | ; B-tree (i.e. the may read the database but not write it), so we can
|
|---|
| 433 | ; release the database lock around the call to the user function.
|
|---|
| 434 | ; Otherwise the database would have to be locked across the entire operation.
|
|---|
| 435 | ; with-databases-locked is required around btree-find-leaf-node, because that
|
|---|
| 436 | ; function doesn't call with-databases-locked itself, and also because the
|
|---|
| 437 | ; with-locked-page below has a timing hazard (buf could be reused before
|
|---|
| 438 | ; the page has been locked) unless it is called inside with-databases-locked.
|
|---|
| 439 | (defun dc-map-btree (disk-cache btree function &optional from to)
|
|---|
| 440 | (if (null from)
|
|---|
| 441 | (unless (eql btree *forwarded-btree*)
|
|---|
| 442 | (require-satisfies dc-vector-subtype-p disk-cache btree $v_btree))
|
|---|
| 443 | (unless (stringp from)
|
|---|
| 444 | (setq from (require-type from '(or null string)))))
|
|---|
| 445 | (unless (or (null to) (stringp to))
|
|---|
| 446 | (setq to (require-type to '(or null string))))
|
|---|
| 447 | (with-databases-locked
|
|---|
| 448 | (multiple-value-bind (node p)
|
|---|
| 449 | (if from
|
|---|
| 450 | (btree-find-leaf-node disk-cache btree from)
|
|---|
| 451 | (values (dc-%svref disk-cache btree $btree.first-leaf)
|
|---|
| 452 | $btree_data))
|
|---|
| 453 | (declare (fixnum p))
|
|---|
| 454 | (let ((string-equal-function (string-equal-function disk-cache btree))
|
|---|
| 455 | (compare-strings-function (and to (compare-strings-function disk-cache btree))))
|
|---|
| 456 | (loop
|
|---|
| 457 | (block once-per-node
|
|---|
| 458 | (with-locked-page (disk-cache node nil buf buf-offset)
|
|---|
| 459 | (accessing-byte-array (buf buf-offset)
|
|---|
| 460 | (let ((max-p (+ $btree_data (load.w $btree_used) -4)))
|
|---|
| 461 | (declare (fixnum max-p))
|
|---|
| 462 | (loop
|
|---|
| 463 | (when (>= p max-p)
|
|---|
| 464 | (when (> p max-p)
|
|---|
| 465 | (error "Inconsistency: pointer off end of btree node"))
|
|---|
| 466 | (return))
|
|---|
| 467 | (multiple-value-bind (value imm?) (load.p p)
|
|---|
| 468 | (let* ((len (load.b (incf p 4)))
|
|---|
| 469 | (key (make-string len :element-type 'base-character)))
|
|---|
| 470 | (declare (fixnum len)
|
|---|
| 471 | (dynamic-extent key))
|
|---|
| 472 | (load.string (the fixnum (1+ p)) len key)
|
|---|
| 473 | (when (and to (< (the fixnum (funcall compare-strings-function to key)) 0))
|
|---|
| 474 | (return-from dc-map-btree nil))
|
|---|
| 475 | (with-databases-unlocked
|
|---|
| 476 | (funcall function disk-cache key value imm?))
|
|---|
| 477 | (let ((newlen (load.b p)))
|
|---|
| 478 | (declare (fixnum newlen))
|
|---|
| 479 | (unless (and (eql newlen len)
|
|---|
| 480 | (let ((new-key (make-string newlen :element-type 'base-character)))
|
|---|
| 481 | (declare (dynamic-extent new-key))
|
|---|
| 482 | (load.string (the fixnum (1+ p)) newlen new-key)
|
|---|
| 483 | (funcall string-equal-function key new-key)))
|
|---|
| 484 | ; The user inserted or deleted something that caused
|
|---|
| 485 | ; the key to move. Need to find it again.
|
|---|
| 486 | (let (eq)
|
|---|
| 487 | (multiple-value-setq (node p eq)
|
|---|
| 488 | (btree-find-leaf-node disk-cache btree key))
|
|---|
| 489 | (when eq
|
|---|
| 490 | (incf p (normalize-size (1+ len) 4)))
|
|---|
| 491 | (return-from once-per-node))))
|
|---|
| 492 | (incf p (normalize-size (1+ len) 4))))))
|
|---|
| 493 | (setq node (load.l p)
|
|---|
| 494 | p $btree_data)
|
|---|
| 495 | (when (eql node $pheap-nil)
|
|---|
| 496 | (return nil))))))))))
|
|---|
| 497 |
|
|---|
| 498 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 499 | ;;;
|
|---|
| 500 | ;;; Grungy internal details
|
|---|
| 501 | ;;; First, some generally useful utility functions
|
|---|
| 502 | ;;;
|
|---|
| 503 |
|
|---|
| 504 | (defparameter *max-btree-node-size* 512)
|
|---|
| 505 |
|
|---|
| 506 | (defun dc-cons-btree-node (disk-cache btree parent flags)
|
|---|
| 507 | (let ((node (or (with-locked-page (disk-cache (+ $root-vector $v_data
|
|---|
| 508 | (* 4 $pheap.btree-free-list)))
|
|---|
| 509 | (accessing-disk-cache (disk-cache)
|
|---|
| 510 | (let ((free-list (svref.p $root-vector $pheap.btree-free-list)))
|
|---|
| 511 | (unless (eql $pheap-nil free-list)
|
|---|
| 512 | (svset.p $root-vector $pheap.btree-free-list
|
|---|
| 513 | (accessing-disk-cache (disk-cache free-list)
|
|---|
| 514 | (load.l $btree_parent)))
|
|---|
| 515 | free-list))))
|
|---|
| 516 | (dc-allocate-new-btree-node disk-cache))))
|
|---|
| 517 | (accessing-disk-cache (disk-cache node)
|
|---|
| 518 | (store.l parent $btree_parent)
|
|---|
| 519 | (store.w flags $btree_flags))
|
|---|
| 520 | (with-locked-page (disk-cache (+ btree $v_data (* 4 $btree.nodes)) t)
|
|---|
| 521 | (accessing-disk-cache (disk-cache)
|
|---|
| 522 | (svset.p btree $btree.nodes (1+ (svref.p btree $btree.nodes)) t)))
|
|---|
| 523 | node))
|
|---|
| 524 |
|
|---|
| 525 | ; This takes care of chopping up a disk block into btree nodes.
|
|---|
| 526 | ; This is necessary if the page size is bigger than the *max-btree-node-size*.
|
|---|
| 527 | ; Otherwise, we just use one disk page.
|
|---|
| 528 | (defun dc-allocate-new-btree-node (disk-cache)
|
|---|
| 529 | (let ((node (if (>= *max-btree-node-size* (disk-cache-page-size disk-cache))
|
|---|
| 530 | (%dc-allocate-new-memory disk-cache 1 $v_btree-node 0 t)
|
|---|
| 531 | ; Could do most of this size computation at pheap open time and cache the
|
|---|
| 532 | ; results, but it's in the noise compared to everything else.
|
|---|
| 533 | (let* ((segment (%dc-allocate-new-memory disk-cache 1 $v_segment nil))
|
|---|
| 534 | (segment-size (dc-%vector-size disk-cache segment))
|
|---|
| 535 | (segment-header-bytes (* 4 $segment-header-size))
|
|---|
| 536 | (bytes (- segment-size segment-header-bytes))
|
|---|
| 537 | (bytes-per-node *max-btree-node-size*)
|
|---|
| 538 | (count (ceiling bytes bytes-per-node))
|
|---|
| 539 | (size-per-node (- bytes-per-node $vector-header-size))
|
|---|
| 540 | (first-node-bytes (- bytes (* (1- count) bytes-per-node)))
|
|---|
| 541 | (first-node-size (- first-node-bytes $vector-header-size))
|
|---|
| 542 | (ptr (+ segment $v_data segment-header-bytes))
|
|---|
| 543 | res)
|
|---|
| 544 | (dc-%svfill disk-cache segment
|
|---|
| 545 | $segment.area $pheap-nil
|
|---|
| 546 | $segment.header $pheap-nil)
|
|---|
| 547 | (dotimes (i count)
|
|---|
| 548 | (if (eql i 0)
|
|---|
| 549 | (progn
|
|---|
| 550 | (setq res (initialize-vector-storage
|
|---|
| 551 | disk-cache ptr first-node-size $v_btree-node 1 0 t))
|
|---|
| 552 | (incf ptr first-node-bytes))
|
|---|
| 553 | (progn
|
|---|
| 554 | (dc-free-btree-node
|
|---|
| 555 | disk-cache nil
|
|---|
| 556 | (initialize-vector-storage
|
|---|
| 557 | disk-cache ptr size-per-node $v_btree-node 1 nil))
|
|---|
| 558 | (incf ptr bytes-per-node))))
|
|---|
| 559 | (unless (eql (+ segment $v_data segment-size) ptr)
|
|---|
| 560 | (error "ptr not at segment end"))
|
|---|
| 561 | res))))
|
|---|
| 562 | (init-btree-node disk-cache node)))
|
|---|
| 563 |
|
|---|
| 564 | (defun dc-free-btree-node (disk-cache btree node)
|
|---|
| 565 | (multiple-value-bind (node used free) (init-btree-node disk-cache node)
|
|---|
| 566 | (accessing-disk-cache (disk-cache node)
|
|---|
| 567 | (fill.b (+ $btree_data used) 0 free)))
|
|---|
| 568 | (with-locked-page (disk-cache $root-vector t)
|
|---|
| 569 | (accessing-disk-cache (disk-cache)
|
|---|
| 570 | (let ((free-list (svref.p $root-vector $pheap.btree-free-list)))
|
|---|
| 571 | (accessing-disk-cache (disk-cache node)
|
|---|
| 572 | (store.l free-list $btree_parent)))
|
|---|
| 573 | (svset.p $root-vector $pheap.btree-free-list node)))
|
|---|
| 574 | (when btree
|
|---|
| 575 | (with-locked-page (disk-cache (+ btree $v_data (* 4 $btree.nodes)) t)
|
|---|
| 576 | (accessing-disk-cache (disk-cache)
|
|---|
| 577 | (svset.p btree $btree.nodes (1- (svref.p btree $btree.nodes)) t)))))
|
|---|
| 578 |
|
|---|
| 579 | (defun init-btree-node (disk-cache node)
|
|---|
| 580 | (accessing-disk-cache (disk-cache node)
|
|---|
| 581 | (let* ((vector-size (%vector-size.p node))
|
|---|
| 582 | (data-size (- vector-size (- $btree_data $v_data)))
|
|---|
| 583 | (used 4)
|
|---|
| 584 | (free (- data-size used)))
|
|---|
| 585 | (store.l $pheap-nil $btree_link)
|
|---|
| 586 | (store.w used $btree_used)
|
|---|
| 587 | (store.w free $btree_free)
|
|---|
| 588 | (store.w 0 $btree_count)
|
|---|
| 589 | (store.l $pheap-nil $btree_data)
|
|---|
| 590 | (values node used free))))
|
|---|
| 591 |
|
|---|
| 592 | (defun %btree-leaf-node-p (disk-cache node)
|
|---|
| 593 | (accessing-disk-cache (disk-cache node)
|
|---|
| 594 | (logbitp $btree_flags.leaf-bit (load.w $btree_flags))))
|
|---|
| 595 |
|
|---|
| 596 | (defun %btree-root-node-p (disk-cache node)
|
|---|
| 597 | (accessing-disk-cache (disk-cache node)
|
|---|
| 598 | (logbitp $btree_flags.root-bit (load.w $btree_flags))))
|
|---|
| 599 |
|
|---|
| 600 | (defun compare-strings-function (disk-cache btree)
|
|---|
| 601 | (if (logbitp $btree-type_string-equal-bit
|
|---|
| 602 | (dc-%svref disk-cache btree $btree.type))
|
|---|
| 603 | #'compare-strings-case-insensitive
|
|---|
| 604 | #'compare-strings))
|
|---|
| 605 |
|
|---|
| 606 | ; New function
|
|---|
| 607 | (defun compare-strings-case-insensitive (str1 str2)
|
|---|
| 608 | (cond ((string-lessp str1 str2) -1)
|
|---|
| 609 | ((string-equal str1 str2) 0)
|
|---|
| 610 | (t 1)))
|
|---|
| 611 |
|
|---|
| 612 | ; New function
|
|---|
| 613 | (defun string-equal-function (disk-cache btree)
|
|---|
| 614 | (if (logbitp $btree-type_string-equal-bit
|
|---|
| 615 | (dc-%svref disk-cache btree $btree.type))
|
|---|
| 616 | #'string-equal
|
|---|
| 617 | #'string=))
|
|---|
| 618 |
|
|---|
| 619 | ; Returns two values:
|
|---|
| 620 | ; 1) offset - from node for the place where key-string goes
|
|---|
| 621 | ; 2) eq - True if the key at this offset is key-string
|
|---|
| 622 | (defun btree-find-leaf-node (disk-cache btree key-string)
|
|---|
| 623 | (unless (eql btree *forwarded-btree*)
|
|---|
| 624 | (require-satisfies dc-vector-subtype-p disk-cache btree $v_btree))
|
|---|
| 625 | (let ((node (dc-%svref disk-cache btree $btree.root))
|
|---|
| 626 | (case-sensitive? (not (logbitp $btree-type_string-equal-bit
|
|---|
| 627 | (dc-%svref disk-cache btree $btree.type)))))
|
|---|
| 628 | (loop
|
|---|
| 629 | (multiple-value-bind (offset eq)
|
|---|
| 630 | (%btree-search-node
|
|---|
| 631 | disk-cache node key-string case-sensitive?)
|
|---|
| 632 | (when (%btree-leaf-node-p disk-cache node)
|
|---|
| 633 | (return (values node offset eq)))
|
|---|
| 634 | (setq node (read-long disk-cache (+ node offset)))
|
|---|
| 635 | (require-satisfies dc-vector-subtype-p
|
|---|
| 636 | disk-cache node $v_btree-node)))))
|
|---|
| 637 |
|
|---|
| 638 | ; This one calls the disk-cache code directly and accesses the
|
|---|
| 639 | ; page vector itself so that it can be reasonably fast.
|
|---|
| 640 | ; Returns same two values as btree-find-leaf-node
|
|---|
| 641 | ; plus a third value which is the offset to the node just to the left of the found one.
|
|---|
| 642 |
|
|---|
| 643 |
|
|---|
| 644 | #| ; old linear search code
|
|---|
| 645 | (defun %btree-search-node (disk-cache node key-string case-sensitive?)
|
|---|
| 646 | (let ((compare-strings-function (if case-sensitive? #'compare-strings #'compare-strings-case-insensitive)))
|
|---|
| 647 | (with-locked-page (disk-cache node nil vec offset bytes)
|
|---|
| 648 | (declare (fixnum offset bytes))
|
|---|
| 649 | (accessing-byte-array (vec offset)
|
|---|
| 650 | (let* ((end (+ offset $btree_data (load.uw $btree_used)))
|
|---|
| 651 | (ptr (+ offset $btree_data 4))
|
|---|
| 652 | (last-ptr nil))
|
|---|
| 653 | (declare (fixnum end ptr))
|
|---|
| 654 | (declare (fixnum offset bytes))
|
|---|
| 655 | (unless (>= (the fixnum (+ offset bytes)) end)
|
|---|
| 656 | (error "End of btree node is past end of disk page"))
|
|---|
| 657 | (loop
|
|---|
| 658 | (if (>= ptr end)
|
|---|
| 659 | (return (values (- ptr offset 4)
|
|---|
| 660 | nil
|
|---|
| 661 | (if last-ptr (- last-ptr offset 4)))))
|
|---|
| 662 | (let* ((len (aref vec ptr))
|
|---|
| 663 | (str (make-string len :element-type 'base-character)))
|
|---|
| 664 | (declare (dynamic-extent str))
|
|---|
| 665 | (%copy-byte-array-portion vec (the fixnum (1+ ptr)) len str 0)
|
|---|
| 666 | ; Here's where we'll eventually use part of the
|
|---|
| 667 | ; $btree_flags to select a sorting predicate.
|
|---|
| 668 | (let ((compare (funcall compare-strings-function key-string str)))
|
|---|
| 669 | (declare (fixnum compare))
|
|---|
| 670 | (when (<= compare 0)
|
|---|
| 671 | (return (values (- ptr offset 4)
|
|---|
| 672 | (eql compare 0)
|
|---|
| 673 | (if last-ptr (- last-ptr offset 4))))))
|
|---|
| 674 | (setq last-ptr ptr)
|
|---|
| 675 | (incf ptr (normalize-size (+ 5 len) 4)))))))))
|
|---|
| 676 | |#
|
|---|
| 677 |
|
|---|
| 678 | #+GZ
|
|---|
| 679 | (defun check-used-counts (where disk-cache node)
|
|---|
| 680 | (let* ((used (read-unsigned-word disk-cache (+ node $btree_used)))
|
|---|
| 681 | (count (read-unsigned-word disk-cache (+ node $btree_count)))
|
|---|
| 682 | (bytes (loop for n = 0 then (+ n (normalize-size (+ 5 len) 4))
|
|---|
| 683 | for i from 0 below count
|
|---|
| 684 | as len = (read-8-bits disk-cache (+ node $btree_data n 4))
|
|---|
| 685 | finally return n)))
|
|---|
| 686 | ;(FORMAT T "~&CHECK-USED-COUNTS@~s node ~s: [count]=~s, [used]=~s, bytes ~s"
|
|---|
| 687 | ; where node count used bytes)
|
|---|
| 688 | where
|
|---|
| 689 | (assert (<= bytes used))))
|
|---|
| 690 |
|
|---|
| 691 |
|
|---|
| 692 |
|
|---|
| 693 | ; New binary search code: Moon's idea.
|
|---|
| 694 | (defun %btree-search-node (disk-cache node key-string case-sensitive?)
|
|---|
| 695 | (with-locked-page (disk-cache node nil vec offset)
|
|---|
| 696 | (declare (fixnum offset)
|
|---|
| 697 | (type (simple-array (unsigned-byte 8) (*)) vec))
|
|---|
| 698 | (accessing-byte-array (vec)
|
|---|
| 699 |
|
|---|
| 700 | (let* ((count (load.uw (+ $btree_count offset)))
|
|---|
| 701 | (min 0) ; inclusive lower bound
|
|---|
| 702 | (max count) ; exclusive upper bound
|
|---|
| 703 | (ptrs (make-array count))
|
|---|
| 704 | (lens (make-array count))
|
|---|
| 705 | (fill-pointer 0) ; unlike Common Lisp, this is an inclusive upper bound
|
|---|
| 706 | (key-len (length key-string))
|
|---|
| 707 | (offset+4 (+ offset 4))
|
|---|
| 708 | (offset+5 (+ offset 5)))
|
|---|
| 709 | (declare (fixnum count min max fill-pointer offset+4 offset+5)
|
|---|
| 710 | (dynamic-extent ptrs lens)
|
|---|
| 711 | (simple-vector ptrs lens)
|
|---|
| 712 | (optimize (speed 3) (safety 0)))
|
|---|
| 713 | (when (eql count 0)
|
|---|
| 714 | (return-from %btree-search-node $btree_data))
|
|---|
| 715 | (setf (svref ptrs 0) $btree_data
|
|---|
| 716 | (svref lens 0) (aref vec (the fixnum (+ $btree_data offset+4)))) ; (load.b (+ $btree_data offset 4))
|
|---|
| 717 | (flet ((get-ptr (index)
|
|---|
| 718 | (declare (fixnum index))
|
|---|
| 719 | (if (<= index fill-pointer)
|
|---|
| 720 | (values (svref ptrs index) (svref lens index))
|
|---|
| 721 | (let ((p (svref ptrs fill-pointer))
|
|---|
| 722 | (len (svref lens fill-pointer)))
|
|---|
| 723 | (declare (fixnum p len))
|
|---|
| 724 | (loop
|
|---|
| 725 | (incf p (the fixnum (normalize-size (the fixnum (+ 5 len)) 4)))
|
|---|
| 726 | (setq len (aref vec (the fixnum (+ p offset+4)))) ; (load.b (+ p 4 offset))
|
|---|
| 727 | (setf (svref ptrs (incf fill-pointer)) p)
|
|---|
| 728 | (setf (svref lens fill-pointer) len)
|
|---|
| 729 | (when (eql fill-pointer index)
|
|---|
| 730 | (return (values p len)))))))
|
|---|
| 731 | (compare-strings (s1 i1 end1 s2 i2 end2 case-sensitive?)
|
|---|
| 732 | (declare (fixnum i1 end1 i2 end2)
|
|---|
| 733 | (type (simple-array (unsigned-byte 8) (*)) s1 s2)
|
|---|
| 734 | (optimize (speed 3) (safety 0)))
|
|---|
| 735 | ; s1 is a simple string and s2 is a (simple-array (unsigned-byte 8) (*))
|
|---|
| 736 | ; Since these are stored the same way in memory, we can assume
|
|---|
| 737 | ; That both are (unsigned-byte 8) or both are simple strings and
|
|---|
| 738 | ; the inline code will work.
|
|---|
| 739 | ; (Unfortunatedly, PPC MCL does not inline %schar, so we need to use aref
|
|---|
| 740 | ; instead).
|
|---|
| 741 | (if case-sensitive?
|
|---|
| 742 | (loop
|
|---|
| 743 | (when (>= i1 end1)
|
|---|
| 744 | (return (if (eql i2 end2) 0 -1)))
|
|---|
| 745 | (when (>= i2 end2) (return 1))
|
|---|
| 746 | (let ((c1 (aref s1 i1))
|
|---|
| 747 | (c2 (aref s2 i2)))
|
|---|
| 748 | (declare (fixnum c1 c2))
|
|---|
| 749 | (if (<= c1 c2)
|
|---|
| 750 | (if (< c1 c2)
|
|---|
| 751 | (return -1))
|
|---|
| 752 | (return 1)))
|
|---|
| 753 | (incf i1)
|
|---|
| 754 | (incf i2))
|
|---|
| 755 | (loop
|
|---|
| 756 | (when (>= i1 end1)
|
|---|
| 757 | (return (if (eql i2 end2) 0 -1)))
|
|---|
| 758 | (when (>= i2 end2) (return 1))
|
|---|
| 759 | (let ((c1 (%char-code (char-upcase (%code-char (aref s1 i1)))))
|
|---|
| 760 | (c2 (%char-code (char-upcase (%code-char (aref s2 i2))))))
|
|---|
| 761 | (declare (fixnum c1 c2))
|
|---|
| 762 | (if (<= c1 c2)
|
|---|
| 763 | (if (< c1 c2)
|
|---|
| 764 | (return -1))
|
|---|
| 765 | (return 1)))
|
|---|
| 766 | (incf i1)
|
|---|
| 767 | (incf i2)))))
|
|---|
| 768 | (declare (inline get-ptr compare-strings))
|
|---|
| 769 | (loop
|
|---|
| 770 | (let ((index (ash (the fixnum (+ min max)) -1)))
|
|---|
| 771 | (declare (fixnum index))
|
|---|
| 772 | (multiple-value-bind (ptr len) (get-ptr index)
|
|---|
| 773 | (declare (fixnum ptr len))
|
|---|
| 774 | (let* ((vec-idx (+ ptr (the fixnum offset+5)))
|
|---|
| 775 | (vec-end (+ vec-idx len))
|
|---|
| 776 | (compare (compare-strings key-string 0 key-len vec vec-idx vec-end case-sensitive?)))
|
|---|
| 777 | (declare (fixnum vec-idx vec-end compare))
|
|---|
| 778 | (if (<= compare 0)
|
|---|
| 779 | (progn
|
|---|
| 780 | (setq max index)
|
|---|
| 781 | (when (or (eql compare 0) (eql min max))
|
|---|
| 782 | (return (values ptr
|
|---|
| 783 | (eql compare 0)
|
|---|
| 784 | (unless (eql index 0)
|
|---|
| 785 | (svref ptrs (the fixnum (1- index))))))))
|
|---|
| 786 | (progn
|
|---|
| 787 | (setq min (1+ index))
|
|---|
| 788 | (when (eql min max)
|
|---|
| 789 | (return (values (the fixnum (+ ptr (normalize-size (the fixnum (+ 5 len)) 4)))
|
|---|
| 790 | nil
|
|---|
| 791 | ptr))))))))))))))
|
|---|
| 792 |
|
|---|
| 793 | (defun compare-strings (str1 str2)
|
|---|
| 794 | (cond ((string< str1 str2) -1)
|
|---|
| 795 | ((string= str1 str2) 0)
|
|---|
| 796 | (t 1)))
|
|---|
| 797 |
|
|---|
| 798 | ; Search a node for a pointer to a subnode.
|
|---|
| 799 | ; Return two values, the offset for the subnode, and the offset
|
|---|
| 800 | ; for the subnode just before it.
|
|---|
| 801 | ; If right-node-p is true, return a third value, the offset of the subnode
|
|---|
| 802 | ; just after subnode.
|
|---|
| 803 | (defun %btree-search-for-subnode (disk-cache node subnode &optional right-node-p)
|
|---|
| 804 | (with-locked-page (disk-cache node nil vec offset bytes)
|
|---|
| 805 | (declare (fixnum offset bytes))
|
|---|
| 806 | (accessing-byte-array (vec offset)
|
|---|
| 807 | (let* ((end (+ offset $btree_data (load.uw $btree_used)))
|
|---|
| 808 | (ptr (+ offset $btree_data))
|
|---|
| 809 | (last-ptr nil))
|
|---|
| 810 | (declare (fixnum end ptr))
|
|---|
| 811 | (declare (fixnum offset bytes))
|
|---|
| 812 | (unless (>= (the fixnum (+ offset bytes)) end)
|
|---|
| 813 | (error "End of btree node is past end of disk page"))
|
|---|
| 814 | (accessing-byte-array (vec)
|
|---|
| 815 | (loop
|
|---|
| 816 | (when (eql subnode (load.p ptr))
|
|---|
| 817 | (return (values (- ptr offset)
|
|---|
| 818 | (if last-ptr (- last-ptr offset))
|
|---|
| 819 | (when right-node-p
|
|---|
| 820 | (let ((right-ptr (+ ptr 4)))
|
|---|
| 821 | (declare (fixnum right-ptr))
|
|---|
| 822 | (unless (>= right-ptr end)
|
|---|
| 823 | (incf right-ptr (normalize-size (1+ (load.b right-ptr)) 4))
|
|---|
| 824 | (- right-ptr offset)))))))
|
|---|
| 825 | (setq last-ptr ptr)
|
|---|
| 826 | (incf ptr 4)
|
|---|
| 827 | (if (>= ptr end)
|
|---|
| 828 | (return nil))
|
|---|
| 829 | (incf ptr (normalize-size (1+ (load.b ptr)) 4))))))))
|
|---|
| 830 |
|
|---|
| 831 | ; Fill the SIZES array with the sizes of the entries in NODE.
|
|---|
| 832 | ; If one of the entries is at INSERT-OFFSET, put INSERT-SIZE
|
|---|
| 833 | ; into SIZES at that index, and return the index.
|
|---|
| 834 | ; Otherwise, return NIL.
|
|---|
| 835 | (defun %lookup-node-sizes (disk-cache node sizes count &optional insert-offset insert-size
|
|---|
| 836 | (start 0))
|
|---|
| 837 | (accessing-disk-cache (disk-cache node)
|
|---|
| 838 | (unless count
|
|---|
| 839 | (setq count (load.uw $btree_count)))
|
|---|
| 840 | (when insert-offset (incf count))
|
|---|
| 841 | (let ((p (+ $btree_data 4))
|
|---|
| 842 | (p-at-offset (and insert-offset (+ insert-offset 4)))
|
|---|
| 843 | insert-index
|
|---|
| 844 | (index (require-type start 'fixnum)))
|
|---|
| 845 | (declare (fixnum p))
|
|---|
| 846 | (dotimes (i count)
|
|---|
| 847 | (if (eql p p-at-offset)
|
|---|
| 848 | (setf (aref sizes index) insert-size
|
|---|
| 849 | insert-index index
|
|---|
| 850 | p-at-offset nil)
|
|---|
| 851 | (incf p (setf (aref sizes index) (normalize-size (+ 5 (load.b p)) 4))))
|
|---|
| 852 | (incf index))
|
|---|
| 853 | (when (and insert-offset (null insert-index))
|
|---|
| 854 | (error "Inconsistency: didn't find insert-offset"))
|
|---|
| 855 | (unless (eql p (+ $btree_data (load.uw $btree_used)))
|
|---|
| 856 | (error "Inconsistency: walking node's entries didn't end up at end"))
|
|---|
| 857 | insert-index)))
|
|---|
| 858 |
|
|---|
| 859 | ; When we move entries around in a non-leaf nodes, the parent pointers
|
|---|
| 860 | ; need to be updated.
|
|---|
| 861 | ; This will go away if I eliminate the parent pointers and replace
|
|---|
| 862 | ; them with passing around the ancestor list.
|
|---|
| 863 | ; Doing this will make insertion and deletion slightly faster
|
|---|
| 864 | ; at the expense of making it hard to click around in a btree
|
|---|
| 865 | ; in the inspector.
|
|---|
| 866 | (defun %btree-update-childrens-parents (disk-cache node &optional start-ptr end-ptr)
|
|---|
| 867 | (with-locked-page (disk-cache node nil node-buf node-buf-offset)
|
|---|
| 868 | (accessing-byte-array (node-buf)
|
|---|
| 869 | (let* ((used (load.uw (+ node-buf-offset $btree_used)))
|
|---|
| 870 | (p (or start-ptr (+ node-buf-offset $btree_data)))
|
|---|
| 871 | (max-p (or end-ptr (+ node-buf-offset $btree_data used)))
|
|---|
| 872 | child)
|
|---|
| 873 | (declare (fixnum p max-p))
|
|---|
| 874 | (loop
|
|---|
| 875 | (setq child (load.p p))
|
|---|
| 876 | (require-satisfies dc-vector-subtype-p disk-cache child $v_btree-node)
|
|---|
| 877 | (accessing-disk-cache (disk-cache child)
|
|---|
| 878 | (store.p node $btree_parent))
|
|---|
| 879 | (incf p 4)
|
|---|
| 880 | (when (>= p max-p)
|
|---|
| 881 | (unless (eql p max-p)
|
|---|
| 882 | (error "Inconsistency. Node scan went past expected end."))
|
|---|
| 883 | (return))
|
|---|
| 884 | (incf p (normalize-size (+ 1 (load.b p)) 4)))))))
|
|---|
| 885 |
|
|---|
| 886 | ; Update and return the maximum key size
|
|---|
| 887 | (defun dc-btree-max-key-size (disk-cache btree &optional new-size)
|
|---|
| 888 | (when new-size
|
|---|
| 889 | (setq new-size (require-type new-size 'fixnum)))
|
|---|
| 890 | (if (<= (dc-uvsize disk-cache btree) $btree.max-key-size)
|
|---|
| 891 | 132 ; old btrees don't track max key size
|
|---|
| 892 | (let ((size (dc-%svref-fixnum disk-cache btree $btree.max-key-size "$btree.max-key-size")))
|
|---|
| 893 | (if (and new-size (> new-size size))
|
|---|
| 894 | (setf (dc-%svref disk-cache btree $btree.max-key-size t) new-size)
|
|---|
| 895 | size))))
|
|---|
| 896 |
|
|---|
| 897 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 898 | ;;
|
|---|
| 899 | ;; Here's where the guts of an insert happens.
|
|---|
| 900 | ;; We know that the key-string belongs at offset from node.
|
|---|
| 901 | ;; Insert it there if it fits.
|
|---|
| 902 | ;; Otherwise split this node into two after creating room in each
|
|---|
| 903 | ;; node in the access path.
|
|---|
| 904 | ;;
|
|---|
| 905 |
|
|---|
| 906 | (defun %btree-insert-in-node (disk-cache btree node offset key-string value
|
|---|
| 907 | &optional value-imm? (key-length (length key-string)))
|
|---|
| 908 | (accessing-disk-cache (disk-cache node)
|
|---|
| 909 | (let* ((free (load.uw $btree_free))
|
|---|
| 910 | (used (load.uw $btree_used))
|
|---|
| 911 | (size (normalize-size (+ 5 key-length) 4))
|
|---|
| 912 | (max-key-size (dc-btree-max-key-size disk-cache btree size))) ; update & get max key size
|
|---|
| 913 | (declare (fixnum free used size))
|
|---|
| 914 | (if (> key-length 127)
|
|---|
| 915 | (error "Keys longer than 127 not supported yet."))
|
|---|
| 916 | (when (<= size free)
|
|---|
| 917 | ; Will fit in this node
|
|---|
| 918 | (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
|
|---|
| 919 | (let* ((bytes-to-move (- used (- offset $btree_data)))
|
|---|
| 920 | (p (+ node-buf-offset offset)))
|
|---|
| 921 | (declare (fixnum bytes-to-move p))
|
|---|
| 922 | (%copy-byte-array-portion node-buf p bytes-to-move
|
|---|
| 923 | node-buf (+ p size) node-page)
|
|---|
| 924 | (%store-btree-entry
|
|---|
| 925 | node-buf p node-page
|
|---|
| 926 | key-string key-length value value-imm? size)
|
|---|
| 927 | (accessing-byte-array (node-buf node-buf-offset node-page)
|
|---|
| 928 | (store.w (1+ (load.uw $btree_count)) $btree_count)
|
|---|
| 929 | (store.w (+ used size) $btree_used)
|
|---|
| 930 | (store.w (- free size) $btree_free))))
|
|---|
| 931 | (return-from %btree-insert-in-node nil))
|
|---|
| 932 | ; Won't fit. Split the node
|
|---|
| 933 | (unless (%btree-leaf-node-p disk-cache node)
|
|---|
| 934 | (error "Wasn't room to insert in non-leaf node"))
|
|---|
| 935 | (%create-insertion-path disk-cache btree key-string max-key-size)
|
|---|
| 936 | (%split-node disk-cache btree node free used
|
|---|
| 937 | t offset key-string value value-imm? key-length size)
|
|---|
| 938 | ; This slightly increases non-leaf node space utilization, but
|
|---|
| 939 | ; at a 10% time penalty, so I've nuked it.
|
|---|
| 940 | ;(%sew-up-insertion-path disk-cache btree node t)
|
|---|
| 941 | )))
|
|---|
| 942 |
|
|---|
| 943 | (eval-when (:load-toplevel :compile-toplevel :execute)
|
|---|
| 944 |
|
|---|
| 945 | (defvar *enable-debug-break* nil)
|
|---|
| 946 |
|
|---|
| 947 | ) ; end of eval-when
|
|---|
| 948 |
|
|---|
| 949 | (defmacro debug-break (format-string &rest format-args)
|
|---|
| 950 | (when *enable-debug-break*
|
|---|
| 951 | `(%debug-break ,format-string ,@format-args)))
|
|---|
| 952 |
|
|---|
| 953 | (defun %debug-break (format-string &rest format-args)
|
|---|
| 954 | (when *enable-debug-break*
|
|---|
| 955 | (let ((*print-base* 16.))
|
|---|
| 956 | (apply 'cerror "Continue" format-string format-args))))
|
|---|
| 957 |
|
|---|
| 958 | ; There is an important difference between the leaf and non-leaf nodes.
|
|---|
| 959 | ; When entries are shifted between leaf nodes, the parent node does not
|
|---|
| 960 | ; need to be referenced except to update it with the last key in the
|
|---|
| 961 | ; left-hand leaf node. When non-leaf nodes are shifted, the shifting needs
|
|---|
| 962 | ; to go through the parent node, i.e. the key in the parent that is between
|
|---|
| 963 | ; the keys in the left child and the right child does not appear in either child
|
|---|
| 964 | ; and needs to move to one of them. After we're done, the parent will have
|
|---|
| 965 | ; a new key that used to be in one of its children but isn't any more.
|
|---|
| 966 |
|
|---|
| 967 | (defun %split-node (disk-cache btree node free used leaf-p &optional
|
|---|
| 968 | offset key-string value value-imm? key-length (size 0))
|
|---|
| 969 | (when (%shift-node-left disk-cache btree node free used leaf-p
|
|---|
| 970 | offset key-string value value-imm? key-length size)
|
|---|
| 971 | (return-from %split-node :shift-left))
|
|---|
| 972 | (when (%shift-node-right disk-cache btree node free used leaf-p
|
|---|
| 973 | offset key-string value value-imm? key-length size)
|
|---|
| 974 | (return-from %split-node :shift-right))
|
|---|
| 975 | (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
|
|---|
| 976 | (accessing-byte-array (node-buf node-buf-offset node-page)
|
|---|
| 977 | (let* ((parent (load.p $btree_parent))
|
|---|
| 978 | (old-count (load.uw $btree_count))
|
|---|
| 979 | (count (if offset (1+ old-count) old-count))
|
|---|
| 980 | (sizes (make-array count))
|
|---|
| 981 | (insert-index (%lookup-node-sizes disk-cache node sizes old-count offset size))
|
|---|
| 982 | (new-used (+ used size))
|
|---|
| 983 | (last-new-used 0)
|
|---|
| 984 | (new-count 0)
|
|---|
| 985 | (last-size 0)
|
|---|
| 986 | (right-node (dc-cons-btree-node
|
|---|
| 987 | disk-cache btree parent (if leaf-p (ash 1 $btree_flags.leaf-bit) 0)))
|
|---|
| 988 | (right-used 4)
|
|---|
| 989 | (last-right-used 0)
|
|---|
| 990 | (right-count 0)
|
|---|
| 991 | (last-last-size 0))
|
|---|
| 992 | (declare (fixnum old-count count new-used new-count last-size right-used right-count
|
|---|
| 993 | last-new-used last-right-used last-last-size)
|
|---|
| 994 | (dynamic-extent sizes))
|
|---|
| 995 | (loop for i from (1- count) downto 0
|
|---|
| 996 | finally (error "Didn't find a split point")
|
|---|
| 997 | do
|
|---|
| 998 | (setq last-new-used new-used
|
|---|
| 999 | last-right-used right-used
|
|---|
| 1000 | last-last-size last-size)
|
|---|
| 1001 | (if leaf-p
|
|---|
| 1002 | (progn
|
|---|
| 1003 | (incf right-used (setq last-size (aref sizes i)))
|
|---|
| 1004 | (decf new-used last-size))
|
|---|
| 1005 | (progn
|
|---|
| 1006 | (incf right-used last-last-size)
|
|---|
| 1007 | (decf new-used (setq last-size (aref sizes i)))))
|
|---|
| 1008 | (when (>= right-used new-used)
|
|---|
| 1009 | (setq new-count i)
|
|---|
| 1010 | (let ((diff (- right-used new-used))
|
|---|
| 1011 | (old-diff (- last-new-used last-right-used)))
|
|---|
| 1012 | (when (> diff old-diff)
|
|---|
| 1013 | (setq new-used last-new-used
|
|---|
| 1014 | right-used last-right-used
|
|---|
| 1015 | new-count (1+ i))))
|
|---|
| 1016 | (setq last-size (aref sizes (1- new-count)))
|
|---|
| 1017 | (return)))
|
|---|
| 1018 | (debug-break "after figuring where to put split")
|
|---|
| 1019 | (with-locked-page (disk-cache right-node t right-buf right-offset nil right-page)
|
|---|
| 1020 | (setq right-count (- count new-count (if leaf-p 0 1)))
|
|---|
| 1021 | (let* ((insert-middle (if leaf-p
|
|---|
| 1022 | (eql insert-index (1- new-count))
|
|---|
| 1023 | (eql insert-index new-count)))
|
|---|
| 1024 | (insert-left (and insert-index (< insert-index new-count)))
|
|---|
| 1025 | (insert-not-right (or (not insert-index) insert-middle insert-left))
|
|---|
| 1026 | (end-ptr (+ node-buf-offset $btree_data new-used))
|
|---|
| 1027 | (node-ptr (- end-ptr
|
|---|
| 1028 | (if insert-left size 0)
|
|---|
| 1029 | (if leaf-p last-size 0)))
|
|---|
| 1030 | (last-string-length (if insert-middle
|
|---|
| 1031 | key-length
|
|---|
| 1032 | (accessing-byte-array (node-buf) (load.b node-ptr))))
|
|---|
| 1033 | (last-string (make-string last-string-length :element-type 'base-character)))
|
|---|
| 1034 | (declare (fixnum end-ptr node-ptr last-string-length)
|
|---|
| 1035 | (dynamic-extent last-string))
|
|---|
| 1036 | (debug-break "About to fill last-string")
|
|---|
| 1037 | (if insert-middle
|
|---|
| 1038 | (setq last-string key-string)
|
|---|
| 1039 | (%copy-byte-array-portion node-buf (1+ node-ptr) last-string-length
|
|---|
| 1040 | last-string 0))
|
|---|
| 1041 | (if insert-not-right
|
|---|
| 1042 | ; New entry goes in node or there is no new entry & this is a non-leaf node
|
|---|
| 1043 | (let ((bytes-to-shift 0))
|
|---|
| 1044 | (declare (fixnum bytes-to-shift))
|
|---|
| 1045 | (setq node-ptr (- (+ node-buf-offset $btree_data used) right-used))
|
|---|
| 1046 | (debug-break "Before first copy-byte-array-portion")
|
|---|
| 1047 | (%copy-byte-array-portion
|
|---|
| 1048 | node-buf node-ptr right-used right-buf (+ right-offset $btree_data) right-page)
|
|---|
| 1049 | (when insert-left
|
|---|
| 1050 | (setq node-ptr (+ node-buf-offset offset)
|
|---|
| 1051 | bytes-to-shift (- new-used (- offset $btree_data) size))
|
|---|
| 1052 | (debug-break "About to open up node")
|
|---|
| 1053 | (%copy-byte-array-portion
|
|---|
| 1054 | node-buf node-ptr bytes-to-shift node-buf (+ node-ptr size))
|
|---|
| 1055 | (%store-btree-entry node-buf node-ptr node-page
|
|---|
| 1056 | key-string key-length value value-imm? size)))
|
|---|
| 1057 | ; New entry goes in right-node. leaf-p is true.
|
|---|
| 1058 | (let* ((bytes-to-copy (- right-used size))
|
|---|
| 1059 | (bytes-before-offset (- offset $btree_data (- new-used 4)))
|
|---|
| 1060 | (bytes-after-offset (- bytes-to-copy bytes-before-offset))
|
|---|
| 1061 | (right-ptr (+ right-offset $btree_data)))
|
|---|
| 1062 | (declare (fixnum bytes-to-copy bytes-before-offset bytes-after-offset right-ptr))
|
|---|
| 1063 | (setq node-ptr (- (+ node-buf-offset $btree_data used) bytes-to-copy))
|
|---|
| 1064 | (debug-break "Before first copy-byte-array-portion when insert goes right")
|
|---|
| 1065 | (%copy-byte-array-portion
|
|---|
| 1066 | node-buf node-ptr bytes-before-offset right-buf right-ptr right-page)
|
|---|
| 1067 | (incf node-ptr bytes-before-offset)
|
|---|
| 1068 | (incf right-ptr bytes-before-offset)
|
|---|
| 1069 | (%store-btree-entry right-buf right-ptr right-page
|
|---|
| 1070 | key-string key-length value value-imm? size)
|
|---|
| 1071 | (incf right-ptr size)
|
|---|
| 1072 | (%copy-byte-array-portion
|
|---|
| 1073 | node-buf node-ptr bytes-after-offset right-buf right-ptr right-page)))
|
|---|
| 1074 | (accessing-byte-array (node-buf nil node-page)
|
|---|
| 1075 | (let ((parent-offset (%btree-search-for-subnode disk-cache parent node)))
|
|---|
| 1076 | (unless parent-offset
|
|---|
| 1077 | (error "Couldn't find node ~s in parent node ~s" node parent))
|
|---|
| 1078 | (setq node-ptr (+ node-buf-offset $btree_data new-used -4))
|
|---|
| 1079 | (debug-break "About to fix up node")
|
|---|
| 1080 | (if leaf-p
|
|---|
| 1081 | (store.p right-node node-ptr)
|
|---|
| 1082 | (when insert-middle
|
|---|
| 1083 | (store.p value node-ptr value-imm?)))
|
|---|
| 1084 | (incf node-ptr 4)
|
|---|
| 1085 | (accessing-disk-cache (disk-cache parent)
|
|---|
| 1086 | (store.p right-node parent-offset))
|
|---|
| 1087 | (fill.b node-ptr 0 (- used new-used))
|
|---|
| 1088 | (debug-break "About to insert in parent node")
|
|---|
| 1089 | (%btree-insert-in-node
|
|---|
| 1090 | disk-cache btree parent parent-offset last-string node nil last-string-length))))
|
|---|
| 1091 | (accessing-byte-array (node-buf node-buf-offset node-page)
|
|---|
| 1092 | (store.w new-count $btree_count)
|
|---|
| 1093 | (store.w (- (+ free used) new-used) $btree_free)
|
|---|
| 1094 | (store.w new-used $btree_used))
|
|---|
| 1095 | (accessing-byte-array (right-buf right-offset right-page)
|
|---|
| 1096 | (store.w right-count $btree_count)
|
|---|
| 1097 | (let ((total (+ (load.uw $btree_used) (load.uw $btree_free))))
|
|---|
| 1098 | (store.w (- total right-used) $btree_free)
|
|---|
| 1099 | (store.w right-used $btree_used)))
|
|---|
| 1100 | (unless leaf-p
|
|---|
| 1101 | (%btree-update-childrens-parents disk-cache right-node))
|
|---|
| 1102 | (debug-break "Done with %split-node")))
|
|---|
| 1103 | :split)))
|
|---|
| 1104 |
|
|---|
| 1105 | ; Attempt to shift the node left enough to make room for the new key-string
|
|---|
| 1106 | ; Works for non-leaf-nodes as well
|
|---|
| 1107 | ; Non-leaf nodes are harder since the shifting has to go through the parent.
|
|---|
| 1108 | ; This function exists because without it the space utilization is only 51%.
|
|---|
| 1109 | ; There is guaranteed (due to %create-insertion-path) to be enough room in the parent.
|
|---|
| 1110 | ; Returns true if it succeeded.
|
|---|
| 1111 | ; Otherwise, makes no changes and returns nil.
|
|---|
| 1112 | (defun %shift-node-left (disk-cache btree node free used leaf-p
|
|---|
| 1113 | offset key-string value value-imm? key-length size)
|
|---|
| 1114 | ;(let ((*enable-debug-break* (not leaf-p)))
|
|---|
| 1115 | (unless offset
|
|---|
| 1116 | ; If we're not inserting, we need to make room for the maximum node size
|
|---|
| 1117 | (setq size (dc-btree-max-key-size disk-cache btree)))
|
|---|
| 1118 | (unless (%btree-root-node-p disk-cache node)
|
|---|
| 1119 | (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
|
|---|
| 1120 | (declare (fixnum node-buf-offset))
|
|---|
| 1121 | (accessing-byte-array (node-buf node-buf-offset node-page)
|
|---|
| 1122 | (let* ((parent (load.p $btree_parent)))
|
|---|
| 1123 | (multiple-value-bind (node-offset left-offset)
|
|---|
| 1124 | (%btree-search-for-subnode disk-cache parent node)
|
|---|
| 1125 | (when left-offset
|
|---|
| 1126 | (let* ((left-node (accessing-disk-cache (disk-cache parent) (load.p left-offset)))
|
|---|
| 1127 | (left-free (accessing-disk-cache (disk-cache left-node) (load.uw $btree_free)))
|
|---|
| 1128 | (new-left-free left-free)
|
|---|
| 1129 | (left-used (accessing-disk-cache (disk-cache left-node) (load.uw $btree_used)))
|
|---|
| 1130 | (new-left-used left-used)
|
|---|
| 1131 | (new-free free)
|
|---|
| 1132 | (new-used used)
|
|---|
| 1133 | (count (load.uw $btree_count))
|
|---|
| 1134 | (sizes (make-array (the fixnum (1+ count))))
|
|---|
| 1135 | (bytes-moved 0)
|
|---|
| 1136 | (bytes-received 0)
|
|---|
| 1137 | (bytes-needed (- size free))
|
|---|
| 1138 | (bytes-to-offset (if offset (- offset $btree_data) most-positive-fixnum))
|
|---|
| 1139 | (count-diff 0)
|
|---|
| 1140 | (last-shifted-entry-size 0)
|
|---|
| 1141 | (initial-parent-size (- node-offset left-offset))
|
|---|
| 1142 | (parent-size initial-parent-size)
|
|---|
| 1143 | (new-parent-size (if leaf-p 0 parent-size)))
|
|---|
| 1144 | (declare (fixnum left-free new-left-free left-used new-left-used
|
|---|
| 1145 | free new-free used new-used count
|
|---|
| 1146 | bytes-moved bytes-needed bytes-to-offset
|
|---|
| 1147 | count-diff last-shifted-entry-size
|
|---|
| 1148 | initial-parent-size parent-size new-parent-size)
|
|---|
| 1149 | (dynamic-extent sizes))
|
|---|
| 1150 | (%lookup-node-sizes disk-cache node sizes count)
|
|---|
| 1151 | (with-locked-page (disk-cache left-node t left-buf left-buf-offset nil left-page)
|
|---|
| 1152 | (declare (fixnum left-buf-offset))
|
|---|
| 1153 | (with-locked-page (disk-cache parent t parent-buf parent-buf-offset nil parent-page)
|
|---|
| 1154 | (declare (fixnum parent-buf-offset))
|
|---|
| 1155 | (labels ((shift-left (new-entry-in-node)
|
|---|
| 1156 | (decf new-used bytes-moved)
|
|---|
| 1157 | (incf new-free bytes-moved)
|
|---|
| 1158 | (incf new-left-used bytes-received)
|
|---|
| 1159 | (decf new-left-free bytes-received)
|
|---|
| 1160 | (let* ((node-ptr (+ node-buf-offset $btree_data))
|
|---|
| 1161 | (left-ptr (+ left-buf-offset $btree_data left-used -4))
|
|---|
| 1162 | (bytes-to-last-string (+ (- bytes-moved last-shifted-entry-size) 4))
|
|---|
| 1163 | (bytes-to-copy (if (or leaf-p (not new-entry-in-node))
|
|---|
| 1164 | bytes-moved
|
|---|
| 1165 | bytes-to-last-string)))
|
|---|
| 1166 | (declare (fixnum node-ptr left-ptr bytes-to-last-string bytes-to-copy))
|
|---|
| 1167 | (debug-break "About to copy bytes left")
|
|---|
| 1168 | (unless leaf-p
|
|---|
| 1169 | (let ((parent-ptr (+ left-offset parent-buf-offset 4))
|
|---|
| 1170 | (parent-bytes (- parent-size 4)))
|
|---|
| 1171 | (declare (fixnum parent-ptr parent-bytes))
|
|---|
| 1172 | (incf left-ptr 4)
|
|---|
| 1173 | (%copy-byte-array-portion parent-buf parent-ptr parent-bytes
|
|---|
| 1174 | left-buf left-ptr left-page)
|
|---|
| 1175 | (incf left-ptr parent-bytes)))
|
|---|
| 1176 | (%copy-byte-array-portion node-buf node-ptr bytes-to-copy
|
|---|
| 1177 | left-buf left-ptr left-page)
|
|---|
| 1178 | (incf left-ptr bytes-to-copy)
|
|---|
| 1179 | (when leaf-p
|
|---|
| 1180 | (accessing-byte-array (left-buf nil left-page)
|
|---|
| 1181 | (store.p node left-ptr)))
|
|---|
| 1182 | (if new-entry-in-node
|
|---|
| 1183 | (let ((node-ptr (+ node-ptr bytes-to-last-string))
|
|---|
| 1184 | (parent-ptr (open-parent last-shifted-entry-size)))
|
|---|
| 1185 | (declare (fixnum node-ptr parent-ptr))
|
|---|
| 1186 | (debug-break "About to copy node to parent")
|
|---|
| 1187 | (%copy-byte-array-portion node-buf node-ptr (- last-shifted-entry-size 4)
|
|---|
| 1188 | parent-buf parent-ptr parent-page))
|
|---|
| 1189 | (let* ((parent-ptr (open-parent size))
|
|---|
| 1190 | (key-size (1+ key-length))
|
|---|
| 1191 | (fill-count (- (normalize-size key-size 4) key-size)))
|
|---|
| 1192 | (declare (fixnum parent-ptr key-size fill-count))
|
|---|
| 1193 | (debug-break "About to enter key-string in parent")
|
|---|
| 1194 | (accessing-byte-array (parent-buf 0 parent-page)
|
|---|
| 1195 | (store.b key-length parent-ptr))
|
|---|
| 1196 | (incf parent-ptr)
|
|---|
| 1197 | (%copy-byte-array-portion key-string 0 key-length
|
|---|
| 1198 | parent-buf parent-ptr parent-page)
|
|---|
| 1199 | (incf parent-ptr key-length)
|
|---|
| 1200 | (unless (eql 0 fill-count)
|
|---|
| 1201 | (accessing-byte-array (parent-buf 0 parent-page)
|
|---|
| 1202 | (fill.b parent-ptr 0 fill-count)))))
|
|---|
| 1203 | (debug-break "About to shift node contents left")
|
|---|
| 1204 | (%copy-byte-array-portion node-buf (+ node-ptr bytes-moved) new-used
|
|---|
| 1205 | node-buf node-ptr node-page)
|
|---|
| 1206 | (incf node-ptr new-used)
|
|---|
| 1207 | (accessing-byte-array (node-buf nil node-page)
|
|---|
| 1208 | (fill.b node-ptr 0 bytes-moved))
|
|---|
| 1209 | (debug-break "Exiting shift-left")
|
|---|
| 1210 | ))
|
|---|
| 1211 | (update-free-and-used ()
|
|---|
| 1212 | (accessing-byte-array (node-buf node-buf-offset node-page)
|
|---|
| 1213 | (store.w new-used $btree_used)
|
|---|
| 1214 | (store.w new-free $btree_free)
|
|---|
| 1215 | (store.w (- (load.uw $btree_count) count-diff) $btree_count))
|
|---|
| 1216 | (accessing-byte-array (left-buf left-buf-offset left-page)
|
|---|
| 1217 | (store.w new-left-used $btree_used)
|
|---|
| 1218 | (store.w new-left-free $btree_free)
|
|---|
| 1219 | (store.w (+ (load.uw $btree_count) count-diff) $btree_count))
|
|---|
| 1220 | (unless leaf-p
|
|---|
| 1221 | (%btree-update-childrens-parents
|
|---|
| 1222 | disk-cache left-node (+ left-buf-offset $btree_data left-used initial-parent-size -4)))
|
|---|
| 1223 | (debug-break "Free and used updated")
|
|---|
| 1224 | )
|
|---|
| 1225 | (open-parent (size)
|
|---|
| 1226 | (accessing-byte-array (parent-buf parent-buf-offset parent-page)
|
|---|
| 1227 | (let* ((old-size (- node-offset left-offset))
|
|---|
| 1228 | (size-diff (- old-size size))
|
|---|
| 1229 | (parent-used (load.uw $btree_used))
|
|---|
| 1230 | (parent-free (load.uw $btree_free))
|
|---|
| 1231 | (ptr (+ parent-buf-offset node-offset))
|
|---|
| 1232 | (bytes-to-move (- parent-used (- node-offset $btree_data))))
|
|---|
| 1233 | (declare (fixnum old-size size-diff parent-used parent-free
|
|---|
| 1234 | ptr bytes-to-move))
|
|---|
| 1235 | (unless (eql size-diff 0)
|
|---|
| 1236 | (debug-break "About to shift parent tail")
|
|---|
| 1237 | (%copy-byte-array-portion
|
|---|
| 1238 | parent-buf ptr bytes-to-move
|
|---|
| 1239 | parent-buf (- ptr size-diff) parent-page)
|
|---|
| 1240 | (when (> size-diff 0)
|
|---|
| 1241 | (incf ptr (- bytes-to-move size-diff))
|
|---|
| 1242 | (accessing-byte-array (parent-buf nil parent-page)
|
|---|
| 1243 | (fill.b ptr 0 size-diff)))
|
|---|
| 1244 | (store.w (- parent-used size-diff) $btree_used)
|
|---|
| 1245 | (store.w (+ parent-free size-diff) $btree_free))
|
|---|
| 1246 | (+ parent-buf-offset left-offset 4)))))
|
|---|
| 1247 | (declare (dynamic-extent #'shift-left #'update-free-and-used
|
|---|
| 1248 | #'open-parent))
|
|---|
| 1249 | (dotimes (i count (error "Didn't run over offset"))
|
|---|
| 1250 | (when (>= bytes-received left-free)
|
|---|
| 1251 | ; Ran out of room in left node
|
|---|
| 1252 | (return nil))
|
|---|
| 1253 | (when (>= bytes-moved bytes-needed)
|
|---|
| 1254 | ; The new entry now fits in node
|
|---|
| 1255 | (setq count-diff i)
|
|---|
| 1256 | (shift-left t)
|
|---|
| 1257 | (update-free-and-used)
|
|---|
| 1258 | (when offset
|
|---|
| 1259 | (%btree-insert-in-node disk-cache btree node (- offset bytes-moved)
|
|---|
| 1260 | key-string value value-imm? key-length))
|
|---|
| 1261 | (debug-break "Done with insertion in node")
|
|---|
| 1262 | ; #+bill (check-btree-consistency disk-cache btree)
|
|---|
| 1263 | (return t))
|
|---|
| 1264 | (when (>= bytes-moved bytes-to-offset)
|
|---|
| 1265 | (unless (eql bytes-moved bytes-to-offset)
|
|---|
| 1266 | (error "Inconsistency: offset was not at an entry boundary"))
|
|---|
| 1267 | (unless (or (not leaf-p) (>= new-left-free (+ size bytes-received)))
|
|---|
| 1268 | (debug-break "Couldn't shift left")
|
|---|
| 1269 | (return nil))
|
|---|
| 1270 | ; The new entry fits at the end of left-node
|
|---|
| 1271 | (setq count-diff i)
|
|---|
| 1272 | (shift-left nil)
|
|---|
| 1273 | (when leaf-p
|
|---|
| 1274 | (let ((left-ptr (+ left-buf-offset $btree_data new-left-used -4)))
|
|---|
| 1275 | (declare (fixnum left-ptr))
|
|---|
| 1276 | (debug-break "Storing new entry in left neighbor")
|
|---|
| 1277 | (%store-btree-entry left-buf left-ptr left-page
|
|---|
| 1278 | key-string key-length value value-imm? size)
|
|---|
| 1279 | (incf left-ptr size)
|
|---|
| 1280 | (accessing-byte-array (left-buf)
|
|---|
| 1281 | (store.p node left-ptr))
|
|---|
| 1282 | (incf new-left-used size)
|
|---|
| 1283 | (decf new-left-free size)
|
|---|
| 1284 | (accessing-byte-array (left-buf left-buf-offset)
|
|---|
| 1285 | (store.w (1+ (load.uw $btree_count)) $btree_count))))
|
|---|
| 1286 | (update-free-and-used)
|
|---|
| 1287 | (debug-break "Done with insertion in left neighbor")
|
|---|
| 1288 | ;#+bill (check-btree-consistency disk-cache btree)
|
|---|
| 1289 | (return t))
|
|---|
| 1290 | (setq last-shifted-entry-size (aref sizes i))
|
|---|
| 1291 | (if leaf-p
|
|---|
| 1292 | (progn
|
|---|
| 1293 | (incf bytes-moved last-shifted-entry-size)
|
|---|
| 1294 | (incf bytes-received last-shifted-entry-size))
|
|---|
| 1295 | (progn
|
|---|
| 1296 | (incf bytes-moved last-shifted-entry-size)
|
|---|
| 1297 | (incf bytes-received new-parent-size)
|
|---|
| 1298 | (setq new-parent-size last-shifted-entry-size)))))))))))))))
|
|---|
| 1299 |
|
|---|
| 1300 |
|
|---|
| 1301 | ; Attempt to shift the node right enough to make room for the new key-string
|
|---|
| 1302 | ; This is necessary because inserting in reverse order foils %shift-node-left
|
|---|
| 1303 | ; This doesn't handle the non-leaf case yet. It's hardly worth it.
|
|---|
| 1304 | (defun %shift-node-right (disk-cache btree node free used leaf-p
|
|---|
| 1305 | offset key-string value value-imm? key-length size)
|
|---|
| 1306 | (declare (fixnum free used))
|
|---|
| 1307 | ;(return-from %shift-node-right nil) ; not yet debugged.
|
|---|
| 1308 | (when (and leaf-p (not (%btree-root-node-p disk-cache node)))
|
|---|
| 1309 | (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
|
|---|
| 1310 | (accessing-byte-array (node-buf node-buf-offset node-page)
|
|---|
| 1311 | (let* ((parent (load.p $btree_parent)))
|
|---|
| 1312 | (multiple-value-bind (node-offset left-offset right-offset)
|
|---|
| 1313 | (%btree-search-for-subnode disk-cache parent node t)
|
|---|
| 1314 | (declare (ignore left-offset))
|
|---|
| 1315 | (when right-offset
|
|---|
| 1316 | (let* ((right-node (accessing-disk-cache (disk-cache parent) (load.p right-offset)))
|
|---|
| 1317 | (right-free (accessing-disk-cache (disk-cache right-node) (load.uw $btree_free)))
|
|---|
| 1318 | (new-right-free right-free)
|
|---|
| 1319 | (right-used (accessing-disk-cache (disk-cache right-node) (load.uw $btree_used)))
|
|---|
| 1320 | (new-right-used right-used)
|
|---|
| 1321 | (new-free free)
|
|---|
| 1322 | (new-used used)
|
|---|
| 1323 | (count (load.uw $btree_count))
|
|---|
| 1324 | (sizes (make-array (the fixnum (1+ count))))
|
|---|
| 1325 | (bytes-moved 0)
|
|---|
| 1326 | (bytes-needed (- size free))
|
|---|
| 1327 | (bytes-to-offset (- used (- offset $btree_data) 4))
|
|---|
| 1328 | (count-diff 0))
|
|---|
| 1329 | (declare (fixnum right-length right-offset right-free new-right-free
|
|---|
| 1330 | right-used new-right-used new-free new-used count
|
|---|
| 1331 | bytes-moved bytes-needed bytes-to-offset
|
|---|
| 1332 | count-diff last-shifted-entry-size)
|
|---|
| 1333 | (dynamic-extent sizes))
|
|---|
| 1334 | (%lookup-node-sizes disk-cache node sizes count)
|
|---|
| 1335 | (with-locked-page (disk-cache right-node t right-buf right-buf-offset nil right-page)
|
|---|
| 1336 | (flet ((shift-right (&optional (new-entry-size 0))
|
|---|
| 1337 | (decf new-used bytes-moved)
|
|---|
| 1338 | (incf new-free bytes-moved)
|
|---|
| 1339 | (incf new-right-used bytes-moved)
|
|---|
| 1340 | (decf new-right-free bytes-moved)
|
|---|
| 1341 | (let ((node-ptr (+ node-buf-offset $btree_data new-used -4))
|
|---|
| 1342 | (right-ptr (+ right-buf-offset $btree_data)))
|
|---|
| 1343 | (declare (fixnum node-ptr right-ptr))
|
|---|
| 1344 | (debug-break "About to copy bytes right")
|
|---|
| 1345 | (%copy-byte-array-portion right-buf right-ptr right-used
|
|---|
| 1346 | right-buf
|
|---|
| 1347 | (+ right-ptr new-entry-size bytes-moved)
|
|---|
| 1348 | right-page)
|
|---|
| 1349 | (incf right-ptr new-entry-size)
|
|---|
| 1350 | (%copy-byte-array-portion node-buf node-ptr bytes-moved
|
|---|
| 1351 | right-buf right-ptr right-page)
|
|---|
| 1352 | (accessing-byte-array (node-buf nil node-page)
|
|---|
| 1353 | (store.p right-node node-ptr))
|
|---|
| 1354 | (incf node-ptr 4)
|
|---|
| 1355 | (accessing-byte-array (node-buf nil node-page)
|
|---|
| 1356 | (fill.b node-ptr 0 bytes-moved))
|
|---|
| 1357 | (debug-break "Exiting shift-right")
|
|---|
| 1358 | ))
|
|---|
| 1359 | (update-free-and-used ()
|
|---|
| 1360 | (accessing-byte-array (node-buf node-buf-offset node-page)
|
|---|
| 1361 | (store.w new-used $btree_used)
|
|---|
| 1362 | (store.w new-free $btree_free)
|
|---|
| 1363 | (store.w (- (load.uw $btree_count) count-diff) $btree_count))
|
|---|
| 1364 | (accessing-byte-array (right-buf right-buf-offset right-page)
|
|---|
| 1365 | (store.w new-right-used $btree_used)
|
|---|
| 1366 | (store.w new-right-free $btree_free)
|
|---|
| 1367 | (store.w (+ (load.uw $btree_count) count-diff) $btree_count))
|
|---|
| 1368 | (debug-break "Free and used updated")
|
|---|
| 1369 | )
|
|---|
| 1370 | (replace-parent-entry (i &optional string (size (aref sizes i)))
|
|---|
| 1371 | (declare (fixnum size))
|
|---|
| 1372 | (with-locked-page (disk-cache parent t parent-buf parent-buf-offset nil parent-page)
|
|---|
| 1373 | (accessing-byte-array (parent-buf parent-buf-offset parent-page)
|
|---|
| 1374 | (let* ((last-entry-ptr (+ node-buf-offset $btree_data
|
|---|
| 1375 | (- new-used size)))
|
|---|
| 1376 | (length (if string
|
|---|
| 1377 | (length string)
|
|---|
| 1378 | (accessing-byte-array (node-buf)
|
|---|
| 1379 | (load.b last-entry-ptr))))
|
|---|
| 1380 | (temp-string (make-string length :element-type 'base-character)))
|
|---|
| 1381 | (declare (fixnum last-entry-ptr length)
|
|---|
| 1382 | (dynamic-extent temp-string))
|
|---|
| 1383 | (unless string
|
|---|
| 1384 | (debug-break "Filling string")
|
|---|
| 1385 | (setq string temp-string)
|
|---|
| 1386 | (%copy-byte-array-portion node-buf (1+ last-entry-ptr) length
|
|---|
| 1387 | string 0))
|
|---|
| 1388 | (let* ((old-size (- right-offset node-offset))
|
|---|
| 1389 | (size-diff (- old-size size))
|
|---|
| 1390 | (ptr (+ parent-buf-offset right-offset)))
|
|---|
| 1391 | (declare (fixnum old-size size-diff ptr))
|
|---|
| 1392 | (unless (eql size-diff 0)
|
|---|
| 1393 | (let* ((parent-used (load.uw $btree_used))
|
|---|
| 1394 | (parent-free (load.uw $btree_free))
|
|---|
| 1395 | (bytes-to-move (- parent-used (- right-offset $btree_data))))
|
|---|
| 1396 | (declare (fixnum parent-used parent-free bytes-to-move))
|
|---|
| 1397 | (debug-break "About to shift parent tail")
|
|---|
| 1398 | (%copy-byte-array-portion
|
|---|
| 1399 | parent-buf ptr bytes-to-move
|
|---|
| 1400 | parent-buf (- ptr size-diff) parent-page)
|
|---|
| 1401 | (when (> size-diff 0)
|
|---|
| 1402 | (incf ptr (- bytes-to-move size-diff))
|
|---|
| 1403 | (accessing-byte-array (parent-buf nil parent-page)
|
|---|
| 1404 | (fill.b ptr 0 size-diff)))
|
|---|
| 1405 | (store.w (- parent-used size-diff) $btree_used)
|
|---|
| 1406 | (store.w (+ parent-free size-diff) $btree_free)))
|
|---|
| 1407 | (setq ptr (+ parent-buf-offset node-offset))
|
|---|
| 1408 | (debug-break "About to enter node string in parent")
|
|---|
| 1409 | (%store-btree-entry parent-buf ptr parent-page
|
|---|
| 1410 | string length (load.p node-offset) nil size)))))))
|
|---|
| 1411 | (declare (dynamic-extent #'shift-right #'update-free-and-used
|
|---|
| 1412 | #'replace-parent-entry))
|
|---|
| 1413 | (loop for i from (1- count) downto 0 do
|
|---|
| 1414 | (when (>= bytes-moved right-free)
|
|---|
| 1415 | ; Ran out of room in right node
|
|---|
| 1416 | (return nil))
|
|---|
| 1417 | (when (>= bytes-moved bytes-needed)
|
|---|
| 1418 | ; The new entry now fits in node
|
|---|
| 1419 | (setq count-diff (- count i 1))
|
|---|
| 1420 | (shift-right)
|
|---|
| 1421 | (update-free-and-used)
|
|---|
| 1422 | (if (eql (- offset $btree_data) (- new-used 4))
|
|---|
| 1423 | (replace-parent-entry i key-string size)
|
|---|
| 1424 | (replace-parent-entry i))
|
|---|
| 1425 | (%btree-insert-in-node disk-cache btree node offset
|
|---|
| 1426 | key-string value value-imm? key-length)
|
|---|
| 1427 | (debug-break "Done with insertion in node")
|
|---|
| 1428 | ; #+bill (check-btree-consistency disk-cache btree)
|
|---|
| 1429 | (return t))
|
|---|
| 1430 | (when (>= bytes-moved bytes-to-offset)
|
|---|
| 1431 | (unless (eql bytes-moved bytes-to-offset)
|
|---|
| 1432 | (error "Inconsistency: offset was not at an entry boundary"))
|
|---|
| 1433 | (unless (>= new-right-free (+ size bytes-moved))
|
|---|
| 1434 | (debug-break "Couldn't shift right")
|
|---|
| 1435 | (return nil))
|
|---|
| 1436 | ; The new entry fits at the beginning of right-node
|
|---|
| 1437 | (setq count-diff (- count i 1))
|
|---|
| 1438 | (shift-right size)
|
|---|
| 1439 | (let ((right-ptr (+ right-buf-offset $btree_data)))
|
|---|
| 1440 | (declare (fixnum right-ptr))
|
|---|
| 1441 | (debug-break "Storing new entry in right neighbor")
|
|---|
| 1442 | (%store-btree-entry right-buf right-ptr right-page
|
|---|
| 1443 | key-string key-length value value-imm? size)
|
|---|
| 1444 | (incf new-right-used size)
|
|---|
| 1445 | (decf new-right-free size)
|
|---|
| 1446 | (update-free-and-used)
|
|---|
| 1447 | (accessing-byte-array (right-buf right-buf-offset)
|
|---|
| 1448 | (store.w (1+ (load.uw $btree_count)) $btree_count))
|
|---|
| 1449 | (replace-parent-entry i)
|
|---|
| 1450 | (debug-break "Done with insertion in right neighbor")
|
|---|
| 1451 | ; #+bill (check-btree-consistency disk-cache btree)
|
|---|
| 1452 | (return t)))
|
|---|
| 1453 | (incf bytes-moved (aref sizes i)))))))))))))
|
|---|
| 1454 |
|
|---|
| 1455 | ; Much like btree-find-leaf-node, but it makes sure there's room
|
|---|
| 1456 | ; for an entry of max-key-size in every node on the way to the leaf.
|
|---|
| 1457 | ; This is simpler than letting node splits "bubble up" and it also
|
|---|
| 1458 | ; works better in a multi-processing environment (this code does
|
|---|
| 1459 | ; not yet work in a multi-processing environment, but using this
|
|---|
| 1460 | ; algorithm will allow multiple processes to access a single btree
|
|---|
| 1461 | ; at the same time).
|
|---|
| 1462 | (defun %create-insertion-path (disk-cache btree key-string max-key-size)
|
|---|
| 1463 | (let ((node (dc-%svref disk-cache btree $btree.root))
|
|---|
| 1464 | (case-sensitive? (not (logbitp $btree-type_string-equal-bit
|
|---|
| 1465 | (dc-%svref disk-cache btree $btree.type)))))
|
|---|
| 1466 | (loop
|
|---|
| 1467 | (accessing-disk-cache (disk-cache node)
|
|---|
| 1468 | (let* ((offset (%btree-search-node
|
|---|
| 1469 | disk-cache node key-string case-sensitive?))
|
|---|
| 1470 | (flags (load.w $btree_flags))
|
|---|
| 1471 | (leaf-p (logbitp $btree_flags.leaf-bit flags))
|
|---|
| 1472 | (root-p (logbitp $btree_flags.root-bit flags)))
|
|---|
| 1473 | (when leaf-p
|
|---|
| 1474 | (when root-p
|
|---|
| 1475 | (%make-new-root-node disk-cache btree node))
|
|---|
| 1476 | (return t))
|
|---|
| 1477 | (let ((free (load.uw $btree_free)))
|
|---|
| 1478 | (if (>= free max-key-size)
|
|---|
| 1479 | (setq node (read-long disk-cache (+ node offset)))
|
|---|
| 1480 | (progn
|
|---|
| 1481 | (when root-p
|
|---|
| 1482 | (%make-new-root-node disk-cache btree node))
|
|---|
| 1483 | (%split-node disk-cache btree node free (load.uw $btree_used) nil)
|
|---|
| 1484 | (setq node (load.p $btree_parent)))))) ; may have moved to new right neighbor
|
|---|
| 1485 | (require-satisfies dc-vector-subtype-p
|
|---|
| 1486 | disk-cache node $v_btree-node)))))
|
|---|
| 1487 |
|
|---|
| 1488 | ; node is the current root node. Creates a new root node
|
|---|
| 1489 | ; with node as its only child.
|
|---|
| 1490 | (defun %make-new-root-node (disk-cache btree node)
|
|---|
| 1491 | (let ((root (dc-cons-btree-node disk-cache btree btree (ash 1 $btree_flags.root-bit))))
|
|---|
| 1492 | (accessing-disk-cache (disk-cache root)
|
|---|
| 1493 | (store.p node $btree_data))
|
|---|
| 1494 | (setf (dc-%svref disk-cache btree $btree.root) root)
|
|---|
| 1495 | (setf (dc-%svref disk-cache btree $btree.depth t)
|
|---|
| 1496 | (1+ (dc-%svref disk-cache btree $btree.depth)))
|
|---|
| 1497 | (accessing-disk-cache (disk-cache node)
|
|---|
| 1498 | (store.p root $btree_parent)
|
|---|
| 1499 | (store.w (logandc1 (ash 1 $btree_flags.root-bit) (load.w $btree_flags))
|
|---|
| 1500 | $btree_flags))))
|
|---|
| 1501 |
|
|---|
| 1502 | ; This will only ever do anything if you have large keys
|
|---|
| 1503 | ; Maybe it's not worth the effort, but it doesn't happen very often
|
|---|
| 1504 | ; (unless there are large keys, and then it's worth it)
|
|---|
| 1505 | (defun %sew-up-insertion-path (disk-cache btree node leaf-p)
|
|---|
| 1506 | (accessing-disk-cache (disk-cache node)
|
|---|
| 1507 | (let* ((free (load.uw $btree_free))
|
|---|
| 1508 | (used (load.uw $btree_used))
|
|---|
| 1509 | (count (load.uw $btree_count))
|
|---|
| 1510 | (unmerged-node (%btree-merge-with-neighbors
|
|---|
| 1511 | disk-cache btree node free used count leaf-p)))
|
|---|
| 1512 | (when unmerged-node
|
|---|
| 1513 | (accessing-disk-cache (disk-cache unmerged-node)
|
|---|
| 1514 | (%sew-up-insertion-path disk-cache btree (load.p $btree_parent) nil))))))
|
|---|
| 1515 |
|
|---|
| 1516 | ;; Store a single entry into a buffer.
|
|---|
| 1517 | (defun %store-btree-entry (buf offset page string string-length value value-imm? &optional size)
|
|---|
| 1518 | (declare (fixnum offset string-length))
|
|---|
| 1519 | (let ((p offset))
|
|---|
| 1520 | (declare (fixnum p))
|
|---|
| 1521 | (accessing-byte-array (buf nil page)
|
|---|
| 1522 | (store.p value p value-imm?)
|
|---|
| 1523 | (store.b string-length (incf p 4))
|
|---|
| 1524 | (store.string string (incf p 1) string-length)
|
|---|
| 1525 | (incf p string-length)
|
|---|
| 1526 | (let* ((bytes (+ 5 string-length))
|
|---|
| 1527 | (filler (- (or size (setq size (normalize-size bytes 4)))
|
|---|
| 1528 | bytes)))
|
|---|
| 1529 | (declare (fixnum bytes filler))
|
|---|
| 1530 | (when (> filler 0)
|
|---|
| 1531 | ; This is for us poor humans.
|
|---|
| 1532 | (fill.b p 0 filler)))))
|
|---|
| 1533 | size)
|
|---|
| 1534 |
|
|---|
| 1535 |
|
|---|
| 1536 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 1537 | ;;
|
|---|
| 1538 | ;; Code to support deletion
|
|---|
| 1539 | ;;
|
|---|
| 1540 |
|
|---|
| 1541 | (defun %btree-delete-from-node (disk-cache btree node offset leaf-p)
|
|---|
| 1542 | (declare (fixnum offset))
|
|---|
| 1543 | (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
|
|---|
| 1544 | (accessing-byte-array (node-buf node-buf-offset node-page)
|
|---|
| 1545 | (let* ((size (normalize-size (+ 5 (load.b (+ offset 4))) 4))
|
|---|
| 1546 | (free (load.uw $btree_free))
|
|---|
| 1547 | (new-free (+ free size))
|
|---|
| 1548 | (used (load.uw $btree_used))
|
|---|
| 1549 | (new-used (- used size))
|
|---|
| 1550 | (count (load.uw $btree_count))
|
|---|
| 1551 | (new-count (1- count))
|
|---|
| 1552 | (p (+ node-buf-offset offset))
|
|---|
| 1553 | (bytes-to-copy (- used size (- offset $btree_data))))
|
|---|
| 1554 | (declare (fixnum size free new-free used new-used count new-count p bytes-to-copy))
|
|---|
| 1555 | (debug-break "About to delete from node")
|
|---|
| 1556 | (%copy-byte-array-portion node-buf (+ p size) bytes-to-copy
|
|---|
| 1557 | node-buf p node-page)
|
|---|
| 1558 | (fill.b (+ $btree_data new-used) 0 size)
|
|---|
| 1559 | (store.w new-free $btree_free)
|
|---|
| 1560 | (store.w new-used $btree_used)
|
|---|
| 1561 | (store.w new-count $btree_count)
|
|---|
| 1562 | (debug-break "Deleted from node")
|
|---|
| 1563 | (%btree-merge-with-neighbors
|
|---|
| 1564 | disk-cache btree node new-free new-used new-count leaf-p)))))
|
|---|
| 1565 |
|
|---|
| 1566 | ; Returns the last node on the way up the parent chain that could not be
|
|---|
| 1567 | ; merged with either neighbor, or NIL if it got all the way to the root.
|
|---|
| 1568 |
|
|---|
| 1569 | (defun %btree-merge-with-neighbors (disk-cache btree node free used count leaf-p)
|
|---|
| 1570 | (if (%btree-root-node-p disk-cache node)
|
|---|
| 1571 | (when (eql 0 count)
|
|---|
| 1572 | ; delete the root node, unless it is also the leaf node
|
|---|
| 1573 | (unless (%btree-leaf-node-p disk-cache node)
|
|---|
| 1574 | (accessing-disk-cache (disk-cache node)
|
|---|
| 1575 | (unless (eql 4 (load.uw $btree_used))
|
|---|
| 1576 | (error "Inconsistency: root should be empty, but isn't"))
|
|---|
| 1577 | (let ((new-root (load.p $btree_data)))
|
|---|
| 1578 | (debug-break "About to install new root")
|
|---|
| 1579 | (setf (dc-%svref disk-cache btree $btree.root) new-root)
|
|---|
| 1580 | (setf (dc-%svref disk-cache btree $btree.depth t)
|
|---|
| 1581 | (1- (dc-%svref disk-cache btree $btree.depth)))
|
|---|
| 1582 | (accessing-disk-cache (disk-cache new-root)
|
|---|
| 1583 | (store.p btree $btree_parent)
|
|---|
| 1584 | (store.w (logior (ash 1 $btree_flags.root-bit)
|
|---|
| 1585 | (load.uw $btree_flags))
|
|---|
| 1586 | $btree_flags))
|
|---|
| 1587 | (debug-break "Installed new root")
|
|---|
| 1588 | (dc-free-btree-node disk-cache btree node)
|
|---|
| 1589 | nil))))
|
|---|
| 1590 | (let ((parent (accessing-disk-cache (disk-cache node) (load.p $btree_parent))))
|
|---|
| 1591 | (multiple-value-bind (node-offset left-offset) (%btree-search-for-subnode disk-cache parent node)
|
|---|
| 1592 | (unless node-offset
|
|---|
| 1593 | (error "Inconsistency: didn't find node: ~s in parent: ~s" node parent))
|
|---|
| 1594 | (accessing-disk-cache (disk-cache parent)
|
|---|
| 1595 | (when left-offset
|
|---|
| 1596 | (let ((left-node (load.p left-offset))
|
|---|
| 1597 | ; Initializes parent size to -4 if leaf-p, which is correct since
|
|---|
| 1598 | ; when merging two nodes, the pointer from the left node to the
|
|---|
| 1599 | ; right node is eliminated, making the data take 4 bytes less.
|
|---|
| 1600 | (parent-size (- (if leaf-p 0 (- node-offset left-offset)) 4)))
|
|---|
| 1601 | (declare (fixnum parent-size))
|
|---|
| 1602 | (accessing-disk-cache (disk-cache left-node)
|
|---|
| 1603 | (let ((left-free (load.uw $btree_free)))
|
|---|
| 1604 | (declare (fixnum left-free))
|
|---|
| 1605 | (when (>= left-free (+ used parent-size))
|
|---|
| 1606 | (debug-break "About to merge with left neighbor")
|
|---|
| 1607 | (return-from %btree-merge-with-neighbors
|
|---|
| 1608 | (%btree-merge-nodes
|
|---|
| 1609 | disk-cache btree left-node node parent left-offset node-offset leaf-p)))))))
|
|---|
| 1610 | (let ((end-offset (+ $btree_data -4 (load.uw $btree_used))))
|
|---|
| 1611 | (declare (fixnum end-offset))
|
|---|
| 1612 | (when (< node-offset end-offset)
|
|---|
| 1613 | (let* ((right-length (load.b (+ node-offset 4)))
|
|---|
| 1614 | (right-offset (+ node-offset (normalize-size (+ 5 right-length) 4)))
|
|---|
| 1615 | (right-node (load.p right-offset))
|
|---|
| 1616 | (parent-size (- (if leaf-p 0 (- right-offset node-offset)) 4)))
|
|---|
| 1617 | (declare (fixnum right-offset parent-size))
|
|---|
| 1618 | (accessing-disk-cache (disk-cache right-node)
|
|---|
| 1619 | (let ((right-used (load.uw $btree_used)))
|
|---|
| 1620 | (when (>= free (+ right-used parent-size))
|
|---|
| 1621 | (debug-break "About to merge with right neighbor")
|
|---|
| 1622 | (return-from %btree-merge-with-neighbors
|
|---|
| 1623 | (%btree-merge-nodes
|
|---|
| 1624 | disk-cache btree node right-node parent node-offset right-offset leaf-p))))))))
|
|---|
| 1625 | node)))))
|
|---|
| 1626 |
|
|---|
| 1627 | ; We know that there's room to merge the nodes. Do it.
|
|---|
| 1628 | ; It's important that this code merges into the LEFT node as that ensures that the
|
|---|
| 1629 | ; first leaf node remains constant (the btree points at it and p-map-btree relies on that fact).
|
|---|
| 1630 | ; (You could instead update $btree.first-leaf as necessary).
|
|---|
| 1631 | (defun %btree-merge-nodes (disk-cache btree left-node right-node parent left-offset right-offset leaf-p)
|
|---|
| 1632 | (declare (fixnum left-offset right-offset))
|
|---|
| 1633 | (with-locked-page (disk-cache parent nil parent-buf parent-buf-offset)
|
|---|
| 1634 | (with-locked-page (disk-cache left-node t left-buf left-buf-offset nil left-page)
|
|---|
| 1635 | (with-locked-page (disk-cache right-node nil right-buf right-buf-offset)
|
|---|
| 1636 | (accessing-byte-array (left-buf left-buf-offset)
|
|---|
| 1637 | (let* ((p (+ left-buf-offset $btree_data (load.uw $btree_used)))
|
|---|
| 1638 | (right-used (accessing-byte-array (right-buf right-buf-offset)
|
|---|
| 1639 | (load.uw $btree_used)))
|
|---|
| 1640 | (count-inc (accessing-byte-array (right-buf right-buf-offset)
|
|---|
| 1641 | (load.uw $btree_count)))
|
|---|
| 1642 | (used-inc right-used))
|
|---|
| 1643 | (declare (fixnum p right-used count-inc used-inc))
|
|---|
| 1644 | (if leaf-p
|
|---|
| 1645 | (progn
|
|---|
| 1646 | (decf p 4)
|
|---|
| 1647 | (decf used-inc 4))
|
|---|
| 1648 | (let ((size (- right-offset left-offset 4)))
|
|---|
| 1649 | (declare (fixnum size))
|
|---|
| 1650 | (debug-break "About to copy parent info")
|
|---|
| 1651 | (%copy-byte-array-portion parent-buf (+ parent-buf-offset left-offset 4) size
|
|---|
| 1652 | left-buf p left-page)
|
|---|
| 1653 | (incf used-inc size)
|
|---|
| 1654 | (incf count-inc)
|
|---|
| 1655 | (incf p size)))
|
|---|
| 1656 | (debug-break "About to copy right-buf info")
|
|---|
| 1657 | (%copy-byte-array-portion right-buf (+ right-buf-offset $btree_data) right-used
|
|---|
| 1658 | left-buf p left-page)
|
|---|
| 1659 | (store.w (+ (load.uw $btree_used) used-inc) $btree_used)
|
|---|
| 1660 | (store.w (- (load.uw $btree_free) used-inc) $btree_free)
|
|---|
| 1661 | (store.w (+ (load.uw $btree_count) count-inc) $btree_count)
|
|---|
| 1662 | (dc-free-btree-node disk-cache btree right-node)
|
|---|
| 1663 | (accessing-byte-array (parent-buf parent-buf-offset)
|
|---|
| 1664 | (store.p left-node right-offset))
|
|---|
| 1665 | (unless leaf-p
|
|---|
| 1666 | (%btree-update-childrens-parents disk-cache left-node p))
|
|---|
| 1667 | (debug-break "Nodes merged")
|
|---|
| 1668 | (%btree-delete-from-node disk-cache btree parent left-offset nil)))))))
|
|---|
| 1669 |
|
|---|
| 1670 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 1671 | ;;;
|
|---|
| 1672 | ;;; Consistency checking and statistics gathering
|
|---|
| 1673 | ;;;
|
|---|
| 1674 |
|
|---|
| 1675 | (defun check-btree (btree)
|
|---|
| 1676 | (check-btree-consistency (pheap-disk-cache (pptr-pheap btree)) (pptr-pointer btree)))
|
|---|
| 1677 |
|
|---|
| 1678 | ; Checks consistency and returns how full the btree is.
|
|---|
| 1679 | (defun check-btree-consistency (disk-cache btree &optional check-nodes-and-count?)
|
|---|
| 1680 | (let ((root (accessing-disk-cache (disk-cache)
|
|---|
| 1681 | (svref.p btree $btree.root))))
|
|---|
| 1682 | (multiple-value-bind (free used nodes count leaf-free leaf-used leaf-nodes non-leaf-free non-leaf-used non-leaf-nodes)
|
|---|
| 1683 | (check-btree-node-consistency disk-cache root btree)
|
|---|
| 1684 | (when check-nodes-and-count?
|
|---|
| 1685 | (let ((missing-nodes (- (accessing-disk-cache (disk-cache)
|
|---|
| 1686 | (svref.p btree $btree.nodes))
|
|---|
| 1687 | nodes)))
|
|---|
| 1688 | (unless (eql missing-nodes 0)
|
|---|
| 1689 | (cerror "Continue" "~d. missing nodes" missing-nodes)))
|
|---|
| 1690 | (let ((missing-entries (- (accessing-disk-cache (disk-cache)
|
|---|
| 1691 | (svref.p btree $btree.count))
|
|---|
| 1692 | count)))
|
|---|
| 1693 | (unless (eql 0 missing-entries)
|
|---|
| 1694 | (cerror "Continue" "~d. missing entries" missing-entries))))
|
|---|
| 1695 | (values (if (eql used 0) 0 (/ used (float (+ free used))))
|
|---|
| 1696 | nodes
|
|---|
| 1697 | count
|
|---|
| 1698 | (if (eql leaf-used 0) 0 (/ leaf-used (float (+ leaf-free leaf-used))))
|
|---|
| 1699 | leaf-nodes
|
|---|
| 1700 | (if (eql non-leaf-used 0) 0 (/ non-leaf-used (float (+ non-leaf-free non-leaf-used))))
|
|---|
| 1701 | non-leaf-nodes))))
|
|---|
| 1702 |
|
|---|
| 1703 | (defun check-btree-node-consistency (disk-cache node parent)
|
|---|
| 1704 | (require-satisfies dc-vector-subtype-p disk-cache node $v_btree-node)
|
|---|
| 1705 | (accessing-disk-cache (disk-cache node)
|
|---|
| 1706 | (let* ((vector-size (%vector-size.p node))
|
|---|
| 1707 | (free (load.uw $btree_free))
|
|---|
| 1708 | (used (load.uw $btree_used))
|
|---|
| 1709 | (count (load.uw $btree_count))
|
|---|
| 1710 | (nodes 1)
|
|---|
| 1711 | (sizes (make-array (the fixnum (1+ count))))
|
|---|
| 1712 | (leaf? (%btree-leaf-node-p disk-cache node))
|
|---|
| 1713 | (total-count (if leaf? count 0))
|
|---|
| 1714 | (p $btree_data)
|
|---|
| 1715 | (leaf-free 0)
|
|---|
| 1716 | (leaf-used 0)
|
|---|
| 1717 | (leaf-nodes 0)
|
|---|
| 1718 | (non-leaf-free 0)
|
|---|
| 1719 | (non-leaf-used 0)
|
|---|
| 1720 | (non-leaf-nodes 0))
|
|---|
| 1721 | (declare (fixnum free used count p leaf-free leaf-used leaf-nodes non-leaf-free non-leaf-used non-leaf-nodes)
|
|---|
| 1722 | (dynamic-extent sizes))
|
|---|
| 1723 | (if leaf?
|
|---|
| 1724 | (setq leaf-free free leaf-used used leaf-nodes 1)
|
|---|
| 1725 | (setq non-leaf-free free non-leaf-used used non-leaf-nodes 1))
|
|---|
| 1726 | (unless (eql parent (load.l $btree_parent))
|
|---|
| 1727 | (error "parent should be: #x~x, was: #x~x" parent (load.l $btree_parent)))
|
|---|
| 1728 | (unless (eql (- vector-size (- $btree_data $v_data)) (+ free used))
|
|---|
| 1729 | (cerror "Continue."
|
|---|
| 1730 | "~&(+ free used) is wrong. Node: #x~x, free: #x~x, used: #x~x~%"
|
|---|
| 1731 | node free used))
|
|---|
| 1732 | (%lookup-node-sizes disk-cache node sizes count)
|
|---|
| 1733 | (setf (aref sizes count) 0)
|
|---|
| 1734 | (unless leaf?
|
|---|
| 1735 | (dotimes (i (1+ count))
|
|---|
| 1736 | (multiple-value-bind (c-free c-used c-nodes c-count
|
|---|
| 1737 | c-leaf-free c-leaf-used c-leaf-nodes
|
|---|
| 1738 | c-non-leaf-free c-non-leaf-used c-non-leaf-nodes)
|
|---|
| 1739 | (check-btree-node-consistency disk-cache (load.l p) node)
|
|---|
| 1740 | (incf free c-free)
|
|---|
| 1741 | (incf used c-used)
|
|---|
| 1742 | (incf leaf-free c-leaf-free)
|
|---|
| 1743 | (incf leaf-used c-leaf-used)
|
|---|
| 1744 | (incf leaf-nodes c-leaf-nodes)
|
|---|
| 1745 | (incf non-leaf-free c-non-leaf-free)
|
|---|
| 1746 | (incf non-leaf-used c-non-leaf-used)
|
|---|
| 1747 | (incf nodes c-nodes)
|
|---|
| 1748 | (incf non-leaf-nodes c-non-leaf-nodes)
|
|---|
| 1749 | (incf total-count c-count))
|
|---|
| 1750 | (incf p (aref sizes i))))
|
|---|
| 1751 | (values free used nodes total-count leaf-free leaf-used leaf-nodes non-leaf-free non-leaf-used non-leaf-nodes))))
|
|---|
| 1752 |
|
|---|
| 1753 |
|
|---|
| 1754 | #|
|
|---|
| 1755 | ; Test code. Stores symbols in a btree.
|
|---|
| 1756 | (defun init-temp-btree ()
|
|---|
| 1757 | (declare (special pheap dc b))
|
|---|
| 1758 | (when (boundp 'pheap)
|
|---|
| 1759 | (close-pheap pheap))
|
|---|
| 1760 | (delete-file "temp.pheap")
|
|---|
| 1761 | (create-pheap "temp.pheap")
|
|---|
| 1762 | (setq pheap (open-pheap "temp.pheap")
|
|---|
| 1763 | dc (pheap-disk-cache pheap))
|
|---|
| 1764 | (dolist (w (windows :class 'inspector::inspector-window))
|
|---|
| 1765 | (window-close w))
|
|---|
| 1766 | (setq b (dc-make-btree dc))
|
|---|
| 1767 | #+ignore
|
|---|
| 1768 | (let ((w (inspect dc)))
|
|---|
| 1769 | (set-view-size w #@(413 384))
|
|---|
| 1770 | (scroll-to-address (inspector::inspector-view w) (dc-%svref dc b $btree.root))))
|
|---|
| 1771 |
|
|---|
| 1772 | (defvar *symbols* nil)
|
|---|
| 1773 | (defvar *value-offset* 0)
|
|---|
| 1774 |
|
|---|
| 1775 | (defun *symbols* ()
|
|---|
| 1776 | (let ((syms *symbols*))
|
|---|
| 1777 | (unless syms
|
|---|
| 1778 | (let ((hash (make-hash-table :test 'equal)))
|
|---|
| 1779 | (do-symbols (s)
|
|---|
| 1780 | (unless (gethash (symbol-name s) hash)
|
|---|
| 1781 | (setf (gethash (symbol-name s) hash) t)
|
|---|
| 1782 | (push s syms))))
|
|---|
| 1783 | (setq *symbols* syms
|
|---|
| 1784 | *value-offset* 0))
|
|---|
| 1785 | syms))
|
|---|
| 1786 |
|
|---|
| 1787 | (defun store-symbols (&optional (step-sym 0) check? (check-sym 0))
|
|---|
| 1788 | (declare (special dc b))
|
|---|
| 1789 | (let ((syms (*symbols*))
|
|---|
| 1790 | (check-check-sym? nil)
|
|---|
| 1791 | (i 0))
|
|---|
| 1792 | (dolist (s syms)
|
|---|
| 1793 | (let ((string (symbol-name s))
|
|---|
| 1794 | (value (+ i *value-offset*)))
|
|---|
| 1795 | (if (eq s step-sym)
|
|---|
| 1796 | (step
|
|---|
| 1797 | (dc-btree-store dc b string (require-type value 'fixnum) t))
|
|---|
| 1798 | (dc-btree-store dc b string (require-type value 'fixnum) t))
|
|---|
| 1799 | (when (eql s check-sym) (setq check-check-sym? i))
|
|---|
| 1800 | (incf i)
|
|---|
| 1801 | (when check-check-sym?
|
|---|
| 1802 | (unless (eql check-check-sym? (dc-btree-lookup dc b (symbol-name check-sym)))
|
|---|
| 1803 | (cerror "Continue" "Can't find ~s" check-sym)))
|
|---|
| 1804 | (when (and check? (or (not (fixnump check?))
|
|---|
| 1805 | (eql 0 (mod i check?))))
|
|---|
| 1806 | (format t "~&Checking ~d..." i)
|
|---|
| 1807 | (check-symbols s)
|
|---|
| 1808 | (terpri))))
|
|---|
| 1809 | i))
|
|---|
| 1810 |
|
|---|
| 1811 | (defun check-symbols (&optional (upto-and-including 0))
|
|---|
| 1812 | (declare (special dc b))
|
|---|
| 1813 | (let ((i 0))
|
|---|
| 1814 | (dolist (s (*symbols*))
|
|---|
| 1815 | (let ((was (dc-btree-lookup dc b (symbol-name s)))
|
|---|
| 1816 | (value (+ i *value-offset*)))
|
|---|
| 1817 | (unless (eql was value)
|
|---|
| 1818 | (cerror "Continue"
|
|---|
| 1819 | "Sym: ~s, was: ~s, sb: ~s" s was value))
|
|---|
| 1820 | (incf i)
|
|---|
| 1821 | (when (eq s upto-and-including)
|
|---|
| 1822 | (return))))
|
|---|
| 1823 | i))
|
|---|
| 1824 |
|
|---|
| 1825 | (defun delete-symbols (&optional (count nil) (check-period nil))
|
|---|
| 1826 | (declare (special dc b))
|
|---|
| 1827 | (let ((check-count (or check-period most-positive-fixnum)))
|
|---|
| 1828 | (dotimes (i (or count (length *symbols*)))
|
|---|
| 1829 | (when (null *symbols*) (return))
|
|---|
| 1830 | (incf *value-offset*)
|
|---|
| 1831 | (dc-btree-delete dc b (symbol-name (pop *symbols*)))
|
|---|
| 1832 | (when (<= (decf check-count) 0)
|
|---|
| 1833 | (setq check-count check-period)
|
|---|
| 1834 | (format t "~&Checking ~d..." i)
|
|---|
| 1835 | (check-symbols)
|
|---|
| 1836 | (terpri)))))
|
|---|
| 1837 |
|
|---|
| 1838 | (defun sort-syms-upto (sym)
|
|---|
| 1839 | (let ((first-n (let ((res nil))
|
|---|
| 1840 | (dolist (s *symbols* (error "Not found"))
|
|---|
| 1841 | (push s res)
|
|---|
| 1842 | (when (eq s sym) (return res))))))
|
|---|
| 1843 | (sort first-n #'string<)))
|
|---|
| 1844 |
|
|---|
| 1845 | (defun btree-test (&optional (step-sym 0))
|
|---|
| 1846 | (init-temp-btree)
|
|---|
| 1847 | (store-symbols step-sym))
|
|---|
| 1848 |
|
|---|
| 1849 | (defun clear-disk-cache ()
|
|---|
| 1850 | (unwind-protect
|
|---|
| 1851 | (with-open-file (s "temp.temp" :direction :output :if-exists :overwrite)
|
|---|
| 1852 | (file-length s (* 256 1024))
|
|---|
| 1853 | (dotimes (i 512)
|
|---|
| 1854 | (file-position s (* i 512))
|
|---|
| 1855 | (tyo #\f s)))
|
|---|
| 1856 | (delete-file "temp.temp")))
|
|---|
| 1857 |
|
|---|
| 1858 | (defun time-btree-store (&optional (swap-space-in-k 20))
|
|---|
| 1859 | (let* ((syms (*symbols*))
|
|---|
| 1860 | (syms-count (length syms))
|
|---|
| 1861 | (index 0))
|
|---|
| 1862 | (declare (fixnum index))
|
|---|
| 1863 | (clear-disk-cache)
|
|---|
| 1864 | (gc)
|
|---|
| 1865 | (let ((time (get-internal-real-time)))
|
|---|
| 1866 | (with-open-pheap (p "temp.pheap"
|
|---|
| 1867 | :if-exists :supersede
|
|---|
| 1868 | :if-does-not-exist :create
|
|---|
| 1869 | :swapping-space (* swap-space-in-k 1024)
|
|---|
| 1870 | :page-size 512)
|
|---|
| 1871 | (let ((b (p-make-btree p)))
|
|---|
| 1872 | (setf (root-object p) b)
|
|---|
| 1873 | (dolist (s syms)
|
|---|
| 1874 | (setf (p-btree-lookup b (symbol-name s)) (incf index))))
|
|---|
| 1875 | (let ((total-time (/ (float (- (get-internal-real-time) time))
|
|---|
| 1876 | internal-time-units-per-second))
|
|---|
| 1877 | (file-length (with-open-file (s "temp.pheap") (file-length s))))
|
|---|
| 1878 | (format t "~&Total time: ~d~%Elements: ~d~%time/element: ~d~%file length: ~d"
|
|---|
| 1879 | total-time
|
|---|
| 1880 | syms-count
|
|---|
| 1881 | (/ total-time syms-count)
|
|---|
| 1882 | file-length))))))
|
|---|
| 1883 |
|
|---|
| 1884 | (defun time-btree-read (&optional (swap-space-in-k 20))
|
|---|
| 1885 | (let* ((syms (*symbols*))
|
|---|
| 1886 | (syms-count (length syms)))
|
|---|
| 1887 | (clear-disk-cache)
|
|---|
| 1888 | (gc)
|
|---|
| 1889 | (let ((time (get-internal-real-time)))
|
|---|
| 1890 | (with-open-pheap (p "temp.pheap"
|
|---|
| 1891 | :swapping-space (* swap-space-in-k 1024))
|
|---|
| 1892 | (let ((b (root-object p)))
|
|---|
| 1893 | (dolist (s syms)
|
|---|
| 1894 | (p-btree-lookup b (symbol-name s)))))
|
|---|
| 1895 | (let ((total-time (/ (float (- (get-internal-real-time) time))
|
|---|
| 1896 | internal-time-units-per-second))
|
|---|
| 1897 | (file-length (with-open-file (s "temp.pheap") (file-length s))))
|
|---|
| 1898 | (format t "~&Total time: ~d~%Elements: ~d~%time/element: ~d~%file length: ~d"
|
|---|
| 1899 | total-time
|
|---|
| 1900 | syms-count
|
|---|
| 1901 | (/ total-time syms-count)
|
|---|
| 1902 | file-length)))))
|
|---|
| 1903 |
|
|---|
| 1904 |
|
|---|
| 1905 | |#
|
|---|
| 1906 |
|
|---|
| 1907 | #|
|
|---|
| 1908 | ; Code to trace functions that were hard to debug.
|
|---|
| 1909 | (advise %btree-insert-in-node
|
|---|
| 1910 | (destructuring-bind (dc b node offset key-string value &optional value-imm? (key-length (length key-string))) arglist
|
|---|
| 1911 | (declare (ignore offset value value-imm?))
|
|---|
| 1912 | (if (or (%btree-leaf-node-p dc node)
|
|---|
| 1913 | (<= (normalize-size (+ 5 key-length))
|
|---|
| 1914 | (accessing-disk-cache (dc node) (load.uw $btree_free))))
|
|---|
| 1915 | (:do-it)
|
|---|
| 1916 | (step (:do-it))))
|
|---|
| 1917 | :when :around)
|
|---|
| 1918 |
|
|---|
| 1919 | (advise %balance-inner-node-after-deletion
|
|---|
| 1920 | (step (:do-it))
|
|---|
| 1921 | :when :around)
|
|---|
| 1922 | |#
|
|---|
| 1923 | ;;; 1 3/10/94 bill 1.8d247
|
|---|
| 1924 | ;;; 2 7/26/94 Derek 1.9d027
|
|---|
| 1925 | ;;; 3 10/04/94 bill 1.9d071
|
|---|
| 1926 | ;;; 4 11/01/94 Derek 1.9d085 Bill's Saving Library Task
|
|---|
| 1927 | ;;; 5 11/03/94 Moon 1.9d086
|
|---|
| 1928 | ;;; 2 2/18/95 Rti 1.10d019
|
|---|
| 1929 | ;;; 3 3/23/95 bill 1.11d010
|
|---|
| 1930 | ;;; 4 4/19/95 bill 1.11d021
|
|---|
| 1931 | ;;; 5 6/02/95 bill 1.11d040
|
|---|
![(please configure the [header_logo] section in trac.ini)](/wood/chrome/site/your_project_logo.png){kind=logo}
