diff --git a/functional-tests/bcache/bcache-tests.scm b/functional-tests/bcache/bcache-tests.scm new file mode 100644 index 0000000..997f4dd --- /dev/null +++ b/functional-tests/bcache/bcache-tests.scm @@ -0,0 +1,38 @@ +(library + (bcache bcache-tests) + (export register-bcache-tests) + (import (bcache block-manager) + (chezscheme) + (functional-tests) + (fmt fmt) + (process) + (temp-file)) + + (define-syntax with-empty-metadata + (syntax-rules () + ((_ (md nr-blocks) b1 b2 ...) + (with-temp-file-sized ((md "bcache.bin" (* 4096 nr-blocks))) + b1 b2 ...)))) + + ;; We have to export something that forces all the initialisation expressions + ;; to run. + (define (register-bcache-tests) #t) + + ;;;----------------------------------------------------------- + ;;; scenarios + ;;;----------------------------------------------------------- + + (define-scenario (bcache create) + "create and destroy a block cache" + (with-empty-metadata (md 16) + (with-bcache (cache md 16) + #t))) + + (define-scenario (bcache read-ref) + "get a read-ref on a block" + (with-empty-metadata (md 16) + (with-bcache (cache md 16) + (with-block (b cache 0 (get-flags)) + #f)))) + ) + diff --git a/functional-tests/bcache/block-manager.scm b/functional-tests/bcache/block-manager.scm new file mode 100644 index 0000000..83c2191 --- /dev/null +++ b/functional-tests/bcache/block-manager.scm @@ -0,0 +1,103 @@ +(library + ;; We can't call this (bcache bcache) because it'll clash with the C lib + (bcache block-manager) + (export with-bcache + get-nr-blocks + get-nr-locked + get-block + block-data + block-index + release-block + flush-cache + get-flags + prefetch-block + with-block) + (import (chezscheme) + (fmt fmt) + (utils)) + + (define __ (load-shared-object "./bcache/bcache.so")) + + (define bcache-simple + (foreign-procedure "bcache_simple" (string unsigned) ptr)) + + (define bcache-destroy + (foreign-procedure "bcache_destroy" (ptr) void)) + + (define-syntax with-bcache + (syntax-rules () + ((_ (name path nr-cache-blocks) b1 b2 ...) + (let ((name (bcache-simple path nr-cache-blocks))) + (dynamic-wind + (lambda () #f) + (lambda () b1 b2 ...) + (lambda () (bcache-destroy name))))))) + + (define get-nr-blocks + (foreign-procedure "get_nr_blocks" (ptr) unsigned-64)) + + (define get-nr-locked + (foreign-procedure "get_nr_locked" (ptr) unsigned-64)) + + (define-enumeration get-flag-element + (zero dirty barrier) get-flags) + + (define (build-flags es) + (define (to-bits e) + (case e + ((zero) 1) + ((dirty) 2) + ((barrier) 4))) + + (define (combine fs e) + (fxior fs (to-bits e))) + + (fold-left combine 0 (enum-set->list es))) + + (define (fail msg) + (raise + (condition + (make-error) + (make-message-condition msg)))) + + (define-ftype Block + (struct + (data void*) + (index unsigned-64))) + + (define (block-data b) + (ftype-ref Block (data) b)) + + (define (block-index b) + (ftype-ref Block (index) b)) + + (define (get-block cache index flags) + (define getb (foreign-procedure "get_block" (ptr unsigned-64 unsigned) (* Block))) + + (let ((b (getb cache index (build-flags flags)))) + (if (ftype-pointer-null? b) + (fail (fmt #f "unable to get block " index)) + b))) + + (define release-block + (foreign-procedure "release_block" ((* Block)) void)) + + (define (flush-cache cache) + (define flush (foreign-procedure "flush_cache" (ptr) int)) + + (let ((r (flush cache))) + (when (< 0 r) + (fail "flush_cache failed")))) + + (define prefetch-block + (foreign-procedure "prefetch_block" (ptr unsigned-64) void)) + + (define-syntax with-block + (syntax-rules () + ((_ (b cache index flags) b1 b2 ...) + (let ((b (get-block cache index flags))) + (dynamic-wind + (lambda () #f) + (lambda () b1 b2 ...) + (lambda () (release-block b))))))) +) diff --git a/functional-tests/run-tests b/functional-tests/run-tests index 6239ff6..59f39aa 100755 --- a/functional-tests/run-tests +++ b/functional-tests/run-tests @@ -1,9 +1,11 @@ #! /usr/bin/scheme-script (import (rnrs) + (only (chezscheme) load-shared-object) (fmt fmt) (list-utils) (functional-tests) + (bcache bcache-tests) (cache-functional-tests) (era-functional-tests) (parser-combinators) @@ -169,9 +171,12 @@ ;;------------------------------------------------ +(load-shared-object "./bcache/bcache.so") + (register-thin-tests) (register-cache-tests) (register-era-tests) +(register-bcache-tests) (with-dir "test-output" ((parse-command-line)))