# HG changeset patch # User ellis # Date 1683403762 14400 # Node ID 4230ce61dcfa97beefa02ac9e39b570a7edec45f # Parent 1b1176a6310931186044a6ce61173be4ef6ce7cc db ffi from cl-rocksdb diff -r 1b1176a63109 -r 4230ce61dcfa db.lisp --- a/db.lisp Fri May 05 22:44:22 2023 -0400 +++ b/db.lisp Sat May 06 16:09:22 2023 -0400 @@ -1,1 +1,197 @@ (in-package :demo) + +(define-foreign-library rocksdb + (:win32 "rocksdb") + (t (:default "librocksdb"))) + +(use-foreign-library rocksdb) + +(defcfun ("rocksdb_options_create" create-options) :pointer) +(defcfun ("rocksdb_options_destroy" destroy-options) :void (options :pointer)) +(defcfun ("rocksdb_options_increase_parallelism" increase-parallelism) :void (opt :pointer) (total-threads :int)) +(defcfun ("rocksdb_options_optimize_level_style_compaction" optimize-level-style-compaction) :void (opt :pointer) (memtable_memory_budget :uint64)) +(defcfun ("rocksdb_options_set_create_if_missing" set-create-if-missing) :void (opt :pointer) (val :boolean)) + +(defcfun ("rocksdb_writeoptions_create" create-writeoptions) :pointer) +(defcfun ("rocksdb_writeoptions_destroy" destroy-writeoptions) :void (opt :pointer)) +(defcfun ("rocksdb_readoptions_create" create-readoptions) :pointer) +(defcfun ("rocksdb_readoptions_destroy" destroy-readoptions) :void (opt :pointer)) + +(defcfun ("rocksdb_open" open-db*) :pointer (opt :pointer) (name :string) (errptr :pointer)) +(defcfun ("rocksdb_close" close-db) :void (opt :pointer)) +(defcfun ("rocksdb_cancel_all_background_work" cancel-all-background-work) :void (db :pointer) (wait :boolean)) + +(defcfun ("rocksdb_put" put*) :void (db :pointer) (options :pointer) (key :pointer) (keylen :unsigned-int) (val :pointer) (vallen :unsigned-int) (errptr :pointer)) +(defcfun ("rocksdb_get" get*) :pointer (db :pointer) (options :pointer) (key :pointer) (keylen :unsigned-int) (vallen :pointer) (errptr :pointer)) + +(defcfun ("rocksdb_create_iterator" create-iter*) :pointer (db :pointer) (opt :pointer)) +(defcfun ("rocksdb_iter_destroy" destroy-iter) :void (iter :pointer)) +(defcfun ("rocksdb_iter_seek_to_first" move-iter-to-first) :void (iter :pointer)) +(defcfun ("rocksdb_iter_valid" valid-iter-p) :boolean (iter :pointer)) +(defcfun ("rocksdb_iter_next" move-iter-forward) :void (iter :pointer)) +(defcfun ("rocksdb_iter_prev" move-iter-backward) :void (iter :pointer)) +(defcfun ("rocksdb_iter_key" iter-key*) :pointer (iter :pointer) (klen-ptr :pointer)) +(defcfun ("rocksdb_iter_value" iter-value*) :pointer (iter :pointer) (vlen-ptr :pointer)) + +(define-condition unable-to-open-db (error) + ((db-path :initarg :db-path + :reader db-path) + (error-message :initarg :error-message + :reader error-message))) + +(defmethod print-object ((obj unable-to-open-db) stream) + (print-unreadable-object (obj stream :type t :identity t) + (format stream "error-message=~A" (error-message obj)))) + +(define-condition unable-to-put-key-value-to-db (error) + ((db :initarg :db + :reader db) + (key :initarg :key + :reader key) + (val :initarg :val + :reader val) + (error-message :initarg :error-message + :reader error-message))) + +(define-condition unable-to-get-value-to-db (error) + ((db :initarg :db + :reader db) + (key :initarg :key + :reader key) + (error-message :initarg :error-message + :reader error-message))) + +(defun open-db (db-path &optional opt) + (unless opt + (setq opt (create-options))) + (let ((errptr (foreign-alloc :pointer))) + (setf (mem-ref errptr :pointer) (null-pointer)) + (let* ((db-path (if (pathnamep db-path) + (namestring db-path) + db-path)) + (db (open-db* opt db-path errptr)) + (err (mem-ref errptr :pointer))) + (unless (null-pointer-p err) + (error 'unable-to-open-db + :db-path db-path + :error-message (foreign-string-to-lisp err))) + db))) + +(defmacro clone-octets-to-foreign (lisp-array foreign-array) + (let ((i (gensym))) + `(loop for ,i from 0 below (length ,lisp-array) + do (setf (mem-aref ,foreign-array :unsigned-char ,i) + (aref ,lisp-array ,i))))) + +(defmacro clone-octets-from-foreign (foreign-array lisp-array len) + (let ((i (gensym))) + `(loop for ,i from 0 below ,len + do (setf (aref ,lisp-array ,i) + (mem-aref ,foreign-array :unsigned-char ,i))))) + +(defun put-kv (db key val &optional opt) + (unless opt + (setq opt (create-writeoptions))) + (with-foreign-objects ((errptr :pointer) + (key* :unsigned-char (length key)) + (val* :unsigned-char (length val))) + (clone-octets-to-foreign key key*) + (clone-octets-to-foreign val val*) + (setf (mem-ref errptr :pointer) (null-pointer)) + (put* db + opt + key* + (length key) + val* + (length val) + errptr) + (let ((err (mem-ref errptr :pointer))) + (unless (null-pointer-p err) + (error 'unable-to-put-key-value-to-db + :db db + :key key + :val val + :error-message (foreign-string-to-lisp err)))))) + +(defun put-kv-str (db key val &optional opt) + (let ((key-octets (babel:string-to-octets key)) + (val-octets (babel:string-to-octets val))) + (put-kv db key-octets val-octets opt))) + +(defun get-kv (db key &optional opt) + (unless opt + (setq opt (create-readoptions))) + + (with-foreign-objects ((val-len-ptr :unsigned-int) + (errptr :pointer) + (key* :unsigned-char (length key))) + (clone-octets-to-foreign key key*) + (setf (mem-ref errptr :pointer) (null-pointer)) + (let ((val (get* db + opt + key* + (length key) + val-len-ptr + errptr))) + (let ((err (mem-ref errptr :pointer))) + (unless (null-pointer-p err) + (error 'unable-to-get-value-to-db + :db db + :key key + :error-message (foreign-string-to-lisp err))) + + (unless (null-pointer-p val) + (let* ((val-len (mem-ref val-len-ptr :unsigned-int)) + (val* (make-array val-len + :element-type '(unsigned-byte 8)))) + (clone-octets-from-foreign val val* val-len) + val*)))))) + +(defun get-kv-str (db key &optional opt) + (let ((key-octets (babel:string-to-octets key))) + (let ((#1=val-octets (get-kv db key-octets opt))) + (when #1# + (babel:octets-to-string #1#))))) + +(defun create-iter (db &optional opt) + (unless opt + (setq opt (create-readoptions))) + (create-iter* db opt)) + +(defun iter-key (iter) + (with-foreign-objects ((klen-ptr :unsigned-int)) + (setf (mem-ref klen-ptr :unsigned-int) 0) + (let* ((key-ptr (iter-key* iter klen-ptr)) + (klen (mem-ref klen-ptr :unsigned-int)) + (key (make-array klen :element-type '(unsigned-byte 8)))) + (clone-octets-from-foreign key-ptr key klen) + key))) + +(defun iter-key-str (iter) + (let ((#1=key-octets (iter-key iter))) + (when #1# + (babel:octets-to-string #1#)))) + +(defun iter-value (iter) + (with-foreign-objects ((len-ptr :unsigned-int)) + (setf (mem-ref len-ptr :unsigned-int) 0) + (let* ((value-ptr (iter-value* iter len-ptr)) + (vlen (mem-ref len-ptr :unsigned-int)) + (value* (make-array vlen :element-type '(unsigned-byte 8)))) + (clone-octets-from-foreign value-ptr value* vlen) + value*))) + +(defun iter-value-str (iter) + (let ((#1=val-octets (iter-value iter))) + (when #1# + (babel:octets-to-string #1#)))) + +(defmacro with-open-db ((db-var db-path &optional opt) &body body) + `(let ((,db-var (open-db ,db-path ,opt))) + (unwind-protect (progn ,@body) + (close-db ,db-var)))) + +(defmacro with-iter ((iter-var db &optional opt) &body body) + `(let ((,iter-var (create-iter ,db ,opt))) + (unwind-protect (progn ,@body) + (destroy-iter ,iter-var)))) diff -r 1b1176a63109 -r 4230ce61dcfa ffi.lisp --- a/ffi.lisp Fri May 05 22:44:22 2023 -0400 +++ b/ffi.lisp Sat May 06 16:09:22 2023 -0400 @@ -1,8 +1,7 @@ (in-package :demo) (define-foreign-library demo_ffi - (:win32 (:default "./target/release/demo_ffi")) - (t (:default "./target/release/libdemo_ffi"))) + (:win32 (:default "demo")) + (t (:default "libdemo"))) -(use-foreign-library demo_ffi) - +;; (use-foreign-library "./target/release/libdemo_ffi.dylib") diff -r 1b1176a63109 -r 4230ce61dcfa pkg.lisp --- a/pkg.lisp Fri May 05 22:44:22 2023 -0400 +++ b/pkg.lisp Sat May 06 16:09:22 2023 -0400 @@ -1,6 +1,5 @@ #| demo - > (demo:main) |# (defpackage #:demo @@ -11,26 +10,50 @@ (#:bt #:bordeaux-threads) (#:cli #:clingon)) ;; db.lisp - (:export - ;; #:make-db - ;; #:with-db - ;; #:db - ) + (:export #:create-options + #:destroy-options + #:increase-parallelism + #:optimize-level-style-compaction + #:set-create-if-missing + #:create-writeoptions + #:destroy-writeoptions + #:create-readoptions + #:destroy-readoptions + #:open-db + #:close-db + #:cancel-all-background-work + #:put-kv + #:put-kv-str + #:get-kv + #:get-kv-str + #:create-iter + #:destroy-iter + #:move-iter-to-first + #:move-iter-forward + #:move-iter-backword + #:valid-iter-p + #:iter-key + #:iter-key-str + #:iter-value + #:iter-value-str + #:with-open-db + #:with-iter) ;; demo.lisp - (:export - #:main - #:demo-path - #:db-path - #:cli-opts - #:cli-handler - #:cli-cmd) + (:export #:main + #:demo-path + #:db-path + #:cli-opts + #:cli-handler + #:cli-cmd) ;; ui.lisp - (:export - #:on-new-window - #:start-ui) + (:export #:on-new-window + #:start-ui) ;; tk.lisp - (:export - #:random-id - #:scan-dir) + (:export #:random-id + #:scan-dir + #:mkstr + #:symb + #:sbq-reader) ;; ffi.lisp + ;; (:export) ) diff -r 1b1176a63109 -r 4230ce61dcfa tk.lisp --- a/tk.lisp Fri May 05 22:44:22 2023 -0400 +++ b/tk.lisp Sat May 06 16:09:22 2023 -0400 @@ -1,8 +1,42 @@ (in-package #:demo) +(defvar *cargo-target* #P"/Users/ellis/dev/otom8/demo/target/") + +(defmacro find-rust-dll (name &optional debug) + "Find the rust dll specified by NAME." + (cond + ((uiop:directory-exists-p (merge-pathnames *cargo-target* "release")) + `,(mkstr "./target/release/" name)) + ((uiop:directory-exists-p (merge-pathnames *cargo-target* "debug")) + `,(mkstr "./target/debug/" name)) + (t (progn + (uiop:run-program `("cargo" "build" ,(unless debug "--release")) :output t) + `,(find-rust-dll name debug))))) + (defun random-id () (format NIL "~8,'0x-~8,'0x" (random #xFFFFFFFF) (get-universal-time))) (defun scan-dir (dir filename callback) (dolist (path (directory (merge-pathnames (merge-pathnames filename "**/") dir))) (funcall callback path))) + +(defun mkstr (&rest args) + (with-output-to-string (s) + (dolist (a args) (princ a s)))) + +(defun symb (&rest args) + (values (intern (apply #'mkstr args)))) + +(defun sbq-reader (stream sub-char numarg) + "The anaphoric sharp-backquote reader: #`((,a1))" + (declare (ignore sub-char)) + (unless numarg (setq numarg 1)) + `(lambda ,(loop for i from 1 to numarg + collect (symb 'a i)) + ,(funcall + (get-macro-character #\`) stream nil))) + +(eval-when (:execute) + (in-package :demo) + (set-dispatch-macro-character + #\# #\` #'demo:sbq-reader))