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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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