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

Contents of /src/code/signal.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.42 - (hide 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 wlott 1.13 ;;; -*- Package: UNIX -*-
2 wlott 1.1 ;;;
3     ;;; **********************************************************************
4 ram 1.12 ;;; 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 rtoy 1.42 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/signal.lisp,v 1.42 2010/12/22 02:12:51 rtoy Exp $")
9 ram 1.12 ;;;
10 wlott 1.1 ;;; **********************************************************************
11     ;;;
12     ;;;
13     ;;; Code for handling UNIX signals.
14     ;;;
15     ;;; Written by William Lott.
16     ;;;
17    
18 wlott 1.13 (in-package "UNIX")
19     (use-package "KERNEL")
20 rtoy 1.37 (intl:textdomain "cmucl")
21    
22 wlott 1.4 (export '(unix-signal-name unix-signal-description unix-signal-number
23 wlott 1.13 sigmask unix-sigblock unix-sigpause unix-sigsetmask unix-kill
24     unix-killpg))
25 wlott 1.1
26 wlott 1.15 (in-package "KERNEL")
27     (export '(signal-init))
28 wlott 1.1
29 wlott 1.15 (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 wlott 1.4 ;;; These should probably be somewhere, but I don't know where.
36     ;;;
37     (defconstant sig_dfl 0)
38     (defconstant sig_ign 1)
39    
40 pw 1.30 (declaim (special lisp::lisp-command-line-list))
41 wlott 1.4
42 wlott 1.8
43 wlott 1.4
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 wlott 1.14 (%number nil :type integer) ; UNIX signal number
50     (%description nil :type string)) ; Documentation
51 wlott 1.4
52     (defvar *unix-signals* nil
53 rtoy 1.38 "A list of unix signal structures.")
54 wlott 1.4
55 ram 1.25
56 wlott 1.4 (eval-when (compile eval)
57 ram 1.25 ;(setf *unix-signals* nil) ; pve: sigh or else...
58 wlott 1.4 (defmacro def-unix-signal (name number description)
59 wlott 1.13 (let ((symbol (intern (symbol-name name))))
60 wlott 1.4 `(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 wlott 1.13 (defconstant ,symbol ,number ,description)
68     (export ',symbol))))
69 wlott 1.4 ) ;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 rtoy 1.39 (error (intl:gettext "~S is not a valid signal name or number.") arg))
78 wlott 1.4 signal))
79    
80     (defun unix-signal-name (signal)
81 rtoy 1.38 "Return the name of the signal as a string. Signal should be a valid
82 wlott 1.4 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 rtoy 1.38 "Return a string describing signal. Signal should be a valid signal
87 wlott 1.4 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 rtoy 1.38 "Return the number of the given signal. Signal should be a valid
92 wlott 1.4 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 ram 1.25
99 wlott 1.4 (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 pw 1.29 (def-unix-signal :SIGIOT 6 "Iot instruction") ; Compatibility
105     (def-unix-signal :SIGABRT 6 "C abort()")
106 rtoy 1.41 (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os"
107 rtoy 1.42 #+(or sparc solaris) "cmucl-sparc-svr4"
108 rtoy 1.41 #+bsd "cmucl-bsd-os")
109 ram 1.25 #-linux
110 rtoy 1.40 (def-unix-signal :SIGEMT 7 "Emt instruction"))
111    
112    
113 wlott 1.4 (def-unix-signal :SIGFPE 8 "Floating point exception")
114     (def-unix-signal :SIGKILL 9 "Kill")
115 ram 1.25 (def-unix-signal :SIGBUS #-linux 10 #+linux 7 "Bus error")
116 wlott 1.4 (def-unix-signal :SIGSEGV 11 "Segmentation violation")
117 rtoy 1.41 (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os"
118 rtoy 1.42 #+(or sparc solaris) "cmucl-sparc-svr4"
119 rtoy 1.41 #+bsd "cmucl-bsd-os")
120 ram 1.25 #-linux
121 rtoy 1.40 (def-unix-signal :SIGSYS 12 "Bad argument to system call"))
122    
123 wlott 1.4 (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 rtoy 1.41 (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os"
127 rtoy 1.42 #+(or sparc solaris) "cmucl-sparc-svr4"
128 rtoy 1.41 #+bsd "cmucl-bsd-os")
129 ram 1.25 #+linux
130 rtoy 1.40 (def-unix-signal :SIGSTKFLT 16 "Stack fault on coprocessor"))
131    
132 ram 1.25 (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 pw 1.27 (def-unix-signal :SIGCHLD #-(or linux hpux svr4) 20
141     #+(or hpux svr4) 18 #+linux 17 "Child status has changed")
142 ram 1.23 (def-unix-signal :SIGTTIN #-(or hpux svr4) 21 #+hpux 27 #+svr4 26
143 hallgren 1.19 "Background read attempted from control terminal")
144 ram 1.23 (def-unix-signal :SIGTTOU #-(or hpux svr4) 22 #+hpux 28 #+svr4 27
145 hallgren 1.19 "Background write attempted to control terminal")
146 pw 1.27 (def-unix-signal :SIGIO #-(or svr4 hpux irix linux) 23 #+(or svr4 hpux irix) 22
147 ram 1.25 #+linux 29
148 hallgren 1.22 "I/O is possible on a descriptor")
149 hallgren 1.19 #-hpux
150 ram 1.23 (def-unix-signal :SIGXCPU #-svr4 24 #+svr4 30 "Cpu time limit exceeded")
151 hallgren 1.19 #-hpux
152 ram 1.23 (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 ram 1.25 (def-unix-signal :SIGPROF #-(or hpux svr4 linux) 27 #+hpux 21 #+svr4 29
156 gerd 1.35 #+linux 27 "Profiling timer alarm")
157 ram 1.23 (def-unix-signal :SIGWINCH #-(or hpux svr4) 28 #+hpux 23 #+svr4 20
158     "Window size change")
159 ram 1.25 (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 ram 1.23
164     ;;; SVR4 (or Solaris?) specific signals
165 rtoy 1.41 (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os"
166 rtoy 1.42 #+(or sparc solaris) "cmucl-sparc-svr4"
167 rtoy 1.41 #+bsd "cmucl-bsd-os")
168 ram 1.23 #+svr4
169 rtoy 1.40 (def-unix-signal :SIGWAITING 32 "Process's lwps are blocked"))
170 ram 1.25
171 wlott 1.4 ;;; SIGMASK -- Public
172     ;;;
173     (defmacro sigmask (&rest signals)
174 rtoy 1.38 "Returns a mask given a set of signals."
175 wlott 1.4 (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 pw 1.30 (declaim (inline real-unix-kill))
184 wlott 1.4
185 wlott 1.13 (alien:def-alien-routine ("kill" real-unix-kill) c-call:int
186     (pid c-call:int)
187     (signal c-call:int))
188 wlott 1.4
189     (defun unix-kill (pid signal)
190 rtoy 1.38 "Unix-kill sends the signal signal to the process with process
191 wlott 1.4 id pid. Signal should be a valid signal number or a keyword of the
192     standard UNIX signal name."
193 pw 1.31 (if (minusp (real-unix-kill pid (unix-signal-number signal)))
194 pmai 1.36 (values nil (unix-errno))
195 pw 1.31 t))
196 wlott 1.4
197 pw 1.30 (declaim (inline real-unix-killpg))
198 wlott 1.4
199 wlott 1.13 (alien:def-alien-routine ("killpg" real-unix-killpg) c-call:int
200     (pgrp c-call:int)
201     (signal c-call:int))
202 wlott 1.4
203     (defun unix-killpg (pgrp signal)
204 rtoy 1.38 "Unix-killpg sends the signal signal to the all the process in process
205 wlott 1.4 group PGRP. Signal should be a valid signal number or a keyword of
206     the standard UNIX signal name."
207 pw 1.31 (if (minusp (real-unix-killpg pgrp (unix-signal-number signal)))
208 pmai 1.36 (values nil (unix-errno))
209 pw 1.31 t))
210 wlott 1.4
211 wlott 1.13 (alien:def-alien-routine ("sigblock" unix-sigblock) c-call:unsigned-long
212 rtoy 1.38 "Unix-sigblock cause the signals specified in mask to be
213 wlott 1.4 added to the set of signals currently being blocked from
214     delivery. The macro sigmask is provided to create masks."
215 wlott 1.13 (mask c-call:unsigned-long))
216 wlott 1.4
217    
218 wlott 1.13 (alien:def-alien-routine ("sigpause" unix-sigpause) c-call:void
219 rtoy 1.38 "Unix-sigpause sets the set of masked signals to its argument
220 wlott 1.4 and then waits for a signal to arrive, restoring the previous
221     mask upon its return."
222 wlott 1.13 (mask c-call:unsigned-long))
223 wlott 1.4
224    
225 wlott 1.13 (alien:def-alien-routine ("sigsetmask" unix-sigsetmask) c-call:unsigned-long
226 rtoy 1.38 "Unix-sigsetmask sets the current set of masked signals (those
227 pw 1.26 being blocked from delivery) to the argument. The macro sigmask
228 wlott 1.4 can be used to create the mask. The previous value of the signal
229     mask is returned."
230 wlott 1.13 (mask c-call:unsigned-long))
231 wlott 1.4
232    
233    
234     ;;;; C routines that actually do all the work of establishing signal handlers.
235    
236 wlott 1.13 (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 wlott 1.1
241 wlott 1.2
242 wlott 1.4
243     ;;;; Interface to enabling and disabling signal handlers.
244    
245     (defun enable-interrupt (signal handler)
246 wlott 1.5 (declare (type (or function (member :default :ignore)) handler))
247 wlott 1.4 (without-gcing
248 wlott 1.5 (let ((result (install-handler (unix-signal-number signal)
249     (case handler
250     (:default sig_dfl)
251     (:ignore sig_ign)
252 wlott 1.13 (t
253     (kernel:get-lisp-obj-address handler))))))
254 wlott 1.5 (cond ((= result sig_dfl) :default)
255     ((= result sig_ign) :ignore)
256 wlott 1.13 (t (the function (kernel:make-lisp-obj result)))))))
257 wlott 1.4
258     (defun default-interrupt (signal)
259 wlott 1.11 (enable-interrupt signal :default))
260 wlott 1.4
261     (defun ignore-interrupt (signal)
262 wlott 1.11 (enable-interrupt signal :ignore))
263 wlott 1.4
264    
265    
266     ;;;; Default LISP signal handlers.
267    
268     ;;; Most of these just call ERROR to report the presence of the signal.
269    
270 wlott 1.2 (defmacro define-signal-handler (name what &optional (function 'error))
271     `(defun ,name (signal code scp)
272 wlott 1.13 (declare (ignore signal code)
273 pw 1.32 (type system-area-pointer scp)
274 pmai 1.33 ;; 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 wlott 1.13 (system:without-hemlock
278     (,function ,(concatenate 'simple-string what " at #x~x.")
279     (with-alien ((scp (* sigcontext) scp))
280 wlott 1.17 (sap-int (vm:sigcontext-program-counter scp)))))))
281 wlott 1.2
282     (define-signal-handler sigint-handler "Interrupted" break)
283     (define-signal-handler sigill-handler "Illegal Instruction")
284 wlott 1.10 (define-signal-handler sigtrap-handler "Breakpoint/Trap")
285 pw 1.29 (define-signal-handler sigabrt-handler "SIGABRT")
286 ram 1.25 #-linux
287 wlott 1.2 (define-signal-handler sigemt-handler "SIGEMT")
288     (define-signal-handler sigbus-handler "Bus Error")
289     (define-signal-handler sigsegv-handler "Segmentation Violation")
290 ram 1.25 #-linux
291 wlott 1.2 (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 wlott 1.1 (defun signal-init ()
300 rtoy 1.38 "Enable all the default signals that Lisp knows how to deal with."
301 wlott 1.8 (unless (member "-monitor" lisp::lisp-command-line-list :test #'string=)
302     (enable-interrupt :sigint #'sigint-handler))
303 wlott 1.4 (enable-interrupt :sigquit #'sigquit-handler)
304 wlott 1.10 (enable-interrupt :sigill #'sigill-handler)
305     (enable-interrupt :sigtrap #'sigtrap-handler)
306 pw 1.29 (enable-interrupt :sigabrt #'sigabrt-handler)
307 ram 1.25 #-linux
308 wlott 1.4 (enable-interrupt :sigemt #'sigemt-handler)
309 ram 1.7 (enable-interrupt :sigfpe #'vm:sigfpe-handler)
310 wlott 1.4 (enable-interrupt :sigbus #'sigbus-handler)
311     (enable-interrupt :sigsegv #'sigsegv-handler)
312 ram 1.25 #-linux
313 wlott 1.4 (enable-interrupt :sigsys #'sigsys-handler)
314     (enable-interrupt :sigpipe #'sigpipe-handler)
315     (enable-interrupt :sigalrm #'sigalrm-handler)
316 wlott 1.1 nil)
317 wlott 1.5
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 wlott 1.18 #-gengc (progn
353    
354     (defvar *interrupts-enabled* t)
355     (defvar *interrupt-pending* nil)
356    
357 wlott 1.5 ;;; WITHOUT-INTERRUPTS -- puiblic
358     ;;;
359     (defmacro without-interrupts (&body body)
360 rtoy 1.38 "Execute BODY in a context impervious to interrupts."
361 wlott 1.5 (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 rtoy 1.38 "Allow interrupts while executing BODY. As interrupts are normally allowed,
375 wlott 1.5 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 wlott 1.18
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 wlott 1.21 (incf (kernel:mutator-interrupts-disabled-count)))
402 wlott 1.18 ,@body)
403     (locally
404     (declare (optimize (speed 3) (safety 0)))
405 wlott 1.20 (when (and (zerop (decf (kernel:mutator-interrupts-disabled-count)))
406 wlott 1.21 (not (zerop (kernel:mutator-interrupt-pending))))
407 wlott 1.18 (do-pending-interrupt)))))
408 wlott 1.15
409    
410     ;;;; WITH-ENABLED-INTERRUPTS
411    
412     (defmacro with-enabled-interrupts (interrupt-list &body body)
413 rtoy 1.38 "With-enabled-interrupts ({(interrupt function)}*) {form}*
414 ram 1.16 Establish function as a handler for the Unix signal interrupt which
415     should be a number between 1 and 31 inclusive."
416 wlott 1.15 (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 ram 1.16 (when (symbolp intr)
427     (setq intr (symbol-value intr)))
428     (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
429     forms))
430 wlott 1.15 ,@body)
431     (dolist (,it (nreverse ,il))
432 ram 1.16 (enable-interrupt (car ,it) (cadr ,it)))))))
433 wlott 1.5

  ViewVC Help
Powered by ViewVC 1.1.5