From 57db3a2b999928894bf471d3e0b994142ad0f096 Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Tue, 8 Aug 2017 11:47:37 +0100
Subject: [PATCH 1/6] [functional tests] Break up check-superblock.scm into
 separate libraries

---
 .gitignore                            |   2 +
 functional-tests/binary-format.scm    |  41 ++++++++++
 functional-tests/block-io.scm         |  53 +++++++++++++
 functional-tests/check-superblock.scm | 105 +-------------------------
 functional-tests/crc32.scm            |  23 ++++++
 5 files changed, 120 insertions(+), 104 deletions(-)
 create mode 100644 functional-tests/binary-format.scm
 create mode 100644 functional-tests/block-io.scm
 create mode 100644 functional-tests/crc32.scm

diff --git a/.gitignore b/.gitignore
index 4544b4f..47e6166 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,6 @@
 *~
+*.swp
+*.swo
 *.o
 *.so
 *.a
diff --git a/functional-tests/binary-format.scm b/functional-tests/binary-format.scm
new file mode 100644
index 0000000..95c18e0
--- /dev/null
+++ b/functional-tests/binary-format.scm
@@ -0,0 +1,41 @@
+(library
+  (binary-format)
+  (export binary-format)
+  (import (rnrs))
+
+  (define-syntax unpack-type
+    (syntax-rules (le32 le64 bytes)
+      ((_ bv offset le32)
+       (bytevector-u32-ref bv offset (endianness little)))
+
+      ((_ bv offset le64)
+       (bytevector-u64-ref bv offset (endianness little)))
+
+      ((_ bv offset (bytes count))
+       (let ((copy (make-bytevector count)))
+        (bytevector-copy! bv offset copy 0 count)
+        copy))))
+
+  (define (size-type t)
+    (syntax-case t (le32 le64 bytes)
+                 (le32 #'4)
+                 (le64 #'8)
+                 ((bytes count) #'count)))
+
+  ;;; FIXME: (bytes <count>) has to use a literal rather than a symbol.
+  (define-syntax binary-format
+    (lambda (x)
+      (syntax-case x ()
+                   ((_ (name pack-name unpack-name) (field type) ...)
+                    (with-syntax ((((t o) ...)
+                                   (let f ((acc 0) (types #'(type ...)))
+                                    (if (null? types)
+                                        '()
+                                        (cons (list (car types) acc)
+                                              (f (+ (syntax->datum (size-type (car types))) acc) (cdr types)))))))
+                                 #`(begin
+                                     (define-record-type name (fields field ...))
+
+                                     (define (unpack-name bv offset)
+                                       ((record-constructor (record-type-descriptor name))
+                                        (unpack-type bv (+ offset o) t) ...)))))))))
diff --git a/functional-tests/block-io.scm b/functional-tests/block-io.scm
new file mode 100644
index 0000000..dc873a2
--- /dev/null
+++ b/functional-tests/block-io.scm
@@ -0,0 +1,53 @@
+(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))))))
+
+
diff --git a/functional-tests/check-superblock.scm b/functional-tests/check-superblock.scm
index 3129d1d..e3cccb8 100644
--- a/functional-tests/check-superblock.scm
+++ b/functional-tests/check-superblock.scm
@@ -1,4 +1,5 @@
 (import
+  (block-io)
   (fmt fmt)
   (matchable))
 
@@ -10,115 +11,11 @@
 (define (current-metadata)
   "./metadata.bin")
 
-(define metadata-block-size 4096)
 (define superblock-magic 27022010)
 (define superblock-salt 160774)
 (define uuid-size 16)
 (define space-map-root-size 128)
 
-;;;;---------------------------------------------------
-;;;; Metadata IO
-;;;;---------------------------------------------------
-
-(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)))))
-
-;;; FIXME: implement a little block cache.
-
-
-;;;;---------------------------------------------------
-;;;; CRC32
-;;;;---------------------------------------------------
-
-;; FIXME: move to own library
-(load-shared-object "libz.so")
-(define crc32
-  (foreign-procedure "crc32" (unsigned-long u8* unsigned-int) unsigned-long))
-
-(define crc32-combine
-  (foreign-procedure "crc32_combine" (unsigned-long unsigned-long unsigned-long) unsigned-long))
-
-;; FIXME: stop copying the bytevector.  I'm not sure how to pass an offset into
-;; the bv.
-(define (crc32-region salt bv start end)
-  (assert (< start end))
-  (let ((len (- end start)))
-   (let ((copy (make-bytevector len)))
-    (bytevector-copy! bv start copy 0 len)
-    (let ((crc (crc32 salt copy 0)))
-     (crc32 crc copy len)))))
-
-;;;;---------------------------------------------------
-;;;; Decoding
-;;;;---------------------------------------------------
-
-(define-syntax unpack-type
-  (syntax-rules (le32 le64 bytes)
-    ((_ bv offset le32)
-     (bytevector-u32-ref bv offset (endianness little)))
-
-    ((_ bv offset le64)
-     (bytevector-u64-ref bv offset (endianness little)))
-
-    ((_ bv offset (bytes count))
-     (let ((copy (make-bytevector count)))
-      (bytevector-copy! bv offset copy 0 count)
-      copy))))
-
-(define (size-type t)
-  (syntax-case t (le32 le64 bytes)
-                 (le32 #'4)
-                 (le64 #'8)
-                 ((bytes count) #'count)))
-
-;;; FIXME: (bytes <count>) has to use a literal rather than a symbol.
-(define-syntax binary-format
-  (lambda (x)
-    (syntax-case x ()
-                 ((_ (name pack-name unpack-name) (field type) ...)
-                  (with-syntax ((((t o) ...)
-                                 (let f ((acc 0) (types #'(type ...)))
-                                  (if (null? types)
-                                      '()
-                                      (cons (list (car types) acc)
-                                            (f (+ (syntax->datum (size-type (car types))) acc) (cdr types)))))))
-                               #`(begin
-                                   (define-record-type name (fields field ...))
-
-                                   (define (unpack-name bv offset)
-                                     ((record-constructor (record-type-descriptor name))
-                                      (unpack-type bv (+ offset o) t) ...))))))))
-
 (binary-format (superblock pack-superblock unpack-superblock)
   (csum le32)
   (flags le32)
diff --git a/functional-tests/crc32.scm b/functional-tests/crc32.scm
new file mode 100644
index 0000000..c50d8d0
--- /dev/null
+++ b/functional-tests/crc32.scm
@@ -0,0 +1,23 @@
+(library
+  (crc32)
+  (export crc32)
+  (import (chezscheme))
+
+  (load-shared-object "libz.so")
+
+  (define crc32
+    (foreign-procedure "crc32" (unsigned-long u8* unsigned-int) unsigned-long))
+
+  (define crc32-combine
+    (foreign-procedure "crc32_combine" (unsigned-long unsigned-long unsigned-long) unsigned-long))
+
+  ;; FIXME: stop copying the bytevector.  I'm not sure how to pass an offset
+  ;; into the bv.
+  (define (crc32-region salt bv start end)
+    (assert (< start end))
+    (let ((len (- end start)))
+     (let ((copy (make-bytevector len)))
+      (bytevector-copy! bv start copy 0 len)
+      (let ((crc (crc32 salt copy 0)))
+       (crc32 crc copy len))))))
+

From 78488e8909052d95747c378ecb8eca06a8df3461 Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Tue, 8 Aug 2017 19:28:59 +0100
Subject: [PATCH 2/6] [functional tests] add code to read btrees

---
 functional-tests/btree.scm | 138 +++++++++++++++++++++++++++++++++++++
 1 file changed, 138 insertions(+)
 create mode 100644 functional-tests/btree.scm

diff --git a/functional-tests/btree.scm b/functional-tests/btree.scm
new file mode 100644
index 0000000..bd39de0
--- /dev/null
+++ b/functional-tests/btree.scm
@@ -0,0 +1,138 @@
+(library
+  (btree)
+
+  (export btree-open
+          btree-lookup
+          btree-each)
+
+  (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 pack-btree-node unpack-btree-node)
+
+    (csum le32)
+    (flags le32)
+    (blocknr le64)
+    (nr-entries le32)
+    (max-entries le32)
+    (value-size le32)
+    (padding le32))
+
+  (define-record-type value-type (fields size unpacker))
+
+  (define (max-entries vt)
+    (/ (- metadata-block-size node-header-size)
+       (+ (size-of 'le64)
+          (value-type-size vt))))
+
+  (define (key-offset index)
+    (+ node-header-size (* (size-of 'le64 index))))
+
+  (define (value-base vt)
+    (+ node-header-size
+       (* (max-entries vt)
+          (size-of 'le64))))
+
+  (define (value-offset vt index)
+    (+ (value-base vt)
+       (* (value-type-size vt) index)))
+
+  (define-record-type btree
+                      (fields value-type dev root))
+
+  (define (btree-open vt dev root)
+    (make-btree value-type dev root))
+
+  (define le64-type
+    (make-value-type (size-of 'le64)
+                     (lambda (bv offset)
+                       (unpack-type bv offset le64))))
+
+  (define (internal-node? header)
+    (bitwise-bit-set? 0 (node-header-flags header)))
+
+  (define (leaf-node? header)
+    (bitwise-bit-set? 1 (node-header-flags header)))
+
+  (define (key-at node index)
+    (unpack-type node (key-offset index le64)))
+
+  (define (value-at node index vt)
+    ((value-type-unpacker vt) node (value-offset 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 ((nr-entries (node-header-nr-entries header)))
+     (let loop ((lo 0) (hi nr-entries))
+      (if (= 1 (- hi lo))
+          lo
+          (let* ((mid (+ lo (/ (- hi lo) 2)))
+                 (k (key-at 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)))
+
+      (define (lookup root fail-k)
+        (let loop ((root root))
+         (let* ((node (read-block dev root))
+                (header (unpack-node-header node 0))
+                (index (lower-bound node header key fail-k)))
+           (if (internal-node? header)
+               (loop (unpack-value node index le64-type))
+               (if (= key (key-at node index))
+                   (value-at node index vt)
+                   (fail-k default))))))
+
+      (call/cc
+        (lambda (fail-k)
+          (lookup (btree-root tree) fail-k)))))
+
+  ;;;;----------------------------------------------
+  ;;;; 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 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 node index le64-type))
+          (loop (+ 1 index)))))
+
+     (define (visit-node root)
+       (let* ((node (read-block root))
+              (header (unpack-node-header node 0)))
+         ((if (internal-node? header) visit-internal visit-leaf) node header)))
+
+     (visit-node (btree-root tree)))
+
+
+
+
+
+
+
+    ))

From d0040a169db9f4d7087d3f86264836912fc6b476 Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Thu, 10 Aug 2017 15:07:20 +0100
Subject: [PATCH 3/6] [functional tests] more work on the binary-format macro

---
 functional-tests/binary-format.scm    | 61 +++++++++++++++++----------
 functional-tests/btree.scm            | 12 +++---
 functional-tests/check-superblock.scm | 17 ++++----
 functional-tests/list-utils.scm       |  7 ++-
 4 files changed, 59 insertions(+), 38 deletions(-)

diff --git a/functional-tests/binary-format.scm b/functional-tests/binary-format.scm
index 95c18e0..4c67801 100644
--- a/functional-tests/binary-format.scm
+++ b/functional-tests/binary-format.scm
@@ -1,7 +1,14 @@
 (library
   (binary-format)
-  (export binary-format)
-  (import (rnrs))
+  (export size-type binary-format le32 le64 bytes)
+  (import (rnrs)
+          (list-utils))
+
+  (define-syntax size-type
+    (syntax-rules (le32 le64 bytes)
+      ((_ le32) 4)
+      ((_ le64) 8)
+      ((_ (bytes count)) count)))
 
   (define-syntax unpack-type
     (syntax-rules (le32 le64 bytes)
@@ -16,26 +23,34 @@
         (bytevector-copy! bv offset copy 0 count)
         copy))))
 
-  (define (size-type t)
-    (syntax-case t (le32 le64 bytes)
-                 (le32 #'4)
-                 (le64 #'8)
-                 ((bytes count) #'count)))
-
-  ;;; FIXME: (bytes <count>) has to use a literal rather than a symbol.
   (define-syntax binary-format
-    (lambda (x)
-      (syntax-case x ()
-                   ((_ (name pack-name unpack-name) (field type) ...)
-                    (with-syntax ((((t o) ...)
-                                   (let f ((acc 0) (types #'(type ...)))
-                                    (if (null? types)
-                                        '()
-                                        (cons (list (car types) acc)
-                                              (f (+ (syntax->datum (size-type (car types))) acc) (cdr types)))))))
-                                 #`(begin
-                                     (define-record-type name (fields field ...))
+    (syntax-rules ()
+      ((_ (name pack-name unpack-name) (field type) ...)
+       (begin
+         (define-record-type name (fields field ...))
+
+       (define (unpack-name bv offset)
+         (let ((offset offset))
+
+          (define (inc-offset n v)
+            (set! offset (+ offset n))
+            v)
+
+          ((record-constructor (record-constructor-descriptor name))
+           (inc-offset (size-type type) (unpack-type bv offset type)) ...)))))))
+
+  ;;; since le32, le64 and bytes are used as auxiliary keywords, we must export
+  ;;; definitions of them as well.
+  ;;; FIXME: use a macro to remove duplication
+  (define-syntax le32
+    (lambda (x)
+      (syntax-violation 'le32 "misplaced auxiliary keyword" x)))
+
+  (define-syntax le64
+    (lambda (x)
+      (syntax-violation 'le64 "misplaced auxiliary keyword" x)))
+
+  (define-syntax bytes
+    (lambda (x)
+      (syntax-violation 'bytes "misplaced auxiliary keyword" x))))
 
-                                     (define (unpack-name bv offset)
-                                       ((record-constructor (record-type-descriptor name))
-                                        (unpack-type bv (+ offset o) t) ...)))))))))
diff --git a/functional-tests/btree.scm b/functional-tests/btree.scm
index bd39de0..78a61bd 100644
--- a/functional-tests/btree.scm
+++ b/functional-tests/btree.scm
@@ -3,7 +3,8 @@
 
   (export btree-open
           btree-lookup
-          btree-each)
+          btree-each
+          le64-type)
 
   (import (block-io)
           (chezscheme)
@@ -68,16 +69,15 @@
   ;;; Performs a binary search looking for the key and returns the index of the
   ;;; lower bound.
   (define (lower-bound node header key)
-    (let ((nr-entries (node-header-nr-entries header)))
-     (let loop ((lo 0) (hi nr-entries))
-      (if (= 1 (- hi lo))
+    (let loop ((lo 0) (hi (node-header-nr-entries header)))
+      (if (<= (- hi lo) 1)
           lo
           (let* ((mid (+ lo (/ (- hi lo) 2)))
-                 (k (key-at mid)))
+                 (k (key-at node mid)))
             (cond
               ((= key k) mid)
               ((< k key) (loop mid hi))
-              (else (loop lo mid))))))))
+              (else (loop lo mid)))))))
 
   ;;;;----------------------------------------------
   ;;;; Lookup
diff --git a/functional-tests/check-superblock.scm b/functional-tests/check-superblock.scm
index e3cccb8..d6e1437 100644
--- a/functional-tests/check-superblock.scm
+++ b/functional-tests/check-superblock.scm
@@ -1,20 +1,21 @@
 (import
+  (binary-format)
   (block-io)
   (fmt fmt)
-  (matchable))
+  (matchable)
+  (rnrs))
 
 ;;;;---------------------------------------------------
 ;;;; Constants
 ;;;;---------------------------------------------------
 
 ;; FIXME: duplicate with main.scm
-(define (current-metadata)
-  "./metadata.bin")
+(define (current-metadata) "./metadata.bin")
 
-(define superblock-magic 27022010)
-(define superblock-salt 160774)
-(define uuid-size 16)
-(define space-map-root-size 128)
+(define $superblock-magic 27022010)
+(define $superblock-salt 160774)
+(define $uuid-size 16)
+(define $space-map-root-size 128)
 
 (binary-format (superblock pack-superblock unpack-superblock)
   (csum le32)
@@ -54,5 +55,5 @@
   (with-metadata (md (current-metadata))
                  (let ((superblock (read-block md 0)))
                   (fmt #t (dsp "checksum on disk: ") (dsp (bytevector-u32-ref superblock 0 (endianness little))) nl)
-                  (fmt #t (dsp "calculated checksum: ") (dsp (crc32-region superblock-salt superblock 4 4092)) nl)
+                  ;(fmt #t (dsp "calculated checksum: ") (dsp (crc32-region $superblock-salt superblock 4 4092)) nl)
                   (check-magic superblock))))
diff --git a/functional-tests/list-utils.scm b/functional-tests/list-utils.scm
index a4b8d1e..3f7bdb0 100644
--- a/functional-tests/list-utils.scm
+++ b/functional-tests/list-utils.scm
@@ -1,8 +1,13 @@
 (library
   (list-utils)
-  (export intersperse iterate accumulate)
+  (export tails intersperse iterate accumulate)
   (import (rnrs))
 
+  (define (tails xs)
+    (if (null? xs)
+        '()
+        (cons xs (tails (cdr xs)))))
+
   (define (intersperse sep xs)
     (cond
       ((null? xs) '())

From 5e6ffbbd3a8070e55115da94b452fe5160c96a35 Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Fri, 11 Aug 2017 15:41:57 +0100
Subject: [PATCH 4/6] [functional tests] more work on decoding btrees

---
 functional-tests/binary-format.scm    | 78 ++++++++++++++++++++++-----
 functional-tests/btree.scm            | 59 ++++++++++----------
 functional-tests/check-superblock.scm | 39 ++++++++++++--
 functional-tests/mapping-tree.scm     | 34 ++++++++++++
 4 files changed, 161 insertions(+), 49 deletions(-)
 create mode 100644 functional-tests/mapping-tree.scm

diff --git a/functional-tests/binary-format.scm b/functional-tests/binary-format.scm
index 4c67801..be1611a 100644
--- a/functional-tests/binary-format.scm
+++ b/functional-tests/binary-format.scm
@@ -1,9 +1,20 @@
 (library
   (binary-format)
-  (export size-type binary-format le32 le64 bytes)
-  (import (rnrs)
+
+  (export unpack-type
+          size-type
+          binary-format
+          binary-format-names
+          le32
+          le64
+          bytes)
+
+  (import (chezscheme)
+          (fmt fmt)
           (list-utils))
 
+  ;;;-----------------------------------------
+
   (define-syntax size-type
     (syntax-rules (le32 le64 bytes)
       ((_ le32) 4)
@@ -23,23 +34,66 @@
         (bytevector-copy! bv offset copy 0 count)
         copy))))
 
-  (define-syntax binary-format
+#|
+(define-syntax ordered-funcall
+  (lambda (form)
+    (let ((form^ (cdr (syntax->list form))))
+     (let ((gens (map (lambda (_) (datum->syntax #'* (gensym "t"))) form^)))
+      #`(let* #,(map list gens form^)
+         #,gens)))))
+|#
+
+(define-syntax ordered-funcall
+  (lambda (x)
+    (syntax-case x ()
+       ((k f v ...)
+        (with-syntax
+          ([(t ...) (map (lambda (_)
+                           (datum->syntax #'k (gensym)))
+                         #'(v ...))])
+          #'(let* ([t v] ...)
+              (f t ...)))))))
+
+  (define-syntax binary-format-names
     (syntax-rules ()
-      ((_ (name pack-name unpack-name) (field type) ...)
+      ((_ (name pack-name unpack-name size-name) (field type) ...)
        (begin
          (define-record-type name (fields field ...))
 
-       (define (unpack-name bv offset)
-         (let ((offset offset))
+         (define size-name
+           (+ (size-type type) ...))
 
-          (define (inc-offset n v)
-            (set! offset (+ offset n))
-            v)
+         (define (unpack-name bv offset)
+           (let ((offset offset))
 
-          ((record-constructor (record-constructor-descriptor name))
-           (inc-offset (size-type type) (unpack-type bv offset type)) ...)))))))
+            (define (inc-offset n v)
+              (set! offset (+ offset n))
+              v)
 
-  ;;; since le32, le64 and bytes are used as auxiliary keywords, we must export
+            (ordered-funcall
+              (record-constructor (record-constructor-descriptor name))
+              (inc-offset (size-type type) (unpack-type bv offset type)) ...)))))))
+
+  (define-syntax binary-format
+    (lambda (x)
+      ;;; FIXME: we don't need multiple args
+      (define (gen-id template-id . args)
+        (datum->syntax template-id
+          (string->symbol
+            (apply string-append
+                   (map (lambda (x)
+                          (if (string? x)
+                              x
+                              (symbol->string (syntax->datum x))))
+                        args)))))
+      (syntax-case x ()
+                   ((_ name field ...)
+                    (with-syntax ((pack-name (gen-id #'name #'name "-pack"))
+                                  (unpack-name (gen-id #'name #'name "-unpack"))
+                                  (size-name (gen-id #'name #'name "-size")))
+                                 #'(binary-format-names (name pack-name unpack-name size-name) field ...))))))
+
+  ;;; Since le32, le64 and bytes are used as auxiliary keywords, we must export
   ;;; definitions of them as well.
   ;;; FIXME: use a macro to remove duplication
   (define-syntax le32
diff --git a/functional-tests/btree.scm b/functional-tests/btree.scm
index 78a61bd..052bc5b 100644
--- a/functional-tests/btree.scm
+++ b/functional-tests/btree.scm
@@ -1,7 +1,10 @@
 (library
   (btree)
 
-  (export btree-open
+  (export btree-value-type
+          btree-dev
+          btree-root
+          btree-open
           btree-lookup
           btree-each
           le64-type)
@@ -13,9 +16,7 @@
 
   ;;; 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 pack-btree-node unpack-btree-node)
-
+  (binary-format node-header
     (csum le32)
     (flags le32)
     (blocknr le64)
@@ -24,33 +25,34 @@
     (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-of 'le64)
+       (+ (size-type le64)
           (value-type-size vt))))
 
   (define (key-offset index)
-    (+ node-header-size (* (size-of 'le64 index))))
+    (+ node-header-size (* (size-type le64) index)))
 
-  (define (value-base vt)
+  (define (value-base header)
     (+ node-header-size
-       (* (max-entries vt)
-          (size-of 'le64))))
+       (* (node-header-max-entries header)
+          (size-type le64))))
 
-  (define (value-offset vt index)
-    (+ (value-base vt)
+  (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 value-type dev root))
+    (make-btree vt dev root))
 
   (define le64-type
-    (make-value-type (size-of 'le64)
+    (make-value-type (size-type le64)
                      (lambda (bv offset)
                        (unpack-type bv offset le64))))
 
@@ -61,10 +63,10 @@
     (bitwise-bit-set? 1 (node-header-flags header)))
 
   (define (key-at node index)
-    (unpack-type node (key-offset index le64)))
+    (unpack-type node (key-offset index) le64))
 
-  (define (value-at node index vt)
-    ((value-type-unpacker vt) node (value-offset vt index)))
+  (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.
@@ -90,12 +92,12 @@
       (define (lookup root fail-k)
         (let loop ((root root))
          (let* ((node (read-block dev root))
-                (header (unpack-node-header node 0))
-                (index (lower-bound node header key fail-k)))
+                (header (node-header-unpack node 0))
+                (index (lower-bound node header key)))
            (if (internal-node? header)
-               (loop (unpack-value node index le64-type))
+               (loop (value-at header node index le64-type))
                (if (= key (key-at node index))
-                   (value-at node index vt)
+                   (value-at header node index vt)
                    (fail-k default))))))
 
       (call/cc
@@ -113,26 +115,19 @@
      (define (visit-leaf node header)
        (let loop ((index 0))
         (when (< index (node-header-nr-entries header))
-          (fn (key-at node index) (value-at node index vt))
+          (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 node index le64-type))
+          (visit-node (value-at header node index le64-type))
           (loop (+ 1 index)))))
 
      (define (visit-node root)
-       (let* ((node (read-block root))
-              (header (unpack-node-header node 0)))
+       (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)))
+     (visit-node (btree-root tree)))))
 
-
-
-
-
-
-
-    ))
diff --git a/functional-tests/check-superblock.scm b/functional-tests/check-superblock.scm
index d6e1437..b8b6779 100644
--- a/functional-tests/check-superblock.scm
+++ b/functional-tests/check-superblock.scm
@@ -1,8 +1,10 @@
 (import
   (binary-format)
   (block-io)
+  (btree)
   (fmt fmt)
   (matchable)
+  (mapping-tree)
   (rnrs))
 
 ;;;;---------------------------------------------------
@@ -17,18 +19,18 @@
 (define $uuid-size 16)
 (define $space-map-root-size 128)
 
-(binary-format (superblock pack-superblock unpack-superblock)
+(binary-format superblock
   (csum le32)
   (flags le32)
   (block-nr le64)
-  (uuid (bytes 16))
+  (uuid (bytes $uuid-size))
   (magic le64)
   (version le32)
   (time le32)
   (trans-id le64)
   (metadata-snap le64)
-  (data-space-map-root (bytes 128))
-  (metadata-space-map-root (bytes 128))
+  (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)
@@ -49,7 +51,34 @@
 
 (define (read-superblock)
   (with-metadata (md (current-metadata))
-                 (unpack-superblock (read-block md 0) 0)))
+                 (superblock-unpack (read-block md 0) 0)))
+
+(define (dump-dev-tree)
+  (with-metadata (md (current-metadata))
+                 (let ((sb (superblock-unpack (read-block md 0) 0)))
+                  (btree-each (btree-open le64-type md (superblock-data-mapping-root sb))
+                              (lambda (k v)
+                                (fmt #t (dsp "dev-id: ") (num k)
+                                     (dsp ", mapping root: ") (num v) nl))))))
+
+(define (dump-mappings root)
+  (with-metadata (md (current-metadata))
+                 (btree-each (btree-open le64-type md root)
+                             (lambda (k v)
+                               (fmt #t (dsp "vblock: ") (num k)
+                                    (dsp ", pblock: ") (num v) nl)))))
+
+(define (dump-all-mappings)
+  (with-metadata (md (current-metadata))
+                 (let ((sb (superblock-unpack (read-block md 0) 0)))
+                  (let ((mappings (mapping-tree-open md (superblock-data-mapping-root sb))))
+                   (mapping-tree-each mappings
+                                      (lambda (dev-id vblock pblock)
+                                        (fmt #t
+                                             (dsp "thin dev ") (num dev-id)
+                                             (dsp ", vblock ") (num vblock)
+                                             (dsp ", pblock ") (num pblock)
+                                             nl)))))))
 
 (define (check-superblock)
   (with-metadata (md (current-metadata))
diff --git a/functional-tests/mapping-tree.scm b/functional-tests/mapping-tree.scm
new file mode 100644
index 0000000..229acdd
--- /dev/null
+++ b/functional-tests/mapping-tree.scm
@@ -0,0 +1,34 @@
+(library
+  (mapping-tree)
+
+  (export mapping-tree-open
+          mapping-tree-lookup
+          mapping-tree-each)
+
+  (import (btree)
+          (chezscheme)
+          (binary-format))
+
+  (define-record-type mapping-tree (fields dev-tree))
+
+  (define (mapping-tree-open dev root)
+    (make-mapping-tree (btree-open le64-type dev root)))
+
+  (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-type (btree-dev dev-tree) root2) vblock default))))
+
+  ;;; Visits every entry in the mapping tree calling (fn dev-id vblock mapping).
+  (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)
+                   (lambda (vblock mapping)
+                     (fn dev-id vblock mapping))))
+
+     (btree-each dev-tree visit-dev))))

From b2355df7198fc4bfe06c785cebd43fd73d44a967 Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Sat, 12 Aug 2017 19:27:21 +0100
Subject: [PATCH 5/6] [functional tests] we can now walk both levels of the
 mapping tree.

---
 functional-tests/binary-format.scm    | 20 ++++++++++----------
 functional-tests/btree.scm            |  4 ++--
 functional-tests/check-superblock.scm |  3 ++-
 functional-tests/mapping-tree.scm     | 14 +++++++++++---
 4 files changed, 25 insertions(+), 16 deletions(-)

diff --git a/functional-tests/binary-format.scm b/functional-tests/binary-format.scm
index be1611a..e36a787 100644
--- a/functional-tests/binary-format.scm
+++ b/functional-tests/binary-format.scm
@@ -43,16 +43,16 @@
          #,gens)))))
 |#
 
-(define-syntax ordered-funcall
-  (lambda (x)
-    (syntax-case x ()
-       ((k f v ...)
-        (with-syntax
-          ([(t ...) (map (lambda (_)
-                           (datum->syntax #'k (gensym)))
-                         #'(v ...))])
-          #'(let* ([t v] ...)
-              (f t ...)))))))
+  (define-syntax ordered-funcall
+    (lambda (x)
+      (syntax-case x ()
+        ((k f v ...)
+         (with-syntax
+           ([(t ...) (map (lambda (_)
+                            (datum->syntax #'k (gensym)))
+                          #'(v ...))])
+           #'(let* ([t v] ...)
+               (f t ...)))))))
 
   (define-syntax binary-format-names
     (syntax-rules ()
diff --git a/functional-tests/btree.scm b/functional-tests/btree.scm
index 052bc5b..e2c0f26 100644
--- a/functional-tests/btree.scm
+++ b/functional-tests/btree.scm
@@ -57,10 +57,10 @@
                        (unpack-type bv offset le64))))
 
   (define (internal-node? header)
-    (bitwise-bit-set? 0 (node-header-flags header)))
+    (bitwise-bit-set? (node-header-flags header) 0))
 
   (define (leaf-node? header)
-    (bitwise-bit-set? 1 (node-header-flags header)))
+    (bitwise-bit-set? (node-header-flags header) 1))
 
   (define (key-at node index)
     (unpack-type node (key-offset index) le64))
diff --git a/functional-tests/check-superblock.scm b/functional-tests/check-superblock.scm
index b8b6779..f2707a5 100644
--- a/functional-tests/check-superblock.scm
+++ b/functional-tests/check-superblock.scm
@@ -73,11 +73,12 @@
                  (let ((sb (superblock-unpack (read-block md 0) 0)))
                   (let ((mappings (mapping-tree-open md (superblock-data-mapping-root sb))))
                    (mapping-tree-each mappings
-                                      (lambda (dev-id vblock pblock)
+                                      (lambda (dev-id vblock pblock time)
                                         (fmt #t
                                              (dsp "thin dev ") (num dev-id)
                                              (dsp ", vblock ") (num vblock)
                                              (dsp ", pblock ") (num pblock)
+                                             (dsp ", time ") (num time)
                                              nl)))))))
 
 (define (check-superblock)
diff --git a/functional-tests/mapping-tree.scm b/functional-tests/mapping-tree.scm
index 229acdd..1f28e7a 100644
--- a/functional-tests/mapping-tree.scm
+++ b/functional-tests/mapping-tree.scm
@@ -7,7 +7,8 @@
 
   (import (btree)
           (chezscheme)
-          (binary-format))
+          (binary-format)
+          (srfi s8 receive))
 
   (define-record-type mapping-tree (fields dev-tree))
 
@@ -22,13 +23,20 @@
          default
          (btree-lookup (btree-open le64-type (btree-dev dev-tree) root2) vblock default))))
 
-  ;;; Visits every entry in the mapping tree calling (fn dev-id vblock mapping).
+  ;; (values <block> <time>)
+  (define time-mask (- (fxsll 1 24) 1))
+
+  (define (unpack-block-time bt)
+    (values (fxsrl bt 24) (fxlogand bt time-mask)))
+
+  ;;; 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)
                    (lambda (vblock mapping)
-                     (fn dev-id vblock mapping))))
+                     (receive (block time) (unpack-block-time mapping)
+                              (fn dev-id vblock block time)))))
 
      (btree-each dev-tree visit-dev))))

From 7f7a7d6605eabdb33858c8e3c5f36d9a1b0b8ab2 Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Mon, 14 Aug 2017 10:05:38 +0100
Subject: [PATCH 6/6] [functional tests] start thinking about a block cache
 interface.

I want to use FFI to link with a C library containing the actual block
cache, io engine and crc32 code.
---
 functional-tests/block-cache.scm  | 83 +++++++++++++++++++++++++++++++
 functional-tests/block-io.scm     | 11 ++--
 functional-tests/btree.scm        | 23 ++++-----
 functional-tests/mapping-tree.scm | 14 +++---
 4 files changed, 105 insertions(+), 26 deletions(-)
 create mode 100644 functional-tests/block-cache.scm

diff --git a/functional-tests/block-cache.scm b/functional-tests/block-cache.scm
new file mode 100644
index 0000000..6b0dfc8
--- /dev/null
+++ b/functional-tests/block-cache.scm
@@ -0,0 +1,83 @@
+(library
+  (block-cache)
+  (exports)
+  (imports (chezscheme))
+
+  (define (cache-open path block-size nr-cache-blocks)
+    ...
+    )
+
+  (define (cache-read-lock cache index)
+    
+    )
+
+  (define (cache-write-lock cache index))
+  (define (cache-zero-lock cache index))
+
+  ;; The super block is the one that should be written last.  Unlocking this
+  ;; block triggers the following events:
+  ;;
+  ;; i)  synchronous write of all dirty blocks _except_ the superblock.
+  ;;
+  ;; ii)  synchronous write of superblock
+  ;;
+  ;; If any locks are held at the time of the superblock being unlocked then an
+  ;; error will be raised.
+  (define (cache-superblock-lock cache index))
+  (define (cache-superblock-zero))
+
+  (define (cache-unlock b)
+    )
+
+  (define-syntax with-block
+    (syntax-rules ()
+      ((_ (var b) body ...)
+       (let ((var b))
+        (dynamic-wind
+         (lambda () #f)
+         (lambda () body ...)
+         (lambda () (block-put var)))))))
+
+  ;;--------------------------------------------
+
+  (define-record-type ro-spine (fields cache parent child))
+
+  (define (ro-spine-begin cache)
+    (make-ro-spine cache #f #f))
+
+  (define (ro-spine-end spine)
+    (define (unlock bl)
+      (if bl (cache-unlock) #f))
+
+    (unlock (ro-spine-parent spine))
+    (unlock (ro-spine-child spine))
+    (ro-spine-parent-set! spine #f)
+    (ro-spind-child-set! spine #f))
+
+  (define (ro-spine-step spine index)
+    (define (push b)
+      (cond
+        ((ro-spine-child spine)
+         (let ((grandparent (ro-spine-parent spine)))
+          (ro-spine-parent-set! spine (ro-spine-child spine))
+          (ro-spine-child-set! spine b)))
+        ((ro-spine-parent spine)
+         (ro-spine-child-set! spine b))
+        (else
+          (ro-spine-parent-set! spine b))))
+
+    (push (cache-read-lock (ro-spine-cache spine) index)))
+
+  (define-syntax with-ro-spine
+    (syntax-rules ()
+      ((_ (n cache) body ...)
+
+       (let ((n (ro-spine-begin cache)))
+        (dynamic-wind
+         (lambda () #f)
+         (lambda () body ...)
+         (lambda () (ro-spine-end)))))))
+
+  )
+
+
diff --git a/functional-tests/block-io.scm b/functional-tests/block-io.scm
index dc873a2..7cf0625 100644
--- a/functional-tests/block-io.scm
+++ b/functional-tests/block-io.scm
@@ -22,11 +22,12 @@
 
   (define-syntax with-metadata
     (syntax-rules ()
-      ((_ (port path) body ...) (let ((port (open-metadata path)))
-                                 (dynamic-wind
-                                   (lambda () #f)
-                                   (lambda () body ...)
-                                   (lambda () (close-port port)))))))
+      ((_ (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)
diff --git a/functional-tests/btree.scm b/functional-tests/btree.scm
index e2c0f26..a947ca4 100644
--- a/functional-tests/btree.scm
+++ b/functional-tests/btree.scm
@@ -89,20 +89,15 @@
     (let ((dev (btree-dev tree))
           (vt (btree-value-type tree)))
 
-      (define (lookup root fail-k)
-        (let loop ((root root))
-         (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)
-                   (fail-k default))))))
-
-      (call/cc
-        (lambda (fail-k)
-          (lookup (btree-root tree) fail-k)))))
+      (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
diff --git a/functional-tests/mapping-tree.scm b/functional-tests/mapping-tree.scm
index 1f28e7a..00028a1 100644
--- a/functional-tests/mapping-tree.scm
+++ b/functional-tests/mapping-tree.scm
@@ -7,7 +7,6 @@
 
   (import (btree)
           (chezscheme)
-          (binary-format)
           (srfi s8 receive))
 
   (define-record-type mapping-tree (fields dev-tree))
@@ -15,6 +14,13 @@
   (define (mapping-tree-open dev root)
     (make-mapping-tree (btree-open le64-type dev root)))
 
+  ;; (values <block> <time>)
+  (define time-mask (- (fxsll 1 24) 1))
+
+  (define (unpack-block-time bt)
+    (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))
@@ -23,12 +29,6 @@
          default
          (btree-lookup (btree-open le64-type (btree-dev dev-tree) root2) vblock default))))
 
-  ;; (values <block> <time>)
-  (define time-mask (- (fxsll 1 24) 1))
-
-  (define (unpack-block-time bt)
-    (values (fxsrl bt 24) (fxlogand bt time-mask)))
-
   ;;; 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)))