From 40a26a4dd7f2891e78421ba465b99bb67f892856 Mon Sep 17 00:00:00 2001
From: Gabor Melis <mega@hotpop.com>
Date: Sun, 4 Sep 2005 20:14:46 +0000
Subject: [PATCH] 0.9.4.26:   * added timer/scheduler based on setitimer that
 works with threads     (interface not public, yet)   *
 with-timeout now uses said scheduler

---
 NEWS                        |    1 +
 build-order.lisp-expr       |    1 +
 src/code/target-signal.lisp |    2 +-
 src/code/timer.lisp         |  302 +++++++++++++++++++++++++++++++++++++++++++
 src/code/unix.lisp          |   24 ----
 tests/timer.impure.lisp     |  109 ++++++++++++++++
 version.lisp-expr           |    2 +-
 7 files changed, 415 insertions(+), 26 deletions(-)
 create mode 100644 src/code/timer.lisp
 create mode 100644 tests/timer.impure.lisp

diff --git a/NEWS b/NEWS
index 37f8e36..af54853 100644
--- a/NEWS
+++ b/NEWS
@@ -33,6 +33,7 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4:
     ** bug fix: interrupt handlers are now per-process, RUN-PROGRAM
        and SB-SPROF do not die with 'no handler for signal XX in
        interrupt_handle_now(..)' anymore
+    ** bug fix: WITH-TIMEOUT works with multiple running threads
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** ENSURE-GENERIC-FUNCTION should take a method class object for
        the :method-class keyword argument.
diff --git a/build-order.lisp-expr b/build-order.lisp-expr
index 9db6817..380b26a 100644
--- a/build-order.lisp-expr
+++ b/build-order.lisp-expr
@@ -277,6 +277,7 @@
 
  ("src/code/sort"  :not-host)
  ("src/code/time"  :not-host)
+ ("src/code/timer" :not-host)
  ("src/code/weak"  :not-host)
  ("src/code/final" :not-host)
 
diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index 97bc95e..4d3e40e 100644
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -121,7 +121,7 @@
 (defun sigalrm-handler (signal info context)
   (declare (ignore signal info context))
   (declare (type system-area-pointer context))
-  (cerror "Continue" 'sb!ext::timeout))
+  (sb!impl::run-expired-timers))
 
 (defun sigquit-handler (signal code context)
   (declare (ignore signal code context))
diff --git a/src/code/timer.lisp b/src/code/timer.lisp
new file mode 100644
index 0000000..a38d98e
--- /dev/null
+++ b/src/code/timer.lisp
@@ -0,0 +1,302 @@
+;;;; a timer facility based heavily on the timer package by Zach Beane
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; 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 "SB!IMPL")
+
+;;; 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 #'>=))
+  (when (< (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)))
+
+(def!method 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))))
+
+;;; timers
+
+(defstruct (timer
+             (:conc-name %timer-)
+             (:constructor %make-timer))
+  name
+  function
+  expire-time
+  repeat-interval
+  (thread nil :type (or sb!thread:thread (member t nil))))
+
+(def!method 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 sb!thread:*current-thread*))
+  (%make-timer :name name :function function :thread thread))
+
+(defun timer-name (timer)
+  (%timer-name timer))
+
+(defun timer-expired-p (timer &optional (delta 0))
+  (symbol-macrolet ((expire-time (%timer-expire-time timer))
+                    (repeat-interval (%timer-repeat-interval timer)))
+    (and (not (and repeat-interval (plusp repeat-interval)))
+         (or (null expire-time)
+             (< expire-time
+                (+ (get-internal-real-time) delta))))))
+
+;;; The scheduler
+
+(defvar *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock"))
+
+(defmacro with-scheduler-lock ((&optional) &body body)
+  ;; don't let the SIGALRM handler mess things up
+  `(sb!sys:without-interrupts
+    (sb!thread:with-mutex (*scheduler-lock*)
+      ,@body)))
+
+(defun under-scheduler-lock-p ()
+  #!-sb-thread
+  t
+  #!+sb-thread
+  (eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*)))
+
+(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-internal-real-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))
+    (when (eql 0 (priority-queue-remove *schedule* timer))
+      (setq changed-p t))
+    (when (zerop (priority-queue-insert *schedule* timer))
+      (setq changed-p t))
+    (when changed-p
+      (set-system-timer)))
+  (values))
+
+(defun schedule-timer (timer time &key repeat-interval absolute-p)
+  (with-scheduler-lock ()
+    (setf (%timer-expire-time timer) (+ (get-internal-real-time)
+                                        (delta->real
+                                         (if absolute-p
+                                             (- time (get-universal-time))
+                                             time)))
+          (%timer-repeat-interval timer) (if repeat-interval
+                                             (delta->real repeat-interval)
+                                             nil))
+    (%schedule-timer timer)))
+
+(defun unschedule-timer (timer)
+  (with-scheduler-lock ()
+    (setf (%timer-expire-time timer) nil
+          (%timer-repeat-interval timer) nil)
+    (when (eql 0 (priority-queue-remove *schedule* timer))
+      (set-system-timer)))
+  (values))
+
+(defun list-all-timers ()
+  (with-scheduler-lock ()
+    (concatenate 'list (%pqueue-contents *schedule*))))
+
+;;; Not public, but related
+
+(defun reschedule-timer (timer)
+  (with-scheduler-lock ()
+    (setf (%timer-expire-time timer) (+ (get-internal-real-time)
+                                        (%timer-repeat-interval timer)))
+    (%schedule-timer timer)))
+
+;;; Expiring timers
+
+(defun real-time->sec-and-usec(time)
+  (if (minusp time)
+      (list 0 1)
+      (multiple-value-bind (s u) (floor time internal-time-units-per-second)
+        (setf u (floor (* (/ u internal-time-units-per-second) 1000000)))
+        (if (= 0 s u)
+            ;; 0 0 means "shut down the timer" for setitimer
+            (list 0 1)
+            (list s u)))))
+
+(defun set-system-timer ()
+  (assert (under-scheduler-lock-p))
+  (let ((next-timer (peek-schedule)))
+    (if next-timer
+        (let ((delta (- (%timer-expire-time next-timer)
+                        (get-internal-real-time))))
+          (apply #'sb!unix:unix-setitimer
+                 :real 0 0 (real-time->sec-and-usec delta)))
+        (sb!unix:unix-setitimer :real 0 0 0 0))))
+
+(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)
+           (sb!thread:make-thread function))
+          (t
+           (handler-case
+               (sb!thread:interrupt-thread thread function)
+             (sb!thread:interrupt-thread-error (c)
+               (warn c)))))))
+
+(defun run-expired-timers ()
+  (unwind-protect
+       (let (timer)
+         (loop
+          (with-scheduler-lock ()
+            (setq timer (peek-schedule))
+            (unless (and timer
+                         (> (get-internal-real-time)
+                            (%timer-expire-time timer)))
+              (return-from run-expired-timers nil))
+            (assert (eq timer (priority-queue-extract-maximum *schedule*))))
+          ;; run the timer without the lock
+          (run-timer timer)))
+    (with-scheduler-lock ()
+      (set-system-timer))))
+
+(defmacro sb!ext:with-timeout (expires &body body)
+  "Execute the body, asynchronously interrupting it and signalling a
+TIMEOUT condition after at least EXPIRES seconds have passed."
+  (with-unique-names (timer)
+    `(let ((,timer (make-timer (lambda ()
+                                 (cerror "Continue" 'sb!ext::timeout)))))
+       (schedule-timer ,timer ,expires)
+       (unwind-protect
+            (progn ,@body)
+         (unschedule-timer ,timer)))))
diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index 95f8fb1..1d922ef 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -782,28 +782,6 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted."
                         (slot (slot itvo 'it-value) 'tv-usec))
                 which (alien-sap (addr itvn))(alien-sap (addr itvo))))))
 
-(defmacro sb!ext:with-timeout (expires &body body)
-  "Execute the body, interrupting it with a SIGALRM after at least
-EXPIRES seconds have passed.  Uses Unix setitimer(), restoring any
-previous timer after the body has finished executing"
-  (with-unique-names (saved-seconds saved-useconds s u)
-    `(let (- ,saved-seconds ,saved-useconds)
-      (multiple-value-setq (- - - ,saved-seconds ,saved-useconds)
-        (unix-getitimer :real))
-      (multiple-value-bind (,s ,u) (floor ,expires)
-        (setf ,u (floor (* ,u 1000000)))
-        (if (and (> ,expires 0)
-                 (or (and (zerop ,saved-seconds) (zerop ,saved-useconds))
-                     (> ,saved-seconds ,s)
-                     (and (= ,saved-seconds ,s)
-                          (> ,saved-useconds ,u))))
-            (unwind-protect
-                 (progn
-                   (unix-setitimer :real 0 0 ,s ,u)
-                   ,@body)
-              (unix-setitimer :real 0 0 ,saved-seconds ,saved-useconds))
-            (progn
-              ,@body))))))
 
 ;;; FIXME: Many Unix error code definitions were deleted from the old
 ;;; CMU CL source code here, but not in the exports of SB-UNIX. I
@@ -1026,5 +1004,3 @@ previous timer after the body has finished executing"
   `(progn
      ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits)
          collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
-
-
diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp
new file mode 100644
index 0000000..d07a7a0
--- /dev/null
+++ b/tests/timer.impure.lisp
@@ -0,0 +1,109 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package "CL-USER")
+
+(use-package :test-util)
+
+(with-test (:name (:timer :relative))
+  (let* ((has-run-p nil)
+         (timer (sb-impl::make-timer (lambda () (setq has-run-p t))
+                            :name "simple timer")))
+    (sb-impl::schedule-timer timer 0.5)
+    (sleep 0.2)
+    (assert (not has-run-p))
+    (sleep 0.5)
+    (assert has-run-p)
+    (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
+
+(with-test (:name (:timer :absolute))
+  (let* ((has-run-p nil)
+         (timer (sb-impl::make-timer (lambda () (setq has-run-p t))
+                            :name "simple timer")))
+    (sb-impl::schedule-timer timer (+ 1/2 (get-universal-time))
+                             :absolute-p t)
+    (sleep 0.2)
+    (assert (not has-run-p))
+    (sleep 0.5)
+    (assert has-run-p)
+    (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
+
+(defvar *x* nil)
+
+#+sb-thread
+(with-test (:name (:timer :other-thread))
+  (let* ((thread (sb-thread:make-thread (lambda () (let ((*x* t)) (sleep 2)))))
+         (timer (sb-impl::make-timer (lambda () (assert *x*)) :thread thread)))
+    (sb-impl::schedule-timer timer 0.1)))
+
+#+sb-thread
+(with-test (:name (:timer :new-thread))
+  (let ((*x* t)
+        (timer (sb-impl::make-timer (lambda () (assert (not *x*))) :thread t)))
+    (sb-impl::schedule-timer timer 0.1)))
+
+(with-test (:name (:timer :repeat-and-unschedule))
+  (let* ((run-count 0)
+         timer)
+    (setq timer
+          (sb-impl::make-timer (lambda ()
+                        (when (= 5 (incf run-count))
+                          (sb-impl::unschedule-timer timer)))))
+    (sb-impl::schedule-timer timer 0 :repeat-interval 0.2)
+    (assert (not (sb-impl::timer-expired-p timer 0.3)))
+    (sleep 1.3)
+    (assert (= 5 run-count))
+    (assert (sb-impl::timer-expired-p timer))
+    (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
+
+(with-test (:name (:timer :reschedule))
+  (let* ((has-run-p nil)
+         (timer (sb-impl::make-timer (lambda ()
+                              (setq has-run-p t)))))
+    (sb-impl::schedule-timer timer 0.2)
+    (sb-impl::schedule-timer timer 0.3)
+    (sleep 0.5)
+    (assert has-run-p)
+    (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
+
+(with-test (:name (:timer :stress))
+  (let ((time (1+ (get-universal-time))))
+    (loop repeat 200 do
+          (sb-impl::schedule-timer (sb-impl::make-timer (lambda ())) time
+                                   :absolute-p t))
+    (sleep 2)
+    (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
+
+(defmacro raises-timeout-p (&body body)
+  `(handler-case (progn (progn ,@body) nil)
+    (sb-ext:timeout () t)))
+
+(with-test (:name (:with-timeout :timeout))
+  (assert (raises-timeout-p
+           (sb-ext:with-timeout 0.2
+             (sleep 1)))))
+
+(with-test (:name (:with-timeout :fall-through))
+  (assert (not (raises-timeout-p
+                (sb-ext:with-timeout 0.3
+                  (sleep 0.1))))))
+
+(with-test (:name (:with-timeout :nested-timeout-smaller))
+  (assert(raises-timeout-p
+          (sb-ext:with-timeout 10
+            (sb-ext:with-timeout 0.5
+              (sleep 2))))))
+
+(with-test (:name (:with-timeout :nested-timeout-bigger))
+  (assert(raises-timeout-p
+          (sb-ext:with-timeout 0.5
+            (sb-ext:with-timeout 2
+              (sleep 2))))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 8b44167..1920ab4 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.4.25"
+"0.9.4.26"
-- 
1.7.10.4