1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PXNK:TRAP.SL
4% Description:  Signal handling for Aarch64 Linux
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:       Open Source: BSD License
11%
12% (c) Copyright 1983, Hewlett-Packard Company, see the file
13%            HP_disclaimer at the root of the PSL file tree
14%
15%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
16%
17% Revisions:
18%
19% 17-Feb-89 (Chris Burdorf)
20%  Use sun3_sigset for os/4.
21% 09-Oct-87 (Leigh Stoller)
22%  Do not call build-trap-message anymore. It is too flakey to be relied
23%   on to tell the truth.
24% 31-Apr-87 (Leigh Stoller)
25%  After consult with Julian Padget, altered sigunwind to decrease the
26%   stack frame by 320 bytes instead of 98. The interrupted address is
27%   found 312 bytes into this frame.
28% 18-Aug-86 (Leigh Stoller)
29%  Reworked so that signals can be added more easily. Also added calls to
30%  external functions which set up the trap, and reinit the trap after a
31%  signal is recieved.
32% 2-Jan-85 10:21:47 (Vicki O'Day)
33%  Instead of just calling stderror with a message about the kind of trap,
34%  we now find the name of the routine that caused the trap and report
35%  that as well.  CODE-ADDRESS-TO-SYMBOL is used to figure out the name.
36% 27-Dec-84 10:55:56 (Vicki O'Day)
37%  Added sigunwind, to pop the signal handler's stack frame before calling
38%  stderror.  (Many thanks to Jim Davis for deciphering the contents of this
39%  frame.)
40% 17-Dec-84 10:24:41 (Vicki O'Day)
41%  Added lots more signals to catch, to try to prevent those occasional
42%  dumps out of Nmode.
43%
44%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
45
46(fluid '(errornumber* sigaddr* faultaddr* arith-exception-type* stack-pointer*
47	 on-altstack*      % variable to indicate that we are on an alternate signal stack
48))
49
50
51(compiletime
52 (progn
53   (setf *sigcalls* nil)
54   %
55   % Create a list of initialization code needed to set up the traps. The
56   % return value is the entry points for each signal handler.
57   % This is later flaged as a
58   %  cmacro so the returned code can be inserted directly into the lap coded
59   %  procedure 'initializeinterrupts each time it is called. The list
60   %  *sigentries is then inserted to define the entry points.
61   (de *sigsetup (signumber function handler errorstring)
62       (setf *sigcalls* (append
63             % Sigset takes a function pointer.
64             `((*move (wconst ,signumber) (reg 1))
65               (*move ,handler (reg 2))
66               (*link sun3_sigset expr 2))
67             *sigcalls*))
68       % Return the the function definition for the signal handler.
69       `(
70     (*entry ,function expr 0)
71     ,handler
72     (*alloc 0)
73
74     % restore SYMVAL and SYMFNC registers
75     (LDR (reg symval) symval_adr)
76     (LDR (reg symfnc) symfnc_adr)
77
78     % reg 3 contains a pointer to an ucontext_t structre
79     % restore lisp registers x23 (symfnc), x24 (symval), x25 (bndstkptr),
80     % x26 (bndstklowerbound), x27 (bndstkupperbound), x28 (nil)
81%     (*move (memory (reg 3) 368) (reg symfnc))
82%     (*move (memory (reg 3) 376) (reg symval))
83     (*move (memory (reg 3) 384) (reg bndstkptr))
84     (*move (memory (reg 3) 392) (reg bndstklowerbound))
85     (*move (memory (reg 3) 400) (reg bndstkupperbound))
86     (*move (memory (reg 3) 408) (reg nil))
87     (*move (memory (reg 3) 440) (fluid sigaddr*))   % instruction pointer at fault
88     (*move (memory (reg 3) 432) (fluid stack-pointer*))   % stack pointer at fault
89     (*move (wconst ,signumber) (reg 1))
90     (*move (reg 1) (fluid errornumber*))
91
92     % Reg r2 contains a pointer to a siginto_t structure
93     % for SIGILL, SIGFPE, SIGSEGV, SIGBUS, get faulting address (at offset 16 of siginfo_t structure)
94     (*move (memory (reg 2) 16) (fluid faultaddr*))
95     % for arithmetic expressions, get exception subtype: at offset 8 of siginfo_t structure
96     % there is si_code (4 byte integer) which is the FPE subtype
97     (LDRSW (reg w2) (displacement (reg 2) 8))
98     (*move (reg 2) (fluid arith-exception-type*))
99     (*move ,handler (reg 2))
100     (*link sigrelse expr 2)
101     (*move (quote ,errorstring) (reg 1))
102     (*dealloc 0)
103     (*jcall sigunwind))
104       )
105
106
107   % Return the entry point list. Defined as a cmacro.
108   (de *sigcall ()
109       *sigcalls*)
110
111   (defcmacro *sigcall)
112   (defcmacro *sigsetup)
113
114   )
115) % End of compiletime.
116
117
118(lap '(
119   % (*sigsetup 1  Huphandler  Huphandlerinstruction   "Hup")
120   (*sigsetup 2  Inthandler   IntHandlerInstruction   "Interrupt")
121   (*sigsetup 3  QuitHandler  QuitHandlerInstruction  "Quit")
122   (*sigsetup 4  IllHandler   IllHandlerInstruction   "Illegal Instruction")
123   (*sigsetup 5  Traphandler  TrapHandlerInstruction  "Trace Trap")
124   (*sigsetup 6  AbortHandler AbortHandlerInstruction "Program aborted")
125   (*sigsetup 7  Emthandler   BusHandlerInstruction   "Bus error")
126   (*sigsetup 8  FpeHandler   FpeHandlerInstruction   "Arithmetic Exception")
127%   (*sigsetup 10 Usr1handler  Usr1HandlerInstruction  "User defined signal 1")
128   (*sigsetup 11 SegHandler   SegHandlerInstruction   "Segmentation Violation")
129%   (*sigsetup 12 Usr2handler  Usr2HandlerInstruction  "User defined signal 2")
130   (*sigsetup 13 PipeHandler PipeHandlerinstruction   "Write on Pipe With Noone to Read")
131   (*sigsetup 14 AlrmHandler AlrmHandlerInstruction   "Alarm Clock")
132   (*sigsetup 15 TermHandler  TermHandlerInstruction  "Termination signal")
133%   (*sigsetup 16 STKXhandler STKXHandlerInstruction   "Stack fault")
134%   (*sigsetup 17 Childhandler ChildHandlerInstruction "Child waiting")
135%   (*sigsetup 18 Conthandler  ContHandlerInstruction  "SIGCONT received")
136%   (*sigsetup 20 Stophandler  StopHandlerInstruction  "SIGTSTP received")
137%   (*sigsetup 21 Ttinhandler  TtinHandlerInstruction  "Bg process waiting for input")
138%   (*sigsetup 22 Ttouhandler  TtouHandlerInstruction  "Bg process waiting for output")
139%   (*sigsetup 23 Urghandler   UrgHandlerInstruction   "Urgent out-of-band data")
140   (*sigsetup 24 CPUXhandler  CPUXHandlerInstruction  "CPU time limit exceeded")
141   (*sigsetup 25 FileXhandler FileXHandlerInstruction "File size limit exceeded")
142%   (*sigsetup 26 VAlrmHandler VAlrmHandlerInstruction "CPU Timer")
143%   (*sigsetup 27 ProfHandler ProfHandlerInstruction  "Profiling timer")
144%   (*sigsetup 28 WinchHandler WinchHandlerInstruction "Window size change")
145%   (*sigsetup 29 IOHandler    IOHandlerInstruction    "IO ready")
146   (*sigsetup 30 Pwrhandler   PwrHandlerInstruction   "Power failure")
147   (*sigsetup 31 Syshandler   SysHandlerInstruction   "Bad system call")
148        (*entry initializeinterrupts expr 0)
149       (*alloc 0)
150       (*sigcall)
151       (*exit 0)
152       (*entry init_symval_symfnc expr 0)
153       (ADR (reg t1) symval_adr)
154       (STR (reg symval) (indirect (reg t1)))
155       (ADR (reg t1) symfnc_adr)
156       (STR (reg symfnc) (indirect (reg t1)))
157       (RET)
158       (*entry _set-symval-symfnc expr 0)
159       (LDR (reg symval) symval_adr)
160       (LDR (reg symfnc) symfnc_adr)
161       (RET)
162       symval_adr
163       (fullword 0)
164       symfnc_adr
165       (fullword 0)
166))
167
168%% store values of symval and symfnc where the signal handler can find them
169(init_symval_symfnc)
170
171%(de initializeinterrupts (nn)
172%%       (ieee_flags (strbase (strinf "set")) (strbase (strinf "direction"))
173%%				(strbase (strinf "tozero")) 0)
174%%       (ieee_handler (strbase (strinf "set"))
175%%                  (strbase (strinf "common"))
176%%                  (symfnc (id2int 'fpehandler)))
177%%       (*freset)
178%%       (initializeinterrupts-1)
179%%       (unless (eq 17 nn) (sun3_sigset 500)) % Hack! If stated from top-loop, save
180%					       the fp environment.
181%)
182
183(lap
184 '((!*entry sigunwind expr 1)
185     % At this point, an arg is already set up in register 1 with a message
186     % describing the kind of trap.
187
188     (*alloc 1)
189     (*move (reg 1) (frame 1))
190     (*move 256 (reg nil))
191     (*mkitem (reg NIL) id-tag)	    % make sure (reg nil) contains nil
192     % if this is a terminal interrupt (errornumber* = 2) we check
193     % whether it occured within lisp code. If not, just return.
194     (*jumpnoteq (label in-lisp) (fluid errornumber*) 2)
195     (*move (quote "Terminal Interrupt") (reg 1))
196     (*call console-print-string)
197     (*call console-newline)
198     (*move (fluid sigaddr*) (reg 1))
199     (*link codeaddressp expr 1)
200     (!*jumpnoteq (label in-lisp) (reg 1) (quote nil))
201     (*move (frame 1) (reg 1))
202     (*exit 1)
203    in-lisp
204%     (*link *freset expr 0)
205     (*link initializeinterrupts expr 0) % MK
206     (*move (frame 1) (reg 2))
207     (*move (fluid errornumber*) (reg 1))
208     (*move (reg nil) (fluid on-altstack*))
209     % if the error number = 11 (segmentation violation,
210     %  set on-altstack* to t and try to check for stack overflow
211     (*jumpnoteq (label nostackoverflow) (reg 1) 11)
212     (*move (quote t) (fluid on-altstack*))
213     % if sp + 1024 >= faultaddr* >= sp - 1024, assume a stack overflow
214     (*move ($fluid faultaddr*) (reg 3))
215     (*WPlus2 (reg 3) 1024)
216     (*jumpwlessp (label nostackoverflow) (reg 3) (fluid stack-pointer*))
217     (!*WDifference (reg 3) 2048)
218     (*jumpwgreaterp (label nostackoverflow) (reg 3) (fluid stack-pointer*))
219     (*move (quote "Stack overflow") (reg 2))
220    nostackoverflow
221     (*move (wconst 0) (reg 3))
222     (*jumpnoteq (label done) (reg 1) 8)
223     (*move (fluid arith-exception-type*) (reg 3))
224     done
225     (*wplus2 (reg 1)(wconst 10000))
226     (*dealloc 1)
227     (*jcall error-trap)
228     ))
229
230%(setq errorcall* (wgetv symfnc (id2int 'errortrap)))
231
232(commentoutcode
233(lap '((*entry *freset expr 0)
234       (*alloc 0)
235       (*move 100000 (reg 5))
236     lab
237       (*move ($fluid onewordbuffer) (reg 4))
238       (*wplus2 (reg 5) -1)
239       (*jumpwgreaterp (label lab) (reg 5) 0)
240
241%       (fclex)
242%       (wait)
243       (*move ($fluid onewordbuffer) (reg 3))
244       (*move 0 (reg 2))
245       (*move (reg 2) (displacement (reg 3) 0))
246 %      (fstcw (displacement (reg 3) 0))
247 %      (wait)
248       (*move (displacement (reg 3) 0) (reg 2))
249%       (*wor (reg 2)  2#110000000000)
250       (*wand (reg 2) 2#11111111110010)
251       (*move (reg 2) (displacement (reg 3) 0))
252 %      (fldcw (displacement (reg 3) 0))
253 %      (wait)
254       (*exit 0)))
255)
256
257%% Error subtypes for arithmetic exception
258(define-constant FPE_INTDIV 1)
259(define-constant FPE_INTOVF 2)
260(define-constant FPE_FLTDIV 3)
261(define-constant FPE_FLTOVF 4)
262(define-constant FPE_FLTUND 5)
263(define-constant FPE_FLTRES 6)
264(define-constant FPE_FLTINV 7)
265(define-constant FPE_FLTSUB 8)
266
267%% convert arithmetic error subtype to error message
268(de get-fpe-errmsg (n)
269  (cond
270    ((eq n FPE_INTDIV) "Integer divide by zero")
271    ((eq n FPE_INTOVF) "Integer overflow")
272    ((eq n FPE_FLTDIV) "Floating point divide by zero")
273    ((eq n FPE_FLTOVF) "Floating point overflow")
274    ((eq n FPE_FLTUND) "Floating point underflow")
275    ((eq n FPE_FLTRES) "Floating point inexact result")
276    ((eq n FPE_FLTINV) "Floating point invalid operation")
277    ((eq n FPE_FLTSUB) "Subscript out of range")
278    (t "Arithmetic exception")))
279
280(de error-trap (errornumber errorstring arithsubtype)
281  (error errornumber
282   (build-trap-message
283    (if (eq errornumber* 8) (get-fpe-errmsg arithsubtype)
284        errorstring)
285    sigaddr*)))
286
287(de build-trap-message (trap-type trap-addr)
288    (let (extra-info)
289      (cond ((funboundp 'code-address-to-symbol)
290             (setf extra-info
291                   (bldmsg "%w%x%w%n%w%n%w%n%w"
292                           " at address 0x"
293                           (inf trap-addr)
294                           " :"
295                           " the name of the routine that trapped can't be"
296                           " reported unless the function CODE-ADDRESS-TO-SYMBOL"
297                           " has been defined, by loading ADDR2ID.")))
298            % else, get the name of the offending function
299            ((setf extra-info (code-address-to-symbol (inf trap-addr)))
300             (setf extra-info (bldmsg "%w%w" " in " extra-info)))
301            (t (setf extra-info (bldmsg "%w%x" " at address 0x" (inf trap-addr))))
302      )
303      (bldmsg "%w%w" trap-type extra-info)))
304
305(de mask-terminal-interrupt (block?)
306  (mask_signal 2 (if block? 1 0)))
307
308(fluid '(code-address* closest-address* closest-symbol*))
309
310(de x-code-address-to-symbol (code-address*)
311  (let ((closest-symbol* ()) (closest-address* 0))
312        (mapobl #'(lambda (symbol)
313                 (when (fcodep symbol)
314                       (let ((address (inf (getfcodepointer symbol))))
315                            (when (and (ileq address code-address*)
316                                       (igreaterp address closest-address*))
317                                  (setq closest-address* address)
318                                  (setq closest-symbol* symbol))))))
319       closest-symbol*))
320
321(de code-address-to-symbol (ad)
322    (and (wlessp ad nextbps) (x-code-address-to-symbol ad)))
323
324% End of file.
325
326