1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PXNK:TRAP.SL
4% Description:  Signal handling for 88k
5% Author:       Vicki O'Day, HP Labs/CRC
6% Created:      27-Feb-84
7% Modified:     2-Jan-85 13:13:16 (Vicki O'Day)
8% Mode:         Lisp
9% Package:
10% Status:       Experimental (Do Not Distribute)
11%
12% (c) Copyright 1984, Hewlett-Packard Company, all rights reserved.
13%
14%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
15%
16% Revisions:
17%
18% 5-Mar-90  (Winfried Neun)
19%  added and refined (x-)code-address-to-symbol
20% 10-Mar-89 (Winfried Neun)
21%  Handling for 88k (SUN4). Complete redesign.
22%  Also installed fluid *bruch* to allow gc (etc) to turn off
23%  cntrl-c interrupt detection, which destroy system.
24% 18-Aug-86 (Leigh Stoller)
25%  Reworked so that signals can be added more easily. Also added calls to
26%  external functions which set up the trap, and reinit the trap after a
27%  signal is received.
28% 2-Jan-85 10:21:47 (Vicki O'Day)
29%  Instead of just calling stderror with a message about the kind of trap,
30%  we now find the name of the routine that caused the trap and report
31%  that as well.  CODE-ADDRESS-TO-SYMBOL is used to figure out the name.
32% 27-Dec-84 10:55:56 (Vicki O'Day)
33%  Added sigunwind, to pop the signal handler's stack frame before calling
34%  stderror.  (Many thanks to Jim Davis for deciphering the contents of this
35%  frame.)
36% 17-Dec-84 10:24:41 (Vicki O'Day)
37%  Added lots more signals to catch, to try to prevent those occasional
38%  dumps out of Nmode.
39%
40%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
41
42(compiletime (flag '(build-trap-message) 'internalfunction))
43
44(fluid '(*bruch* ibmrs-sigcp ibmrs-sigaddr ibmrs-sigcode ibmrs-signumber
45         *dump ibmrs-sigpc ibmrs-dumparray*))
46
47% this is the interface for toploop
48
49(de initializeinterrupts ()
50
51	  % all signals are initiated expect for those in the following list
52          % they are ignored
53    (!*!*hu!*!*)
54    (for (from i 1 31) (do
55       (when (not (memq i '(1 15 18 19 20 21 22 28))) (sigsetup i)))))
56
57% this installs the handler
58
59(compiletime (put 'givereg2 'opencode '((*move (reg r2) (reg 1)))))
60
61(de sigsetup (signumber)
62    (wputv isasavesystem 0 (wgetv symfnc (id2int 'signalhaendler)))
63    (wputv isasavesystem 1 (givereg2)) % place of the TOK
64    (wputv isasavesystem 2 0)
65    %% old(psl_sigset signumber isasavesystem))
66	(psl_sigset signumber (wgetv symfnc (id2int 'lisprpv)))
67)
68
69% this is the 'handler'
70
71(setq ibmrs-dumparray* (gtwarray 60))
72
73(setq *bruch* 0)
74
75(compiletime (put 'putto 'opencode '((st (reg 2) (displacement (reg 1) 0)))))
76(de signal-done ()
77     (prog (handel)
78         (setq handel (wgetv symfnc (id2int 'lisprpv)))
79	 (initializeinterrupts)
80         (putto (wplus2 ibmrs-sigcp 40) handel)
81)    )            %        'Brutal' version like Cray X-MP for UNICOS
82
83(de lisprpv()
84   (prog (mess)
85    (setq *bruch* 0)
86    (smalldump)
87    (initializeinterrupts)
88    (setq mess (atsoc ibmrs-signumber '((1 . "Hangup")
89                          (2 . "Interrupt")
90                          (3 . "Quit")
91                          (4 . "Illegal Instruction")
92                          (5 . "Trace Trap")
93                          (6 . "IOT Instruction")
94                          (7 . "EMT Instruction")
95                          (8 . "Floating Point Exception")
96                          (10 . "Bus Error")
97			  (11 . "Memory Fault")
98                          (12 . "Bad Args to System Call")
99                          (13 . "Write on Pipe With None to Read")
100                          (14 . "Alarm Clock")
101                          (15 . "Software termination signal")  )))
102    (when (eq ibmrs-signumber 8)
103          (cond ((eq ibmrs-sigcode 16#c8)
104                         (setq mess '( 0 . "Floating Point divide by zero")))
105                ((eq ibmrs-sigcode 16#d4)
106                         (setq mess '( 0 . "Floating Point overflow")))
107                ((eq ibmrs-sigcode 16#cc)
108                         (setq mess '( 0 . "Floating Point underflow")))))
109    (setq mess (if mess (cdr mess)
110                  (bldmsg " Unknown signal type %d"  ibmrs-signumber)))
111    (build-trap-message mess ibmrs-sigpc)
112    (setq ibmrs-sigaddr 0 ibmrs-sigcp 0 ibmrs-sigpc 0) % for gc
113    (return (stderror))))
114
115(de smalldump()
116  (when *dump
117    (console-print-string "*** UNEXPECTED INTERRUPT ***")
118    (console-newline)
119    (console-print-string "*** System signal number: 16#")
120    (unixputn ibmrs-signumber)
121    (console-print-string " , signal code: 16#")
122    (unixputn ibmrs-sigcode)
123    (console-newline)
124    (console-print-string "*** signal pc: 16#")
125    (unixputn ibmrs-sigpc)
126    (console-print-string " , signal stack: 16#")
127    (unixputn ibmrs-sigaddr)
128    (console-print-string " , context: 16#")
129    (unixputn ibmrs-sigcp)
130    (console-newline)
131    (setq ibmrs-sigaddr 0 ibmrs-sigcp 0) % for gc
132    (console-print-string "*** Registers  0-7 : ")
133    (unixputn (wgetv ibmrs-dumparray* 0)) (console-print-string " ")
134    (unixputn (wgetv ibmrs-dumparray* 1)) (console-print-string " ")
135    (unixputn (wgetv ibmrs-dumparray* 2)) (console-print-string " ")
136    (unixputn (wgetv ibmrs-dumparray* 3)) (console-print-string " ")
137    (unixputn (wgetv ibmrs-dumparray* 4)) (console-print-string " ")
138    (unixputn (wgetv ibmrs-dumparray* 5)) (console-print-string " ")
139    (unixputn (wgetv ibmrs-dumparray* 6)) (console-print-string " ")
140    (unixputn (wgetv ibmrs-dumparray* 7)) (console-print-string " ")
141     (console-newline)
142    (console-print-string "*** Registers  8-15: ")
143    (unixputn (wgetv ibmrs-dumparray* 8)) (console-print-string " ")
144    (unixputn (wgetv ibmrs-dumparray* 9)) (console-print-string " ")
145    (unixputn (wgetv ibmrs-dumparray* 10)) (console-print-string " ")
146    (unixputn (wgetv ibmrs-dumparray* 11)) (console-print-string " ")
147    (unixputn (wgetv ibmrs-dumparray* 12)) (console-print-string " ")
148    (unixputn (wgetv ibmrs-dumparray* 13)) (console-print-string " ")
149    (unixputn (wgetv ibmrs-dumparray* 14)) (console-print-string " ")
150    (unixputn (wgetv ibmrs-dumparray* 15)) (console-print-string " ")
151     (console-newline)
152    (console-print-string "*** Registers 16-23: ")
153    (unixputn (wgetv ibmrs-dumparray* 16)) (console-print-string " ")
154    (unixputn (wgetv ibmrs-dumparray* 17)) (console-print-string " ")
155    (unixputn (wgetv ibmrs-dumparray* 18)) (console-print-string " ")
156    (unixputn (wgetv ibmrs-dumparray* 19)) (console-print-string " ")
157    (unixputn (wgetv ibmrs-dumparray* 20)) (console-print-string " ")
158    (unixputn (wgetv ibmrs-dumparray* 21)) (console-print-string " ")
159    (unixputn (wgetv ibmrs-dumparray* 22)) (console-print-string " ")
160    (unixputn (wgetv ibmrs-dumparray* 23)) (console-print-string " ")
161     (console-newline)
162    (console-print-string "*** Registers 24-31: ")
163    (unixputn (wgetv ibmrs-dumparray* 24)) (console-print-string " ")
164    (unixputn (wgetv ibmrs-dumparray* 25)) (console-print-string " ")
165    (unixputn (wgetv ibmrs-dumparray* 26)) (console-print-string " ")
166    (unixputn (wgetv ibmrs-dumparray* 27)) (console-print-string " ")
167    (unixputn (wgetv ibmrs-dumparray* 28)) (console-print-string " ")
168    (unixputn (wgetv ibmrs-dumparray* 29)) (console-print-string " ")
169    (unixputn (wgetv ibmrs-dumparray* 30)) (console-print-string " ")
170    (unixputn (wgetv ibmrs-dumparray* 31)) (console-print-string " ")
171     (console-newline)
172    (console-print-string "*** Sigcontext     : ")
173    (unixputn (wgetv ibmrs-dumparray* 50)) (console-print-string " ")
174    (unixputn (wgetv ibmrs-dumparray* 51)) (console-print-string " ")
175    (unixputn (wgetv ibmrs-dumparray* 52)) (console-print-string " ")
176    (unixputn (wgetv ibmrs-dumparray* 53)) (console-print-string " ")
177    (unixputn (wgetv ibmrs-dumparray* 54)) (console-print-string " ")
178    (unixputn (wgetv ibmrs-dumparray* 55)) (console-print-string " ")
179    (unixputn (wgetv ibmrs-dumparray* 56)) (console-print-string " ")
180    (unixputn (wgetv ibmrs-dumparray* 57)) (console-print-string " ")
181     (console-newline)
182     (console-newline)
183))
184
185(compiletime (flag '(x-code-address-to-symbol) 'internalfunction))
186
187(de build-trap-message (trap-type trap-addr)
188    (let (extra-info)
189      (setf extra-info (bldmsg "%w%w" " in "
190                                 (x-code-address-to-symbol (inf trap-addr))))
191      (bldmsg "%w%w" trap-type extra-info)))
192
193(fluid '(code-address* closest-address* closest-symbol*))
194
195(de x-code-address-to-symbol (code-address*)
196  (let ((closest-symbol* ()) (closest-address* 0))
197        (mapobl #'(lambda (symbol)
198                 (when (fcodep symbol)
199                       (let ((address (inf (getfcodepointer symbol))))
200                            (when (and (ileq address code-address*)
201                                       (igreaterp address closest-address*))
202                                  (setq closest-address* address)
203                                  (setq closest-symbol* symbol))))))
204       closest-symbol*))
205
206(de code-address-to-symbol (ad) (x-code-address-to-symbol ad))
207