Merge branch '2017-08-08-rewrite-some-more-cucumber-tests'

.gitignore

@@ -1,4 +1,6 @@
 *~
+*.swp
+*.swo
 *.o
 *.so
 *.a

functional-tests/binary-format.scm

@@ -0,0 +1,110 @@
+(library
+  (binary-format)
+
+  (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)
+      ((_ le64) 8)
+      ((_ (bytes count)) count)))
+
+  (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-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 size-name) (field type) ...)
+       (begin
+         (define-record-type name (fields field ...))
+
+         (define size-name
+           (+ (size-type type) ...))
+
+         (define (unpack-name bv offset)
+           (let ((offset offset))
+
+            (define (inc-offset n v)
+              (set! offset (+ offset n))
+              v)
+
+            (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
+    (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))))
+

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

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

@@ -0,0 +1,128 @@
+(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/check-superblock.scm

@@ -1,136 +1,36 @@
 (import
+  (binary-format)
+  (block-io)
+  (btree)
   (fmt fmt)
-  (matchable))
+  (matchable)
+  (mapping-tree)
+  (rnrs))
 
 ;;;;---------------------------------------------------
 ;;;; Constants
 ;;;;---------------------------------------------------
 
 ;; FIXME: duplicate with main.scm
-(define (current-metadata)
+(define (current-metadata) "./metadata.bin")
-  "./metadata.bin")
 
-(define metadata-block-size 4096)
+(define $superblock-magic 27022010)
-(define superblock-magic 27022010)
+(define $superblock-salt 160774)
-(define superblock-salt 160774)
+(define $uuid-size 16)
-(define uuid-size 16)
+(define $space-map-root-size 128)
-(define space-map-root-size 128)
 
-;;;;---------------------------------------------------
+(binary-format superblock
-;;;; 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)
   (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))
+  (data-space-map-root (bytes $space-map-root-size))
-  (metadata-space-map-root (bytes 128))
+  (metadata-space-map-root (bytes $space-map-root-size))
   (data-mapping-root le64)
   (device-details-root le64)
   (data-block-size le32)
@@ -151,11 +51,39 @@
 
 (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 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)
   (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))))

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

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

functional-tests/mapping-tree.scm

@@ -0,0 +1,42 @@
+(library
+  (mapping-tree)
+
+  (export mapping-tree-open
+          mapping-tree-lookup
+          mapping-tree-each)
+
+  (import (btree)
+          (chezscheme)
+          (srfi s8 receive))
+
+  (define-record-type mapping-tree (fields dev-tree))
+
+  (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))
+           (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 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)
+                     (receive (block time) (unpack-block-time mapping)
+                              (fn dev-id vblock block time)))))
+
+     (btree-each dev-tree visit-dev))))