[functional-tests] Change btree code to use a spine

functional-tests/bcache/block-manager.scm

@@ -11,9 +11,17 @@
           flush-cache
           get-flags
           prefetch-block
-          with-block)
+          with-block
+          spine
+          spine-exit
+          spine-step
+          spine-current
+          spine-parent
+          with-spine)
+
   (import (chezscheme)
           (fmt fmt)
+          (srfi s8 receive)
           (utils))
 
   (define __ (load-shared-object "./bcache/bcache.so"))
@@ -100,4 +108,52 @@
           (lambda () #f)
           (lambda () b1 b2 ...)
           (lambda () (release-block b)))))))
+
+  ;;;--------------------------------------------------------
+  ;;; Spine
+  ;;;--------------------------------------------------------
+  (define-record-type spine
+    (fields (mutable max) (mutable entries))
+    (protocol
+      (lambda (new)
+        (lambda (max)
+          (new max '())))))
+
+  (define (spine-exit sp)
+    (for-each release-block (spine-entries sp)))
+
+  (define (pop-last xs)
+    (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-current sp)
+    (car (spine-entries sp)))
+
+  (define (spine-parent sp)
+    (cadr (spine-entries sp)))
+
+  (define-syntax with-spine
+    (syntax-rules ()
+      ((_ (sp max) b1 b2 ...)
+       (let ((sp (make-spine max)))
+        (dynamic-wind
+          (lambda () #f)
+          (lambda () b1 b2 ...)
+          (lambda () (spine-exit sp)))))))
+
+  (define-syntax spine-step
+    (syntax-rules ()
+      ((_ sp (b expr) b1 b2 ...)
+       (begin
+         (spine-step% sp expr)
+         (let ((b (spine-current sp)))
+          b1 b2 ...)))))
 )

functional-tests/persistent-data/btree.scm

@@ -1,5 +1,5 @@
 (library
-  (btree)
+  (persistent-data btree)
 
   (export btree-value-type
           btree-bcache
@@ -9,6 +9,8 @@
           btree-each
           le64-vt
 
+          define-value-type
+          define-compound-value-type
           BTreeNodeHeader)
 
   (import (bcache block-manager)
@@ -34,27 +36,42 @@
   ;; The metadata block is made up of:
   ;; | node header | keys | values |
   (define (block->header b)
-    (make-ftype-pointer BTreeNodeHeader b))
+    (make-ftype-pointer BTreeNodeHeader (block-data b)))
 
   (define (block->keys b)
     (make-ftype-pointer LittleEndian64
-                        (+ b (ftype-sizeof BTreeNodeHeader))))
+                        (+ (block-data 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
+  (define-syntax define-value-type
+    (syntax-rules ()
+      ((_ name ft)
+       (define name
          (dlambda
-      (mk-ptr (p) (make-ftype-pointer LittleEndian64 p))
+           (mk-ptr (p) (make-ftype-pointer ft p))
-      (ref (fp index) (ftype-ref LittleEndian64 () fp index))
+           (ref (fp index) (ftype-ref ft () fp index))
-      (set (fp index val) (ftype-set! LittleEndian64 () fp index val))
+           (set (fp index val) (ftype-set! ft () fp index val))
-      (size () (ftype-sizeof LittleEndian64))))
+           (size () (ftype-sizeof ft)))))))
+
+  (define-syntax define-compound-value-type
+    (syntax-rules ()
+      ((_ name ft)
+       (define name
+         (dlambda
+           (mk-ptr (p) (make-ftype-pointer ft p))
+           (ref (fp index) (ftype-&ref ft () fp index))
+           (set (fp index val) (assert #f))   ;; (ftype-set! ft () fp index val)) ;;; FIXME: not sure what to put here
+           (size () (ftype-sizeof ft)))))))
+
+  (define-value-type le64-vt LittleEndian64)
 
   (define (block->values b vt)
-    (vt
+    (vt 'mk-ptr
-      (+ b (ftype-sizeof BTreeNodeHeader)
+      (+ (block-data b) (ftype-sizeof BTreeNodeHeader)
         (* (ftype-ref BTreeNodeHeader (max-entries) (block->header b))
            (ftype-sizeof LittleEndian64)))))
 
@@ -105,14 +122,12 @@
   ;;;; 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)))
-
+         (with-spine (sp 1)
            (let loop ((root (btree-root tree)))
-           (with-block (b cache root (get-flags))
+            (spine-step sp (b (get-block cache root (get-flags)))
               (let* ((header (block->header b))
                      (keys (block->keys b))
                      (vals (block->values b vt))
@@ -121,7 +136,7 @@
                         (loop (value-at le64-vt vals index))
                         (if (= key (key-at keys index))
                             (value-at vt vals index)
-                           default)))))))
+                            default))))))))
 
   ;;;;----------------------------------------------
   ;;;; Walking the btree
@@ -132,20 +147,21 @@
     (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)
-                        (fn (key-at keys index) (value-at vt vals index))
+                    (fn (key-at keys index) (vt 'ref 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))
+                    (visit-node (le64-vt 'ref vals index))
                     (loop (+ 1 index)))))
 
            (define (visit-node root)
-                 (with-block (b cache root (get-flags))
+             (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))
@@ -155,4 +171,5 @@
                           visit-leaf) nr-entries keys vals))))
 
            (visit-node (btree-root tree)))))
+  )