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

[functional tests] more work on decoding btrees

Browse Source
This commit is contained in:
Joe Thornber 2017-08-11 15:41:57 +01:00
parent d0040a169d
commit 5e6ffbbd3a
4 changed files with 161 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,9 +1,20 @@
(library
(binary-format)
(export size-type binary-format le32 le64 bytes)
(import (rnrs)
(export unpack-type
size-type
binary-format
binary-format-names
le32
le64
bytes)
(import (chezscheme)
(fmt fmt)
(list-utils))
;;;-----------------------------------------
(define-syntax size-type
(syntax-rules (le32 le64 bytes)
((_ le32) 4)
@ -23,23 +34,66 @@
(bytevector-copy! bv offset copy 0 count)
copy))))
(define-syntax binary-format
#|
(define-syntax ordered-funcall
(lambda (form)
(let ((form^ (cdr (syntax->list form))))
(let ((gens (map (lambda (_) (datum->syntax #'* (gensym "t"))) form^)))
#`(let* #,(map list gens form^)
#,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 binary-format-names
(syntax-rules ()
((_ (name pack-name unpack-name) (field type) ...)
((_ (name pack-name unpack-name size-name) (field type) ...)
(begin
(define-record-type name (fields field ...))
(define (unpack-name bv offset)
(let ((offset offset))
(define size-name
(+ (size-type type) ...))
(define (inc-offset n v)
(set! offset (+ offset n))
v)
(define (unpack-name bv offset)
(let ((offset offset))
((record-constructor (record-constructor-descriptor name))
(inc-offset (size-type type) (unpack-type bv offset type)) ...)))))))
(define (inc-offset n v)
(set! offset (+ offset n))
v)
;;; since le32, le64 and bytes are used as auxiliary keywords, we must export
(ordered-funcall
(record-constructor (record-constructor-descriptor name))
(inc-offset (size-type type) (unpack-type bv offset type)) ...)))))))
(define-syntax binary-format
(lambda (x)
;;; FIXME: we don't need multiple args
(define (gen-id template-id . args)
(datum->syntax template-id
(string->symbol
(apply string-append
(map (lambda (x)
(if (string? x)
x
(symbol->string (syntax->datum x))))
args)))))
(syntax-case x ()
((_ name field ...)
(with-syntax ((pack-name (gen-id #'name #'name "-pack"))
(unpack-name (gen-id #'name #'name "-unpack"))
(size-name (gen-id #'name #'name "-size")))
#'(binary-format-names (name pack-name unpack-name size-name) field ...))))))
;;; Since le32, le64 and bytes are used as auxiliary keywords, we must export
;;; definitions of them as well.
;;; FIXME: use a macro to remove duplication
(define-syntax le32

59
functional-tests/btree.scm
View File

@ -1,7 +1,10 @@
(library
(btree)
(export btree-open
(export btree-value-type
btree-dev
btree-root
btree-open
btree-lookup
btree-each
le64-type)
@ -13,9 +16,7 @@
;;; Unlike the kernel or c++ versions, I'm going to leave it to the hiogher
;;; levels to handle multi level btrees.
(binary-format
(node-header pack-btree-node unpack-btree-node)
(binary-format node-header
(csum le32)
(flags le32)
(blocknr le64)
@ -24,33 +25,34 @@
(value-size le32)
(padding le32))
;;; (unpacker bv offset)
(define-record-type value-type (fields size unpacker))
(define (max-entries vt)
(/ (- metadata-block-size node-header-size)
(+ (size-of 'le64)
(+ (size-type le64)
(value-type-size vt))))
(define (key-offset index)
(+ node-header-size (* (size-of 'le64 index))))
(+ node-header-size (* (size-type le64) index)))
(define (value-base vt)
(define (value-base header)
(+ node-header-size
(* (max-entries vt)
(size-of 'le64))))
(* (node-header-max-entries header)
(size-type le64))))
(define (value-offset vt index)
(+ (value-base vt)
(define (value-offset header vt index)
(+ (value-base header)
(* (value-type-size vt) index)))
(define-record-type btree
(fields value-type dev root))
(define (btree-open vt dev root)
(make-btree value-type dev root))
(make-btree vt dev root))
(define le64-type
(make-value-type (size-of 'le64)
(make-value-type (size-type le64)
(lambda (bv offset)
(unpack-type bv offset le64))))
@ -61,10 +63,10 @@
(bitwise-bit-set? 1 (node-header-flags header)))
(define (key-at node index)
(unpack-type node (key-offset index le64)))
(unpack-type node (key-offset index) le64))
(define (value-at node index vt)
((value-type-unpacker vt) node (value-offset vt index)))
(define (value-at header node index vt)
((value-type-unpacker vt) node (value-offset header vt index)))
;;; Performs a binary search looking for the key and returns the index of the
;;; lower bound.
@ -90,12 +92,12 @@
(define (lookup root fail-k)
(let loop ((root root))
(let* ((node (read-block dev root))
(header (unpack-node-header node 0))
(index (lower-bound node header key fail-k)))
(header (node-header-unpack node 0))
(index (lower-bound node header key)))
(if (internal-node? header)
(loop (unpack-value node index le64-type))
(loop (value-at header node index le64-type))
(if (= key (key-at node index))
(value-at node index vt)
(value-at header node index vt)
(fail-k default))))))
(call/cc
@ -113,26 +115,19 @@
(define (visit-leaf node header)
(let loop ((index 0))
(when (< index (node-header-nr-entries header))
(fn (key-at node index) (value-at node index vt))
(fn (key-at node index) (value-at header node index vt))
(loop (+ 1 index)))))
(define (visit-internal node header)
(let loop ((index 0))
(when (< index (node-header-nr-entries header))
(visit-node (value-at node index le64-type))
(visit-node (value-at header node index le64-type))
(loop (+ 1 index)))))
(define (visit-node root)
(let* ((node (read-block root))
(header (unpack-node-header node 0)))
(let* ((node (read-block (btree-dev tree) root))
(header (node-header-unpack node 0)))
((if (internal-node? header) visit-internal visit-leaf) node header)))
(visit-node (btree-root tree)))
(visit-node (btree-root tree)))))
))

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

@ -1,8 +1,10 @@
(import
(binary-format)
(block-io)
(btree)
(fmt fmt)
(matchable)
(mapping-tree)
(rnrs))
;;;;---------------------------------------------------
@ -17,18 +19,18 @@
(define $uuid-size 16)
(define $space-map-root-size 128)
(binary-format (superblock pack-superblock unpack-superblock)
(binary-format superblock
(csum le32)
(flags le32)
(block-nr le64)
(uuid (bytes 16))
(uuid (bytes $uuid-size))
(magic le64)
(version le32)
(time le32)
(trans-id le64)
(metadata-snap le64)
(data-space-map-root (bytes 128))
(metadata-space-map-root (bytes 128))
(data-space-map-root (bytes $space-map-root-size))
(metadata-space-map-root (bytes $space-map-root-size))
(data-mapping-root le64)
(device-details-root le64)
(data-block-size le32)
@ -49,7 +51,34 @@
(define (read-superblock)
(with-metadata (md (current-metadata))
(unpack-superblock (read-block md 0) 0)))
(superblock-unpack (read-block md 0) 0)))
(define (dump-dev-tree)
(with-metadata (md (current-metadata))
(let ((sb (superblock-unpack (read-block md 0) 0)))
(btree-each (btree-open le64-type md (superblock-data-mapping-root sb))
(lambda (k v)
(fmt #t (dsp "dev-id: ") (num k)
(dsp ", mapping root: ") (num v) nl))))))
(define (dump-mappings root)
(with-metadata (md (current-metadata))
(btree-each (btree-open le64-type md root)
(lambda (k v)
(fmt #t (dsp "vblock: ") (num k)
(dsp ", pblock: ") (num v) nl)))))
(define (dump-all-mappings)
(with-metadata (md (current-metadata))
(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)
(fmt #t
(dsp "thin dev ") (num dev-id)
(dsp ", vblock ") (num vblock)
(dsp ", pblock ") (num pblock)
nl)))))))
(define (check-superblock)
(with-metadata (md (current-metadata))

34
functional-tests/mapping-tree.scm Normal file
View File

@ -0,0 +1,34 @@
(library
(mapping-tree)
(export mapping-tree-open
mapping-tree-lookup
mapping-tree-each)
(import (btree)
(chezscheme)
(binary-format))
(define-record-type mapping-tree (fields dev-tree))
(define (mapping-tree-open dev root)
(make-mapping-tree (btree-open le64-type dev root)))
(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-type (btree-dev dev-tree) root2) vblock default))))
;;; Visits every entry in the mapping tree calling (fn dev-id vblock mapping).
(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))))
(btree-each dev-tree visit-dev))))