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

[functional tests] we can now walk both levels of the mapping tree.

Browse Source
This commit is contained in:
Joe Thornber 2017-08-12 19:27:21 +01:00
parent 5e6ffbbd3a
commit b2355df719
4 changed files with 25 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
functional-tests/binary-format.scm
View File

@ -43,16 +43,16 @@
#,gens))))) #,gens)))))
|# |#
(define-syntax ordered-funcall (define-syntax ordered-funcall
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((k f v ...) ((k f v ...)
(with-syntax (with-syntax
([(t ...) (map (lambda (_) ([(t ...) (map (lambda (_)
(datum->syntax #'k (gensym))) (datum->syntax #'k (gensym)))
#'(v ...))]) #'(v ...))])
#'(let* ([t v] ...) #'(let* ([t v] ...)
(f t ...))))))) (f t ...)))))))
(define-syntax binary-format-names (define-syntax binary-format-names
(syntax-rules () (syntax-rules ()

4
functional-tests/btree.scm
View File

@ -57,10 +57,10 @@
(unpack-type bv offset le64)))) (unpack-type bv offset le64))))
(define (internal-node? header) (define (internal-node? header)
(bitwise-bit-set? 0 (node-header-flags header))) (bitwise-bit-set? (node-header-flags header) 0))
(define (leaf-node? header) (define (leaf-node? header)
(bitwise-bit-set? 1 (node-header-flags header))) (bitwise-bit-set? (node-header-flags header) 1))
(define (key-at node index) (define (key-at node index)
(unpack-type node (key-offset index) le64)) (unpack-type node (key-offset index) le64))

3
functional-tests/check-superblock.scm
View File

@ -73,11 +73,12 @@
(let ((sb (superblock-unpack (read-block md 0) 0))) (let ((sb (superblock-unpack (read-block md 0) 0)))
(let ((mappings (mapping-tree-open md (superblock-data-mapping-root sb)))) (let ((mappings (mapping-tree-open md (superblock-data-mapping-root sb))))
(mapping-tree-each mappings (mapping-tree-each mappings
(lambda (dev-id vblock pblock) (lambda (dev-id vblock pblock time)
(fmt #t (fmt #t
(dsp "thin dev ") (num dev-id) (dsp "thin dev ") (num dev-id)
(dsp ", vblock ") (num vblock) (dsp ", vblock ") (num vblock)
(dsp ", pblock ") (num pblock) (dsp ", pblock ") (num pblock)
(dsp ", time ") (num time)
nl))))))) nl)))))))
(define (check-superblock) (define (check-superblock)

14
functional-tests/mapping-tree.scm
View File

@ -7,7 +7,8 @@
(import (btree) (import (btree)
(chezscheme) (chezscheme)
(binary-format)) (binary-format)
(srfi s8 receive))
(define-record-type mapping-tree (fields dev-tree)) (define-record-type mapping-tree (fields dev-tree))
@ -22,13 +23,20 @@
default default
(btree-lookup (btree-open le64-type (btree-dev dev-tree) root2) vblock default)))) (btree-lookup (btree-open le64-type (btree-dev dev-tree) root2) vblock default))))
;;; Visits every entry in the mapping tree calling (fn dev-id vblock mapping). ;; (values <block> <time>)
(define time-mask (- (fxsll 1 24) 1))
(define (unpack-block-time bt)
(values (fxsrl bt 24) (fxlogand bt time-mask)))
;;; Visits every entry in the mapping tree calling (fn dev-id vblock pblock time).
(define (mapping-tree-each mtree fn) (define (mapping-tree-each mtree fn)
(let ((dev-tree (mapping-tree-dev-tree mtree))) (let ((dev-tree (mapping-tree-dev-tree mtree)))
(define (visit-dev dev-id mapping-root) (define (visit-dev dev-id mapping-root)
(btree-each (btree-open le64-type (btree-dev dev-tree) mapping-root) (btree-each (btree-open le64-type (btree-dev dev-tree) mapping-root)
(lambda (vblock mapping) (lambda (vblock mapping)
(fn dev-id 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 visit-dev))))