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 flush-cache
get-flags get-flags
prefetch-block prefetch-block
with-block) with-block
spine
spine-exit
spine-step
spine-current
spine-parent
with-spine)
(import (chezscheme) (import (chezscheme)
(fmt fmt) (fmt fmt)
(srfi s8 receive)
(utils)) (utils))
(define __ (load-shared-object "./bcache/bcache.so")) (define __ (load-shared-object "./bcache/bcache.so"))
@ -100,4 +108,52 @@
(lambda () #f) (lambda () #f)
(lambda () b1 b2 ...) (lambda () b1 b2 ...)
(lambda () (release-block b))))))) (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 (library
(btree) (persistent-data btree)
(export btree-value-type (export btree-value-type
btree-bcache btree-bcache
@ -9,6 +9,8 @@
btree-each btree-each
le64-vt le64-vt
define-value-type
define-compound-value-type
BTreeNodeHeader) BTreeNodeHeader)
(import (bcache block-manager) (import (bcache block-manager)
@ -19,14 +21,14 @@
(define-ftype BTreeNodeHeader (define-ftype BTreeNodeHeader
(packed (packed
(endian little (endian little
(struct (struct
(csum unsigned-32) (csum unsigned-32)
(flags unsigned-32) (flags unsigned-32)
(blocknr unsigned-64) (blocknr unsigned-64)
(nr-entries unsigned-32) (nr-entries unsigned-32)
(max-entries unsigned-32) (max-entries unsigned-32)
(value-size unsigned-32) (value-size unsigned-32)
(padding unsigned-32))))) (padding unsigned-32)))))
(define-ftype LittleEndian64 (define-ftype LittleEndian64
(endian little unsigned-64)) (endian little unsigned-64))
@ -34,27 +36,42 @@
;; The metadata block is made up of: ;; The metadata block is made up of:
;; | node header | keys | values | ;; | node header | keys | values |
(define (block->header b) (define (block->header b)
(make-ftype-pointer BTreeNodeHeader b)) (make-ftype-pointer BTreeNodeHeader (block-data b)))
(define (block->keys b) (define (block->keys b)
(make-ftype-pointer LittleEndian64 (make-ftype-pointer LittleEndian64
(+ b (ftype-sizeof BTreeNodeHeader)))) (+ (block-data b) (ftype-sizeof BTreeNodeHeader))))
;;; Value-types are dlambdas with these methods: ;;; Value-types are dlambdas with these methods:
;;; (vt 'mk-ptr <raw-ptr>) ;;; (vt 'mk-ptr <raw-ptr>)
;;; (vt 'ref <vt-ptr> index) ;;; (vt 'ref <vt-ptr> index)
;;; (vt 'set <vt-ptr> index val) ;;; (vt 'set <vt-ptr> index val)
;;; (vt 'size) ;;; (vt 'size)
(define le64-vt (define-syntax define-value-type
(dlambda (syntax-rules ()
(mk-ptr (p) (make-ftype-pointer LittleEndian64 p)) ((_ name ft)
(ref (fp index) (ftype-ref LittleEndian64 () fp index)) (define name
(set (fp index val) (ftype-set! LittleEndian64 () fp index val)) (dlambda
(size () (ftype-sizeof LittleEndian64)))) (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) (define (block->values b vt)
(vt (vt 'mk-ptr
(+ b (ftype-sizeof BTreeNodeHeader) (+ (block-data b) (ftype-sizeof BTreeNodeHeader)
(* (ftype-ref BTreeNodeHeader (max-entries) (block->header b)) (* (ftype-ref BTreeNodeHeader (max-entries) (block->header b))
(ftype-sizeof LittleEndian64))))) (ftype-sizeof LittleEndian64)))))
@ -105,23 +122,21 @@
;;;; Lookup ;;;; Lookup
;;;;---------------------------------------------- ;;;;----------------------------------------------
;; FIXME: this holds more blocks than we need as we recurse, use a fixed
;; size block queue.
(define (btree-lookup tree key default) (define (btree-lookup tree key default)
(let ((cache (btree-bcache tree)) (let ((cache (btree-bcache tree))
(vt (btree-value-type tree))) (vt (btree-value-type tree)))
(with-spine (sp 1)
(let loop ((root (btree-root tree))) (let loop ((root (btree-root tree)))
(with-block (b cache root (get-flags)) (spine-step sp (b (get-block cache root (get-flags)))
(let* ((header (block->header b)) (let* ((header (block->header b))
(keys (block->keys b)) (keys (block->keys b))
(vals (block->values b vt)) (vals (block->values b vt))
(index (lower-bound b header key))) (index (lower-bound b header key)))
(if (internal-node? header) (if (internal-node? header)
(loop (value-at le64-vt vals index)) (loop (value-at le64-vt vals index))
(if (= key (key-at keys index)) (if (= key (key-at keys index))
(value-at vt vals index) (value-at vt vals index)
default))))))) default))))))))
;;;;---------------------------------------------- ;;;;----------------------------------------------
;;;; Walking the btree ;;;; Walking the btree
@ -132,27 +147,29 @@
(let ((vt (btree-value-type tree)) (let ((vt (btree-value-type tree))
(cache (btree-bcache tree))) (cache (btree-bcache tree)))
(define (visit-leaf nr-entries keys vals) (with-spine (sp 1)
(let loop ((index 0)) (define (visit-leaf nr-entries keys vals)
(when (< index nr-entries) (let loop ((index 0))
(fn (key-at keys index) (value-at vt vals index)) (when (< index nr-entries)
(loop (+ 1 index))))) (fn (key-at keys index) (vt 'ref vals index))
(loop (+ 1 index)))))
(define (visit-internal nr-entries keys vals) (define (visit-internal nr-entries keys vals)
(let loop ((index 0)) (let loop ((index 0))
(when (< index nr-entries) (when (< index nr-entries)
(visit-node (value-at le64-vt vals index)) (visit-node (le64-vt 'ref vals index))
(loop (+ 1 index))))) (loop (+ 1 index)))))
(define (visit-node root) (define (visit-node root)
(with-block (b cache root (get-flags)) (spine-step sp (b (get-block cache root (get-flags)))
(let* ((header (block->header b)) (let* ((header (block->header b))
(nr-entries (ftype-ref BTreeNodeHeader (nr-entries) header)) (nr-entries (ftype-ref BTreeNodeHeader (nr-entries) header))
(keys (block->keys b)) (keys (block->keys b))
(vals (block->values b vt))) (vals (block->values b vt)))
((if (internal-node? header) ((if (internal-node? header)
visit-internal visit-internal
visit-leaf) nr-entries keys vals)))) visit-leaf) nr-entries keys vals))))
(visit-node (btree-root tree))))) (visit-node (btree-root tree)))))
)