source: release/1.3/source/level-1/l1-events.lisp @ 11814

Last change on this file since 11814 was 11814, checked in by rme, 11 years ago

Merge trunk changes r11790-r11794, r11796, r11801, r11803

(GC fixes, additional x8632 vinsns, easygui enhancements, x8632 callback fix)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.7 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(defun force-break-in-listener (p)
102  (process-interrupt p
103                     #'(lambda ()
104                         (let* ((condition (condition-arg "interrupt signal" nil 'simple-condition)))
105                           (ignoring-without-interrupts
106                            (when *invoke-debugger-hook-on-interrupt*
107                              (let* ((hook *debugger-hook*)
108                                     (*debugger-hook* nil))
109                                (when hook
110                                  (funcall hook condition hook))))
111                            (%break-in-frame
112                             #+ppc-target *fake-stack-frames*
113                             #+x86-target (or (let* ((xcf (%current-xcf)))
114                                                (if xcf
115                                                  (%%frame-backlink xcf)))
116                                              (%get-frame-ptr))
117                             condition)
118                            (clear-input *terminal-io*))))))
119
120(defglobal *quit-interrupt-hook* nil)
121
122(defun force-async-quit ()
123  (when *quit-interrupt-hook*
124    (funcall *quit-interrupt-hook*))
125  (quit 143))
126
127(defstatic *running-periodic-tasks* nil)
128
129(defun cmain ()
130  (thread-handle-interrupts))
131
132(defun select-interactive-abort-process (&aux proc)
133  (or (and (setq proc *interactive-abort-process*)
134           (process-active-p proc)
135           proc)
136      (let* ((sr (input-stream-shared-resource *terminal-input*)))
137        (when sr
138          (or (and (setq proc (shared-resource-current-owner sr))
139                   (process-active-p proc)
140                   proc)
141              (and (setq proc (shared-resource-primary-owner sr))
142                   (process-active-p proc)
143                   proc))))))
144
145(defun handle-gc-hooks ()
146  (let ((bits *gc-event-status-bits*))
147    (declare (fixnum bits))
148    (cond ((logbitp $gc-postgc-pending-bit bits)
149           (setq *gc-event-status-bits*
150                 (logand (lognot (ash 1 $gc-postgc-pending-bit))
151                         bits))
152           (let ((f *post-gc-hook*))
153             (when (functionp f) (funcall f)))))))
154
155(defconstant $user-interrupt-break 1)
156(defconstant $user-interrupt-quit 2)
157
158(defun housekeeping ()
159  (progn
160    (handle-gc-hooks)
161    (unless *inhibit-abort*
162      (let ((id (pending-user-interrupt)))
163        (cond ((eql id $user-interrupt-quit)
164               ;; Doesn't matter where it happens, but try to use a process that
165               ;; has a shot at reporting any problems in user hook.
166               (let* ((proc (or (select-interactive-abort-process)
167                                *initial-process*)))
168                 (process-interrupt proc #'force-async-quit)))
169              ((eql id $user-interrupt-break)
170               (let* ((proc (select-interactive-abort-process)))
171                 (if proc
172                   (force-break-in-listener proc)))))))
173    (flet ((maybe-run-periodic-task (task)
174             (let ((now (get-tick-count))
175                   (state (ptask.state task)))
176               (when (and (>= (- now (ptaskstate.nexttick state))
177                              0)
178                          (eql 0 (logand (the fixnum (ptaskstate.flags state))
179                                         (the fixnum *periodic-task-mask*))))
180                 (setf (ptaskstate.nexttick state)
181                       (+ now (ptaskstate.interval state)))
182                 (funcall (ptask.function task))))))
183      (let ((event-dispatch-task *event-dispatch-task*))
184        (maybe-run-periodic-task event-dispatch-task)
185        (with-lock-grabbed (*periodic-task-lock*)
186          (bitclrf $gc-allow-stack-overflows-bit *gc-event-status-bits*)
187          (unless *running-periodic-tasks*
188            (let-globally ((*running-periodic-tasks* t))
189              (dolist (task *%periodic-tasks%*)
190                (unless (eq task event-dispatch-task)
191                  (maybe-run-periodic-task task))))))))))
192
193
194(defun %remove-periodic-task (name)
195  (with-lock-grabbed (*periodic-task-lock*)
196    (let ((task (find-named-periodic-task name)))
197      (when task
198        (if (setq *%periodic-tasks%* (delete task *%periodic-tasks%*))
199          (let* ((min-ticks target::target-most-positive-fixnum))
200            (dolist (other *%periodic-tasks%*
201                     (set-periodic-task-interval (/ min-ticks (float *ticks-per-second*))))
202              (let* ((other-ticks
203                      (ptaskstate.interval (ptask.state other))))
204                (if (< other-ticks min-ticks)
205                  (setq min-ticks other-ticks)))))
206          (set-periodic-task-interval 1)))
207      task)))
208
209
210(defun auto-flush-interactive-streams ()
211  (with-lock-grabbed (*auto-flush-streams-lock*)
212    (dolist (s *auto-flush-streams*)
213      (when (open-stream-p s)
214        (if (or (typep s 'basic-stream)
215                (typep s 'buffered-io-stream-mixin))
216          (if (ioblock-outbuf-lock (stream-ioblock s t))
217            (force-output s)))
218        (force-output s)))))
219
220(defun add-auto-flush-stream (s)
221  (with-lock-grabbed (*auto-flush-streams-lock*)
222    (when (typep s 'output-stream)
223      (pushnew s *auto-flush-streams*))))
224     
225(defun remove-auto-flush-stream (s)
226  (with-lock-grabbed (*auto-flush-streams-lock*)
227    (setq *auto-flush-streams* (delete s *auto-flush-streams*))))
228
229; Is it really necessary to keep this guy in a special variable ?
230(defloadvar *event-dispatch-task* 
231  (%install-periodic-task 
232   'auto-flush-interactive-streams
233   'auto-flush-interactive-streams
234   33
235   (+ $ptask_draw-flag $ptask_event-dispatch-flag)))
236
237
238(defun event-ticks ()
239  (let ((task *event-dispatch-task*))
240    (when task (ptaskstate.interval (ptask.state task)))))
241
242(defun set-event-ticks (n)
243  (setq n (require-type n '(integer 0 32767)))   ;  Why this weird limit ?
244  (let ((task *event-dispatch-task*))
245    (when task (setf (ptaskstate.interval (ptask.state task)) n))))
246
247;; Making the *initial-process* quit will cause an exit(),
248;; though it might be nicer if all processes were shut down
249;; in an orderly manner first.  This is the not-so-nice way
250;; of quitting ...
251(defun %quit ()
252  (quit))
253
254
255
256; end of L1-events.lisp
257
Note: See TracBrowser for help on using the repository browser.