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

[functional-tests] change btree to use the bcache

Browse Source
This commit is contained in:
Joe Thornber 2017-09-08 15:51:33 +01:00
parent 3b7320cd84
commit 40b257d42e
5 changed files with 186 additions and 208 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
functional-tests/block-io.scm
View File

@ -1,54 +0,0 @@
(library
(block-io)
(export metadata-block-size
open-metadata
with-metadata
read-block)
(import (rnrs)
(fmt fmt))
;;;---------------------------------------------------
;;; TODO:
;;; - implement a little block cache.
;;; - writes
;;; - zero blocks
;;; - prefetching
;;;---------------------------------------------------
(define metadata-block-size 4096)
(define (open-metadata path)
(open-file-input-port path (file-options) (buffer-mode none)))
(define-syntax with-metadata
(syntax-rules ()
((_ (port path) body ...)
(let ((port (open-metadata path)))
(dynamic-wind
(lambda () #f)
(lambda () body ...)
(lambda () (close-port port)))))))
;; FIXME: return our own condition?
(define (io-error msg)
(raise (condition
(make-error)
(make-message-condition msg))))
;;; Returns a boolean indicating success
(define (read-exact! port offset len bv start)
(set-port-position! port offset)
(let ((nr (get-bytevector-n! port bv start len)))
(and (not (eof-object? nr))
(= len nr))))
;;; Returns a 4k bytevector or #f
(define (read-exact port offset len)
(let ((bv (make-bytevector len)))
(if (read-exact! port offset len bv 0) bv #f)))
(define (read-block port b)
(or (read-exact port (* b metadata-block-size) metadata-block-size)
(io-error (fmt #f (dsp "Unable to read metadata block: ") (num b))))))

128
functional-tests/btree.scm
View File

@ -1,128 +0,0 @@
(library
(btree)
(export btree-value-type
btree-dev
btree-root
btree-open
btree-lookup
btree-each
le64-type)
(import (block-io)
(chezscheme)
(binary-format)
(list-utils))
;;; 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
(csum le32)
(flags le32)
(blocknr le64)
(nr-entries le32)
(max-entries le32)
(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-type le64)
(value-type-size vt))))
(define (key-offset index)
(+ node-header-size (* (size-type le64) index)))
(define (value-base header)
(+ node-header-size
(* (node-header-max-entries header)
(size-type le64))))
(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 vt dev root))
(define le64-type
(make-value-type (size-type le64)
(lambda (bv offset)
(unpack-type bv offset le64))))
(define (internal-node? header)
(bitwise-bit-set? (node-header-flags header) 0))
(define (leaf-node? header)
(bitwise-bit-set? (node-header-flags header) 1))
(define (key-at node index)
(unpack-type node (key-offset index) le64))
(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.
(define (lower-bound node header key)
(let loop ((lo 0) (hi (node-header-nr-entries header)))
(if (<= (- hi lo) 1)
lo
(let* ((mid (+ lo (/ (- hi lo) 2)))
(k (key-at node mid)))
(cond
((= key k) mid)
((< k key) (loop mid hi))
(else (loop lo mid)))))))
;;;;----------------------------------------------
;;;; Lookup
;;;;----------------------------------------------
(define (btree-lookup tree key default)
(let ((dev (btree-dev tree))
(vt (btree-value-type tree)))
(let loop ((root (btree-root tree)))
(let* ((node (read-block dev root))
(header (node-header-unpack node 0))
(index (lower-bound node header key)))
(if (internal-node? header)
(loop (value-at header node index le64-type))
(if (= key (key-at node index))
(value-at header node index vt)
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)))
(define (visit-leaf node header)
(let loop ((index 0))
(when (< index (node-header-nr-entries header))
(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 header node index le64-type))
(loop (+ 1 index)))))
(define (visit-node root)
(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)))))

158
functional-tests/persistent-data/btree.scm Normal file
View File

@ -0,0 +1,158 @@
(library
(btree)
(export btree-value-type
btree-bcache
btree-root
btree-open
btree-lookup
btree-each
le64-vt
BTreeNodeHeader)
(import (bcache block-manager)
(chezscheme)
(list-utils)
(utils))
(define-ftype BTreeNodeHeader
(packed
(endian little
(struct
(csum unsigned-32)
(flags unsigned-32)
(blocknr unsigned-64)
(nr-entries unsigned-32)
(max-entries unsigned-32)
(value-size unsigned-32)
(padding unsigned-32)))))
(define-ftype LittleEndian64
(endian little unsigned-64))
;; The metadata block is made up of:
;; | node header | keys | values |
(define (block->header b)
(make-ftype-pointer BTreeNodeHeader b))
(define (block->keys b)
(make-ftype-pointer LittleEndian64
(+ b (ftype-sizeof BTreeNodeHeader))))
;;; Value-types are dlambdas with these methods:
;;; (vt 'mk-ptr <raw-ptr>)
;;; (vt 'ref <vt-ptr> index)
;;; (vt 'set <vt-ptr> index val)
;;; (vt 'size)
(define le64-vt
(dlambda
(mk-ptr (p) (make-ftype-pointer LittleEndian64 p))
(ref (fp index) (ftype-ref LittleEndian64 () fp index))
(set (fp index val) (ftype-set! LittleEndian64 () fp index val))
(size () (ftype-sizeof LittleEndian64))))
(define (block->values b vt)
(vt
(+ b (ftype-sizeof BTreeNodeHeader)
(* (ftype-ref BTreeNodeHeader (max-entries) (block->header b))
(ftype-sizeof LittleEndian64)))))
(define (key-at keys index)
(ftype-ref LittleEndian64 () keys index))
(define (value-at vt vals index)
(vt 'ref vals index))
#|
(define (max-entries vt)
(/ (- metadata-block-size (ftype-sizeof BTreeNodeHeader))
(+ (ftype-sizeof LittleEndian64)
(vt 'size))))
|#
(define-record-type btree
(fields value-type bcache root))
(define (btree-open vt bcache root)
(make-btree vt bcache root))
;;; (ftype-pointer BTreeNodeHeader) -> bool
(define (internal-node? header)
(bitwise-bit-set? (ftype-ref BTreeNodeHeader (flags) header) 0))
;;; (ftype-pointer BTreeNodeHeader) -> bool
(define (leaf-node? header)
(bitwise-bit-set? (ftype-ref BTreeNodeHeader (flags) header) 1))
;;; void* BTreeNodeHeader u64 -> integer
;;; Performs a binary search looking for the key and returns the index of the
;;; lower bound.
(define (lower-bound b header key)
(let ((keys (block->keys b)))
(let loop ((lo 0)
(hi (ftype-ref BTreeNodeHeader (nr-entries) header)))
(if (<= (- hi lo) 1)
lo
(let* ((mid (+ lo (/ (- hi lo) 2)))
(k (key-at b mid)))
(cond
((= key k) mid)
((< k key) (loop mid hi))
(else (loop lo mid))))))))
;;;;----------------------------------------------
;;;; Lookup
;;;;----------------------------------------------
;; FIXME: this holds more blocks than we need as we recurse, use a fixed
;; size block queue.
(define (btree-lookup tree key default)
(let ((cache (btree-bcache tree))
(vt (btree-value-type tree)))
(let loop ((root (btree-root tree)))
(with-block (b 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)))))))
;;;;----------------------------------------------
;;;; 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 (visit-leaf nr-entries keys vals)
(let loop ((index 0))
(when (< index nr-entries)
(fn (key-at keys index) (value-at vt vals index))
(loop (+ 1 index)))))
(define (visit-internal nr-entries keys vals)
(let loop ((index 0))
(when (< index nr-entries)
(visit-node (value-at le64-vt vals index))
(loop (+ 1 index)))))
(define (visit-node root)
(with-block (b 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))))
(visit-node (btree-root tree)))))

6
functional-tests/mapping-tree.scm → functional-tests/thin/mapping-tree.scm
View File

@ -12,7 +12,7 @@
(define-record-type mapping-tree (fields dev-tree))
(define (mapping-tree-open dev root)
(make-mapping-tree (btree-open le64-type dev root)))
(make-mapping-tree (btree-open le64-vt dev root)))
;; (values <block> <time>)
(define time-mask (- (fxsll 1 24) 1))
@ -27,14 +27,14 @@
(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))))
(btree-lookup (btree-open le64-vt (btree-bcache dev-tree) root2) 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 (visit-dev dev-id mapping-root)
(btree-each (btree-open le64-type (btree-dev dev-tree) 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)))))

48
functional-tests/check-superblock.scm → functional-tests/thin/thin_check
View File

@ -1,11 +1,10 @@
(import
(binary-format)
(block-io)
(bcache block-manager)
(btree)
(fmt fmt)
(matchable)
(mapping-tree)
(rnrs))
(chezscheme))
;;;;---------------------------------------------------
;;;; Constants
@ -19,26 +18,29 @@
(define $uuid-size 16)
(define $space-map-root-size 128)
(binary-format superblock
(csum le32)
(flags le32)
(block-nr le64)
(uuid (bytes $uuid-size))
(magic le64)
(version le32)
(time le32)
(trans-id le64)
(metadata-snap le64)
(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)
(metadata-block-size le32)
(metadata-nr-blocks le64)
(compat-flags le32)
(compat-ro-flags le32)
(incompat-flags le32))
(define-ftype Superblock
(packed
(endian little
(struct
(csum unsigned-32)
(flags unsigned-32)
(block-nr unsigned-64)
(uuid (bytes $uuid-size))
(magic unsigned-32)
(version unsigned-32)
(time unsigned-32)
(trans-id unsigned-64)
(metadata-snap unsigned-64)
(data-space-map-root (bytes $space-map-root-size))
(metadata-space-map-root (bytes $space-map-root-size))
(data-mapping-root unsigned-64)
(device-details-root unsigned-64)
(data-block-size unsigned-32)
(metadata-block-size unsigned-32)
(metadata-nr-blocks unsigned-64)
(compat-flags unsigned-32)
(compat-ro-flags unsigned-32)
(incompat-flags unsigned-32)))))
;;;;---------------------------------------------------
;;;; Top level