[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

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

functional-tests/block-io.scm

@@ -22,7 +22,8 @@
 
   (define-syntax with-metadata
     (syntax-rules ()
-      ((_ (port path) body ...) (let ((port (open-metadata path)))
+      ((_ (port path) body ...)
+       (let ((port (open-metadata path)))
         (dynamic-wind
           (lambda () #f)
           (lambda () body ...)

functional-tests/btree.scm

@@ -89,8 +89,7 @@
     (let ((dev (btree-dev tree))
           (vt (btree-value-type tree)))
 
-      (define (lookup root fail-k)
+      (let loop ((root (btree-root tree)))
-        (let loop ((root root))
        (let* ((node (read-block dev root))
               (header (node-header-unpack node 0))
               (index (lower-bound node header key)))
@@ -98,11 +97,7 @@
              (loop (value-at header node index le64-type))
              (if (= key (key-at node index))
                  (value-at header node index vt)
-                   (fail-k default))))))
+                 default))))))
-
-      (call/cc
-        (lambda (fail-k)
-          (lookup (btree-root tree) fail-k)))))
 
   ;;;;----------------------------------------------
   ;;;; Walking the btree

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