From 40b257d42ed13db85c50155cd8937658b6288860 Mon Sep 17 00:00:00 2001 From: Joe Thornber Date: Fri, 8 Sep 2017 15:51:33 +0100 Subject: [PATCH] [functional-tests] change btree to use the bcache --- functional-tests/block-io.scm | 54 ------ functional-tests/btree.scm | 128 -------------- functional-tests/persistent-data/btree.scm | 158 ++++++++++++++++++ functional-tests/{ => thin}/mapping-tree.scm | 6 +- .../{check-superblock.scm => thin/thin_check} | 48 +++--- 5 files changed, 186 insertions(+), 208 deletions(-) delete mode 100644 functional-tests/block-io.scm delete mode 100644 functional-tests/btree.scm create mode 100644 functional-tests/persistent-data/btree.scm rename functional-tests/{ => thin}/mapping-tree.scm (83%) rename functional-tests/{check-superblock.scm => thin/thin_check} (76%) diff --git a/functional-tests/block-io.scm b/functional-tests/block-io.scm deleted file mode 100644 index 7cf0625..0000000 --- a/functional-tests/block-io.scm +++ /dev/null @@ -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)))))) - - diff --git a/functional-tests/btree.scm b/functional-tests/btree.scm deleted file mode 100644 index a947ca4..0000000 --- a/functional-tests/btree.scm +++ /dev/null @@ -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))))) - diff --git a/functional-tests/persistent-data/btree.scm b/functional-tests/persistent-data/btree.scm new file mode 100644 index 0000000..8778246 --- /dev/null +++ b/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 ) + ;;; (vt 'ref index) + ;;; (vt 'set 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))))) + diff --git a/functional-tests/mapping-tree.scm b/functional-tests/thin/mapping-tree.scm similarity index 83% rename from functional-tests/mapping-tree.scm rename to functional-tests/thin/mapping-tree.scm index 00028a1..f2e28ad 100644 --- a/functional-tests/mapping-tree.scm +++ b/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