emo/thin-provisioning-tools
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[functional-tests] Change btree code to use a spine

Browse Source
This commit is contained in:
Joe Thornber 2017-09-14 11:41:26 +01:00
parent 205caab84c
commit 111d64ec9e
2 changed files with 127 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
functional-tests/bcache/block-manager.scm
View File

@ -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 ...)))))
)

123
functional-tests/persistent-data/btree.scm
View File

@ -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)))))
)