From 4d3733d0e728af730b0af4cce759a6fde435516f Mon Sep 17 00:00:00 2001 From: Joe Thornber Date: Thu, 14 Sep 2017 16:09:43 +0100 Subject: [PATCH] [functional-tests] change btree functions to take a spine. Also change the step-spine interface slightly. --- functional-tests/bcache/block-manager.scm | 29 ++++----- functional-tests/persistent-data/btree.scm | 68 ++++++++++------------ functional-tests/thin-functional-tests.scm | 3 +- functional-tests/thin/check.scm | 17 +++--- functional-tests/thin/mapping-tree.scm | 42 +++++++------ functional-tests/thin/metadata.scm | 4 +- 6 files changed, 80 insertions(+), 83 deletions(-) diff --git a/functional-tests/bcache/block-manager.scm b/functional-tests/bcache/block-manager.scm index 87fe047..ef4f01b 100644 --- a/functional-tests/bcache/block-manager.scm +++ b/functional-tests/bcache/block-manager.scm @@ -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) - (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))))) + (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)))))) (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 ...))))) ) diff --git a/functional-tests/persistent-data/btree.scm b/functional-tests/persistent-data/btree.scm index 1648384..f6cdda2 100644 --- a/functional-tests/persistent-data/btree.scm +++ b/functional-tests/persistent-data/btree.scm @@ -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,54 +121,51 @@ ;;;; Lookup ;;;;---------------------------------------------- - (define (btree-lookup tree key default) - (let ((cache (btree-bcache tree)) - (vt (btree-value-type tree))) - (with-spine (sp 1) - (let loop ((root (btree-root tree))) - (spine-step sp (b (get-block 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)))))))) + (define (btree-lookup tree sp key default) + (let ((vt (btree-value-type tree))) + + (let loop ((root (btree-root tree))) + (spine-step sp (b 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 (btree-each tree sp fn) + (let ((vt (btree-value-type tree))) - (with-spine (sp 1) - (define (visit-leaf nr-entries keys vals) + (define (visit-leaf nr-entries keys vals) (let loop ((index 0)) (when (< index nr-entries) (fn (key-at keys index) (vt 'ref vals index)) (loop (+ 1 index))))) - (define (visit-internal nr-entries keys vals) + (define (visit-internal nr-entries keys vals) (let loop ((index 0)) (when (< index nr-entries) (visit-node (le64-vt 'ref vals index)) (loop (+ 1 index))))) - (define (visit-node root) - (spine-step sp (b (get-block 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)))) + (define (visit-node root) + (spine-step sp (b 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))))) - ) + (visit-node (btree-root tree)))) +) diff --git a/functional-tests/thin-functional-tests.scm b/functional-tests/thin-functional-tests.scm index 8006cf0..3386171 100644 --- a/functional-tests/thin-functional-tests.scm +++ b/functional-tests/thin-functional-tests.scm @@ -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) diff --git a/functional-tests/thin/check.scm b/functional-tests/thin/check.scm index ef32e73..68ac4e0 100644 --- a/functional-tests/thin/check.scm +++ b/functional-tests/thin/check.scm @@ -43,14 +43,15 @@ (define super-block-only #f) (define (dump-dev-tree cache root) - (btree-each (btree-open device-details-vt cache root) - (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")))) + (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"))))) (define-enumeration thin-check-element (quiet diff --git a/functional-tests/thin/mapping-tree.scm b/functional-tests/thin/mapping-tree.scm index 2f133fa..3918469 100644 --- a/functional-tests/thin/mapping-tree.scm +++ b/functional-tests/thin/mapping-tree.scm @@ -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