source: project/release/3/tokyocabinet/tokyocabinet.scm @ 13476

Last change on this file since 13476 was 13476, checked in by Jim Ursetto, 11 years ago

tokyocabinet: speed up tc-hdb-get

File size: 5.5 KB
Line 
1;;;; tokyocabinet.scm -- Tokyo Cabinet DBM bindings for Chicken
2;;
3;; Copyright (c) 2008 Alex Shinn
4;; All rights reserved.
5;;
6;; BSD-style license: http://www.debian.org/misc/bsd.license
7
8(declare
9 (fixnum-arithmetic)
10 (usual-integrations)
11 (export
12  TC_HDBTLARGE TC_HDBTDEFLATE TC_HDBTBZIP TC_HDBTTCBS
13  TC_HDBOWRITER TC_HDBOREADER TC_HDBOCREAT TC_HDBOTRUNC
14  TC_HDBONOLCK TC_HDBOLCKNB
15  tc-hdb-open tc-hdb-close
16  tc-hdb-put! tc-hdb-delete! tc-hdb-get
17  tc-hdb-fold
18  tc-hdb-iter-init tc-hdb-iter-next
19  ))
20
21(require-extension lolevel) ; free
22
23(declare
24  (foreign-declare "
25
26#include <tcutil.h>
27#include <tchdb.h>
28#include <stdlib.h>
29#include <stdbool.h>
30#include <stdint.h>
31
32#define copy_string_result(ptr, len, str)     (C_memcpy(C_c_string(str), (char *)C_block_item(ptr, 0), C_unfix(len)), C_SCHEME_UNDEFINED)
33
34"))
35
36;; tc-hdb-tune flags
37(define-foreign-variable HDBTLARGE int "HDBTLARGE")
38(define-foreign-variable HDBTDEFLATE int "HDBTDEFLATE")
39(define-foreign-variable HDBTBZIP int "HDBTBZIP")
40(define-foreign-variable HDBTTCBS int "HDBTTCBS")
41
42(define TC_HDBTLARGE HDBTLARGE)
43(define TC_HDBTDEFLATE HDBTDEFLATE)
44(define TC_HDBTBZIP HDBTBZIP)
45(define TC_HDBTTCBS HDBTTCBS)
46
47;; tc-hdb-open flags
48(define-foreign-variable HDBOWRITER int "HDBOWRITER")
49(define-foreign-variable HDBOREADER int "HDBOREADER")
50(define-foreign-variable HDBOCREAT int "HDBOCREAT")
51(define-foreign-variable HDBOTRUNC int "HDBOTRUNC")
52(define-foreign-variable HDBONOLCK int "HDBONOLCK")
53(define-foreign-variable HDBOLCKNB int "HDBOLCKNB")
54
55(define TC_HDBOWRITER HDBOWRITER)
56(define TC_HDBOREADER HDBOREADER)
57(define TC_HDBOCREAT HDBOCREAT)
58(define TC_HDBOTRUNC HDBOTRUNC)
59(define TC_HDBONOLCK HDBONOLCK)
60(define TC_HDBOLCKNB HDBOLCKNB)
61
62(define %tc-hdb-new (foreign-lambda c-pointer "tchdbnew"))
63
64(define %tc-hdb-del
65  (foreign-lambda* void ((c-pointer hdb))
66    "tchdbdel((TCHDB*) hdb);"))
67
68(define %tc-hdb-set-mutex!
69  (foreign-lambda* bool ((c-pointer hdb))
70    "return(tchdbsetmutex((TCHDB*) hdb));"))
71
72(define %tc-hdb-set-cache!
73  (foreign-lambda* bool ((c-pointer hdb) (int rcnum))
74    "return(tchdbsetcache((TCHDB*) hdb, rcnum));"))
75
76(define %tc-hdb-set-xmsiz!
77  (foreign-lambda* bool ((c-pointer hdb) (int xmsiz))
78    "return(tchdbsetxmsiz((TCHDB*) hdb, xmsiz));"))
79
80(define %tc-hdb-tune!
81  (foreign-lambda* bool ((c-pointer hdb)
82                         (int bnum) (int apow) (int fpow) (int opts))
83    "return(tchdbtune((TCHDB*) hdb, bnum, apow, fpow, opts));"))
84
85(define %tc-hdb-open
86  (foreign-lambda* bool ((c-pointer hdb) (c-string file) (int flags))
87    "return(tchdbopen(hdb, file, flags));"))
88
89(define (tc-hdb-open file
90                     #!key
91                     (flags (fx+ HDBOWRITER (fx+ HDBOREADER HDBOCREAT)))
92                     (mutex? #f)
93                     (num-buckets #f)
94                     (record-alignment #f)
95                     (num-free-blocks #f)
96                     (tune-opts #f)
97                     (cache-limit #f)
98                     (mmap-size #f))
99  (let ((hdb (%tc-hdb-new)))
100    (and hdb
101         ;; make sure all the specified keyword settings succeed, and
102         ;; return the hdb c-pointer
103         (or (and
104              (or (not mutex?) (%tc-hdb-set-mutex! hdb))
105              (or (not cache-limit) (%tc-hdb-set-cache! hdb cache-limit))
106              (or (not mmap-size) (%tc-hdb-set-xmsiz! hdb mmap-size))
107              (or (not (or num-buckets record-alignment num-free-blocks
108                           tune-opts))
109                  (%tc-hdb-tune! hdb
110                                 (or num-buckets 0)
111                                 (or record-alignment -1)
112                                 (or num-free-blocks -1)
113                                 (or tune-opts 0)))
114              (%tc-hdb-open hdb file flags)
115              hdb)
116             (begin
117               ;; clean up and return #f if any of the functions failed
118               (%tc-hdb-del hdb)
119               #f)))))
120
121(define tc-hdb-close
122  (foreign-lambda* bool ((c-pointer hdb))
123    "if (tchdbclose((TCHDB*) hdb)) {"
124    "    tchdbdel((TCHDB*) hdb);"
125    "    return(1);"
126    "} else {"
127    "    return(0);"
128    "}"))
129
130(define %tc-hdb-put!
131  (foreign-lambda* bool ((c-pointer hdb)
132                         (pointer kptr) (int ksize)
133                         (pointer vptr) (int vsize))
134    "return(tchdbput((TCHDB*) hdb, kptr, ksize, vptr, vsize));"))
135
136(define (tc-hdb-put! hdb key value)
137  (%tc-hdb-put! hdb key (string-length key) value (string-length value)))
138
139(define %tc-hdb-delete!
140  (foreign-lambda* bool ((c-pointer hdb) (pointer kptr) (int ksize))
141    "return(tchdbout((TCHDB*) hdb, kptr, ksize));"))
142
143(define (tc-hdb-delete! hdb key)
144  (%tc-hdb-delete! hdb key (string-length key)))
145
146(define (tc-hdb-get hdb key)
147  (define tchdbget
148    (foreign-lambda c-pointer "tchdbget"
149                    c-pointer scheme-pointer int (c-pointer int)))
150  (let-location ((size int))
151    (let ((valptr (tchdbget hdb key
152                            (string-length key) (location size))))
153      (and valptr
154           (let ((val (make-string size)))
155             (##core#inline "copy_string_result" valptr size val)
156             (free valptr)
157             val)))))
158
159(define tc-hdb-iter-init
160  (foreign-lambda* bool ((c-pointer hdb))
161    "return(tchdbiterinit((TCHDB*) hdb));"))
162
163(define tc-hdb-iter-next
164  (foreign-lambda* c-string ((c-pointer hdb))
165    "return(tchdbiternext2((TCHDB*) hdb));"))
166
167(define (tc-hdb-fold hdb kons knil)
168  (tc-hdb-iter-init hdb)
169  (let lp ((acc knil))
170    (let ((key (tc-hdb-iter-next hdb)))
171      (if (not key)
172          acc
173          (let ((val (tc-hdb-get hdb key)))
174            (lp (kons key val acc)))))))
Note: See TracBrowser for help on using the repository browser.