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

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

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Add a :stream-args argument to CCL:ACCEPT-CONNECTION, for one-time initargs for the stream being created. E.g. (accept-connection listener :stream-args `(:external-format ,external-format-for-this-connection-only))

Add CCL:TEMP-PATHNAME

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods, return object for eql-specializer

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

  • 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 (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                                   (*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.