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. 

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
;;;--------------------------------------------------------
(define-record-type spine
(fields (mutable max) (mutable entries))
(fields (immutable cache) (mutable max) (mutable entries))
(protocol
(lambda (new)
(lambda (max)
(new max '())))))
(lambda (cache max)
(new cache max '())))))
(define (spine-exit sp)
(for-each release-block (spine-entries sp)))
@ -126,13 +126,14 @@
(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-step% sp index flags)
(let ((b (get-block (spine-cache sp) index flags)))
(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)))
@ -142,8 +143,8 @@
(define-syntax with-spine
(syntax-rules ()
((_ (sp max) b1 b2 ...)
(let ((sp (make-spine max)))
((_ (sp cache max) b1 b2 ...)
(let ((sp (make-spine cache max)))
(dynamic-wind
(lambda () #f)
(lambda () b1 b2 ...)
@ -151,9 +152,9 @@
(define-syntax spine-step
(syntax-rules ()
((_ sp (b expr) b1 b2 ...)
((_ sp (b index flags) b1 b2 ...)
(begin
(spine-step% sp expr)
(spine-step% sp index flags)
(let ((b (spine-current sp)))
b1 b2 ...)))))
)

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

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

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

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

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

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

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

@ -1,19 +1,14 @@
(library
(thin mapping-tree)
(export mapping-tree-open
mapping-tree-lookup
(export mapping-tree-lookup
mapping-tree-each)
(import (persistent-data btree)
(bcache block-manager)
(chezscheme)
(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>)
(define time-mask (- (fxsll 1 24) 1))
@ -21,22 +16,25 @@
(values (fxsrl bt 24) (fxlogand bt time-mask)))
;; FIXME: unpack the block time
(define (mapping-tree-lookup mtree dev-id vblock default)
(let* ((unique (gensym))
(dev-tree (mapping-tree-dev-tree mtree))
(root2 (btree-lookup dev-tree dev-id unique)))
(if (eq? unique root2)
default
(btree-lookup (btree-open le64-vt (btree-bcache dev-tree) root2) vblock default))))
(define (mapping-tree-lookup cache root dev-id vblock default)
(with-spine (sp cache 1)
(let* ((unique (gensym))
(dev-tree (btree-open le64-vt root))
(root2 (btree-lookup dev-tree sp dev-id unique)))
(if (eq? unique root2)
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).
(define (mapping-tree-each mtree fn)
(let ((dev-tree (mapping-tree-dev-tree mtree)))
(define (mapping-tree-each cache root fn)
(with-spine (sp cache 1)
(let ((dev-tree (btree-open le64-vt root)))
(define (visit-dev dev-id mapping-root)
(btree-each (btree-open le64-vt (btree-bcache dev-tree) mapping-root)
(lambda (vblock mapping)
(receive (block time) (unpack-block-time mapping)
(fn dev-id vblock block time)))))
(define (visit-dev dev-id mapping-root)
(btree-each (btree-open le64-vt mapping-root)
(lambda (vblock mapping)
(receive (block time) (unpack-block-time mapping)
(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
ThinDeviceDetails)
(import (chezscheme))
(import (chezscheme)
(bcache block-manager)
(persistent-data btree))
(define $superblock-magic 27022010)
(define $superblock-salt 160774)