X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftimer.lisp;h=ca4ffef1545965a2e82b51a1c2032fb0274e57af;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=381e363a5293479de60360df07ac7fa730dd5217;hpb=85e71404cf7ddc58fb85cb043155a4e9896e4d3e;p=sbcl.git diff --git a/src/code/timer.lisp b/src/code/timer.lisp index 381e363..ca4ffef 100644 --- a/src/code/timer.lisp +++ b/src/code/timer.lisp @@ -111,7 +111,7 @@ (heap-extract-maximum contents :key keyfun :test #'<=)))) (defun priority-queue-insert (priority-queue new-item) - "Add NEW-ITEM to PRIOIRITY-QUEUE." + "Add NEW-ITEM to PRIORITY-QUEUE." (symbol-macrolet ((contents (%pqueue-contents priority-queue)) (keyfun (%pqueue-keyfun priority-queue))) (heap-insert contents new-item :key keyfun :test #'<=))) @@ -156,14 +156,15 @@ future versions." (defun make-timer (function &key name (thread sb!thread:*current-thread*)) #!+sb-doc - "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. When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION -and the ordering guarantees of INTERRUPT-THREAD also apply here. -FUNCTION always runs with interrupts disabled but WITH-INTERRUPTS is -allowed." + "Create a timer that runs FUNCTION when triggered. + +If a THREAD is supplied, FUNCTION is run in that thread. If THREAD is +T, a new thread is created for FUNCTION each time the timer is +triggered. If THREAD is NIL, FUNCTION is run in an unspecified thread. + +When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION and the +ordering guarantees of INTERRUPT-THREAD apply. FUNCTION runs with +interrupts disabled but WITH-INTERRUPTS is allowed." (%make-timer :name name :function function :thread thread)) (defun timer-name (timer) @@ -285,6 +286,8 @@ triggers." (setf (%timer-expire-time timer) nil (%timer-repeat-interval timer) nil) (let ((old-position (priority-queue-remove *schedule* timer))) + ;; Don't use cancel-function as the %timer-cancel-function + ;; may have changed before we got the scheduler lock. (when old-position (funcall (%timer-cancel-function timer))) (when (eql 0 old-position) @@ -312,20 +315,87 @@ triggers." (incf (%timer-expire-time timer) (%timer-repeat-interval timer)) (%schedule-timer timer)))))) +;;; setitimer is unavailable for win32, but we can emulate it when +;;; threads are available -- using win32 waitable timers. +;;; +;;; Conversely, when we want to minimize signal use on POSIX, we emulate +;;; win32 waitable timers using a timerfd-like portability layer in +;;; the runtime. + +#!+sb-wtimer +(define-alien-type wtimer + #!+win32 system-area-pointer ;HANDLE, but that's not defined yet + #!+sunos system-area-pointer ;struct os_wtimer * + #!+(or linux bsd) int) + +#!+sb-wtimer +(progn + (define-alien-routine "os_create_wtimer" wtimer) + (define-alien-routine "os_wait_for_wtimer" int (wt wtimer)) + (define-alien-routine "os_close_wtimer" void (wt wtimer)) + (define-alien-routine "os_cancel_wtimer" void (wt wtimer)) + (define-alien-routine "os_set_wtimer" void (wt wtimer) (sec int) (nsec int)) + + ;; scheduler lock already protects us + + (defvar *waitable-timer-handle* nil) + + (defvar *timer-thread* nil) + + (defun get-waitable-timer () + (assert (under-scheduler-lock-p)) + (or *waitable-timer-handle* + (prog1 + (setf *waitable-timer-handle* (os-create-wtimer)) + (setf *timer-thread* + (sb!thread:make-thread + (lambda () + (loop while + (or (zerop + (os-wait-for-wtimer *waitable-timer-handle*)) + *waitable-timer-handle*) + doing (run-expired-timers))) + :ephemeral t + :name "System timer watchdog thread"))))) + + (defun itimer-emulation-deinit () + (with-scheduler-lock () + (when *timer-thread* + (sb!thread:terminate-thread *timer-thread*) + (sb!thread:join-thread *timer-thread* :default nil)) + (when *waitable-timer-handle* + (os-close-wtimer *waitable-timer-handle*) + (setf *waitable-timer-handle* nil)))) + + (defun %clear-system-timer () + (os-cancel-wtimer (get-waitable-timer))) + + (defun %set-system-timer (sec nsec) + (os-set-wtimer (get-waitable-timer) sec nsec))) + ;;; Expiring timers -(defun real-time->sec-and-usec (time) +(defun real-time->sec-and-nsec (time) ;; KLUDGE: Always leave 0.0001 second for other stuff in order to ;; avoid starvation. - (let ((min-usec 100)) + (let ((min-nsec 100000)) (if (minusp time) - (list 0 min-usec) + (values 0 min-nsec) (multiple-value-bind (s u) (floor time internal-time-units-per-second) - (setf u (floor (* (/ u internal-time-units-per-second) 1000000))) - (if (and (= 0 s) (< u min-usec)) + (setf u (floor (* (/ u internal-time-units-per-second) + #.(expt 10 9)))) + (if (and (= 0 s) (< u min-nsec)) ;; 0 0 means "shut down the timer" for setitimer - (list 0 min-usec) - (list s u)))))) + (values 0 min-nsec) + (values s u)))))) + +#!-(or sb-wtimer win32) +(progn + (defun %set-system-timer (sec nsec) + (sb!unix:unix-setitimer :real 0 0 sec (ceiling nsec 1000))) + + (defun %clear-system-timer () + (sb!unix:unix-setitimer :real 0 0 0 0))) (defun set-system-timer () (assert (under-scheduler-lock-p)) @@ -334,9 +404,9 @@ triggers." (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)))) + (multiple-value-call #'%set-system-timer + (real-time->sec-and-nsec delta))) + (%clear-system-timer)))) (defun run-timer (timer) (let ((function (%timer-interrupt-function timer))