- Implement optimized second-resolution timer access minimizing syscalls
authorMatthew Mondor <mmondor@pulsar-zone.net>
Sat, 13 Aug 2011 07:57:43 +0000 (07:57 +0000)
committerMatthew Mondor <mmondor@pulsar-zone.net>
Sat, 13 Aug 2011 07:57:43 +0000 (07:57 +0000)
- Export various time functions
- Document exported functions

mmsoftware/cl/server/ecl-mp-server.lisp

index c616cf3..c78141e 100644 (file)
@@ -1,4 +1,4 @@
-;;; $Id: ecl-mp-server.lisp,v 1.5 2011/08/13 06:48:13 mmondor Exp $
+;;; $Id: ecl-mp-server.lisp,v 1.6 2011/08/13 07:57:43 mmondor Exp $
 
 #|
 
@@ -57,7 +57,11 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
           #:server-stat
           #:line-read
           #:address-string
-          #:address-fixnum))
+          #:address-fixnum
+          #:server-time
+          #:server-time-posix
+          #:server-time-unix
+          #:server-time-rfc))
 
 (in-package :server)
 
@@ -88,7 +92,18 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 ;;; Various utility functions
 
-(defun time-posix (&optional (ut (get-universal-time)))
+(defvar *time-lock* (mp:make-lock :name 'time-lock))
+
+(defvar *time* (mp:with-lock (*time-lock*)
+                (get-universal-time)))
+
+(defun server-time ()
+  "Returns the current universal time in seconds."
+  (let ((time (mp:with-lock (*time-lock*)
+               *time*)))
+    time))
+
+(defun server-time-posix (&optional (ut (server-time)))
   "Returns UTC time stamp.
 UT may optionally be supplied if the current time is already known."
 ; (declare (type integer ut))
@@ -98,8 +113,15 @@ UT may optionally be supplied if the current time is already known."
     (format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D~2,'0D-0000"
            year month date hour minute second)))
 
-(defun time-rfc (&optional (unix-time nil))
-  "Returns RFC time stamp."
+(defun server-time-unix (&optional (ut (server-time)))
+  "Returns Unix timestamp from Epoch.
+UT may optionally be supplied if the current time is already known."
+  (- ut 2208988800))
+
+(defun server-time-rfc (&optional (unix-time nil))
+  "Returns RFC UTC time stamp.
+UNIX-TIME may optionally be supplied if the current Unix timestamp is
+already known."
 ; (declare (type (or null integer) unix-time))
   (let ((days #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
        (months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
@@ -110,7 +132,7 @@ UT may optionally be supplied if the current time is already known."
          (second minute hour date month year day)
        (decode-universal-time (if unix-time
                                   (+ 2208988800 unix-time)
-                                  (get-universal-time))
+                                  (server-time))
                               0)
       (format nil "~A, ~2,'0D ~A ~4,'0D ~2,'0D:~2,'0D:~2,'0D GMT"
              (svref days day)
@@ -118,6 +140,8 @@ UT may optionally be supplied if the current time is already known."
              hour minute second))))
 
 (defun address-string (addr)
+  "Converts supplied ADDR 4-part integer vector to a string suitable for
+representation of an IPv4 address."
   (declare (type (simple-array t (4)) addr)
           (optimize (speed 3) (safety 0) (debug 0)))
   (format nil "~A.~A.~A.~A"
@@ -131,6 +155,8 @@ UT may optionally be supplied if the current time is already known."
          args))
 
 (defun address-fixnum (addr)
+  "Converts supplied ADDR 4-part integer vector to a FIXNUM integer
+suitable for hashing."
   (declare (optimize (speed 3) (safety 0) (debug 0))
           (type (simple-array t (4)) addr))
   (with-fixnum-reduce (logior)
@@ -180,16 +206,20 @@ UT may optionally be supplied if the current time is already known."
 (defvar *log-buffer* nil)
 
 (defun log-line (fmt &rest args)
+  "Appends FORMAT-like results to the server log, prefixed with the current
+time."
   (let ((l (if (null args)
               fmt
               (apply #'format nil fmt args))))
-    (fifo-append *log-buffer* (format nil "~A ~A" (time-posix) l)))
+    (fifo-append *log-buffer* (format nil "~A ~A" (server-time-posix) l)))
   nil)
 
 (defun log-clear ()
+  "Clears the in-memory server log."
   (fifo-clear *log-buffer*))
 
 (defun log-tail ()
+  "Writes to *STANDARD-OUTPUT* the contents of the server log."
   (loop
      for line in (fifo-head *log-buffer*)
      do
@@ -321,6 +351,9 @@ UT may optionally be supplied if the current time is already known."
 (defvar *climit* nil)
 
 (defun server-init (&optional (config (make-server-config)))
+  "Initialization function.  CONFIG supplies an object of type SERVER-CONFIG
+holding the wanted configuration.  Binds the server socket and launches
+server threads."
   (check-type config server-config)
   (setf *config* config)
   #-:SWANK
@@ -347,6 +380,7 @@ UT may optionally be supplied if the current time is already known."
   t)
 
 (defun server-cleanup ()
+  "Kills every thread and unbinds the server socket."
   (handler-case
       (progn
        (mp:process-kill *manager-thread*)
@@ -371,6 +405,14 @@ UT may optionally be supplied if the current time is already known."
 
 
 (defun server-stat ()
+  "Returns an alist with status on the server threads.
+:TOTAL - The total number of current worker threads
+:READY - The number of threads ready to serve a client
+:BUSY - The number of threads currently busy serving clients
+:DEAD - The number of tansient exiting threads
+:CONNECTIONS - The total of the recorded number of connections recorded
+    for each thread.  Note that when threads exit their number of
+    connections are lost and no longer accounted."
   (let ((threads-list *threads-list*)
        (dead 0)
        (ready 0)
@@ -492,6 +534,9 @@ UT may optionally be supplied if the current time is already known."
 ;;; Since we'd need something like setitimer(2), and that we want to
 ;;; leave the main thread free for interactive REPL and optionally SWANK,
 ;;; let's simply use a thread for the children threads pool manager.
+;;; We also use this thread to update the current time which user code
+;;; may want to use to observe timeouts, and which we use to optimize
+;;; logging.
 (defun children-manager-thread ()
   (let ((*ready-avg* 0)
        (*ready-avg-count* 0))
@@ -499,6 +544,9 @@ UT may optionally be supplied if the current time is already known."
        do
         (with-log-errors
           (sleep 1)
+          (let ((time (get-universal-time)))
+            (mp:with-lock (*time-lock*)
+              (setf *time* time)))
           (children-manager))))
   nil)
 
@@ -607,7 +655,7 @@ provided as part of the returned line string.
 If the EXTERNAL-FORMAT is UTF-8 and an invalid UTF-8 input sequence
 is encountered, invalid octets will be imported as LATIN-1 characters,
 in which case output will not preserve the original bytes.
-To obtain litteral bytes, use the LATIN-1 EXTERNAL-FORMAT."
+To obtain literal bytes, use the LATIN-1 EXTERNAL-FORMAT."
   (let ((line (make-array 512
                          :element-type 'character
                          :adjustable nil