[functional-tests] change btree to use the bcache

functional-tests/block-io.scm

@@ -1,54 +0,0 @@
-(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))))))
-
-

functional-tests/btree.scm

@@ -1,128 +0,0 @@
-(library
-  (btree)
-
-  (export btree-value-type
-          btree-dev
-          btree-root
-          btree-open
-          btree-lookup
-          btree-each
-          le64-type)
-
-  (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
-    (csum le32)
-    (flags le32)
-    (blocknr le64)
-    (nr-entries le32)
-    (max-entries le32)
-    (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-type le64)
-          (value-type-size vt))))
-
-  (define (key-offset index)
-    (+ node-header-size (* (size-type le64) index)))
-
-  (define (value-base header)
-    (+ node-header-size
-       (* (node-header-max-entries header)
-          (size-type le64))))
-
-  (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 vt dev root))
-
-  (define le64-type
-    (make-value-type (size-type le64)
-                     (lambda (bv offset)
-                       (unpack-type bv offset le64))))
-
-  (define (internal-node? header)
-    (bitwise-bit-set? (node-header-flags header) 0))
-
-  (define (leaf-node? header)
-    (bitwise-bit-set? (node-header-flags header) 1))
-
-  (define (key-at node index)
-    (unpack-type node (key-offset index) le64))
-
-  (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.
-  (define (lower-bound node header key)
-    (let loop ((lo 0) (hi (node-header-nr-entries header)))
-      (if (<= (- hi lo) 1)
-          lo
-          (let* ((mid (+ lo (/ (- hi lo) 2)))
-                 (k (key-at node 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)))
-
-      (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
-  ;;;;----------------------------------------------
-
-  ;;; 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 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 header node index le64-type))
-          (loop (+ 1 index)))))
-
-     (define (visit-node root)
-       (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)))))
-

functional-tests/persistent-data/btree.scm

@@ -0,0 +1,158 @@
+(library
+  (btree)
+
+  (export btree-value-type
+          btree-bcache
+          btree-root
+          btree-open
+          btree-lookup
+          btree-each
+          le64-vt
+
+          BTreeNodeHeader)
+
+  (import (bcache block-manager)
+          (chezscheme)
+          (list-utils)
+          (utils))
+
+  (define-ftype BTreeNodeHeader
+    (packed
+      (endian little
+              (struct
+                (csum unsigned-32)
+                (flags unsigned-32)
+                (blocknr unsigned-64)
+                (nr-entries unsigned-32)
+                (max-entries unsigned-32)
+                (value-size unsigned-32)
+                (padding unsigned-32)))))
+
+  (define-ftype LittleEndian64
+    (endian little unsigned-64))
+
+  ;; The metadata block is made up of:
+  ;; | node header | keys | values |
+  (define (block->header b)
+    (make-ftype-pointer BTreeNodeHeader b))
+
+  (define (block->keys b)
+    (make-ftype-pointer LittleEndian64
+                        (+ b (ftype-sizeof BTreeNodeHeader))))
+
+  ;;; Value-types are dlambdas with these methods:
+  ;;; (vt 'mk-ptr <raw-ptr>)
+  ;;; (vt 'ref <vt-ptr> index)
+  ;;; (vt 'set <vt-ptr> index val)
+  ;;; (vt 'size)
+  (define le64-vt
+    (dlambda
+      (mk-ptr (p) (make-ftype-pointer LittleEndian64 p))
+      (ref (fp index) (ftype-ref LittleEndian64 () fp index))
+      (set (fp index val) (ftype-set! LittleEndian64 () fp index val))
+      (size () (ftype-sizeof LittleEndian64))))
+
+  (define (block->values b vt)
+    (vt
+      (+ b (ftype-sizeof BTreeNodeHeader)
+        (* (ftype-ref BTreeNodeHeader (max-entries) (block->header b))
+           (ftype-sizeof LittleEndian64)))))
+
+  (define (key-at keys index)
+    (ftype-ref LittleEndian64 () keys index))
+
+  (define (value-at vt vals index)
+    (vt 'ref vals index))
+
+  #|
+  (define (max-entries vt)
+    (/ (- metadata-block-size (ftype-sizeof BTreeNodeHeader))
+       (+ (ftype-sizeof LittleEndian64)
+          (vt 'size))))
+  |#
+
+  (define-record-type btree
+    (fields value-type bcache root))
+
+  (define (btree-open vt bcache root)
+    (make-btree vt bcache root))
+
+  ;;; (ftype-pointer BTreeNodeHeader) -> bool
+  (define (internal-node? header)
+    (bitwise-bit-set? (ftype-ref BTreeNodeHeader (flags) header) 0))
+
+  ;;; (ftype-pointer BTreeNodeHeader) -> bool
+  (define (leaf-node? header)
+    (bitwise-bit-set? (ftype-ref BTreeNodeHeader (flags) header) 1))
+
+  ;;; void* BTreeNodeHeader u64 -> integer
+  ;;; Performs a binary search looking for the key and returns the index of the
+  ;;; lower bound.
+  (define (lower-bound b header key)
+    (let ((keys (block->keys b)))
+     (let loop ((lo 0)
+                (hi (ftype-ref BTreeNodeHeader (nr-entries) header)))
+      (if (<= (- hi lo) 1)
+          lo
+          (let* ((mid (+ lo (/ (- hi lo) 2)))
+                 (k (key-at b mid)))
+                (cond
+                  ((= key k) mid)
+                  ((< k key) (loop mid hi))
+                  (else (loop lo mid))))))))
+
+  ;;;;----------------------------------------------
+  ;;;; Lookup
+  ;;;;----------------------------------------------
+
+  ;; FIXME: this holds more blocks than we need as we recurse,  use a fixed
+  ;; size block queue.
+  (define (btree-lookup tree key default)
+    (let ((cache (btree-bcache tree))
+          (vt (btree-value-type tree)))
+
+      (let loop ((root (btree-root tree)))
+           (with-block (b 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)))))))
+
+  ;;;;----------------------------------------------
+  ;;;; 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 (visit-leaf nr-entries keys vals)
+                 (let loop ((index 0))
+                  (when (< index nr-entries)
+                        (fn (key-at keys index) (value-at vt vals index))
+                        (loop (+ 1 index)))))
+
+         (define (visit-internal nr-entries keys vals)
+                 (let loop ((index 0))
+                  (when (< index nr-entries)
+                        (visit-node (value-at le64-vt vals index))
+                        (loop (+ 1 index)))))
+
+         (define (visit-node root)
+                 (with-block (b 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))))
+
+         (visit-node (btree-root tree)))))
+

functional-tests/thin/mapping-tree.scm

@@ -12,7 +12,7 @@
   (define-record-type mapping-tree (fields dev-tree))
 
   (define (mapping-tree-open dev root)
-    (make-mapping-tree (btree-open le64-type dev root)))
+    (make-mapping-tree (btree-open le64-vt dev root)))
 
   ;; (values <block> <time>)
   (define time-mask (- (fxsll 1 24) 1))
@@ -27,14 +27,14 @@
            (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))))
+         (btree-lookup (btree-open le64-vt (btree-bcache dev-tree) root2) 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 (visit-dev dev-id mapping-root)
-       (btree-each (btree-open le64-type (btree-dev dev-tree) 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)))))

functional-tests/thin/thin_check

@@ -1,11 +1,10 @@
 (import
-  (binary-format)
+  (bcache block-manager)
-  (block-io)
   (btree)
   (fmt fmt)
   (matchable)
   (mapping-tree)
-  (rnrs))
+  (chezscheme))
 
 ;;;;---------------------------------------------------
 ;;;; Constants
@@ -19,26 +18,29 @@
 (define $uuid-size 16)
 (define $space-map-root-size 128)
 
-(binary-format superblock
+(define-ftype Superblock
-  (csum le32)
+  (packed
-  (flags le32)
+    (endian little
-  (block-nr le64)
+      (struct
-  (uuid (bytes $uuid-size))
+        (csum unsigned-32)
-  (magic le64)
+        (flags unsigned-32)
-  (version le32)
+        (block-nr unsigned-64)
-  (time le32)
+        (uuid (bytes $uuid-size))
-  (trans-id le64)
+        (magic unsigned-32)
-  (metadata-snap le64)
+        (version unsigned-32)
-  (data-space-map-root (bytes $space-map-root-size))
+        (time unsigned-32)
-  (metadata-space-map-root (bytes $space-map-root-size))
+        (trans-id unsigned-64)
-  (data-mapping-root le64)
+        (metadata-snap unsigned-64)
-  (device-details-root le64)
+        (data-space-map-root (bytes $space-map-root-size))
-  (data-block-size le32)
+        (metadata-space-map-root (bytes $space-map-root-size))
-  (metadata-block-size le32)
+        (data-mapping-root unsigned-64)
-  (metadata-nr-blocks le64)
+        (device-details-root unsigned-64)
-  (compat-flags le32)
+        (data-block-size unsigned-32)
-  (compat-ro-flags le32)
+        (metadata-block-size unsigned-32)
-  (incompat-flags le32))
+        (metadata-nr-blocks unsigned-64)
+        (compat-flags unsigned-32)
+        (compat-ro-flags unsigned-32)
+        (incompat-flags unsigned-32)))))
 
 ;;;;---------------------------------------------------
 ;;;; Top level