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.

Browse Source 
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

19
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)
(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)))))
(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 ...)))))
)

28
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,12 +121,11 @@
;;;; Lookup
;;;;----------------------------------------------
(define (btree-lookup tree key default)
(let ((cache (btree-bcache tree))
(vt (btree-value-type tree)))
(with-spine (sp 1)
(define (btree-lookup tree sp key default)
(let ((vt (btree-value-type tree)))
(let loop ((root (btree-root tree)))
(spine-step sp (b (get-block cache root (get-flags)))
(spine-step sp (b root (get-flags))
(let* ((header (block->header b))
(keys (block->keys b))
(vals (block->values b vt))
@ -136,18 +134,16 @@
(loop (value-at le64-vt vals index))
(if (= key (key-at keys index))
(value-at vt vals index)
default))))))))
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)
(let loop ((index 0))
(when (< index nr-entries)
@ -161,7 +157,7 @@
(loop (+ 1 index)))))
(define (visit-node root)
(spine-step sp (b (get-block cache root (get-flags)))
(spine-step sp (b root (get-flags))
(let* ((header (block->header b))
(nr-entries (ftype-ref BTreeNodeHeader (nr-entries) header))
(keys (block->keys b))
@ -170,6 +166,6 @@
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)

5
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)
(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"))))
" snapshotted time: " (ftype-ref ThinDeviceDetails (snapshotted-time) v) "\n")))))
(define-enumeration thin-check-element
(quiet

28
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)
(define (mapping-tree-lookup cache root dev-id vblock default)
(with-spine (sp cache 1)
(let* ((unique (gensym))
(dev-tree (mapping-tree-dev-tree mtree))
(root2 (btree-lookup dev-tree dev-id unique)))
(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 (btree-bcache dev-tree) root2) vblock 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)
(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)