[functional tests] start thinking about a block cache interface.

I want to use FFI to link with a C library containing the actual block
cache, io engine and crc32 code.
This commit is contained in:
Joe Thornber 2017-08-14 10:05:38 +01:00
parent b2355df719
commit 7f7a7d6605
4 changed files with 105 additions and 26 deletions

View File

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

View File

@ -22,11 +22,12 @@
(define-syntax with-metadata (define-syntax with-metadata
(syntax-rules () (syntax-rules ()
((_ (port path) body ...) (let ((port (open-metadata path))) ((_ (port path) body ...)
(dynamic-wind (let ((port (open-metadata path)))
(lambda () #f) (dynamic-wind
(lambda () body ...) (lambda () #f)
(lambda () (close-port port))))))) (lambda () body ...)
(lambda () (close-port port)))))))
;; FIXME: return our own condition? ;; FIXME: return our own condition?
(define (io-error msg) (define (io-error msg)

View File

@ -89,20 +89,15 @@
(let ((dev (btree-dev tree)) (let ((dev (btree-dev tree))
(vt (btree-value-type tree))) (vt (btree-value-type tree)))
(define (lookup root fail-k) (let loop ((root (btree-root tree)))
(let loop ((root root)) (let* ((node (read-block dev root))
(let* ((node (read-block dev root)) (header (node-header-unpack node 0))
(header (node-header-unpack node 0)) (index (lower-bound node header key)))
(index (lower-bound node header key))) (if (internal-node? header)
(if (internal-node? header) (loop (value-at header node index le64-type))
(loop (value-at header node index le64-type)) (if (= key (key-at node index))
(if (= key (key-at node index)) (value-at header node index vt)
(value-at header node index vt) default))))))
(fail-k default))))))
(call/cc
(lambda (fail-k)
(lookup (btree-root tree) fail-k)))))
;;;;---------------------------------------------- ;;;;----------------------------------------------
;;;; Walking the btree ;;;; Walking the btree

View File

@ -7,7 +7,6 @@
(import (btree) (import (btree)
(chezscheme) (chezscheme)
(binary-format)
(srfi s8 receive)) (srfi s8 receive))
(define-record-type mapping-tree (fields dev-tree)) (define-record-type mapping-tree (fields dev-tree))
@ -15,6 +14,13 @@
(define (mapping-tree-open dev root) (define (mapping-tree-open dev root)
(make-mapping-tree (btree-open le64-type 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) (define (mapping-tree-lookup mtree dev-id vblock default)
(let* ((unique (gensym)) (let* ((unique (gensym))
(dev-tree (mapping-tree-dev-tree mtree)) (dev-tree (mapping-tree-dev-tree mtree))
@ -23,12 +29,6 @@
default default
(btree-lookup (btree-open le64-type (btree-dev dev-tree) root2) vblock default)))) (btree-lookup (btree-open le64-type (btree-dev dev-tree) root2) vblock default))))
;; (values <block> <time>)
(define time-mask (- (fxsll 1 24) 1))
(define (unpack-block-time bt)
(values (fxsrl bt 24) (fxlogand bt time-mask)))
;;; Visits every entry in the mapping tree calling (fn dev-id vblock pblock time). ;;; Visits every entry in the mapping tree calling (fn dev-id vblock pblock time).
(define (mapping-tree-each mtree fn) (define (mapping-tree-each mtree fn)
(let ((dev-tree (mapping-tree-dev-tree mtree))) (let ((dev-tree (mapping-tree-dev-tree mtree)))