/[cmucl]/src/code/signal.lisp
ViewVC logotype

Contents of /src/code/signal.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.42 - (show annotations)
Wed Dec 22 02:12:51 2010 UTC (3 years, 3 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, HEAD
Changes since 1.41: +5 -5 lines
Merge changes from cross-sol-x86-2010-12-20 which adds support for
Solaris/x86.  There should be no functional changes for either other
x86 ports or for the sparc port.
1 ;;; -*- Package: UNIX -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/signal.lisp,v 1.42 2010/12/22 02:12:51 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;;
13 ;;; Code for handling UNIX signals.
14 ;;;
15 ;;; Written by William Lott.
16 ;;;
17
18 (in-package "UNIX")
19 (use-package "KERNEL")
20 (intl:textdomain "cmucl")
21
22 (export '(unix-signal-name unix-signal-description unix-signal-number
23 sigmask unix-sigblock unix-sigpause unix-sigsetmask unix-kill
24 unix-killpg))
25
26 (in-package "KERNEL")
27 (export '(signal-init))
28
29 (in-package "SYSTEM")
30 (export '(without-interrupts with-interrupts with-enabled-interrupts
31 enable-interrupt ignore-interrupt default-interrupt))
32
33 (in-package "UNIX")
34
35 ;;; These should probably be somewhere, but I don't know where.
36 ;;;
37 (defconstant sig_dfl 0)
38 (defconstant sig_ign 1)
39
40 (declaim (special lisp::lisp-command-line-list))
41
42
43
44 ;;;; Utilities for dealing with signal names and numbers.
45
46 (defstruct (unix-signal
47 (:constructor make-unix-signal (%name %number %description)))
48 %name ; Signal keyword
49 (%number nil :type integer) ; UNIX signal number
50 (%description nil :type string)) ; Documentation
51
52 (defvar *unix-signals* nil
53 "A list of unix signal structures.")
54
55
56 (eval-when (compile eval)
57 ;(setf *unix-signals* nil) ; pve: sigh or else...
58 (defmacro def-unix-signal (name number description)
59 (let ((symbol (intern (symbol-name name))))
60 `(progn
61 (push (make-unix-signal ,name ,number ,description) *unix-signals*)
62 ;;
63 ;; This is to make the new signal lookup stuff compatible with
64 ;; old code which expects the symbol with the same print name as
65 ;; our keywords to be a constant with a value equal to the signal
66 ;; number.
67 (defconstant ,symbol ,number ,description)
68 (export ',symbol))))
69 ) ;eval-when
70
71 (defun unix-signal-or-lose (arg)
72 (let ((signal (find arg *unix-signals*
73 :key (etypecase arg
74 (symbol #'unix-signal-%name)
75 (number #'unix-signal-%number)))))
76 (unless signal
77 (error (intl:gettext "~S is not a valid signal name or number.") arg))
78 signal))
79
80 (defun unix-signal-name (signal)
81 "Return the name of the signal as a string. Signal should be a valid
82 signal number or a keyword of the standard UNIX signal name."
83 (symbol-name (unix-signal-%name (unix-signal-or-lose signal))))
84
85 (defun unix-signal-description (signal)
86 "Return a string describing signal. Signal should be a valid signal
87 number or a keyword of the standard UNIX signal name."
88 (unix-signal-%description (unix-signal-or-lose signal)))
89
90 (defun unix-signal-number (signal)
91 "Return the number of the given signal. Signal should be a valid
92 signal number or a keyword of the standard UNIX signal name."
93 (unix-signal-%number (unix-signal-or-lose signal)))
94
95 ;;; Known signals
96 ;;;
97 (def-unix-signal :CHECK 0 "Check")
98
99 (def-unix-signal :SIGHUP 1 "Hangup")
100 (def-unix-signal :SIGINT 2 "Interrupt")
101 (def-unix-signal :SIGQUIT 3 "Quit")
102 (def-unix-signal :SIGILL 4 "Illegal instruction")
103 (def-unix-signal :SIGTRAP 5 "Trace trap")
104 (def-unix-signal :SIGIOT 6 "Iot instruction") ; Compatibility
105 (def-unix-signal :SIGABRT 6 "C abort()")
106 (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os"
107 #+(or sparc solaris) "cmucl-sparc-svr4"
108 #+bsd "cmucl-bsd-os")
109 #-linux
110 (def-unix-signal :SIGEMT 7 "Emt instruction"))
111
112
113 (def-unix-signal :SIGFPE 8 "Floating point exception")
114 (def-unix-signal :SIGKILL 9 "Kill")
115 (def-unix-signal :SIGBUS #-linux 10 #+linux 7 "Bus error")
116 (def-unix-signal :SIGSEGV 11 "Segmentation violation")
117 (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os"
118 #+(or sparc solaris) "cmucl-sparc-svr4"
119 #+bsd "cmucl-bsd-os")
120 #-linux
121 (def-unix-signal :SIGSYS 12 "Bad argument to system call"))
122
123 (def-unix-signal :SIGPIPE 13 "Write on a pipe with no one to read it")
124 (def-unix-signal :SIGALRM 14 "Alarm clock")
125 (def-unix-signal :SIGTERM 15 "Software termination signal")
126 (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os"
127 #+(or sparc solaris) "cmucl-sparc-svr4"
128 #+bsd "cmucl-bsd-os")
129 #+linux
130 (def-unix-signal :SIGSTKFLT 16 "Stack fault on coprocessor"))
131
132 (def-unix-signal :SIGURG #+svr4 21 #-(or hpux svr4 linux) 16 #+hpux 29
133 #+linux 23 "Urgent condition present on socket")
134 (def-unix-signal :SIGSTOP #-(or hpux svr4 linux) 17 #+hpux 24 #+svr4 23
135 #+linux 19 "Stop")
136 (def-unix-signal :SIGTSTP #-(or hpux svr4 linux) 18 #+hpux 25 #+svr4 24
137 #+linux 20 "Stop signal generated from keyboard")
138 (def-unix-signal :SIGCONT #-(or hpux svr4 linux) 19 #+hpux 26 #+svr4 25
139 #+linux 18 "Continue after stop")
140 (def-unix-signal :SIGCHLD #-(or linux hpux svr4) 20
141 #+(or hpux svr4) 18 #+linux 17 "Child status has changed")
142 (def-unix-signal :SIGTTIN #-(or hpux svr4) 21 #+hpux 27 #+svr4 26
143 "Background read attempted from control terminal")
144 (def-unix-signal :SIGTTOU #-(or hpux svr4) 22 #+hpux 28 #+svr4 27
145 "Background write attempted to control terminal")
146 (def-unix-signal :SIGIO #-(or svr4 hpux irix linux) 23 #+(or svr4 hpux irix) 22
147 #+linux 29
148 "I/O is possible on a descriptor")
149 #-hpux
150 (def-unix-signal :SIGXCPU #-svr4 24 #+svr4 30 "Cpu time limit exceeded")
151 #-hpux
152 (def-unix-signal :SIGXFSZ #-svr4 25 #+svr4 31 "File size limit exceeded")
153 (def-unix-signal :SIGVTALRM #-(or hpux svr4) 26 #+hpux 20 #+svr4 28
154 "Virtual time alarm")
155 (def-unix-signal :SIGPROF #-(or hpux svr4 linux) 27 #+hpux 21 #+svr4 29
156 #+linux 27 "Profiling timer alarm")
157 (def-unix-signal :SIGWINCH #-(or hpux svr4) 28 #+hpux 23 #+svr4 20
158 "Window size change")
159 (def-unix-signal :SIGUSR1 #-(or hpux svr4 linux) 30 #+(or hpux svr4) 16
160 #+linux 10 "User defined signal 1")
161 (def-unix-signal :SIGUSR2 #-(or hpux svr4 linux) 31 #+(or hpux svr4) 17
162 #+linux 12 "User defined signal 2")
163
164 ;;; SVR4 (or Solaris?) specific signals
165 (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os"
166 #+(or sparc solaris) "cmucl-sparc-svr4"
167 #+bsd "cmucl-bsd-os")
168 #+svr4
169 (def-unix-signal :SIGWAITING 32 "Process's lwps are blocked"))
170
171 ;;; SIGMASK -- Public
172 ;;;
173 (defmacro sigmask (&rest signals)
174 "Returns a mask given a set of signals."
175 (apply #'logior
176 (mapcar #'(lambda (signal)
177 (ash 1 (1- (unix-signal-number signal))))
178 signals)))
179
180
181 ;;;; System calls that deal with signals.
182
183 (declaim (inline real-unix-kill))
184
185 (alien:def-alien-routine ("kill" real-unix-kill) c-call:int
186 (pid c-call:int)
187 (signal c-call:int))
188
189 (defun unix-kill (pid signal)
190 "Unix-kill sends the signal signal to the process with process
191 id pid. Signal should be a valid signal number or a keyword of the
192 standard UNIX signal name."
193 (if (minusp (real-unix-kill pid (unix-signal-number signal)))
194 (values nil (unix-errno))
195 t))
196
197 (declaim (inline real-unix-killpg))
198
199 (alien:def-alien-routine ("killpg" real-unix-killpg) c-call:int
200 (pgrp c-call:int)
201 (signal c-call:int))
202
203 (defun unix-killpg (pgrp signal)
204 "Unix-killpg sends the signal signal to the all the process in process
205 group PGRP. Signal should be a valid signal number or a keyword of
206 the standard UNIX signal name."
207 (if (minusp (real-unix-killpg pgrp (unix-signal-number signal)))
208 (values nil (unix-errno))
209 t))
210
211 (alien:def-alien-routine ("sigblock" unix-sigblock) c-call:unsigned-long
212 "Unix-sigblock cause the signals specified in mask to be
213 added to the set of signals currently being blocked from
214 delivery. The macro sigmask is provided to create masks."
215 (mask c-call:unsigned-long))
216
217
218 (alien:def-alien-routine ("sigpause" unix-sigpause) c-call:void
219 "Unix-sigpause sets the set of masked signals to its argument
220 and then waits for a signal to arrive, restoring the previous
221 mask upon its return."
222 (mask c-call:unsigned-long))
223
224
225 (alien:def-alien-routine ("sigsetmask" unix-sigsetmask) c-call:unsigned-long
226 "Unix-sigsetmask sets the current set of masked signals (those
227 being blocked from delivery) to the argument. The macro sigmask
228 can be used to create the mask. The previous value of the signal
229 mask is returned."
230 (mask c-call:unsigned-long))
231
232
233
234 ;;;; C routines that actually do all the work of establishing signal handlers.
235
236 (alien:def-alien-routine ("install_handler" install-handler)
237 c-call:unsigned-long
238 (signal c-call:int)
239 (handler c-call:unsigned-long))
240
241
242
243 ;;;; Interface to enabling and disabling signal handlers.
244
245 (defun enable-interrupt (signal handler)
246 (declare (type (or function (member :default :ignore)) handler))
247 (without-gcing
248 (let ((result (install-handler (unix-signal-number signal)
249 (case handler
250 (:default sig_dfl)
251 (:ignore sig_ign)
252 (t
253 (kernel:get-lisp-obj-address handler))))))
254 (cond ((= result sig_dfl) :default)
255 ((= result sig_ign) :ignore)
256 (t (the function (kernel:make-lisp-obj result)))))))
257
258 (defun default-interrupt (signal)
259 (enable-interrupt signal :default))
260
261 (defun ignore-interrupt (signal)
262 (enable-interrupt signal :ignore))
263
264
265
266 ;;;; Default LISP signal handlers.
267
268 ;;; Most of these just call ERROR to report the presence of the signal.
269
270 (defmacro define-signal-handler (name what &optional (function 'error))
271 `(defun ,name (signal code scp)
272 (declare (ignore signal code)
273 (type system-area-pointer scp)
274 ;; The debug quality ensures that the function call doesn't
275 ;; get tail-call-eliminated, thus confusing the debugger.
276 (optimize (inhibit-warnings 3) (debug 3)))
277 (system:without-hemlock
278 (,function ,(concatenate 'simple-string what " at #x~x.")
279 (with-alien ((scp (* sigcontext) scp))
280 (sap-int (vm:sigcontext-program-counter scp)))))))
281
282 (define-signal-handler sigint-handler "Interrupted" break)
283 (define-signal-handler sigill-handler "Illegal Instruction")
284 (define-signal-handler sigtrap-handler "Breakpoint/Trap")
285 (define-signal-handler sigabrt-handler "SIGABRT")
286 #-linux
287 (define-signal-handler sigemt-handler "SIGEMT")
288 (define-signal-handler sigbus-handler "Bus Error")
289 (define-signal-handler sigsegv-handler "Segmentation Violation")
290 #-linux
291 (define-signal-handler sigsys-handler "Bad Argument to a System Call")
292 (define-signal-handler sigpipe-handler "SIGPIPE")
293 (define-signal-handler sigalrm-handler "SIGALRM")
294
295 (defun sigquit-handler (signal code scp)
296 (declare (ignore signal code scp))
297 (throw 'lisp::top-level-catcher nil))
298
299 (defun signal-init ()
300 "Enable all the default signals that Lisp knows how to deal with."
301 (unless (member "-monitor" lisp::lisp-command-line-list :test #'string=)
302 (enable-interrupt :sigint #'sigint-handler))
303 (enable-interrupt :sigquit #'sigquit-handler)
304 (enable-interrupt :sigill #'sigill-handler)
305 (enable-interrupt :sigtrap #'sigtrap-handler)
306 (enable-interrupt :sigabrt #'sigabrt-handler)
307 #-linux
308 (enable-interrupt :sigemt #'sigemt-handler)
309 (enable-interrupt :sigfpe #'vm:sigfpe-handler)
310 (enable-interrupt :sigbus #'sigbus-handler)
311 (enable-interrupt :sigsegv #'sigsegv-handler)
312 #-linux
313 (enable-interrupt :sigsys #'sigsys-handler)
314 (enable-interrupt :sigpipe #'sigpipe-handler)
315 (enable-interrupt :sigalrm #'sigalrm-handler)
316 nil)
317
318
319
320 ;;;; Macros for dynamically enabling and disabling signal handling.
321
322 ;;; Notes on how the without-interrupts/with-interrupts stuff works.
323 ;;;
324 ;;; Before invoking the supplied handler for any of the signals that can be
325 ;;; blocked, the C interrupt support code checks to see if *interrupts-enabled*
326 ;;; has been bound to NIL. If so, it saves the signal number and the value of
327 ;;; the signal mask (from the sigcontext), sets the signal mask to block all
328 ;;; blockable signals, sets *interrupt-pending* and returns without handling
329 ;;; the signal.
330 ;;;
331 ;;; When we drop out the without interrupts, we check to see if
332 ;;; *interrupt-pending* has been set. If so, we call do-pending-interrupt,
333 ;;; which generates a SIGTRAP. The C code invokes the handler for the saved
334 ;;; signal instead of the SIGTRAP after replacing the signal mask in the
335 ;;; sigcontext with the saved value. When that hander returns, the original
336 ;;; signal mask is installed, allowing any other pending signals to be handled.
337 ;;;
338 ;;; This means that the cost of without-interrupts is just a special binding in
339 ;;; the case when no signals are delivered (the normal case). It's only when
340 ;;; a signal is actually delivered that we use any system calls, and by then
341 ;;; the cost of the extra system calls are lost in the noise when compared
342 ;;; with the cost of delivering the signal in the first place.
343 ;;;
344
345 ;;; DO-PENDING-INTERRUPT -- internal
346 ;;;
347 ;;; Magically converted by the compiler into a break instruction.
348 ;;;
349 (defun do-pending-interrupt ()
350 (do-pending-interrupt))
351
352 #-gengc (progn
353
354 (defvar *interrupts-enabled* t)
355 (defvar *interrupt-pending* nil)
356
357 ;;; WITHOUT-INTERRUPTS -- puiblic
358 ;;;
359 (defmacro without-interrupts (&body body)
360 "Execute BODY in a context impervious to interrupts."
361 (let ((name (gensym)))
362 `(flet ((,name () ,@body))
363 (if *interrupts-enabled*
364 (unwind-protect
365 (let ((*interrupts-enabled* nil))
366 (,name))
367 (when *interrupt-pending*
368 (do-pending-interrupt)))
369 (,name)))))
370
371 ;;; WITH-INTERRUPTS -- puiblic
372 ;;;
373 (defmacro with-interrupts (&body body)
374 "Allow interrupts while executing BODY. As interrupts are normally allowed,
375 this is only useful inside a WITHOUT-INTERRUPTS."
376 (let ((name (gensym)))
377 `(flet ((,name () ,@body))
378 (if *interrupts-enabled*
379 (,name)
380 (let ((*interrupts-enabled* t))
381 (when *interrupt-pending*
382 (do-pending-interrupt))
383 (,name))))))
384
385 ); #-gengc progn
386
387 ;;; On the GENGC system, we have to do it slightly differently because of the
388 ;;; existance of threads. Each thread has a suspends_disabled_count in its
389 ;;; mutator structure. When this value is other then zero, the low level stuff
390 ;;; will not suspend the thread, but will instead set the suspend_pending flag
391 ;;; (also in the mutator). So when we finish the without-interrupts, we just
392 ;;; check the suspend_pending flag and trigger a do-pending-interrupt if
393 ;;; necessary.
394
395 #+gengc
396 (defmacro without-interrupts (&body body)
397 `(unwind-protect
398 (progn
399 (locally
400 (declare (optimize (speed 3) (safety 0)))
401 (incf (kernel:mutator-interrupts-disabled-count)))
402 ,@body)
403 (locally
404 (declare (optimize (speed 3) (safety 0)))
405 (when (and (zerop (decf (kernel:mutator-interrupts-disabled-count)))
406 (not (zerop (kernel:mutator-interrupt-pending))))
407 (do-pending-interrupt)))))
408
409
410 ;;;; WITH-ENABLED-INTERRUPTS
411
412 (defmacro with-enabled-interrupts (interrupt-list &body body)
413 "With-enabled-interrupts ({(interrupt function)}*) {form}*
414 Establish function as a handler for the Unix signal interrupt which
415 should be a number between 1 and 31 inclusive."
416 (let ((il (gensym))
417 (it (gensym)))
418 `(let ((,il NIL))
419 (unwind-protect
420 (progn
421 ,@(do* ((item interrupt-list (cdr item))
422 (intr (caar item) (caar item))
423 (ifcn (cadar item) (cadar item))
424 (forms NIL))
425 ((null item) (nreverse forms))
426 (when (symbolp intr)
427 (setq intr (symbol-value intr)))
428 (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
429 forms))
430 ,@body)
431 (dolist (,it (nreverse ,il))
432 (enable-interrupt (car ,it) (cadr ,it)))))))
433

  ViewVC Help
Powered by ViewVC 1.1.5