1.1--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2+++ b/examples/db/mini-redis.lisp	Sun Dec 24 19:24:39 2023 -0500
     1.3@@ -0,0 +1,126 @@
     1.4+;;; examples/db/mini-redis.lisp --- Mini-Redis client/server
     1.5+
     1.6+;; based on https://github.com/no-defun-allowed/concurrent-hash-tables/blob/master/Examples/phony-redis.lisp
     1.7+
     1.8+;;; Code:
     1.9+(require 'sb-concurrency)
    1.10+(defpackage :examples/mini-redis
    1.11+  (:use :cl :std :net :obj :cli :sb-concurrency :sb-thread)
    1.12+  (:export))
    1.13+
    1.14+(in-package :examples/mini-redis)
    1.15+
    1.16+(defun make-server ()
    1.17+  (make-castable :test #'equal))
    1.18+
    1.19+(defstruct conn tx rx)
    1.20+
    1.21+(defun connect-to-server (server)
    1.22+  (let ((tx (make-mailbox))
    1.23+        (rx (make-mailbox)))
    1.24+    (make-thread 
    1.25+     (lambda ()
    1.26+       (let ((msg (receive-message tx)))
    1.27+         (loop do
    1.28+           (case (car msg)
    1.29+             (:quit (return))
    1.30+             (:get 
    1.31+              (multiple-value-bind (val p)
    1.32+                  (obj/hash:cgethash (cdr msg) server)
    1.33+                (if p
    1.34+                    (send-message rx `(:found ,val))
    1.35+                    (send-message rx `(:not-found)))))
    1.36+             (:put
    1.37+              (setf (cgethash (cadr msg) server)
    1.38+                    (copy-seq (caddr msg)))
    1.39+              (send-message rx '(:ok)))
    1.40+             (t (return))))))
    1.41+     :name "mini-redis-conn")
    1.42+    (make-conn :tx tx :rx rx)))
    1.43+
    1.44+(defun find-val (conn name)
    1.45+  (send-message
    1.46+   (conn-tx conn)
    1.47+   `(:get ,name))
    1.48+  (let ((rx (receive-message (conn-rx conn))))
    1.49+    (case (car rx)
    1.50+      (:found
    1.51+       (values (cdr rx) t))
    1.52+      (:not-found
    1.53+       (values nil nil)))))
    1.54+
    1.55+(defun (setf find-val) (val conn name)
    1.56+  (send-message
    1.57+   (conn-tx conn)
    1.58+   `(:put ,name ,val))
    1.59+  (receive-message
    1.60+   (conn-rx conn)))
    1.61+
    1.62+(defun close-conn (conn)
    1.63+  (send-message
    1.64+   (conn-tx conn)
    1.65+   `(:quit)))
    1.66+
    1.67+(defun worker (n server
    1.68+               ready start
    1.69+               writer-proportion names)
    1.70+  (declare (optimize (speed 3))
    1.71+           (single-float writer-proportion))
    1.72+  (let ((name (elt names n))
    1.73+        (bitmap (make-array 100
    1.74+                            :element-type '(unsigned-byte 8)
    1.75+                            :initial-element 0))
    1.76+        (conn (connect-to-server server)))
    1.77+    (dotimes (i 100)
    1.78+      (setf (aref bitmap i)
    1.79+            (if (< (random 1.0) writer-proportion)
    1.80+                1
    1.81+                0)))
    1.82+    (signal-semaphore ready)
    1.83+    (wait-on-semaphore start)
    1.84+    (let ((position 0))
    1.85+      (dotimes (o (the fixnum *ops*))
    1.86+        (if (zerop (aref bitmap position))
    1.87+            (find-val conn name)
    1.88+            (setf (find-val conn name)
    1.89+                  #(1)))
    1.90+        (setf position (mod (1+ position) 100))))
    1.91+    (close-conn conn)))
    1.92+
    1.93+(defparameter *worker-count* 8)
    1.94+(defparameter *writer-proportion* 0.5)
    1.95+(defvar *keys*
    1.96+  (loop for n below 130 by 2
    1.97+        collect (format nil "~r" n)))
    1.98+(defvar *other-keys*
    1.99+  (loop for n from 1 below 128 by 2
   1.100+        collect (format nil "~r" n)))
   1.101+(defvar *ops* 10000000)
   1.102+
   1.103+(defun run (&optional (worker-count *worker-count*)
   1.104+              (writer-proportion *writer-proportion*)
   1.105+              (keys *keys*))
   1.106+  (let* ((ready (make-semaphore :name "ready-threads"))
   1.107+         (start (make-semaphore :name "start-threads"))
   1.108+         (server (make-server))
   1.109+         (workers (loop for n below worker-count
   1.110+                        collect (let ((n n))
   1.111+                                  (make-thread
   1.112+                                   (lambda ()
   1.113+                                     (worker n server
   1.114+                                             ready start
   1.115+                                             writer-proportion
   1.116+                                             keys)))))))
   1.117+    (dotimes (n worker-count)
   1.118+      (wait-on-semaphore ready))
   1.119+    (let ((start-time (get-internal-real-time)))
   1.120+      (signal-semaphore start worker-count)
   1.121+      (mapc #'join-thread workers)
   1.122+      (let* ((time (float (/ (- (get-internal-real-time) start-time)
   1.123+                             internal-time-units-per-second)))
   1.124+             (throughput (/ (* *ops* worker-count) time)))
   1.125+        (format t "~&~20@a: ~$ seconds (~d transactions/second)"
   1.126+                "mini-redis" time (round throughput))))))
   1.127+
   1.128+(defmain ()
   1.129+  (run 4 1.0 *keys*))