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

[functional-tests] change btree functions to take a spine.

Browse Source 
Also change the step-spine interface slightly.
This commit is contained in:
Joe Thornber 2017-09-14 16:09:43 +01:00
parent 48ae5beead
commit 4d3733d0e7
6 changed files with 80 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -113,11 +113,11 @@
;;; Spine ;;; Spine
;;;-------------------------------------------------------- ;;;--------------------------------------------------------
(define-record-type spine (define-record-type spine
(fields (mutable max) (mutable entries)) (fields (immutable cache) (mutable max) (mutable entries))
(protocol (protocol
(lambda (new) (lambda (new)
(lambda (max) (lambda (cache max)
(new max '()))))) (new cache max '())))))
(define (spine-exit sp) (define (spine-exit sp)
(for-each release-block (spine-entries sp))) (for-each release-block (spine-entries sp)))
@ -126,13 +126,14 @@
(let ((rs (reverse xs))) (let ((rs (reverse xs)))
(values (car xs) (reverse (cdr xs))))) (values (car xs) (reverse (cdr xs)))))
(define (spine-step% sp b) (define (spine-step% sp index flags)
(if (> (length (spine-entries sp)) (let ((b (get-block (spine-cache sp) index flags)))
(spine-max sp)) (if (> (length (spine-entries sp))
(receive (oldest-b es) (pop-last (spine-entries sp)) (spine-max sp))
(release-block oldest-b) (receive (oldest-b es) (pop-last (spine-entries sp))
(spine-entries-set! sp (cons b es))) (release-block oldest-b)
(spine-entries-set! sp (cons b (spine-entries sp))))) (spine-entries-set! sp (cons b es)))
(spine-entries-set! sp (cons b (spine-entries sp))))))
(define (spine-current sp) (define (spine-current sp)
(car (spine-entries sp))) (car (spine-entries sp)))
@ -142,8 +143,8 @@
(define-syntax with-spine (define-syntax with-spine
(syntax-rules () (syntax-rules ()
((_ (sp max) b1 b2 ...) ((_ (sp cache max) b1 b2 ...)
(let ((sp (make-spine max))) (let ((sp (make-spine cache max)))
(dynamic-wind (dynamic-wind
(lambda () #f) (lambda () #f)
(lambda () b1 b2 ...) (lambda () b1 b2 ...)
@ -151,9 +152,9 @@
(define-syntax spine-step (define-syntax spine-step
(syntax-rules () (syntax-rules ()
((_ sp (b expr) b1 b2 ...) ((_ sp (b index flags) b1 b2 ...)
(begin (begin
(spine-step% sp expr) (spine-step% sp index flags)
(let ((b (spine-current sp))) (let ((b (spine-current sp)))
b1 b2 ...))))) b1 b2 ...)))))
) )

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

@ -2,7 +2,6 @@
(persistent-data btree) (persistent-data btree)
(export btree-value-type (export btree-value-type
btree-bcache
btree-root btree-root
btree-open btree-open
btree-lookup btree-lookup
@ -89,10 +88,10 @@
|# |#
(define-record-type btree (define-record-type btree
(fields value-type bcache root)) (fields value-type root))
(define (btree-open vt bcache root) (define (btree-open vt root)
(make-btree vt bcache root)) (make-btree vt root))
;;; (ftype-pointer BTreeNodeHeader) -> bool ;;; (ftype-pointer BTreeNodeHeader) -> bool
(define (internal-node? header) (define (internal-node? header)
@ -122,54 +121,51 @@
;;;; Lookup ;;;; Lookup
;;;;---------------------------------------------- ;;;;----------------------------------------------
(define (btree-lookup tree key default) (define (btree-lookup tree sp key default)
(let ((cache (btree-bcache tree)) (let ((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))) (spine-step sp (b 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
;;;;---------------------------------------------- ;;;;----------------------------------------------
;;; Calls (fn key value) on every entry of the btree. ;;; Calls (fn key value) on every entry of the btree.
(define (btree-each tree fn) (define (btree-each tree sp fn)
(let ((vt (btree-value-type tree)) (let ((vt (btree-value-type tree)))
(cache (btree-bcache tree)))
(with-spine (sp 1) (define (visit-leaf nr-entries keys vals)
(define (visit-leaf nr-entries keys vals)
(let loop ((index 0)) (let loop ((index 0))
(when (< index nr-entries) (when (< index nr-entries)
(fn (key-at keys index) (vt 'ref vals index)) (fn (key-at keys index) (vt 'ref vals index))
(loop (+ 1 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 (le64-vt 'ref vals index)) (visit-node (le64-vt 'ref vals index))
(loop (+ 1 index))))) (loop (+ 1 index)))))
(define (visit-node root) (define (visit-node root)
(spine-step sp (b (get-block cache root (get-flags))) (spine-step sp (b 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))))
) )

3
functional-tests/thin-functional-tests.scm
View File

@ -12,8 +12,7 @@
(scenario-string-constants) (scenario-string-constants)
(temp-file) (temp-file)
(thin-xml) (thin-xml)
(srfi s8 receive) (srfi s8 receive))
(only (srfi s1 lists) drop-while))
(define-tool thin-check) (define-tool thin-check)
(define-tool thin-delta) (define-tool thin-delta)

17
functional-tests/thin/check.scm
View File

@ -43,14 +43,15 @@
(define super-block-only #f) (define super-block-only #f)
(define (dump-dev-tree cache root) (define (dump-dev-tree cache root)
(btree-each (btree-open device-details-vt cache root) (with-spine (sp cache 1)
(lambda (k v) (btree-each (btree-open device-details-vt root) sp
(fmt #t (lambda (k v)
"dev-id: " k "\n" (fmt #t
" mapped blocks: " (ftype-ref ThinDeviceDetails (mapped-blocks) v) "\n" "dev-id: " k "\n"
" transaction id: " (ftype-ref ThinDeviceDetails (transaction-id) v) "\n" " mapped blocks: " (ftype-ref ThinDeviceDetails (mapped-blocks) v) "\n"
" creation time: " (ftype-ref ThinDeviceDetails (creation-time) v) "\n" " transaction id: " (ftype-ref ThinDeviceDetails (transaction-id) v) "\n"
" snapshotted time: " (ftype-ref ThinDeviceDetails (snapshotted-time) v) "\n")))) " creation time: " (ftype-ref ThinDeviceDetails (creation-time) v) "\n"
" snapshotted time: " (ftype-ref ThinDeviceDetails (snapshotted-time) v) "\n")))))
(define-enumeration thin-check-element (define-enumeration thin-check-element
(quiet (quiet

42
functional-tests/thin/mapping-tree.scm
View File

@ -1,19 +1,14 @@
(library (library
(thin mapping-tree) (thin mapping-tree)
(export mapping-tree-open (export mapping-tree-lookup
mapping-tree-lookup
mapping-tree-each) mapping-tree-each)
(import (persistent-data btree) (import (persistent-data btree)
(bcache block-manager)
(chezscheme) (chezscheme)
(srfi s8 receive)) (srfi s8 receive))
(define-record-type mapping-tree (fields dev-tree))
(define (mapping-tree-open dev root)
(make-mapping-tree (btree-open le64-vt dev root)))
;; (values <block> <time>) ;; (values <block> <time>)
(define time-mask (- (fxsll 1 24) 1)) (define time-mask (- (fxsll 1 24) 1))
@ -21,22 +16,25 @@
(values (fxsrl bt 24) (fxlogand bt time-mask))) (values (fxsrl bt 24) (fxlogand bt time-mask)))
;; FIXME: unpack the block time ;; FIXME: unpack the block time
(define (mapping-tree-lookup mtree dev-id vblock default) (define (mapping-tree-lookup cache root dev-id vblock default)
(let* ((unique (gensym)) (with-spine (sp cache 1)
(dev-tree (mapping-tree-dev-tree mtree)) (let* ((unique (gensym))
(root2 (btree-lookup dev-tree dev-id unique))) (dev-tree (btree-open le64-vt root))
(if (eq? unique root2) (root2 (btree-lookup dev-tree sp dev-id unique)))
default (if (eq? unique root2)
(btree-lookup (btree-open le64-vt (btree-bcache dev-tree) root2) vblock default)))) default
(btree-lookup (btree-open le64-vt root2) sp vblock default)))))
;;; Visits every entry in the mapping tree calling (fn dev-id vblock pblock time). ;;; Visits every entry in the mapping tree calling (fn dev-id vblock pblock time).
(define (mapping-tree-each mtree fn) (define (mapping-tree-each cache root fn)
(let ((dev-tree (mapping-tree-dev-tree mtree))) (with-spine (sp cache 1)
(let ((dev-tree (btree-open le64-vt root)))
(define (visit-dev dev-id mapping-root) (define (visit-dev dev-id mapping-root)
(btree-each (btree-open le64-vt (btree-bcache dev-tree) mapping-root) (btree-each (btree-open le64-vt mapping-root)
(lambda (vblock mapping) (lambda (vblock mapping)
(receive (block time) (unpack-block-time mapping) (receive (block time) (unpack-block-time mapping)
(fn dev-id vblock block time))))) (fn dev-id vblock block time)))))
(btree-each dev-tree visit-dev)))) (btree-each dev-tree sp visit-dev))))
)

4
functional-tests/thin/metadata.scm
View File

@ -4,7 +4,9 @@
(export ThinSuperblock (export ThinSuperblock
ThinDeviceDetails) ThinDeviceDetails)
(import (chezscheme)) (import (chezscheme)
(bcache block-manager)
(persistent-data btree))
(define $superblock-magic 27022010) (define $superblock-magic 27022010)
(define $superblock-salt 160774) (define $superblock-salt 160774)