[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)
+        (lambda (cache max)
-          (new 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 ...)
+      ((_ (sp cache max) b1 b2 ...)
-       (let ((sp (make-spine max)))
+       (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)
+  (define (btree-open vt root)
-    (make-btree vt bcache root))
+    (make-btree vt root))
 
   ;;; (ftype-pointer BTreeNodeHeader) -> bool
   (define (internal-node? header)
@@ -122,12 +121,11 @@
   ;;;; Lookup
   ;;;;----------------------------------------------
 
-  (define (btree-lookup tree key default)
+  (define (btree-lookup tree sp key default)
-    (let ((cache (btree-bcache tree))
+    (let ((vt (btree-value-type 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)))
+      (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)
+  (define (btree-each tree sp fn)
-    (let ((vt (btree-value-type tree))
+    (let ((vt (btree-value-type tree)))
-          (cache (btree-bcache 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))))
-  )
+)
 

functional-tests/thin-functional-tests.scm

@@ -12,8 +12,7 @@
     (scenario-string-constants)
     (temp-file)
     (thin-xml)
-    (srfi s8 receive)
+    (srfi s8 receive))
-    (only (srfi s1 lists) drop-while))
 
   (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)
+  (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

functional-tests/thin/mapping-tree.scm

@@ -1,19 +1,14 @@
 (library
   (thin mapping-tree)
 
-  (export mapping-tree-open
+  (export mapping-tree-lookup
-          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))
+             (dev-tree (btree-open le64-vt root))
-           (root2 (btree-lookup dev-tree dev-id unique)))
+             (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)
+  (define (mapping-tree-each cache root fn)
-    (let ((dev-tree (mapping-tree-dev-tree mtree)))
+          (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))))
+  )

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)