source: trunk/source/level-1/l1-events.lisp @ 13636

Last change on this file since 13636 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.4 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20(defvar *inhibit-abort* nil)
21
22;;; If any bits in the *periodic-task-mask* are set in the
23;;; ptaskstate.flags word of a periodic task, it will not be run
24(defvar *periodic-task-mask* 0)
25
26(defmethod print-object ((p periodic-task) stream)
27  (print-unreadable-object (p stream :type t :identity t)
28    (format stream "~s ~d"
29            (ptask.name p)
30            (ptaskstate.interval (ptask.state p)))))
31
32(defvar *periodic-task-lock* (make-lock))
33
34(defun find-named-periodic-task (name)
35  (dolist (task *%periodic-tasks%*)
36    (when (eq name (ptask.name task))
37      (return task))))
38
39(defun %install-periodic-task (name function interval &optional 
40                                    (flags 0)
41                                    (privatedata (%null-ptr)))
42  (with-lock-grabbed (*periodic-task-lock*)
43   (let* ((already (find-named-periodic-task name))
44          (state (if already (ptask.state already)
45                   (%istruct 'ptaskstate 0 0 0 0)))
46          (task (or already (%istruct 'periodic-task state name nil))))
47     (setf (ptask.function task) function)
48     (setf (ptaskstate.interval state) interval
49           (ptaskstate.flags state ) flags
50           (ptaskstate.privatedata state) privatedata
51           (ptaskstate.nexttick state) (+ (get-tick-count) interval))
52     (unless already (push task *%periodic-tasks%*))
53     (let* ((interval-in-seconds (/ interval (float *ticks-per-second*))))
54       (if (< interval-in-seconds *periodic-task-interval*)
55         (set-periodic-task-interval interval-in-seconds)))
56     task)))
57
58(defmacro with-periodic-task-mask ((mask) &body body)
59  (let ((thunk (gensym)))
60    `(let ((,thunk #'(lambda () ,@body)))
61       (funcall-with-periodic-task-mask ,mask ,thunk))))
62
63(defvar *periodic-task-masks* nil)
64
65; All this hair is so that multiple processes can vote on the *periodic-task-mask*
66(defun funcall-with-periodic-task-mask (mask  thunk)
67  (let* ((cell (list mask)))
68    (declare (dynamic-extent cell))
69    (flet ((logior-list (list)
70             (declare (type list list))
71             (let ((res 0))
72               (declare (fixnum res))
73               (loop
74                 (when (null list) (return res))
75                 (setq res (%ilogior res (pop list)))))))
76      (declare (inline logior-list))
77      (unwind-protect
78        (progn
79          (without-interrupts
80           (setf (cdr cell) *periodic-task-masks*
81                 *periodic-task-masks* cell)
82           (setq *periodic-task-mask* (logior-list *periodic-task-masks*))
83)
84          (funcall thunk))
85        (without-interrupts
86         (let* ((first *periodic-task-masks*)
87                (this first)
88                (last nil))
89           (declare (type cons first this last))
90           (loop
91             (when (eq this cell)
92               (if last
93                 (setf (cdr last) (cdr this))
94                 (pop first))
95               (return (setq *periodic-task-masks* first)))
96             (setq last this
97                   this (cdr this))))
98         (setq *periodic-task-mask* (logior-list *periodic-task-masks*)))))))
99
100(defparameter *invoke-debugger-hook-on-interrupt* nil)
101
102(define-condition interrupt-signal-condition (condition) ()
103  (:report "interrupt signal"))
104
105(defun force-break-in-listener (p)
106  (process-interrupt p
107                     #'(lambda ()
108                         (multiple-value-bind (vars inits old-vals) (%check-error-globals)
109                           (progv vars old-vals
110                             (mapcar (lambda (v f) (set v (funcall f))) vars inits)
111                             (let ((condition (make-condition 'interrupt-signal-condition))
112                                   (*top-error-frame* (%current-exception-frame)))
113                               (ignoring-without-interrupts
114                                 (when *invoke-debugger-hook-on-interrupt*
115                                   (let* ((hook *debugger-hook*)
116                                          (*debugger-hook* nil))
117                                     (when hook
118                                       (funcall hook condition hook))))
119                                 (%break-in-frame *top-error-frame* condition)
120                                 (clear-input *terminal-io*))))))))
121
122(defglobal *quit-interrupt-hook* nil)
123
124(defun force-async-quit (signum)
125  (when *quit-interrupt-hook*
126    (multiple-value-bind (req opt restp) (function-args *quit-interrupt-hook*)
127      (if (and (= req 0) (= opt 0) (not restp))
128        (funcall *quit-interrupt-hook*)
129        (funcall *quit-interrupt-hook* signum))))
130  ;; Exit by resignalling, as per http://www.cons.org/cracauer/sigint.html
131  (quit #'(lambda ()
132            (ff-call (%kernel-import target::kernel-import-lisp-sigexit) :signed signum)
133            ;; Shouldn't get here
134            (#__exit 143))))
135
136(defstatic *running-periodic-tasks* nil)
137
138(defun cmain ()
139  (thread-handle-interrupts))
140
141
142(defvar *select-interactive-process-hook* nil)
143
144(defun select-interactive-abort-process ()
145  (flet ((maybe-proc (proc) (and proc (process-active-p proc) proc)))
146    (or (maybe-proc (and *select-interactive-process-hook*
147                         (funcall *select-interactive-process-hook*)))
148        (maybe-proc *interactive-abort-process*)
149        (let* ((sr (input-stream-shared-resource *terminal-input*)))
150          (when sr
151            (or (maybe-proc (shared-resource-current-owner sr))
152                (maybe-proc (shared-resource-primary-owner sr))))))))
153
154(defun handle-gc-hooks ()
155  (let ((bits *gc-event-status-bits*))
156    (declare (fixnum bits))
157    (cond ((logbitp $gc-postgc-pending-bit bits)
158           (setq *gc-event-status-bits*
159                 (logand (lognot (ash 1 $gc-postgc-pending-bit))
160                         bits))
161           (let ((f *post-gc-hook*))
162             (when (functionp f) (funcall f)))))))
163
164(defconstant $user-interrupt-break 1)
165(defconstant $user-interrupt-quit 2)
166
167(defun housekeeping ()
168  (progn
169    (handle-gc-hooks)
170    (unless *inhibit-abort*
171      (let* ((id (pending-user-interrupt))
172             (kind (logand #xFF id)))
173        (cond ((eql kind $user-interrupt-quit)
174               ;; Try to use a process that has a shot at reporting any problems
175               ;; in case of bugs in user hook.
176               (let* ((proc (or (select-interactive-abort-process)
177                                *initial-process*))
178                      (signum (ash id -8)))
179                 (process-interrupt proc #'force-async-quit signum)))
180              ((eql kind $user-interrupt-break)
181               (let* ((proc (select-interactive-abort-process)))
182                 (if proc
183                   (force-break-in-listener proc)))))))
184    (flet ((maybe-run-periodic-task (task)
185             (let ((now (get-tick-count))
186                   (state (ptask.state task)))
187               (when (and (>= (- now (ptaskstate.nexttick state))
188                              0)
189                          (eql 0 (logand (the fixnum (ptaskstate.flags state))
190                                         (the fixnum *periodic-task-mask*))))
191                 (setf (ptaskstate.nexttick state)
192                       (+ now (ptaskstate.interval state)))
193                 (funcall (ptask.function task))))))
194      (let ((event-dispatch-task *event-dispatch-task*))
195        (maybe-run-periodic-task event-dispatch-task)
196        (with-lock-grabbed (*periodic-task-lock*)
197          (bitclrf $gc-allow-stack-overflows-bit *gc-event-status-bits*)
198          (unless *running-periodic-tasks*
199            (let-globally ((*running-periodic-tasks* t))
200              (dolist (task *%periodic-tasks%*)
201                (unless (eq task event-dispatch-task)
202                  (maybe-run-periodic-task task))))))))))
203
204
205(defun %remove-periodic-task (name)
206  (with-lock-grabbed (*periodic-task-lock*)
207    (let ((task (find-named-periodic-task name)))
208      (when task
209        (if (setq *%periodic-tasks%* (delete task *%periodic-tasks%*))
210          (let* ((min-ticks target::target-most-positive-fixnum))
211            (dolist (other *%periodic-tasks%*
212                     (set-periodic-task-interval (/ min-ticks (float *ticks-per-second*))))
213              (let* ((other-ticks
214                      (ptaskstate.interval (ptask.state other))))
215                (if (< other-ticks min-ticks)
216                  (setq min-ticks other-ticks)))))
217          (set-periodic-task-interval 1)))
218      task)))
219
220
221(defun auto-flush-interactive-streams ()
222  (with-lock-grabbed (*auto-flush-streams-lock*)
223    (dolist (s *auto-flush-streams*)
224      (when (open-stream-p s)
225        (if (or (typep s 'basic-stream)
226                (typep s 'buffered-io-stream-mixin))
227          (if (ioblock-outbuf-lock (stream-ioblock s t))
228            (force-output s)))
229        (force-output s)))))
230
231(defun add-auto-flush-stream (s)
232  (with-lock-grabbed (*auto-flush-streams-lock*)
233    (when (typep s 'output-stream)
234      (pushnew s *auto-flush-streams*))))
235     
236(defun remove-auto-flush-stream (s)
237  (with-lock-grabbed (*auto-flush-streams-lock*)
238    (setq *auto-flush-streams* (delete s *auto-flush-streams*))))
239
240; Is it really necessary to keep this guy in a special variable ?
241(defloadvar *event-dispatch-task* 
242  (%install-periodic-task 
243   'auto-flush-interactive-streams
244   'auto-flush-interactive-streams
245   33
246   (+ $ptask_draw-flag $ptask_event-dispatch-flag)))
247
248
249(defun event-ticks ()
250  (let ((task *event-dispatch-task*))
251    (when task (ptaskstate.interval (ptask.state task)))))
252
253(defun set-event-ticks (n)
254  (setq n (require-type n '(integer 0 32767)))   ;  Why this weird limit ?
255  (let ((task *event-dispatch-task*))
256    (when task (setf (ptaskstate.interval (ptask.state task)) n))))
257
258;; Making the *initial-process* quit will cause an exit(),
259;; though it might be nicer if all processes were shut down
260;; in an orderly manner first.  This is the not-so-nice way
261;; of quitting ...
262(defun %quit ()
263  (quit))
264
265
266
267; end of L1-events.lisp
268
Note: See TracBrowser for help on using the repository browser.