[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:
parent
b2355df719
commit
7f7a7d6605
83
functional-tests/block-cache.scm
Normal file
83
functional-tests/block-cache.scm
Normal 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)))))))
|
||||||
|
|
||||||
|
)
|
||||||
|
|
||||||
|
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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)))
|
||||||
|
Loading…
Reference in New Issue
Block a user