[functional-tests] change btree functions to take a spine.
Also change the step-spine interface slightly.
This commit is contained in:
parent
48ae5beead
commit
4d3733d0e7
@ -113,11 +113,11 @@
|
||||
;;; Spine
|
||||
;;;--------------------------------------------------------
|
||||
(define-record-type spine
|
||||
(fields (mutable max) (mutable entries))
|
||||
(fields (immutable cache) (mutable max) (mutable entries))
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda (max)
|
||||
(new max '())))))
|
||||
(lambda (cache max)
|
||||
(new cache max '())))))
|
||||
|
||||
(define (spine-exit sp)
|
||||
(for-each release-block (spine-entries sp)))
|
||||
@ -126,13 +126,14 @@
|
||||
(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-step% sp index flags)
|
||||
(let ((b (get-block (spine-cache sp) index flags)))
|
||||
(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)))
|
||||
@ -142,8 +143,8 @@
|
||||
|
||||
(define-syntax with-spine
|
||||
(syntax-rules ()
|
||||
((_ (sp max) b1 b2 ...)
|
||||
(let ((sp (make-spine max)))
|
||||
((_ (sp cache max) b1 b2 ...)
|
||||
(let ((sp (make-spine cache max)))
|
||||
(dynamic-wind
|
||||
(lambda () #f)
|
||||
(lambda () b1 b2 ...)
|
||||
@ -151,9 +152,9 @@
|
||||
|
||||
(define-syntax spine-step
|
||||
(syntax-rules ()
|
||||
((_ sp (b expr) b1 b2 ...)
|
||||
((_ sp (b index flags) b1 b2 ...)
|
||||
(begin
|
||||
(spine-step% sp expr)
|
||||
(spine-step% sp index flags)
|
||||
(let ((b (spine-current sp)))
|
||||
b1 b2 ...)))))
|
||||
)
|
||||
|
@ -2,7 +2,6 @@
|
||||
(persistent-data btree)
|
||||
|
||||
(export btree-value-type
|
||||
btree-bcache
|
||||
btree-root
|
||||
btree-open
|
||||
btree-lookup
|
||||
@ -89,10 +88,10 @@
|
||||
|#
|
||||
|
||||
(define-record-type btree
|
||||
(fields value-type bcache root))
|
||||
(fields value-type root))
|
||||
|
||||
(define (btree-open vt bcache root)
|
||||
(make-btree vt bcache root))
|
||||
(define (btree-open vt root)
|
||||
(make-btree vt root))
|
||||
|
||||
;;; (ftype-pointer BTreeNodeHeader) -> bool
|
||||
(define (internal-node? header)
|
||||
@ -122,54 +121,51 @@
|
||||
;;;; Lookup
|
||||
;;;;----------------------------------------------
|
||||
|
||||
(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)))
|
||||
(spine-step sp (b (get-block 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))))))))
|
||||
(define (btree-lookup tree sp key default)
|
||||
(let ((vt (btree-value-type tree)))
|
||||
|
||||
(let loop ((root (btree-root tree)))
|
||||
(spine-step sp (b 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 (btree-each tree sp fn)
|
||||
(let ((vt (btree-value-type tree)))
|
||||
|
||||
(with-spine (sp 1)
|
||||
(define (visit-leaf nr-entries keys vals)
|
||||
(define (visit-leaf nr-entries keys vals)
|
||||
(let loop ((index 0))
|
||||
(when (< index nr-entries)
|
||||
(fn (key-at keys index) (vt 'ref vals index))
|
||||
(loop (+ 1 index)))))
|
||||
|
||||
(define (visit-internal nr-entries keys vals)
|
||||
(define (visit-internal nr-entries keys vals)
|
||||
(let loop ((index 0))
|
||||
(when (< index nr-entries)
|
||||
(visit-node (le64-vt 'ref vals index))
|
||||
(loop (+ 1 index)))))
|
||||
|
||||
(define (visit-node root)
|
||||
(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))
|
||||
(vals (block->values b vt)))
|
||||
((if (internal-node? header)
|
||||
visit-internal
|
||||
visit-leaf) nr-entries keys vals))))
|
||||
(define (visit-node root)
|
||||
(spine-step sp (b 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)))))
|
||||
)
|
||||
(visit-node (btree-root tree))))
|
||||
)
|
||||
|
||||
|
@ -12,8 +12,7 @@
|
||||
(scenario-string-constants)
|
||||
(temp-file)
|
||||
(thin-xml)
|
||||
(srfi s8 receive)
|
||||
(only (srfi s1 lists) drop-while))
|
||||
(srfi s8 receive))
|
||||
|
||||
(define-tool thin-check)
|
||||
(define-tool thin-delta)
|
||||
|
@ -43,14 +43,15 @@
|
||||
(define super-block-only #f)
|
||||
|
||||
(define (dump-dev-tree cache root)
|
||||
(btree-each (btree-open device-details-vt cache root)
|
||||
(lambda (k v)
|
||||
(fmt #t
|
||||
"dev-id: " k "\n"
|
||||
" mapped blocks: " (ftype-ref ThinDeviceDetails (mapped-blocks) v) "\n"
|
||||
" transaction id: " (ftype-ref ThinDeviceDetails (transaction-id) v) "\n"
|
||||
" creation time: " (ftype-ref ThinDeviceDetails (creation-time) v) "\n"
|
||||
" snapshotted time: " (ftype-ref ThinDeviceDetails (snapshotted-time) v) "\n"))))
|
||||
(with-spine (sp cache 1)
|
||||
(btree-each (btree-open device-details-vt root) sp
|
||||
(lambda (k v)
|
||||
(fmt #t
|
||||
"dev-id: " k "\n"
|
||||
" mapped blocks: " (ftype-ref ThinDeviceDetails (mapped-blocks) v) "\n"
|
||||
" transaction id: " (ftype-ref ThinDeviceDetails (transaction-id) v) "\n"
|
||||
" creation time: " (ftype-ref ThinDeviceDetails (creation-time) v) "\n"
|
||||
" snapshotted time: " (ftype-ref ThinDeviceDetails (snapshotted-time) v) "\n")))))
|
||||
|
||||
(define-enumeration thin-check-element
|
||||
(quiet
|
||||
|
@ -1,19 +1,14 @@
|
||||
(library
|
||||
(thin mapping-tree)
|
||||
|
||||
(export mapping-tree-open
|
||||
mapping-tree-lookup
|
||||
(export mapping-tree-lookup
|
||||
mapping-tree-each)
|
||||
|
||||
(import (persistent-data btree)
|
||||
(bcache block-manager)
|
||||
(chezscheme)
|
||||
(srfi s8 receive))
|
||||
|
||||
(define-record-type mapping-tree (fields dev-tree))
|
||||
|
||||
(define (mapping-tree-open dev root)
|
||||
(make-mapping-tree (btree-open le64-vt dev root)))
|
||||
|
||||
;; (values <block> <time>)
|
||||
(define time-mask (- (fxsll 1 24) 1))
|
||||
|
||||
@ -21,22 +16,25 @@
|
||||
(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-vt (btree-bcache dev-tree) root2) vblock default))))
|
||||
(define (mapping-tree-lookup cache root dev-id vblock default)
|
||||
(with-spine (sp cache 1)
|
||||
(let* ((unique (gensym))
|
||||
(dev-tree (btree-open le64-vt root))
|
||||
(root2 (btree-lookup dev-tree sp dev-id unique)))
|
||||
(if (eq? unique root2)
|
||||
default
|
||||
(btree-lookup (btree-open le64-vt root2) sp 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 (mapping-tree-each cache root fn)
|
||||
(with-spine (sp cache 1)
|
||||
(let ((dev-tree (btree-open le64-vt root)))
|
||||
|
||||
(define (visit-dev dev-id 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)))))
|
||||
(define (visit-dev dev-id mapping-root)
|
||||
(btree-each (btree-open le64-vt mapping-root)
|
||||
(lambda (vblock mapping)
|
||||
(receive (block time) (unpack-block-time mapping)
|
||||
(fn dev-id vblock block time)))))
|
||||
|
||||
(btree-each dev-tree visit-dev))))
|
||||
(btree-each dev-tree sp visit-dev))))
|
||||
)
|
||||
|
@ -4,7 +4,9 @@
|
||||
(export ThinSuperblock
|
||||
ThinDeviceDetails)
|
||||
|
||||
(import (chezscheme))
|
||||
(import (chezscheme)
|
||||
(bcache block-manager)
|
||||
(persistent-data btree))
|
||||
|
||||
(define $superblock-magic 27022010)
|
||||
(define $superblock-salt 160774)
|
||||
|
Loading…
Reference in New Issue
Block a user