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


Ignore:
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:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/ugarit/trunk/backend-fs.scm

    r25479 r25521  
    153153   "CREATE TABLE metadata (key TEXT PRIMARY KEY, value TEXT);"
    154154   "INSERT INTO metadata VALUES ('version','1');"
    155    "INSERT INTO metadata VALUES ('current-logfile','0');"
    156155   "CREATE TABLE blocks (key TEXT PRIMARY KEY, type TEXT, fileno INTEGER, position INTEGER, length INTEGER);"
    157156   "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);"))
     
    161160        ((*db*
    162161          (let ((db (open-database metapath)))
     162            (change-file-mode metapath (bitwise-ior perm/irusr perm/iwusr)) ; Don't think we can do anything about the journal files, though.
    163163            (when (null? (schema db))
    164164                  (for-each (lambda (statement)
    165165                              (exec (sql db statement)))
    166166                            splitlog-sql-schema))
     167            (exec (sql db "BEGIN;"))
    167168            db))
    168          (*logcount* (string->number (car (query fetch (sql *db* "SELECT value FROM metadata WHERE key = 'current-logfile'")))))
     169
     170         ; Prepared statements
     171         (get-metadata-query (sql *db* "SELECT value FROM metadata WHERE key = ?"))
     172         (set-metadata-query (sql *db* "INSERT OR REPLACE INTO metadata (key,value) VALUES (?,?)"))
     173         (get-block-data-query (sql *db* "SELECT type, fileno, position, length FROM blocks WHERE key = ?"))
     174         (set-block-data-query (sql *db* "INSERT INTO blocks (key,type,fileno,position,length) VALUES (?,?,?,?,?)"))
     175         (get-tag-query (sql *db* "SELECT key FROM tags WHERE tag = ?"))
     176         (set-tag-query (sql *db* "INSERT OR REPLACE INTO tags (tag,key) VALUES (?,?)"))
     177         (remove-tag-query (sql *db* "DELETE FROM tags WHERE tag = ?"))
     178         (set-tag-lock-query (sql *db* "UPDATE tags SET locked = ? WHERE tag = ?"))
     179         (get-tag-lock-query (sql *db* "SELECT locked FROM tags WHERE tag = ?"))
     180         (get-tags-query (sql *db* "SELECT tag FROM tags"))
     181
     182         ; Database access functions
     183         (get-metadata (lambda (key default)
     184                         (let ((result (query fetch get-metadata-query key)))
     185                           (if (null? result)
     186                               (begin
     187                                 (exec set-metadata-query key default)
     188                                 default)
     189                               (car result)))))
     190         (set-metadata (lambda (key value)
     191                         (exec set-metadata-query key value)))
     192
     193         ; Log file management
     194         (*logcount* (string->number (get-metadata "current-logfile" "0")))
    169195         (set-logcount! (lambda (newcount)
    170                          (set! *logcount* newcount)
    171                          (exec (sql *db* "INSERT OR REPLACE INTO metadata (key,value) VALUES ('current-logfile',?)") newcount)))
     196                         (set! *logcount* newcount)))
    172197         (*log* (file-open (string-append logdir "/log" (number->string *logcount*))
    173                   (+ open/creat open/rdwr open/append) perm/irwxu))
     198                  (bitwise-ior open/creat open/rdwr open/append) (bitwise-ior perm/irusr perm/iwusr)))
    174199         (*logfiles* (make-hash-table)) ; hash of file number to FD
     200         (get-log (lambda (index)
     201            (if (hash-table-exists? *logfiles* index)
     202               (hash-table-ref *logfiles* index)
     203               (begin
     204                  (let ((fd (file-open (string-append logdir "/log" (number->string index)) open/rdonly perm/irwxu)))
     205                     (set! (hash-table-ref *logfiles* index) fd)
     206                     fd)))))
     207
     208         ; Periodic commit management
     209         (commit-interval (string->number (get-metadata "commit-interval" "1000")))
     210         (*updates-since-last-commit* 0)
     211         (flush! (lambda ()
     212                   (set-metadata "current-logfile" (number->string *logcount*))
     213                   (exec (sql *db* "COMMIT;"))
     214                   (exec (sql *db* "BEGIN;"))
     215                   (set! *updates-since-last-commit* 0)))
     216         (maybe-flush! (lambda ()
     217                         (set! *updates-since-last-commit*
     218                               (+ *updates-since-last-commit* 1))
     219                         (when (> *updates-since-last-commit* commit-interval)
     220                             (flush!))))
     221
     222         ; Higher-level database utilities
    175223         (get-block-data (lambda (key) ; Returns #f for nonexistant blocks
    176                            (let ((bd (query fetch (sql *db* "SELECT type, fileno, position, length FROM blocks WHERE key = ?") key)))
     224                           (let ((bd (query fetch get-block-data-query key)))
    177225                             (if (pair? bd)
    178226                                 (let ((type (string->symbol (first bd)))
     
    182230                                   (list type fileno position length))
    183231                                 #f))))
     232
    184233         (set-block-data! (lambda (key type fileno position length)
    185                            (exec (sql *db* "INSERT INTO blocks (key,type,fileno,position,length) VALUES (?,?,?,?,?)") key (symbol->string type) fileno position length)))
     234                           (exec set-block-data-query key (symbol->string type) fileno position length)
     235                           (maybe-flush!)))
     236
    186237         (set-tag! (lambda (tag key)
    187                     (exec (sql *db* "INSERT OR REPLACE INTO tags (tag,key) VALUES (?,?)") tag key)))
     238                    (exec set-tag-query tag key)
     239                    (flush!)))
     240
    188241         (remove-tag! (lambda (tag)
    189                         (exec (sql *db* "DELETE FROM tags WHERE tag = ?") tag)))
     242                        (exec remove-tag-query tag)
     243                        (flush!)))
     244
    190245         (get-tag (lambda (tag)
    191                          (let ((td (query fetch (sql *db* "SELECT key FROM tags WHERE tag = ?") tag)))
     246                         (let ((td (query fetch get-tag-query tag)))
    192247                           (if (pair? td)
    193248                               (car td)
    194249                               #f))))
     250
    195251         (set-tag-lock! (lambda (tag lock)
    196                       (exec (sql *db* "UPDATE tags SET locked = ? WHERE tag = ?") lock tag)))
     252                      (exec set-tag-lock-query lock tag)
     253                      (flush!)))
     254
    197255         (get-tag-lock (lambda (tag lock)
    198                          (let ((td (query fetch (sql *db* "SELECT locked FROM tags WHERE tag = ?") tag)))
     256                         (let ((td (query fetch get-tag-lock-query tag)))
    199257                           (if (pair? td)
    200258                               (car td)
    201259                               #f))))
     260
    202261         (get-tags (lambda ()
    203                      (map car (query fetch-all (sql *db* "SELECT tag FROM tags")))))
    204          (get-log (lambda (index)
    205             (if (hash-table-exists? *logfiles* index)
    206                (hash-table-ref *logfiles* index)
    207                (begin
    208                   (let ((fd (file-open (string-append logdir "/log" (number->string index)) open/rdonly perm/irwxu)))
    209                      (set! (hash-table-ref *logfiles* index) fd)
    210                      fd))))))
    211 
    212       ; FIXME: Sanity check that all opened OK
     262                     (map car (query fetch-all get-tags-query)))))
    213263
    214264      (make-storage
    215          (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
     265         (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap, right?
    216266         #t ; We are writable
    217267         #f ; We DO NOT support unlink!
    218268
    219269         (lambda (key data type) ; put!
    220            (with-transaction *db*
    221                              (lambda ()
    222                                (when (pair? (get-block-data key))
    223                                      (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
    224 
    225                                (set-file-position! *log* 0 seek/end)
    226 
    227                                (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))
    228                                      (posn (file-position *log*)))
    229                                  (if (> posn max-logpart-size)
    230                                      (begin
    231                                        (file-close *log*)
    232                                        (set! posn 0)
    233                                        (set-logcount! (+ *logcount* 1))
    234                                        (set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))
    235                                                               (+ open/creat open/rdwr open/append) perm/irwxu))))
    236                                  (file-write *log* header)
    237                                  (file-write *log* (u8vector->blob/shared data))
    238                                  (set-block-data! key type *logcount* (+ (string-length header) posn) (u8vector-length data))
    239                                  (void)))))
     270           (when (pair? (get-block-data key))
     271                 (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
     272
     273           (set-file-position! *log* 0 seek/end)
     274
     275           (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))
     276                 (posn (file-position *log*)))
     277             (if (> posn max-logpart-size)
     278                 (begin
     279                   (file-close *log*)
     280                   (set! posn 0)
     281                   (set-logcount! (+ *logcount* 1))
     282                   (set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))
     283                                          (bitwise-ior open/creat open/rdwr open/append) (bitwise-ior perm/irusr perm/iwusr)))))
     284             (file-write *log* header)
     285             (file-write *log* (u8vector->blob/shared data))
     286             (set-block-data! key type *logcount* (+ (string-length header) posn) (u8vector-length data))
     287             (void)))
    240288
    241289         (lambda (key) ; exists?
     
    286334           (set-tag-lock! tag 0))
    287335         (lambda () ; close!
     336           (flush!)
     337           (exec (sql *db* "COMMIT;"))
    288338           (close-database *db*)
    289339           (file-close *log*)
Note: See TracChangeset for help on using the changeset viewer.