changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > demo / examples/db/mini-redis.lisp

changeset 37: c6d0a37a046a
child: 8259376eee11
author: ellis <ellis@rwest.io>
date: Sun, 24 Dec 2023 19:24:39 -0500
permissions: -rw-r--r--
description: mini-redis and vegadat 
     1 ;;; examples/db/mini-redis.lisp --- Mini-Redis client/server
     2 
     3 ;; based on https://github.com/no-defun-allowed/concurrent-hash-tables/blob/master/Examples/phony-redis.lisp
     4 
     5 ;;; Code:
     6 (require 'sb-concurrency)
     7 (defpackage :examples/mini-redis
     8   (:use :cl :std :net :obj :cli :sb-concurrency :sb-thread)
     9   (:export))
    10 
    11 (in-package :examples/mini-redis)
    12 
    13 (defun make-server ()
    14   (make-castable :test #'equal))
    15 
    16 (defstruct conn tx rx)
    17 
    18 (defun connect-to-server (server)
    19   (let ((tx (make-mailbox))
    20         (rx (make-mailbox)))
    21     (make-thread 
    22      (lambda ()
    23        (let ((msg (receive-message tx)))
    24          (loop do
    25            (case (car msg)
    26              (:quit (return))
    27              (:get 
    28               (multiple-value-bind (val p)
    29                   (obj/hash:cgethash (cdr msg) server)
    30                 (if p
    31                     (send-message rx `(:found ,val))
    32                     (send-message rx `(:not-found)))))
    33              (:put
    34               (setf (cgethash (cadr msg) server)
    35                     (copy-seq (caddr msg)))
    36               (send-message rx '(:ok)))
    37              (t (return))))))
    38      :name "mini-redis-conn")
    39     (make-conn :tx tx :rx rx)))
    40 
    41 (defun find-val (conn name)
    42   (send-message
    43    (conn-tx conn)
    44    `(:get ,name))
    45   (let ((rx (receive-message (conn-rx conn))))
    46     (case (car rx)
    47       (:found
    48        (values (cdr rx) t))
    49       (:not-found
    50        (values nil nil)))))
    51 
    52 (defun (setf find-val) (val conn name)
    53   (send-message
    54    (conn-tx conn)
    55    `(:put ,name ,val))
    56   (receive-message
    57    (conn-rx conn)))
    58 
    59 (defun close-conn (conn)
    60   (send-message
    61    (conn-tx conn)
    62    `(:quit)))
    63 
    64 (defun worker (n server
    65                ready start
    66                writer-proportion names)
    67   (declare (optimize (speed 3))
    68            (single-float writer-proportion))
    69   (let ((name (elt names n))
    70         (bitmap (make-array 100
    71                             :element-type '(unsigned-byte 8)
    72                             :initial-element 0))
    73         (conn (connect-to-server server)))
    74     (dotimes (i 100)
    75       (setf (aref bitmap i)
    76             (if (< (random 1.0) writer-proportion)
    77                 1
    78                 0)))
    79     (signal-semaphore ready)
    80     (wait-on-semaphore start)
    81     (let ((position 0))
    82       (dotimes (o (the fixnum *ops*))
    83         (if (zerop (aref bitmap position))
    84             (find-val conn name)
    85             (setf (find-val conn name)
    86                   #(1)))
    87         (setf position (mod (1+ position) 100))))
    88     (close-conn conn)))
    89 
    90 (defparameter *worker-count* 8)
    91 (defparameter *writer-proportion* 0.5)
    92 (defvar *keys*
    93   (loop for n below 130 by 2
    94         collect (format nil "~r" n)))
    95 (defvar *other-keys*
    96   (loop for n from 1 below 128 by 2
    97         collect (format nil "~r" n)))
    98 (defvar *ops* 10000000)
    99 
   100 (defun run (&optional (worker-count *worker-count*)
   101               (writer-proportion *writer-proportion*)
   102               (keys *keys*))
   103   (let* ((ready (make-semaphore :name "ready-threads"))
   104          (start (make-semaphore :name "start-threads"))
   105          (server (make-server))
   106          (workers (loop for n below worker-count
   107                         collect (let ((n n))
   108                                   (make-thread
   109                                    (lambda ()
   110                                      (worker n server
   111                                              ready start
   112                                              writer-proportion
   113                                              keys)))))))
   114     (dotimes (n worker-count)
   115       (wait-on-semaphore ready))
   116     (let ((start-time (get-internal-real-time)))
   117       (signal-semaphore start worker-count)
   118       (mapc #'join-thread workers)
   119       (let* ((time (float (/ (- (get-internal-real-time) start-time)
   120                              internal-time-units-per-second)))
   121              (throughput (/ (* *ops* worker-count) time)))
   122         (format t "~&~20@a: ~$ seconds (~d transactions/second)"
   123                 "mini-redis" time (round throughput))))))
   124 
   125 (defmain ()
   126   (run 4 1.0 *keys*))