[Initial trivial timers library
clinton@unknownlamer.org**20081211101610] addfile ./packages.lisp
addfile ./timers-bt.lisp
addfile ./timers-sbcl.lisp
addfile ./trivial-timers.asd
hunk ./packages.lisp 1
-
+(cl:defpackage :trivial-timers
+  (:use :common-lisp)
+  (:export
+   #:timer
+   #:timer-name
+   #:timer-scheduled-p
+   
+   #:make-timer
+   #:schedule-timer
+   #:unschedule-timer
+
+   #:list-all-timers))
hunk ./timers-bt.lisp 1
+;;;; a timer facility based heavily on the timer package by Zach Beane
+;;;; ported from SBCL to merely rely upon bordeaux-threads by Clinton Ebadi
+
+;;;; This software was part of the SBCL system. 
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package :trivial-timers)
+
+;;; Heap (for the priority queue)
+
+(declaim (inline heap-parent heap-left heap-right))
+
+(defun heap-parent (i)
+  (ash i -1))
+
+(defun heap-left (i)
+  (1+ (ash i 1)))
+
+(defun heap-right (i)
+  (+ 2 (ash i 1)))
+
+(defun heapify (heap start &key (key #'identity) (test #'>=))
+  (declare (function key test))
+  (flet ((key (obj) (funcall key obj))
+         (ge (i j) (funcall test i j)))
+    (let ((l (heap-left start))
+          (r (heap-right start))
+          (size (length heap))
+          largest)
+      (setf largest (if (and (< l size)
+                             (not (ge (key (aref heap start))
+                                      (key (aref heap l)))))
+                        l
+                        start))
+      (when (and (< r size)
+                 (not (ge (key (aref heap largest))
+                          (key (aref heap r)))))
+        (setf largest r))
+      (when (/= largest start)
+        (rotatef (aref heap largest) (aref heap start))
+        (heapify heap largest :key key :test test)))
+    heap))
+
+(defun heap-insert (heap new-item &key (key #'identity) (test #'>=))
+  (declare (function key test))
+  (flet ((key (obj) (funcall key obj))
+         (ge (i j) (funcall test i j)))
+    (vector-push-extend nil heap)
+    (loop for i = (1- (length heap)) then parent-i
+          for parent-i = (heap-parent i)
+          while (and (> i 0)
+                     (not (ge (key (aref heap parent-i))
+                              (key new-item))))
+          do (setf (aref heap i) (aref heap parent-i))
+          finally (setf (aref heap i) new-item)
+          (return-from heap-insert i))))
+
+(defun heap-maximum (heap)
+  (unless (zerop (length heap))
+    (aref heap 0)))
+
+(defun heap-extract (heap i &key (key #'identity) (test #'>=))
+  (unless (> (length heap) i)
+    (error "Heap underflow"))
+  (prog1
+      (aref heap i)
+    (setf (aref heap i) (aref heap (1- (length heap))))
+    (decf (fill-pointer heap))
+    (heapify heap i :key key :test test)))
+
+(defun heap-extract-maximum (heap &key (key #'identity) (test #'>=))
+  (heap-extract heap 0 :key key :test test))
+
+;;; Priority queue
+
+(defstruct (priority-queue
+             (:conc-name %pqueue-)
+             (:constructor %make-priority-queue))
+  contents
+  keyfun)
+
+(defun make-priority-queue (&key (key #'identity) (element-type t))
+  (let ((contents (make-array 100
+                              :adjustable t
+                              :fill-pointer 0
+                              :element-type element-type)))
+    (%make-priority-queue :keyfun key
+                          :contents contents)))
+
+(defmethod print-object ((object priority-queue) stream)
+  (print-unreadable-object (object stream :type t :identity t)
+    (format stream "~[empty~:;~:*~D item~:P~]"
+            (length (%pqueue-contents object)))))
+
+(defun priority-queue-maximum (priority-queue)
+  "Return the item in PRIORITY-QUEUE with the largest key."
+  (symbol-macrolet ((contents (%pqueue-contents priority-queue)))
+    (unless (zerop (length contents))
+      (heap-maximum contents))))
+
+(defun priority-queue-extract-maximum (priority-queue)
+  "Remove and return the item in PRIORITY-QUEUE with the largest key."
+  (symbol-macrolet ((contents (%pqueue-contents priority-queue))
+                    (keyfun (%pqueue-keyfun priority-queue)))
+    (unless (zerop (length contents))
+      (heap-extract-maximum contents :key keyfun :test #'<=))))
+
+(defun priority-queue-insert (priority-queue new-item)
+  "Add NEW-ITEM to PRIOIRITY-QUEUE."
+  (symbol-macrolet ((contents (%pqueue-contents priority-queue))
+                    (keyfun (%pqueue-keyfun priority-queue)))
+    (heap-insert contents new-item :key keyfun :test #'<=)))
+
+(defun priority-queue-empty-p (priority-queue)
+  (zerop (length (%pqueue-contents priority-queue))))
+
+(defun priority-queue-remove (priority-queue item &key (test #'eq))
+  "Remove and return ITEM from PRIORITY-QUEUE."
+  (symbol-macrolet ((contents (%pqueue-contents priority-queue))
+                    (keyfun (%pqueue-keyfun priority-queue)))
+    (let ((i (position item contents :test test)))
+      (when i
+        (heap-extract contents i :key keyfun :test #'<=)
+        i))))
+
+;;; thread utility
+
+(defun make-cancellable-interruptor (function)
+  ;; return a list of two functions: one that does the same as
+  ;; FUNCTION until the other is called, from when it does nothing.
+  (let ((mutex (bt:make-lock))
+        (cancelled-p nil))
+    (list
+     #'(lambda ()
+         (bt:with-recursive-lock-held (mutex)
+           (unless cancelled-p
+             (funcall function))))
+     #'(lambda ()
+         (bt:with-recursive-lock-held (mutex)
+           (setq cancelled-p t))))))
+
+;;; timers
+
+(defstruct (timer
+             (:conc-name %timer-)
+             (:constructor %make-timer))
+  "Timer type. Do not rely on timers being structs as it may change in
+future versions."
+  name
+  function
+  expire-time
+  repeat-interval
+  (thread nil #| :type (or bt:thread (member t nil)) |#)
+  interrupt-function
+  cancel-function)
+
+(defmethod print-object ((timer timer) stream)
+  (let ((name (%timer-name timer)))
+    (if name
+        (print-unreadable-object (timer stream :type t :identity t)
+          (prin1 name stream))
+        (print-unreadable-object (timer stream :type t :identity t)
+          ;; body is empty => there is only one space between type and
+          ;; identity
+          ))))
+
+(defun make-timer (function &key name (thread (bt:current-thread)))
+  "Create a timer object that's when scheduled runs FUNCTION. If
+THREAD is a thread then that thread is to be interrupted with
+FUNCTION. If THREAD is T then a new thread is created each timer
+FUNCTION is run. If THREAD is NIL then FUNCTION can be run in any
+thread."
+  (%make-timer :name name :function function :thread thread))
+
+(defun timer-name (timer)
+  "Return the name of TIMER."
+  (%timer-name timer))
+
+(defun timer-scheduled-p (timer &key (delta 0))
+  "See if TIMER will still need to be triggered after DELTA seconds
+from now. For timers with a repeat interval it returns true."
+  (symbol-macrolet ((expire-time (%timer-expire-time timer))
+                    (repeat-interval (%timer-repeat-interval timer)))
+      (or (and repeat-interval (plusp repeat-interval))
+          (and expire-time
+               (<= (+ (get-internal-real-time) delta)
+                   expire-time)))))
+
+;;; The scheduler
+
+(defvar *scheduler-lock* (bt:make-lock "Scheduler lock"))
+(defvar *scheduler-cond* (bt:make-condition-variable))
+(defvar *scheduler-thread* nil)
+
+(defmacro with-scheduler-lock ((&optional) &body body)
+  ;; Don't let the SIGALRM handler mess things up.
+  `(bt:with-lock-held (*scheduler-lock*)
+     ,@body))
+
+(defun set-system-timer ()
+  (bt:condition-notify *scheduler-cond*))
+
+(defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
+
+(defun peek-schedule ()
+  (priority-queue-maximum *schedule*))
+
+(defun time-left (timer)
+  (- (%timer-expire-time timer) (get-universal-time)))
+
+;;; real time conversion
+
+(defun delta->real (delta)
+  (floor (* delta internal-time-units-per-second)))
+
+;;; Public interface
+
+(defun %schedule-timer (timer)
+  (let ((changed-p nil)
+        (old-position (priority-queue-remove *schedule* timer)))
+    ;; Make sure interruptors are cancelled even if this timer was
+    ;; scheduled again since our last attempt.
+    (when old-position
+      (funcall (%timer-cancel-function timer)))
+    (when (eql 0 old-position)
+      (setq changed-p t))
+    (when (zerop (priority-queue-insert *schedule* timer))
+      (setq changed-p t))
+    (setf (values (%timer-interrupt-function timer)
+                  (%timer-cancel-function timer))
+          (values-list (make-cancellable-interruptor
+                        (%timer-function timer))))
+    (when changed-p
+      (set-system-timer)))
+  (values))
+
+(defun schedule-timer (timer time &key repeat-interval absolute-p)
+  "Schedule TIMER to be triggered at TIME. If ABSOLUTE-P then TIME is
+universal time, but non-integral values are also allowed, else TIME is
+measured as the number of seconds from the current time. If
+REPEAT-INTERVAL is given, TIMER is automatically rescheduled upon
+expiry."
+  (unless *scheduler-thread*
+    (start-timers))
+  ;; CANCEL-FUNCTION may block until all interruptors finish, let's
+  ;; try to cancel without the scheduler lock first.
+  (when (%timer-cancel-function timer)
+    (funcall (%timer-cancel-function timer)))
+  (with-scheduler-lock ()
+    (setf (%timer-expire-time timer) (if absolute-p
+					 time
+					 (+ time (get-universal-time)))
+          (%timer-repeat-interval timer) repeat-interval)
+    (%schedule-timer timer)))
+
+(defun unschedule-timer (timer)
+  "Cancel TIMER. Once this function returns it is guaranteed that
+TIMER shall not be triggered again and there are no unfinished
+triggers."
+  (let ((cancel-function (%timer-cancel-function timer)))
+    (when cancel-function
+      (funcall cancel-function)))
+  (with-scheduler-lock ()
+    (setf (%timer-expire-time timer) nil
+          (%timer-repeat-interval timer) nil)
+    (let ((old-position (priority-queue-remove *schedule* timer)))
+      (when old-position
+        (funcall (%timer-cancel-function timer)))
+      (when (eql 0 old-position)
+        (set-system-timer))))
+  (values))
+
+(defun list-all-timers ()
+  "Return a list of all timers in the system."
+  (with-scheduler-lock ()
+    (concatenate 'list (%pqueue-contents *schedule*))))
+
+;;; Not public, but related
+
+(defun reschedule-timer (timer)
+  (let ((thread (%timer-thread timer)))
+    (if (and (bt:threadp thread) (not (bt:thread-alive-p thread)))
+        (unschedule-timer timer)
+        (with-scheduler-lock ()
+          (setf (%timer-expire-time timer) (+ (get-universal-time)
+                                              (%timer-repeat-interval timer)))
+          (%schedule-timer timer)))))
+
+;;; Expiring timers
+
+(defun run-timer (timer)
+  (symbol-macrolet ((function (%timer-function timer))
+                    (repeat-interval (%timer-repeat-interval timer))
+                    (thread (%timer-thread timer)))
+    (when repeat-interval
+      (reschedule-timer timer))
+    (cond ((null thread)
+           (funcall function))
+          ((eq t thread)
+           (bt:make-thread function))
+          (t (bt:interrupt-thread thread function)))))
+
+;; Main scheduler loop
+(defun run-expired-timers ()
+  (let (timer)
+    (loop
+       (with-scheduler-lock ()
+	 (setq timer (peek-schedule))
+	 (cond ((and timer
+		     (< (get-universal-time)
+			(%timer-expire-time timer)))
+		(handler-case 
+		    (bt:with-timeout ((- (%timer-expire-time timer)
+					 (get-universal-time)))
+		      (bt:condition-wait *scheduler-cond* *scheduler-lock*))
+		  (bt:timeout () nil)))
+	       (timer
+		(assert (eq timer (priority-queue-extract-maximum *schedule*)))
+		(bt:release-lock *scheduler-lock*)
+		;; run the timer without the lock
+		(run-timer timer)
+		(bt:acquire-lock *scheduler-lock*))
+	       ((not timer)
+		(bt:condition-wait *scheduler-cond* *scheduler-lock*)))))))
+
+(defun start-timers ()
+  (setf *scheduler-thread*
+	(bt:make-thread #'run-expired-timers :name "Timer Scheduler")))
+
+(defun stop-timers ()
+  (when *scheduler-thread*
+    (bt:destroy-thread *scheduler-thread*)))
hunk ./timers-sbcl.lisp 1
-
+(in-package :trivial-timers)
+
+(shadowing-import
+ '(sb-ext:timer
+   sb-ext:timer-name
+   sb-ext:timer-scheduled-p
+   
+   sb-ext:make-timer
+   sb-ext:schedule-timer
+   sb-ext:unschedule-timer
+
+   sb-ext:list-all-timers))
+
+(export '(sb-ext:timer
+	  sb-ext:timer-name
+	  sb-ext:timer-scheduled-p
+	  
+	  sb-ext:make-timer
+	  sb-ext:schedule-timer
+	  sb-ext:unschedule-timer
+	  
+	  sb-ext:list-all-timers))
hunk ./trivial-timers.asd 1
-
+(defpackage :trivial-timers.system
+  (:use :cl :asdf))
+
+(in-package :trivial-timers.system)
+
+(defsystem :trivial-timers
+  :description "Trivial timer library"
+  :author "Clinton Ebadi <clinton@unknownlamer.org>"
+  :license "public domain"
+  :components ((:file "packages")
+	       #+sbcl (:file "timers-sbcl")
+	       #-sbcl (:file "timers-bt"))
+  :serial t
+  :depends-on (#-sbcl :bordeaux-threads))