Changeset 25521 in project for release/4/ugarit/trunk/backend-fs.scm

Timestamp:

11/17/11 12:52:41 (9 years ago)

Author:

Alaric Snell-Pym

Message:

ugarit: Better use of sqlite, which will hopefully improve performance. 1.0.1 release.

File:

• release/4/ugarit/trunk/backend-fs.scm (modified) (4 diffs)

release/4/ugarit/trunk/backend-fs.scm

@@ -153 +153 @@
    "CREATE TABLE metadata (key TEXT PRIMARY KEY, value TEXT);"
    "INSERT INTO metadata VALUES ('version','1');"
-   "INSERT INTO metadata VALUES ('current-logfile','0');"
    "CREATE TABLE blocks (key TEXT PRIMARY KEY, type TEXT, fileno INTEGER, position INTEGER, length INTEGER);"
    "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);"))
@@ -161 +160 @@
         ((*db*
           (let ((db (open-database metapath)))
+            (change-file-mode metapath (bitwise-ior perm/irusr perm/iwusr)) ; Don't think we can do anything about the journal files, though.
             (when (null? (schema db))
                   (for-each (lambda (statement)
                               (exec (sql db statement)))
                             splitlog-sql-schema))
+            (exec (sql db "BEGIN;"))
             db))
-         (*logcount* (string->number (car (query fetch (sql *db* "SELECT value FROM metadata WHERE key = 'current-logfile'")))))
+
+         ; Prepared statements
+         (get-metadata-query (sql *db* "SELECT value FROM metadata WHERE key = ?"))
+         (set-metadata-query (sql *db* "INSERT OR REPLACE INTO metadata (key,value) VALUES (?,?)"))
+         (get-block-data-query (sql *db* "SELECT type, fileno, position, length FROM blocks WHERE key = ?"))
+         (set-block-data-query (sql *db* "INSERT INTO blocks (key,type,fileno,position,length) VALUES (?,?,?,?,?)"))
+         (get-tag-query (sql *db* "SELECT key FROM tags WHERE tag = ?"))
+         (set-tag-query (sql *db* "INSERT OR REPLACE INTO tags (tag,key) VALUES (?,?)"))
+         (remove-tag-query (sql *db* "DELETE FROM tags WHERE tag = ?"))
+         (set-tag-lock-query (sql *db* "UPDATE tags SET locked = ? WHERE tag = ?"))
+         (get-tag-lock-query (sql *db* "SELECT locked FROM tags WHERE tag = ?"))
+         (get-tags-query (sql *db* "SELECT tag FROM tags"))
+
+         ; Database access functions
+         (get-metadata (lambda (key default)
+                         (let ((result (query fetch get-metadata-query key)))
+                           (if (null? result)
+                               (begin
+                                 (exec set-metadata-query key default)
+                                 default)
+                               (car result)))))
+         (set-metadata (lambda (key value)
+                         (exec set-metadata-query key value)))
+
+         ; Log file management
+         (*logcount* (string->number (get-metadata "current-logfile" "0")))
          (set-logcount! (lambda (newcount)
-                         (set! *logcount* newcount)
-                         (exec (sql *db* "INSERT OR REPLACE INTO metadata (key,value) VALUES ('current-logfile',?)") newcount)))
+                         (set! *logcount* newcount)))
          (*log* (file-open (string-append logdir "/log" (number->string *logcount*))
-                  (+ open/creat open/rdwr open/append) perm/irwxu))
+                  (bitwise-ior open/creat open/rdwr open/append) (bitwise-ior perm/irusr perm/iwusr)))
          (*logfiles* (make-hash-table)) ; hash of file number to FD
+         (get-log (lambda (index)
+            (if (hash-table-exists? *logfiles* index)
+               (hash-table-ref *logfiles* index)
+               (begin
+                  (let ((fd (file-open (string-append logdir "/log" (number->string index)) open/rdonly perm/irwxu)))
+                     (set! (hash-table-ref *logfiles* index) fd)
+                     fd)))))
+
+         ; Periodic commit management
+         (commit-interval (string->number (get-metadata "commit-interval" "1000")))
+         (*updates-since-last-commit* 0)
+         (flush! (lambda ()
+                   (set-metadata "current-logfile" (number->string *logcount*))
+                   (exec (sql *db* "COMMIT;"))
+                   (exec (sql *db* "BEGIN;"))
+                   (set! *updates-since-last-commit* 0)))
+         (maybe-flush! (lambda ()
+                         (set! *updates-since-last-commit*
+                               (+ *updates-since-last-commit* 1))
+                         (when (> *updates-since-last-commit* commit-interval)
+                             (flush!))))
+
+         ; Higher-level database utilities
          (get-block-data (lambda (key) ; Returns #f for nonexistant blocks
-                           (let ((bd (query fetch (sql *db* "SELECT type, fileno, position, length FROM blocks WHERE key = ?") key)))
+                           (let ((bd (query fetch get-block-data-query key)))
                              (if (pair? bd)
                                  (let ((type (string->symbol (first bd)))
@@ -182 +230 @@
                                    (list type fileno position length))
                                  #f))))
+
          (set-block-data! (lambda (key type fileno position length)
-                           (exec (sql *db* "INSERT INTO blocks (key,type,fileno,position,length) VALUES (?,?,?,?,?)") key (symbol->string type) fileno position length)))
+                           (exec set-block-data-query key (symbol->string type) fileno position length)
+                           (maybe-flush!)))
+
          (set-tag! (lambda (tag key)
-                    (exec (sql *db* "INSERT OR REPLACE INTO tags (tag,key) VALUES (?,?)") tag key)))
+                    (exec set-tag-query tag key)
+                    (flush!)))
+
          (remove-tag! (lambda (tag)
-                        (exec (sql *db* "DELETE FROM tags WHERE tag = ?") tag)))
+                        (exec remove-tag-query tag)
+                        (flush!)))
+
          (get-tag (lambda (tag)
-                         (let ((td (query fetch (sql *db* "SELECT key FROM tags WHERE tag = ?") tag)))
+                         (let ((td (query fetch get-tag-query tag)))
                            (if (pair? td)
                                (car td)
                                #f))))
+
          (set-tag-lock! (lambda (tag lock)
-                      (exec (sql *db* "UPDATE tags SET locked = ? WHERE tag = ?") lock tag)))
+                      (exec set-tag-lock-query lock tag)
+                      (flush!)))
+
          (get-tag-lock (lambda (tag lock)
-                         (let ((td (query fetch (sql *db* "SELECT locked FROM tags WHERE tag = ?") tag)))
+                         (let ((td (query fetch get-tag-lock-query tag)))
                            (if (pair? td)
                                (car td)
                                #f))))
+
          (get-tags (lambda ()
-                     (map car (query fetch-all (sql *db* "SELECT tag FROM tags")))))
-         (get-log (lambda (index)
-            (if (hash-table-exists? *logfiles* index)
-               (hash-table-ref *logfiles* index)
-               (begin
-                  (let ((fd (file-open (string-append logdir "/log" (number->string index)) open/rdonly perm/irwxu)))
-                     (set! (hash-table-ref *logfiles* index) fd)
-                     fd))))))
-
-      ; FIXME: Sanity check that all opened OK
+                     (map car (query fetch-all get-tags-query)))))
 
       (make-storage
-         (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
+         (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap, right?
          #t ; We are writable
          #f ; We DO NOT support unlink!
 
          (lambda (key data type) ; put!
-           (with-transaction *db*
-                             (lambda ()
-                               (when (pair? (get-block-data key))
-                                     (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
-
-                               (set-file-position! *log* 0 seek/end)
-
-                               (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))
-                                     (posn (file-position *log*)))
-                                 (if (> posn max-logpart-size)
-                                     (begin
-                                       (file-close *log*)
-                                       (set! posn 0)
-                                       (set-logcount! (+ *logcount* 1))
-                                       (set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))
-                                                              (+ open/creat open/rdwr open/append) perm/irwxu))))
-                                 (file-write *log* header)
-                                 (file-write *log* (u8vector->blob/shared data))
-                                 (set-block-data! key type *logcount* (+ (string-length header) posn) (u8vector-length data))
-                                 (void)))))
+           (when (pair? (get-block-data key))
+                 (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
+
+           (set-file-position! *log* 0 seek/end)
+
+           (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))
+                 (posn (file-position *log*)))
+             (if (> posn max-logpart-size)
+                 (begin
+                   (file-close *log*)
+                   (set! posn 0)
+                   (set-logcount! (+ *logcount* 1))
+                   (set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))
+                                          (bitwise-ior open/creat open/rdwr open/append) (bitwise-ior perm/irusr perm/iwusr)))))
+             (file-write *log* header)
+             (file-write *log* (u8vector->blob/shared data))
+             (set-block-data! key type *logcount* (+ (string-length header) posn) (u8vector-length data))
+             (void)))
 
          (lambda (key) ; exists?
@@ -286 +334 @@
            (set-tag-lock! tag 0))
          (lambda () ; close!
+           (flush!)
+           (exec (sql *db* "COMMIT;"))
            (close-database *db*)
            (file-close *log*)