[functional-tests] change btree functions to take a spine.

Also change the step-spine interface slightly.

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

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))))
+)
 

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)

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

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 <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)
-    (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-vt (btree-bcache dev-tree) root2) vblock default))))
+  (define (mapping-tree-lookup cache root dev-id vblock default)
+    (with-spine (sp cache 1)
+      (let* ((unique (gensym))
+             (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 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)
-         (lambda (vblock mapping)
-           (receive (block time) (unpack-block-time mapping)
-             (fn dev-id vblock block time)))))
+             (define (visit-dev dev-id 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))))
+  )

functional-tests/thin/metadata.scm

@@ -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)