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)))))
|#
(define-syntax ordered-funcall
(lambda (x)
(syntax-case x ()
((k f v ...)
(with-syntax
([(t ...) (map (lambda (_)
(datum->syntax #'k (gensym)))
#'(v ...))])
#'(let* ([t v] ...)
(f t ...)))))))
(define-syntax ordered-funcall
(lambda (x)
(syntax-case x ()
((k f v ...)
(with-syntax
([(t ...) (map (lambda (_)
(datum->syntax #'k (gensym)))
#'(v ...))])
#'(let* ([t v] ...)
(f t ...)))))))
(define-syntax binary-format-names
(syntax-rules ()

4
functional-tests/btree.scm
View File

@ -57,10 +57,10 @@
(unpack-type bv offset le64))))
(define (internal-node? header)
(bitwise-bit-set? 0 (node-header-flags header)))
(bitwise-bit-set? (node-header-flags header) 0))
(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)
(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 ((mappings (mapping-tree-open md (superblock-data-mapping-root sb))))
(mapping-tree-each mappings
(lambda (dev-id vblock pblock)
(lambda (dev-id vblock pblock time)
(fmt #t
(dsp "thin dev ") (num dev-id)
(dsp ", vblock ") (num vblock)
(dsp ", pblock ") (num pblock)
(dsp ", time ") (num time)
nl)))))))
(define (check-superblock)

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

@ -7,7 +7,8 @@
(import (btree)
(chezscheme)
(binary-format))
(binary-format)
(srfi s8 receive))
(define-record-type mapping-tree (fields dev-tree))
@ -22,13 +23,20 @@
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)
(let ((dev-tree (mapping-tree-dev-tree mtree)))
(define (visit-dev dev-id mapping-root)
(btree-each (btree-open le64-type (btree-dev dev-tree) mapping-root)
(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))))