diff --git a/.gitignore b/.gitignore index 4544b4f..47e6166 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,6 @@ *~ +*.swp +*.swo *.o *.so *.a diff --git a/functional-tests/binary-format.scm b/functional-tests/binary-format.scm new file mode 100644 index 0000000..e36a787 --- /dev/null +++ b/functional-tests/binary-format.scm @@ -0,0 +1,110 @@ +(library + (binary-format) + + (export unpack-type + size-type + binary-format + binary-format-names + le32 + le64 + bytes) + + (import (chezscheme) + (fmt fmt) + (list-utils)) + + ;;;----------------------------------------- + + (define-syntax size-type + (syntax-rules (le32 le64 bytes) + ((_ le32) 4) + ((_ le64) 8) + ((_ (bytes count)) count))) + + (define-syntax unpack-type + (syntax-rules (le32 le64 bytes) + ((_ bv offset le32) + (bytevector-u32-ref bv offset (endianness little))) + + ((_ bv offset le64) + (bytevector-u64-ref bv offset (endianness little))) + + ((_ bv offset (bytes count)) + (let ((copy (make-bytevector count))) + (bytevector-copy! bv offset copy 0 count) + copy)))) + +#| +(define-syntax ordered-funcall + (lambda (form) + (let ((form^ (cdr (syntax->list form)))) + (let ((gens (map (lambda (_) (datum->syntax #'* (gensym "t"))) form^))) + #`(let* #,(map list gens form^) + #,gens))))) +|# + + (define-syntax ordered-funcall + (lambda (x) + (syntax-case x () + ((k f v ...) + (with-syntax + ([(t ...) (map (lambda (_) + (datum->syntax #'k (gensym))) + #'(v ...))]) + #'(let* ([t v] ...) + (f t ...))))))) + + (define-syntax binary-format-names + (syntax-rules () + ((_ (name pack-name unpack-name size-name) (field type) ...) + (begin + (define-record-type name (fields field ...)) + + (define size-name + (+ (size-type type) ...)) + + (define (unpack-name bv offset) + (let ((offset offset)) + + (define (inc-offset n v) + (set! offset (+ offset n)) + v) + + (ordered-funcall + (record-constructor (record-constructor-descriptor name)) + (inc-offset (size-type type) (unpack-type bv offset type)) ...))))))) + + (define-syntax binary-format + (lambda (x) + ;;; FIXME: we don't need multiple args + (define (gen-id template-id . args) + (datum->syntax template-id + (string->symbol + (apply string-append + (map (lambda (x) + (if (string? x) + x + (symbol->string (syntax->datum x)))) + args))))) + (syntax-case x () + ((_ name field ...) + (with-syntax ((pack-name (gen-id #'name #'name "-pack")) + (unpack-name (gen-id #'name #'name "-unpack")) + (size-name (gen-id #'name #'name "-size"))) + #'(binary-format-names (name pack-name unpack-name size-name) field ...)))))) + + ;;; Since le32, le64 and bytes are used as auxiliary keywords, we must export + ;;; definitions of them as well. + ;;; FIXME: use a macro to remove duplication + (define-syntax le32 + (lambda (x) + (syntax-violation 'le32 "misplaced auxiliary keyword" x))) + + (define-syntax le64 + (lambda (x) + (syntax-violation 'le64 "misplaced auxiliary keyword" x))) + + (define-syntax bytes + (lambda (x) + (syntax-violation 'bytes "misplaced auxiliary keyword" x)))) + diff --git a/functional-tests/block-cache.scm b/functional-tests/block-cache.scm new file mode 100644 index 0000000..6b0dfc8 --- /dev/null +++ b/functional-tests/block-cache.scm @@ -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))))))) + + ) + + diff --git a/functional-tests/block-io.scm b/functional-tests/block-io.scm new file mode 100644 index 0000000..7cf0625 --- /dev/null +++ b/functional-tests/block-io.scm @@ -0,0 +1,54 @@ +(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 new file mode 100644 index 0000000..a947ca4 --- /dev/null +++ b/functional-tests/btree.scm @@ -0,0 +1,128 @@ +(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/check-superblock.scm b/functional-tests/check-superblock.scm index 3129d1d..f2707a5 100644 --- a/functional-tests/check-superblock.scm +++ b/functional-tests/check-superblock.scm @@ -1,136 +1,36 @@ (import + (binary-format) + (block-io) + (btree) (fmt fmt) - (matchable)) + (matchable) + (mapping-tree) + (rnrs)) ;;;;--------------------------------------------------- ;;;; Constants ;;;;--------------------------------------------------- ;; FIXME: duplicate with main.scm -(define (current-metadata) - "./metadata.bin") +(define (current-metadata) "./metadata.bin") -(define metadata-block-size 4096) -(define superblock-magic 27022010) -(define superblock-salt 160774) -(define uuid-size 16) -(define space-map-root-size 128) +(define $superblock-magic 27022010) +(define $superblock-salt 160774) +(define $uuid-size 16) +(define $space-map-root-size 128) -;;;;--------------------------------------------------- -;;;; Metadata IO -;;;;--------------------------------------------------- - -(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))))) - -;;; FIXME: implement a little block cache. - - -;;;;--------------------------------------------------- -;;;; CRC32 -;;;;--------------------------------------------------- - -;; FIXME: move to own library -(load-shared-object "libz.so") -(define crc32 - (foreign-procedure "crc32" (unsigned-long u8* unsigned-int) unsigned-long)) - -(define crc32-combine - (foreign-procedure "crc32_combine" (unsigned-long unsigned-long unsigned-long) unsigned-long)) - -;; FIXME: stop copying the bytevector. I'm not sure how to pass an offset into -;; the bv. -(define (crc32-region salt bv start end) - (assert (< start end)) - (let ((len (- end start))) - (let ((copy (make-bytevector len))) - (bytevector-copy! bv start copy 0 len) - (let ((crc (crc32 salt copy 0))) - (crc32 crc copy len))))) - -;;;;--------------------------------------------------- -;;;; Decoding -;;;;--------------------------------------------------- - -(define-syntax unpack-type - (syntax-rules (le32 le64 bytes) - ((_ bv offset le32) - (bytevector-u32-ref bv offset (endianness little))) - - ((_ bv offset le64) - (bytevector-u64-ref bv offset (endianness little))) - - ((_ bv offset (bytes count)) - (let ((copy (make-bytevector count))) - (bytevector-copy! bv offset copy 0 count) - copy)))) - -(define (size-type t) - (syntax-case t (le32 le64 bytes) - (le32 #'4) - (le64 #'8) - ((bytes count) #'count))) - -;;; FIXME: (bytes ) has to use a literal rather than a symbol. -(define-syntax binary-format - (lambda (x) - (syntax-case x () - ((_ (name pack-name unpack-name) (field type) ...) - (with-syntax ((((t o) ...) - (let f ((acc 0) (types #'(type ...))) - (if (null? types) - '() - (cons (list (car types) acc) - (f (+ (syntax->datum (size-type (car types))) acc) (cdr types))))))) - #`(begin - (define-record-type name (fields field ...)) - - (define (unpack-name bv offset) - ((record-constructor (record-type-descriptor name)) - (unpack-type bv (+ offset o) t) ...)))))))) - -(binary-format (superblock pack-superblock unpack-superblock) +(binary-format superblock (csum le32) (flags le32) (block-nr le64) - (uuid (bytes 16)) + (uuid (bytes $uuid-size)) (magic le64) (version le32) (time le32) (trans-id le64) (metadata-snap le64) - (data-space-map-root (bytes 128)) - (metadata-space-map-root (bytes 128)) + (data-space-map-root (bytes $space-map-root-size)) + (metadata-space-map-root (bytes $space-map-root-size)) (data-mapping-root le64) (device-details-root le64) (data-block-size le32) @@ -151,11 +51,39 @@ (define (read-superblock) (with-metadata (md (current-metadata)) - (unpack-superblock (read-block md 0) 0))) + (superblock-unpack (read-block md 0) 0))) + +(define (dump-dev-tree) + (with-metadata (md (current-metadata)) + (let ((sb (superblock-unpack (read-block md 0) 0))) + (btree-each (btree-open le64-type md (superblock-data-mapping-root sb)) + (lambda (k v) + (fmt #t (dsp "dev-id: ") (num k) + (dsp ", mapping root: ") (num v) nl)))))) + +(define (dump-mappings root) + (with-metadata (md (current-metadata)) + (btree-each (btree-open le64-type md root) + (lambda (k v) + (fmt #t (dsp "vblock: ") (num k) + (dsp ", pblock: ") (num v) nl))))) + +(define (dump-all-mappings) + (with-metadata (md (current-metadata)) + (let ((sb (superblock-unpack (read-block md 0) 0))) + (let ((mappings (mapping-tree-open md (superblock-data-mapping-root sb)))) + (mapping-tree-each mappings + (lambda (dev-id vblock pblock time) + (fmt #t + (dsp "thin dev ") (num dev-id) + (dsp ", vblock ") (num vblock) + (dsp ", pblock ") (num pblock) + (dsp ", time ") (num time) + nl))))))) (define (check-superblock) (with-metadata (md (current-metadata)) (let ((superblock (read-block md 0))) (fmt #t (dsp "checksum on disk: ") (dsp (bytevector-u32-ref superblock 0 (endianness little))) nl) - (fmt #t (dsp "calculated checksum: ") (dsp (crc32-region superblock-salt superblock 4 4092)) nl) + ;(fmt #t (dsp "calculated checksum: ") (dsp (crc32-region $superblock-salt superblock 4 4092)) nl) (check-magic superblock)))) diff --git a/functional-tests/crc32.scm b/functional-tests/crc32.scm new file mode 100644 index 0000000..c50d8d0 --- /dev/null +++ b/functional-tests/crc32.scm @@ -0,0 +1,23 @@ +(library + (crc32) + (export crc32) + (import (chezscheme)) + + (load-shared-object "libz.so") + + (define crc32 + (foreign-procedure "crc32" (unsigned-long u8* unsigned-int) unsigned-long)) + + (define crc32-combine + (foreign-procedure "crc32_combine" (unsigned-long unsigned-long unsigned-long) unsigned-long)) + + ;; FIXME: stop copying the bytevector. I'm not sure how to pass an offset + ;; into the bv. + (define (crc32-region salt bv start end) + (assert (< start end)) + (let ((len (- end start))) + (let ((copy (make-bytevector len))) + (bytevector-copy! bv start copy 0 len) + (let ((crc (crc32 salt copy 0))) + (crc32 crc copy len)))))) + diff --git a/functional-tests/list-utils.scm b/functional-tests/list-utils.scm index a4b8d1e..3f7bdb0 100644 --- a/functional-tests/list-utils.scm +++ b/functional-tests/list-utils.scm @@ -1,8 +1,13 @@ (library (list-utils) - (export intersperse iterate accumulate) + (export tails intersperse iterate accumulate) (import (rnrs)) + (define (tails xs) + (if (null? xs) + '() + (cons xs (tails (cdr xs))))) + (define (intersperse sep xs) (cond ((null? xs) '()) diff --git a/functional-tests/mapping-tree.scm b/functional-tests/mapping-tree.scm new file mode 100644 index 0000000..00028a1 --- /dev/null +++ b/functional-tests/mapping-tree.scm @@ -0,0 +1,42 @@ +(library + (mapping-tree) + + (export mapping-tree-open + mapping-tree-lookup + mapping-tree-each) + + (import (btree) + (chezscheme) + (srfi s8 receive)) + + (define-record-type mapping-tree (fields dev-tree)) + + (define (mapping-tree-open dev root) + (make-mapping-tree (btree-open le64-type dev root))) + + ;; (values