[functional-tests] Change btree code to use a spine
This commit is contained in:
Joe Thornber
parent
205caab84c
commit
111d64ec9e
|
|
@ -11,9 +11,17 @@
|
|||
flush-cache
|
||||
get-flags
|
||||
prefetch-block
|
||||
with-block)
|
||||
with-block
|
||||
spine
|
||||
spine-exit
|
||||
spine-step
|
||||
spine-current
|
||||
spine-parent
|
||||
with-spine)
|
||||
|
||||
(import (chezscheme)
|
||||
(fmt fmt)
|
||||
(srfi s8 receive)
|
||||
(utils))
|
||||
|
||||
(define __ (load-shared-object "./bcache/bcache.so"))
|
||||
|
|
@ -100,4 +108,52 @@
|
|||
(lambda () #f)
|
||||
(lambda () b1 b2 ...)
|
||||
(lambda () (release-block b)))))))
|
||||
|
||||
;;;--------------------------------------------------------
|
||||
;;; Spine
|
||||
;;;--------------------------------------------------------
|
||||
(define-record-type spine
|
||||
(fields (mutable max) (mutable entries))
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda (max)
|
||||
(new max '())))))
|
||||
|
||||
(define (spine-exit sp)
|
||||
(for-each release-block (spine-entries sp)))
|
||||
|
||||
(define (pop-last xs)
|
||||
(let ((rs (reverse xs)))
|
||||
(values (car xs) (reverse (cdr xs)))))
|
||||
|
||||
(define (spine-step% sp b)
|
||||
(if (> (length (spine-entries sp))
|
||||
(spine-max sp))
|
||||
(receive (oldest-b es) (pop-last (spine-entries sp))
|
||||
(release-block oldest-b)
|
||||
(spine-entries-set! sp (cons b es)))
|
||||
(spine-entries-set! sp (cons b (spine-entries sp)))))
|
||||
|
||||
(define (spine-current sp)
|
||||
(car (spine-entries sp)))
|
||||
|
||||
(define (spine-parent sp)
|
||||
(cadr (spine-entries sp)))
|
||||
|
||||
(define-syntax with-spine
|
||||
(syntax-rules ()
|
||||
((_ (sp max) b1 b2 ...)
|
||||
(let ((sp (make-spine max)))
|
||||
(dynamic-wind
|
||||
(lambda () #f)
|
||||
(lambda () b1 b2 ...)
|
||||
(lambda () (spine-exit sp)))))))
|
||||
|
||||
(define-syntax spine-step
|
||||
(syntax-rules ()
|
||||
((_ sp (b expr) b1 b2 ...)
|
||||
(begin
|
||||
(spine-step% sp expr)
|
||||
(let ((b (spine-current sp)))
|
||||
b1 b2 ...)))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(library
|
||||
(btree)
|
||||
(persistent-data btree)
|
||||
|
||||
(export btree-value-type
|
||||
btree-bcache
|
||||
|
|
@ -9,6 +9,8 @@
|
|||
btree-each
|
||||
le64-vt
|
||||
|
||||
define-value-type
|
||||
define-compound-value-type
|
||||
BTreeNodeHeader)
|
||||
|
||||
(import (bcache block-manager)
|
||||
|
|
@ -19,14 +21,14 @@
|
|||
(define-ftype BTreeNodeHeader
|
||||
(packed
|
||||
(endian little
|
||||
(struct
|
||||
(csum unsigned-32)
|
||||
(flags unsigned-32)
|
||||
(blocknr unsigned-64)
|
||||
(nr-entries unsigned-32)
|
||||
(max-entries unsigned-32)
|
||||
(value-size unsigned-32)
|
||||
(padding unsigned-32)))))
|
||||
(struct
|
||||
(csum unsigned-32)
|
||||
(flags unsigned-32)
|
||||
(blocknr unsigned-64)
|
||||
(nr-entries unsigned-32)
|
||||
(max-entries unsigned-32)
|
||||
(value-size unsigned-32)
|
||||
(padding unsigned-32)))))
|
||||
|
||||
(define-ftype LittleEndian64
|
||||
(endian little unsigned-64))
|
||||
|
|
@ -34,27 +36,42 @@
|
|||
;; The metadata block is made up of:
|
||||
;; | node header | keys | values |
|
||||
(define (block->header b)
|
||||
(make-ftype-pointer BTreeNodeHeader b))
|
||||
(make-ftype-pointer BTreeNodeHeader (block-data b)))
|
||||
|
||||
(define (block->keys b)
|
||||
(make-ftype-pointer LittleEndian64
|
||||
(+ b (ftype-sizeof BTreeNodeHeader))))
|
||||
(+ (block-data b) (ftype-sizeof BTreeNodeHeader))))
|
||||
|
||||
;;; Value-types are dlambdas with these methods:
|
||||
;;; (vt 'mk-ptr <raw-ptr>)
|
||||
;;; (vt 'ref <vt-ptr> index)
|
||||
;;; (vt 'set <vt-ptr> index val)
|
||||
;;; (vt 'size)
|
||||
(define le64-vt
|
||||
(dlambda
|
||||
(mk-ptr (p) (make-ftype-pointer LittleEndian64 p))
|
||||
(ref (fp index) (ftype-ref LittleEndian64 () fp index))
|
||||
(set (fp index val) (ftype-set! LittleEndian64 () fp index val))
|
||||
(size () (ftype-sizeof LittleEndian64))))
|
||||
(define-syntax define-value-type
|
||||
(syntax-rules ()
|
||||
((_ name ft)
|
||||
(define name
|
||||
(dlambda
|
||||
(mk-ptr (p) (make-ftype-pointer ft p))
|
||||
(ref (fp index) (ftype-ref ft () fp index))
|
||||
(set (fp index val) (ftype-set! ft () fp index val))
|
||||
(size () (ftype-sizeof ft)))))))
|
||||
|
||||
(define-syntax define-compound-value-type
|
||||
(syntax-rules ()
|
||||
((_ name ft)
|
||||
(define name
|
||||
(dlambda
|
||||
(mk-ptr (p) (make-ftype-pointer ft p))
|
||||
(ref (fp index) (ftype-&ref ft () fp index))
|
||||
(set (fp index val) (assert #f)) ;; (ftype-set! ft () fp index val)) ;;; FIXME: not sure what to put here
|
||||
(size () (ftype-sizeof ft)))))))
|
||||
|
||||
(define-value-type le64-vt LittleEndian64)
|
||||
|
||||
(define (block->values b vt)
|
||||
(vt
|
||||
(+ b (ftype-sizeof BTreeNodeHeader)
|
||||
(vt 'mk-ptr
|
||||
(+ (block-data b) (ftype-sizeof BTreeNodeHeader)
|
||||
(* (ftype-ref BTreeNodeHeader (max-entries) (block->header b))
|
||||
(ftype-sizeof LittleEndian64)))))
|
||||
|
||||
|
|
@ -105,23 +122,21 @@
|
|||
;;;; Lookup
|
||||
;;;;----------------------------------------------
|
||||
|
||||
;; FIXME: this holds more blocks than we need as we recurse, use a fixed
|
||||
;; size block queue.
|
||||
(define (btree-lookup tree key default)
|
||||
(let ((cache (btree-bcache tree))
|
||||
(vt (btree-value-type tree)))
|
||||
|
||||
(let loop ((root (btree-root tree)))
|
||||
(with-block (b cache root (get-flags))
|
||||
(let* ((header (block->header b))
|
||||
(keys (block->keys b))
|
||||
(vals (block->values b vt))
|
||||
(index (lower-bound b header key)))
|
||||
(if (internal-node? header)
|
||||
(loop (value-at le64-vt vals index))
|
||||
(if (= key (key-at keys index))
|
||||
(value-at vt vals index)
|
||||
default)))))))
|
||||
(with-spine (sp 1)
|
||||
(let loop ((root (btree-root tree)))
|
||||
(spine-step sp (b (get-block cache root (get-flags)))
|
||||
(let* ((header (block->header b))
|
||||
(keys (block->keys b))
|
||||
(vals (block->values b vt))
|
||||
(index (lower-bound b header key)))
|
||||
(if (internal-node? header)
|
||||
(loop (value-at le64-vt vals index))
|
||||
(if (= key (key-at keys index))
|
||||
(value-at vt vals index)
|
||||
default))))))))
|
||||
|
||||
;;;;----------------------------------------------
|
||||
;;;; Walking the btree
|
||||
|
|
@ -132,27 +147,29 @@
|
|||
(let ((vt (btree-value-type tree))
|
||||
(cache (btree-bcache tree)))
|
||||
|
||||
(define (visit-leaf nr-entries keys vals)
|
||||
(let loop ((index 0))
|
||||
(when (< index nr-entries)
|
||||
(fn (key-at keys index) (value-at vt vals index))
|
||||
(loop (+ 1 index)))))
|
||||
(with-spine (sp 1)
|
||||
(define (visit-leaf nr-entries keys vals)
|
||||
(let loop ((index 0))
|
||||
(when (< index nr-entries)
|
||||
(fn (key-at keys index) (vt 'ref vals index))
|
||||
(loop (+ 1 index)))))
|
||||
|
||||
(define (visit-internal nr-entries keys vals)
|
||||
(let loop ((index 0))
|
||||
(when (< index nr-entries)
|
||||
(visit-node (value-at le64-vt vals index))
|
||||
(loop (+ 1 index)))))
|
||||
(define (visit-internal nr-entries keys vals)
|
||||
(let loop ((index 0))
|
||||
(when (< index nr-entries)
|
||||
(visit-node (le64-vt 'ref vals index))
|
||||
(loop (+ 1 index)))))
|
||||
|
||||
(define (visit-node root)
|
||||
(with-block (b cache root (get-flags))
|
||||
(let* ((header (block->header b))
|
||||
(nr-entries (ftype-ref BTreeNodeHeader (nr-entries) header))
|
||||
(keys (block->keys b))
|
||||
(vals (block->values b vt)))
|
||||
((if (internal-node? header)
|
||||
visit-internal
|
||||
visit-leaf) nr-entries keys vals))))
|
||||
(define (visit-node root)
|
||||
(spine-step sp (b (get-block cache root (get-flags)))
|
||||
(let* ((header (block->header b))
|
||||
(nr-entries (ftype-ref BTreeNodeHeader (nr-entries) header))
|
||||
(keys (block->keys b))
|
||||
(vals (block->values b vt)))
|
||||
((if (internal-node? header)
|
||||
visit-internal
|
||||
visit-leaf) nr-entries keys vals))))
|
||||
|
||||
(visit-node (btree-root tree)))))
|
||||
(visit-node (btree-root tree)))))
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue