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

Last change on this file since 12222 was 12222, checked in by gz, 10 years ago

Merge r11499: make the signum arg to *quit-interrupt-hook* optional

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
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(defun force-break-in-listener (p)
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                               (ignoring-without-interrupts
112                                 (when *invoke-debugger-hook-on-interrupt*
113                                   (let* ((hook *debugger-hook*)
114                                          (*debugger-hook* nil))
115                                     (when hook
116                                       (funcall hook condition hook))))
117                                 (%break-in-frame
118                                  #+ppc-target *fake-stack-frames*
119                                  #+x86-target (or (let* ((xcf (%current-xcf)))
120                                                     (if xcf
121                                                       (%%frame-backlink xcf)))
122                                                   (%get-frame-ptr))
123                                  condition)
124                                 (clear-input *terminal-io*))))))))
125
126(defglobal *quit-interrupt-hook* nil)
127
128(defun force-async-quit (signum)
129  (when *quit-interrupt-hook*
130    (multiple-value-bind (req opt restp) (function-args *quit-interrupt-hook*)
131      (if (and (= req 0) (= opt 0) (not restp))
132        (funcall *quit-interrupt-hook*)
133        (funcall *quit-interrupt-hook* signum))))
134  ;; Exit by resignalling, as per http://www.cons.org/cracauer/sigint.html
135  (quit #'(lambda ()
136            (ff-call (%kernel-import target::kernel-import-lisp-sigexit) :signed signum)
137            ;; Shouldn't get here
138            (#__exit 143))))
139
140(defstatic *running-periodic-tasks* nil)
141
142(defun cmain ()
143  (thread-handle-interrupts))
144
145(defun select-interactive-abort-process (&aux proc)
146  (or (and (setq proc *interactive-abort-process*)
147           (process-active-p proc)
148           proc)
149      (let* ((sr (input-stream-shared-resource *terminal-input*)))
150        (when sr
151          (or (and (setq proc (shared-resource-current-owner sr))
152                   (process-active-p proc)
153                   proc)
154              (and (setq proc (shared-resource-primary-owner sr))
155                   (process-active-p proc)
156                   proc))))))
157
158(defun handle-gc-hooks ()
159  (let ((bits *gc-event-status-bits*))
160    (declare (fixnum bits))
161    (cond ((logbitp $gc-postgc-pending-bit bits)
162           (setq *gc-event-status-bits*
163                 (logand (lognot (ash 1 $gc-postgc-pending-bit))
164                         bits))
165           (let ((f *post-gc-hook*))
166             (when (functionp f) (funcall f)))))))
167
168(defconstant $user-interrupt-break 1)
169(defconstant $user-interrupt-quit 2)
170
171(defun housekeeping ()
172  (progn
173    (handle-gc-hooks)
174    (unless *inhibit-abort*
175      (let* ((id (pending-user-interrupt))
176             (kind (logand #xFF id)))
177        (cond ((eql kind $user-interrupt-quit)
178               ;; Try to use a process that has a shot at reporting any problems
179               ;; in case of bugs in user hook.
180               (let* ((proc (or (select-interactive-abort-process)
181                                *initial-process*))
182                      (signum (ash id -8)))
183                 (process-interrupt proc #'force-async-quit signum)))
184              ((eql kind $user-interrupt-break)
185               (let* ((proc (select-interactive-abort-process)))
186                 (if proc
187                   (force-break-in-listener proc)))))))
188    (flet ((maybe-run-periodic-task (task)
189             (let ((now (get-tick-count))
190                   (state (ptask.state task)))
191               (when (and (>= (- now (ptaskstate.nexttick state))
192                              0)
193                          (eql 0 (logand (the fixnum (ptaskstate.flags state))
194                                         (the fixnum *periodic-task-mask*))))
195                 (setf (ptaskstate.nexttick state)
196                       (+ now (ptaskstate.interval state)))
197                 (funcall (ptask.function task))))))
198      (let ((event-dispatch-task *event-dispatch-task*))
199        (maybe-run-periodic-task event-dispatch-task)
200        (with-lock-grabbed (*periodic-task-lock*)
201          (bitclrf $gc-allow-stack-overflows-bit *gc-event-status-bits*)
202          (unless *running-periodic-tasks*
203            (let-globally ((*running-periodic-tasks* t))
204              (dolist (task *%periodic-tasks%*)
205                (unless (eq task event-dispatch-task)
206                  (maybe-run-periodic-task task))))))))))
207
208
209(defun %remove-periodic-task (name)
210  (with-lock-grabbed (*periodic-task-lock*)
211    (let ((task (find-named-periodic-task name)))
212      (when task
213        (if (setq *%periodic-tasks%* (delete task *%periodic-tasks%*))
214          (let* ((min-ticks target::target-most-positive-fixnum))
215            (dolist (other *%periodic-tasks%*
216                     (set-periodic-task-interval (/ min-ticks (float *ticks-per-second*))))
217              (let* ((other-ticks
218                      (ptaskstate.interval (ptask.state other))))
219                (if (< other-ticks min-ticks)
220                  (setq min-ticks other-ticks)))))
221          (set-periodic-task-interval 1)))
222      task)))
223
224
225(defun auto-flush-interactive-streams ()
226  (with-lock-grabbed (*auto-flush-streams-lock*)
227    (dolist (s *auto-flush-streams*)
228      (when (open-stream-p s)
229        (if (or (typep s 'basic-stream)
230                (typep s 'buffered-io-stream-mixin))
231          (if (ioblock-outbuf-lock (stream-ioblock s t))
232            (force-output s)))
233        (force-output s)))))
234
235(defun add-auto-flush-stream (s)
236  (with-lock-grabbed (*auto-flush-streams-lock*)
237    (when (typep s 'output-stream)
238      (pushnew s *auto-flush-streams*))))
239     
240(defun remove-auto-flush-stream (s)
241  (with-lock-grabbed (*auto-flush-streams-lock*)
242    (setq *auto-flush-streams* (delete s *auto-flush-streams*))))
243
244; Is it really necessary to keep this guy in a special variable ?
245(defloadvar *event-dispatch-task* 
246  (%install-periodic-task 
247   'auto-flush-interactive-streams
248   'auto-flush-interactive-streams
249   33
250   (+ $ptask_draw-flag $ptask_event-dispatch-flag)))
251
252
253(defun event-ticks ()
254  (let ((task *event-dispatch-task*))
255    (when task (ptaskstate.interval (ptask.state task)))))
256
257(defun set-event-ticks (n)
258  (setq n (require-type n '(integer 0 32767)))   ;  Why this weird limit ?
259  (let ((task *event-dispatch-task*))
260    (when task (setf (ptaskstate.interval (ptask.state task)) n))))
261
262;; Making the *initial-process* quit will cause an exit(),
263;; though it might be nicer if all processes were shut down
264;; in an orderly manner first.  This is the not-so-nice way
265;; of quitting ...
266(defun %quit ()
267  (quit))
268
269
270
271; end of L1-events.lisp
272
Note: See TracBrowser for help on using the repository browser.